diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Storage.hs | 56 | ||||
| -rw-r--r-- | src/Storage/Internal.hs | 10 | ||||
| -rw-r--r-- | src/Storage/Key.hs | 4 |
3 files changed, 50 insertions, 20 deletions
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 |