1-- Copyright (C) 2009-2011 Petr Rockai 2-- 3-- BSD3 4 5-- | A monadic interface to Tree mutation. The main idea is to 6-- simulate IO-ish manipulation of real filesystem (that's the state part of 7-- the monad), and to keep memory usage down by reasonably often dumping the 8-- intermediate data to disk and forgetting it. The monad interface itself is 9-- generic, and a number of actual implementations can be used. This module 10-- provides just 'virtualTreeIO' that never writes any changes, but may trigger 11-- filesystem reads as appropriate. 12module Darcs.Util.Tree.Monad 13 ( -- * 'TreeMonad' 14 TreeMonad 15 , TreeState(tree) 16 , runTreeMonad 17 , virtualTreeMonad 18 -- * Specializing to 'IO' 19 , TreeIO 20 , virtualTreeIO 21 -- * Read actions 22 , readFile 23 , exists 24 , directoryExists 25 , fileExists 26 -- * Write actions 27 , writeFile 28 , createDirectory 29 , unlink 30 , rename 31 , copy 32 -- * Other actions 33 , findM, findFileM, findTreeM 34 ) where 35 36import Darcs.Prelude hiding ( readFile, writeFile ) 37 38import Control.Exception ( throw ) 39 40import Darcs.Util.Path 41import Darcs.Util.Tree 42 43import Data.List( sortBy ) 44import Data.Int( Int64 ) 45import Data.Maybe( isNothing, isJust ) 46 47import qualified Data.ByteString.Lazy as BL 48import Control.Monad.RWS.Strict 49import qualified Data.Map as M 50 51-- | Keep track of the size and age of changes to the tree. 52type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age 53 54-- | Internal state of the 'TreeMonad'. Keeps track of the current 'Tree' 55-- content and unsync'd changes. 56data TreeState m = TreeState 57 { tree :: !(Tree m) 58 , changed :: !Changed 59 , changesize :: !Int64 60 , maxage :: !Int64 61 } 62 63data TreeEnv m = TreeEnv 64 { updateHash :: TreeItem m -> m Hash 65 , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) 66 } 67 68-- | A monad transformer that adds state of type 'TreeState' and an environment 69-- of type 'AnchoredPath' (for the current directory). 70type TreeMonad m = RWST (TreeEnv m) () (TreeState m) m 71 72-- | 'TreeMonad' specialized to 'IO' 73type TreeIO = TreeMonad IO 74 75initialEnv :: (TreeItem m -> m Hash) 76 -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) 77 -> TreeEnv m 78initialEnv uh u = TreeEnv {updateHash = uh, update = u} 79 80initialState :: Tree m -> TreeState m 81initialState t = 82 TreeState {tree = t, changed = M.empty, changesize = 0, maxage = 0} 83 84flush :: Monad m => TreeMonad m () 85flush = do changed' <- map fst . M.toList <$> gets changed 86 dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ] 87 modify $ \st -> st { changed = M.empty, changesize = 0 } 88 forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem 89 90runTreeMonad' :: Monad m => TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m) 91runTreeMonad' action initEnv initState = do 92 (out, final, _) <- runRWST action initEnv initState 93 return (out, tree final) 94 95runTreeMonad :: Monad m 96 => TreeMonad m a 97 -> Tree m 98 -> (TreeItem m -> m Hash) 99 -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) 100 -> m (a, Tree m) 101runTreeMonad action t uh u = do 102 let action' = do x <- action 103 flush 104 return x 105 runTreeMonad' action' (initialEnv uh u) (initialState t) 106 107-- | Run a 'TreeMonad' action without storing any changes. This is useful for 108-- running monadic tree mutations for obtaining the resulting 'Tree' (as opposed 109-- to their effect of writing a modified tree to disk). The actions can do both 110-- read and write -- reads are passed through to the actual filesystem, but the 111-- writes are held in memory in the form of a modified 'Tree'. 112virtualTreeMonad :: Monad m => TreeMonad m a -> Tree m -> m (a, Tree m) 113virtualTreeMonad action t = 114 runTreeMonad action t (\_ -> return NoHash) (\_ x -> return x) 115 116-- | 'virtualTreeMonad' specialized to 'IO' 117virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) 118virtualTreeIO = virtualTreeMonad 119 120-- | Modifies an item in the current Tree. This action keeps an account of the 121-- modified data, in changed and changesize, for subsequent flush 122-- operations. Any modifications (as in "modifyTree") are allowed. 123modifyItem :: Monad m 124 => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () 125modifyItem path item = do 126 age <- gets maxage 127 changed' <- gets changed 128 let getsize (Just (File b)) = lift (BL.length <$> readBlob b) 129 getsize _ = return 0 130 size <- getsize item 131 let change = case M.lookup path changed' of 132 Nothing -> size 133 Just (oldsize, _) -> size - oldsize 134 135 modify $ \st -> st { tree = modifyTree (tree st) path item 136 , changed = M.insert path (size, age) (changed st) 137 , maxage = age + 1 138 , changesize = changesize st + change } 139 140renameChanged :: Monad m 141 => AnchoredPath -> AnchoredPath -> TreeMonad m () 142renameChanged from to = modify $ \st -> st {changed = rename' $ changed st} 143 where 144 rename' = M.fromList . map renameone . M.toList 145 renameone (x, d) 146 | from `isPrefix` x = (to `catPaths` relative from x, d) 147 | otherwise = (x, d) 148 relative (AnchoredPath from') (AnchoredPath x) = 149 AnchoredPath $ drop (length from') x 150 151-- | Replace an item with a new version without modifying the content of the 152-- tree. This does not do any change tracking. Ought to be only used from a 153-- 'sync' implementation for a particular storage format. The presumed use-case 154-- is that an existing in-memory Blob is replaced with a one referring to an 155-- on-disk file. 156replaceItem :: Monad m 157 => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () 158replaceItem path item = do 159 modify $ \st -> st { tree = modifyTree (tree st) path item } 160 161flushItem :: forall m. Monad m => AnchoredPath -> TreeMonad m () 162flushItem path = 163 do current <- gets tree 164 case find current path of 165 Nothing -> return () -- vanished, do nothing 166 Just x -> do y <- fixHash x 167 new <- asks update >>= ($ y) . ($ path) 168 replaceItem path (Just new) 169 where fixHash :: TreeItem m -> TreeMonad m (TreeItem m) 170 fixHash f@(File (Blob con NoHash)) = do 171 hash <- asks updateHash >>= \x -> lift $ x f 172 return $ File $ Blob con hash 173 fixHash (SubTree s) | treeHash s == NoHash = 174 asks updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s) 175 fixHash x = return x 176 177 178-- | If buffers are becoming large, sync, otherwise do nothing. 179flushSome :: Monad m => TreeMonad m () 180flushSome = do x <- gets changesize 181 when (x > megs 100) $ do 182 remaining <- go =<< sortBy age . M.toList <$> gets changed 183 modify $ \s -> s { changed = M.fromList remaining } 184 where go [] = return [] 185 go ((path, (size, _)):chs) = do 186 x <- subtract size <$> gets changesize 187 flushItem path 188 modify $ \s -> s { changesize = x } 189 if x > megs 50 then go chs 190 else return chs 191 megs = (* (1024 * 1024)) 192 age (_, (_, a)) (_, (_, b)) = compare a b 193 194-- read only actions 195 196expandTo :: Monad m => AnchoredPath -> TreeMonad m () 197expandTo p = 198 do t <- gets tree 199 t' <- lift $ expandPath t p 200 modify $ \st -> st { tree = t' } 201 202-- | Check for existence of a file. 203fileExists :: Monad m => AnchoredPath -> TreeMonad m Bool 204fileExists p = 205 do expandTo p 206 (isJust . (`findFile` p)) <$> gets tree 207 208-- | Check for existence of a directory. 209directoryExists :: Monad m => AnchoredPath -> TreeMonad m Bool 210directoryExists p = 211 do expandTo p 212 (isJust . (`findTree` p)) <$> gets tree 213 214-- | Check for existence of a node (file or directory, doesn't matter). 215exists :: Monad m => AnchoredPath -> TreeMonad m Bool 216exists p = 217 do expandTo p 218 isJust . (`find` p) <$> gets tree 219 220-- | Grab content of a file in the current Tree at the given path. 221readFile :: Monad m => AnchoredPath -> TreeMonad m BL.ByteString 222readFile p = 223 do expandTo p 224 t <- gets tree 225 let f = findFile t p 226 case f of 227 Nothing -> throw $ userError $ "No such file " ++ displayPath p 228 Just x -> lift (readBlob x) 229 230-- | Change content of a file at a given path. The change will be 231-- eventually flushed to disk, but might be buffered for some time. 232writeFile :: Monad m => AnchoredPath -> BL.ByteString -> TreeMonad m () 233writeFile p con = 234 do expandTo p 235 modifyItem p (Just blob) 236 flushSome 237 where blob = File $ Blob (return con) hash 238 hash = NoHash -- we would like to say "sha256 con" here, but due 239 -- to strictness of Hash in Blob, this would often 240 -- lead to unnecessary computation which would then 241 -- be discarded anyway; we rely on the sync 242 -- implementation to fix up any NoHash occurrences 243 244-- | Create a directory. 245createDirectory :: Monad m => AnchoredPath -> TreeMonad m () 246createDirectory p = 247 do expandTo p 248 modifyItem p $ Just $ SubTree emptyTree 249 250-- | Remove the item at a path. 251unlink :: Monad m => AnchoredPath -> TreeMonad m () 252unlink p = 253 do expandTo p 254 modifyItem p Nothing 255 256-- | Rename the item at a path. 257rename :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m () 258rename from to = 259 do expandTo from 260 expandTo to 261 tr <- gets tree 262 let item = find tr from 263 found_to = find tr to 264 unless (isNothing found_to) $ 265 throw $ userError $ "Error renaming: destination " ++ displayPath to ++ " exists." 266 if isJust item then do 267 modifyItem from Nothing 268 modifyItem to item 269 renameChanged from to 270 else 271 throw $ userError $ "Error renaming: source " ++ displayPath from ++ " does not exist." 272 273-- | Copy an item from some path to another path. 274copy :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m () 275copy from to = 276 do expandTo from 277 expandTo to 278 tr <- gets tree 279 let item = find tr from 280 unless (isNothing item) $ modifyItem to item 281 282findM' :: forall m a . Monad m 283 => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a 284findM' what t path = fst <$> virtualTreeMonad (look path) t 285 where look :: AnchoredPath -> TreeMonad m a 286 look p = expandTo p >> flip what p <$> gets tree 287 288findM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) 289findM = findM' find 290 291findTreeM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Tree m)) 292findTreeM = findM' findTree 293 294findFileM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Blob m)) 295findFileM = findM' findFile 296