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