1 -- | The plain format implementation resides in this module. The plain format
    2 -- does not use any hashing and basically just wraps a normal filesystem tree
    3 -- in the hashed-storage API.
    4 --
    5 -- NB. The 'read' function on Blobs coming from a plain tree is susceptible to
    6 -- file content changes. Since we use mmap in 'read', this will break
    7 -- referential transparency and produce unexpected results. Please always make
    8 -- sure that all parallel access to the underlying filesystem tree never
    9 -- mutates files. Unlink + recreate is fine though (in other words, the
   10 -- 'writePlainTree' and 'plainTreeIO' implemented in this module are safe in
   11 -- this respect).
   12 module Storage.Hashed.Plain( readPlainTree, writePlainTree,
   13                              plainTreeIO  -- (obsolete?  if so remove implementation!)
   14                            ) where
   15 
   16 import Data.Maybe( catMaybes, fromJust )
   17 import qualified Data.ByteString as BS
   18 import qualified Data.ByteString.Char8 as BS8
   19 import qualified Data.ByteString.Lazy as BL
   20 import System.FilePath( (</>) )
   21 import System.Directory( getDirectoryContents
   22                        , createDirectoryIfMissing )
   23 import Bundled.Posix( getFileStatus, isDirectory, isRegularFile, FileStatus )
   24 
   25 import Storage.Hashed.Path hiding ( (</>) )
   26 import Storage.Hashed.Utils
   27 import Storage.Hashed.Hash( Hash( NoHash) )
   28 import Storage.Hashed.Tree( Tree(), TreeItem(..)
   29                           , Blob(..), makeTree
   30                           , list, readBlob, find, modifyTree, expand )
   31 import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, replaceItem )
   32 import qualified Data.Set as S
   33 import Control.Monad.State( liftIO, gets, modify )
   34 
   35 readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]
   36 readPlainDir dir =
   37     withCurrentDirectory dir $ do
   38       items <- getDirectoryContents "."
   39       sequence [ do st <- getFileStatus s
   40                     return (s, st)
   41                  | s <- items, s `notElem` [ ".", ".." ] ]
   42 
   43 readPlainTree :: FilePath -> IO (Tree IO)
   44 readPlainTree dir = do
   45   items <- readPlainDir dir
   46   let subs = catMaybes [
   47        let name = (BS8.pack name')
   48         in case status of
   49              _ | isDirectory status -> Just (name, Stub (readPlainTree (dir </> name')) NoHash)
   50              _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name) NoHash)
   51              _ -> Nothing
   52             | (name', status) <- items ]
   53   return $ makeTree subs
   54     where readBlob' name = readSegment (dir </> BS8.unpack name, Nothing)
   55 
   56 -- | Write out /full/ tree to a plain directory structure. If you instead want
   57 -- to make incremental updates, refer to "Storage.Hashed.Monad".
   58 writePlainTree :: Tree IO -> FilePath -> IO ()
   59 writePlainTree t dir = do
   60   createDirectoryIfMissing True dir
   61   expand t >>= mapM_ write . list
   62     where write (p, File b) = write' p b
   63           write (p, SubTree _) =
   64               createDirectoryIfMissing True (dir </> pathToString p)
   65           write _ = return ()
   66           write' p b = readBlob b >>= BL.writeFile (dir </> pathToString p)
   67 
   68 -- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the
   69 -- plain tree every now and then (after the action is finished, the last tree
   70 -- state is always flushed to disk). XXX Modify the tree with filesystem
   71 -- reading and put it back into st (ie. replace the in-memory Blobs with normal
   72 -- ones, so the memory can be GCd).
   73 plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO)
   74 plainTreeIO action t dir = runTreeMonad action $ initialState t (\_ -> return NoHash) updatePlain
   75     where updatePlain path (File b) =
   76             do liftIO $ createDirectoryIfMissing True (pathToString $ fromJust $ parent path)
   77                liftIO $ readBlob b >>= BL.writeFile (pathToString path)
   78                return $ File $ Blob (BL.readFile $ pathToString path) NoHash
   79           updatePlain _ x = return x
   80