Storage: watching head changes

4 files changed, 51 insertions, 20 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 98310b4..c712d91 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -56,6 +56,7 @@ executable erebos
                        directory >= 1.3 && <1.4,
                        filepath >=1.4 && <1.5,
                        haskeline >=0.7 && <0.8,
+                       hinotify >=0.4 && <0.5,
                        memory >=0.14 && <0.15,
                        mime >= 0.4 && < 0.5,
                        mtl >=2.2 && <2.3,
diff --git a/src/Storage.hs b/src/Storage.hs
index ec5da48..1cf5cd4 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -18,6 +18,7 @@ module Storage (
     Head,
     headName, headRef, headObject,
     loadHeads, loadHead, loadHeadDef, replaceHead,
+    watchHead,
 
     Storable(..),
     StorableText(..), StorableDate(..),
@@ -95,6 +96,7 @@ import Data.Time.Format
 import Data.Time.LocalTime
 
 import System.Directory
+import System.INotify
 import System.IO.Error
 import System.IO.Unsafe
 
@@ -108,11 +110,12 @@ openStorage :: FilePath -> IO Storage
 openStorage path = do
     createDirectoryIfMissing True $ path ++ "/objects"
     createDirectoryIfMissing True $ path ++ "/heads"
-    return $ Storage { stBacking = StorageDir path, stParent = Nothing }
+    watchers <- newMVar (Nothing, [])
+    return $ Storage { stBacking = StorageDir path watchers, stParent = Nothing }
 
 memoryStorage' :: IO (Storage' c')
 memoryStorage' = do
-    backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty
+    backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar []
     return $ Storage { stBacking = backing, stParent = Nothing }
 
 memoryStorage :: IO Storage
@@ -242,7 +245,7 @@ unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
 unsafeStoreRawBytes st raw = do
     let dgst = hashFinalize $ hashUpdates hashInit $ BL.toChunks raw
     case stBacking st of
-         StorageDir sdir -> writeFileOnce (refPath sdir dgst) $ compress raw
+         StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw
          StorageMemory { memObjs = tobjs } ->
              dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
                  modifyMVar_ tobjs (return . M.insert dgst raw)
@@ -363,7 +366,7 @@ headObject = load . headRef
 
 
 loadHeads :: Storage -> IO [Head]
-loadHeads s@(Storage { stBacking = StorageDir spath }) = do
+loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = do
     let hpath = spath ++ "/heads/"
     files <- filterM (doesFileExist . (hpath++)) =<< getDirectoryContents hpath
     forM files $ \hname -> do
@@ -373,7 +376,7 @@ loadHeads s@(Storage { stBacking = StorageDir spath }) = do
 loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = readMVar theads
 
 loadHead :: Storage -> String -> IO (Maybe Head)
-loadHead s@(Storage { stBacking = StorageDir spath }) hname = do
+loadHead s@(Storage { stBacking = StorageDir { dirPath = spath }}) hname = do
     handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
         let hpath = spath ++ "/heads/"
         (h:_) <- BC.lines <$> B.readFile (hpath ++ hname)
@@ -394,7 +397,7 @@ replaceHead obj prev = do
     let (st, name) = either id (\(Head n (Ref s _)) -> (s, n)) prev
     ref <- store st obj
     case stBacking st of
-         StorageDir spath -> do
+         StorageDir { dirPath = spath } -> do
              let filename = spath ++ "/heads/" ++ name
                  showRefL r = showRef r `B.append` BC.singleton '\n'
 
@@ -404,15 +407,38 @@ replaceHead obj prev = do
                                       return $ Left $ Just $ Head name oref
                  Right () -> return $ Right $ Head name ref
 
-         StorageMemory { memHeads = theads } -> modifyMVar theads $ \hs ->
-             case (partition ((== name) . headName) hs, prev) of
-                  (([], _), Left _)  -> let h = Head name ref
-                                         in return (h:hs, Right h)
-                  (([], _), Right _) -> return (hs, Left Nothing)
-                  ((h:_, _), Left _) -> return (hs, Left (Just h))
-                  ((h:_, hs'), Right h') | headRef h == headRef h' -> let nh = Head name ref
-                                                                       in return (nh:hs', Right nh)
-                                         | otherwise -> return (hs, Left (Just h))
+         StorageMemory { memHeads = theads, memWatchers = twatch } -> do
+             res <- modifyMVar theads $ \hs -> do
+                 ws <- map snd . filter ((==name) . fst) <$> readMVar twatch
+                 case (partition ((== name) . headName) hs, prev) of
+                      (([], _), Left _)  -> let h = Head name ref
+                                             in return (h:hs, Right (h, ws))
+                      (([], _), Right _) -> return (hs, Left Nothing)
+                      ((h:_, _), Left _) -> return (hs, Left (Just h))
+                      ((h:_, hs'), Right h') | headRef h == headRef h' -> let nh = Head name ref
+                                                                           in return (nh:hs', Right (nh, ws))
+                                             | otherwise -> return (hs, Left (Just h))
+             case res of
+                  Right (h, ws) -> mapM_ ($h) ws >> return (Right h)
+                  Left x -> return $ Left x
+
+watchHead :: Head -> (Head -> IO ()) -> IO ()
+watchHead (Head name (Ref st _)) cb = do
+    case stBacking st of
+         StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar_ mvar $ \(mbi, watchers) -> do
+             inotify <- (\f -> maybe f return mbi) $ do
+                 inotify <- initINotify
+                 void $ addWatch inotify [Move] (BC.pack $ spath ++ "/heads") $ \case
+                     MovedIn { filePath = fpath } -> do
+                         let cname = BC.unpack fpath
+                         loadHead st cname >>= \case
+                             Just h -> mapM_ ($h) . map snd . filter ((== cname) . fst) . snd =<< readMVar mvar
+                             Nothing -> return ()
+                     _ -> return ()
+                 return inotify
+             return (Just inotify, (name, cb) : watchers)
+
+         StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . ((name, cb) :)
 
 
 class Storable a where
diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
index 76a3945..88741e0 100644
--- a/src/Storage/Internal.hs
+++ b/src/Storage/Internal.hs
@@ -21,6 +21,7 @@ import qualified Data.Map as M
 
 import System.Directory
 import System.FilePath
+import System.INotify (INotify)
 import System.IO
 import System.IO.Error
 import System.Posix.Files
@@ -35,7 +36,7 @@ data Storage' c = Storage
     deriving (Eq)
 
 instance Show (Storage' c) where
-    show st@(Storage { stBacking = StorageDir path }) = "dir" ++ showParentStorage st ++ ":" ++ path
+    show st@(Storage { stBacking = StorageDir { dirPath = path }}) = "dir" ++ showParentStorage st ++ ":" ++ path
     show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st
 
 showParentStorage :: Storage' c -> String
@@ -43,10 +44,13 @@ showParentStorage Storage { stParent = Nothing } = ""
 showParentStorage Storage { stParent = Just st } = "@" ++ show st
 
 data StorageBacking c
-         = StorageDir FilePath
+         = StorageDir { dirPath :: FilePath
+                      , dirWatchers :: MVar (Maybe INotify, [(String, Head' c -> IO ())])
+                      }
          | StorageMemory { memHeads :: MVar [Head' c]
                          , memObjs :: MVar (Map RefDigest BL.ByteString)
                          , memKeys :: MVar (Map RefDigest ScrubbedBytes)
+                         , memWatchers :: MVar [(String, Head' c -> IO ())]
                          }
     deriving (Eq)
 
@@ -107,7 +111,7 @@ ioLoadBytesFromStorage st dgst = loadCurrent st >>=
     \case Just bytes -> return $ Just bytes
           Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst
                   | otherwise                  -> return Nothing
-    where loadCurrent Storage { stBacking = StorageDir spath } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+    where loadCurrent Storage { stBacking = StorageDir { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
               Just . decompress <$> (BL.readFile $ refPath spath dgst)
           loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs
 
diff --git a/src/Storage/Key.hs b/src/Storage/Key.hs
index 8e6d04c..28fc989 100644
--- a/src/Storage/Key.hs
+++ b/src/Storage/Key.hs
@@ -31,13 +31,13 @@ storeKey :: KeyPair sec pub => sec -> IO ()
 storeKey key = do
     let spub = keyGetPublic key
     case stBacking $ storedStorage spub of
-         StorageDir dir -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key)
+         StorageDir { dirPath = dir } -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key)
          StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key)
 
 loadKey :: KeyPair sec pub => Stored pub -> IO (Maybe sec)
 loadKey spub = do
     case stBacking $ storedStorage spub of
-         StorageDir dir -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case
+         StorageDir { dirPath = dir } -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case
              Right kdata -> return $ keyFromData (convert kdata) spub
              Left _ -> return Nothing
          StorageMemory { memKeys = kstore } -> (flip keyFromData spub <=< M.lookup (refDigest $ storedRef spub)) <$> readMVar kstore