From 394d35d586fba3db55217e1e9f1e88e8bc8a0719 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 2 Jun 2019 20:29:35 +0200 Subject: Partial and memory-backed storage variants --- erebos.cabal | 5 +- src/Main.hs | 48 +++---- src/Message.hs | 2 +- src/Network.hs | 213 +++++++++++++++------------- src/Storage.hs | 363 ++++++++++++++++++++++++++++++------------------ src/Storage/Internal.hs | 97 ++++++++++++- src/Storage/Key.hs | 25 ++-- 7 files changed, 481 insertions(+), 272 deletions(-) diff --git a/erebos.cabal b/erebos.cabal index 0eedaa4..cf50a74 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -32,8 +32,10 @@ executable erebos FunctionalDependencies, LambdaCase, MultiWayIf, + RankNTypes, ScopedTypeVariables, - TupleSections + TupleSections, + TypeFamilies -- other-extensions: build-depends: aeson >=1.4 && <1.5, @@ -42,6 +44,7 @@ executable erebos cereal >= 0.5 && <0.6, containers >= 0.6 && <0.7, cryptonite >=0.25 && <0.26, + deepseq >= 1.4 && <1.5, directory >= 1.3 && <1.4, filepath >=1.4 && <1.5, haskeline >=0.7 && <0.8, diff --git a/src/Main.hs b/src/Main.hs index 59e6d5c..b42c3cf 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,6 @@ module Main (main) where import Control.Concurrent -import Control.Exception import Control.Monad import Control.Monad.Reader import Control.Monad.State @@ -18,7 +17,6 @@ import Data.Time.LocalTime import System.Console.Haskeline import System.Environment import System.IO -import System.IO.Error import Identity import Message @@ -43,36 +41,32 @@ instance Storable Erebos where loadErebosHead :: Storage -> IO Head -loadErebosHead st = do - catchJust (guard . isDoesNotExistError) (loadHead st "erebos") $ \_ -> do - putStr "Name: " - hFlush stdout - name <- T.getLine - - (secret, public) <- generateKeys st - (_secretMsg, publicMsg) <- generateKeys st - (devSecret, devPublic) <- generateKeys st - (_devSecretMsg, devPublicMsg) <- generateKeys st - - owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name } - identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<< - wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner } - - msgs <- emptySList st - let erebos = Erebos - { erbIdentity = identity - , erbMessages = msgs - } - - Right h <- replaceHead erebos (Left (st, "erebos")) - return h +loadErebosHead st = loadHeadDef st "erebos" $ do + putStr "Name: " + hFlush stdout + name <- T.getLine + + (secret, public) <- generateKeys st + (_secretMsg, publicMsg) <- generateKeys st + (devSecret, devPublic) <- generateKeys st + (_devSecretMsg, devPublicMsg) <- generateKeys st + + owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name } + identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<< + wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner } + + msgs <- emptySList st + return $ Erebos + { erbIdentity = identity + , erbMessages = msgs + } updateErebosHead_ :: Storage -> (Stored Erebos -> IO (Stored Erebos)) -> IO () updateErebosHead_ st f = updateErebosHead st (fmap (,()) . f) updateErebosHead :: Storage -> (Stored Erebos -> IO (Stored Erebos, a)) -> IO a updateErebosHead st f = do - erebosHead <- loadHead st "erebos" + Just erebosHead <- loadHead st "erebos" (erebos, x) <- f $ wrappedLoad (headRef erebosHead) Right _ <- replaceHead erebos (Right erebosHead) return x @@ -211,7 +205,7 @@ cmdHistory = void $ runMaybeT $ do Just peer <- gets csPeer Just powner <- return $ finalOwner <$> peerIdentity peer - erebosHead <- liftIO $ loadHead st "erebos" + Just erebosHead <- liftIO $ loadHead st "erebos" let erebos = wrappedLoad (headRef erebosHead) Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos tzone <- liftIO $ getCurrentTimeZone diff --git a/src/Message.hs b/src/Message.hs index 0b633ae..0a1a70e 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -76,4 +76,4 @@ threadToList thread = helper S.empty $ msgHead thread | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg)) | otherwise = [] - cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, storedRef msg) + cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg) diff --git a/src/Network.hs b/src/Network.hs index 391e236..c5ce8cb 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -33,6 +33,7 @@ data Peer = Peer , peerIdentity :: Maybe (Stored Identity) , peerChannels :: [Channel] , peerSocket :: Socket + , peerInStorage :: PartialStorage } deriving (Show) @@ -40,15 +41,15 @@ data PeerAddress = DatagramAddress SockAddr deriving (Show) -data TransportHeader = AnnouncePacket Ref - | IdentityRequest Ref Ref - | IdentityResponse Ref - | TrChannelRequest Ref - | TrChannelAccept Ref +data TransportHeader = AnnouncePacket PartialRef + | IdentityRequest PartialRef PartialRef + | IdentityResponse PartialRef + | TrChannelRequest PartialRef + | TrChannelAccept PartialRef -data ServiceHeader = ServiceHeader T.Text Ref +data ServiceHeader = ServiceHeader T.Text PartialRef -transportToObject :: TransportHeader -> Object +transportToObject :: TransportHeader -> PartialObject transportToObject = \case AnnouncePacket ref -> Rec [ (BC.pack "TRANS", RecText $ T.pack "announce") @@ -72,7 +73,7 @@ transportToObject = \case , (BC.pack "acc", RecRef ref) ] -transportFromObject :: Object -> Maybe TransportHeader +transportFromObject :: PartialObject -> Maybe TransportHeader transportFromObject (Rec items) | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "announce" , Just (RecRef ref) <- lookup (BC.pack "identity") items @@ -97,13 +98,13 @@ transportFromObject (Rec items) transportFromObject _ = Nothing -serviceToObject :: ServiceHeader -> Object +serviceToObject :: ServiceHeader -> PartialObject serviceToObject (ServiceHeader svc ref) = Rec [ (BC.pack "SVC", RecText svc) , (BC.pack "ref", RecRef ref) ] -serviceFromObject :: Object -> Maybe ServiceHeader +serviceFromObject :: PartialObject -> Maybe ServiceHeader serviceFromObject (Rec items) | Just (RecText svc) <- lookup (BC.pack "SVC") items , Just (RecRef ref) <- lookup (BC.pack "ref") items @@ -126,127 +127,146 @@ startServer logd bhost sidentity = do return sock loop sock = do + st <- derivePartialStorage $ storedStorage sidentity baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort) - void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr) + void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ partialRef st $ storedRef sidentity) (addrAddress baddr) forever $ do (msg, paddr) <- recvFrom sock 4096 mbpeer <- M.lookup paddr <$> readMVar peers if | Just peer <- mbpeer , ch:_ <- peerChannels peer , Just plain <- channelDecrypt ch msg - , Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict plain + , Right (obj:objs) <- runExcept $ deserializeObjects (peerInStorage peer) $ BL.fromStrict plain , Just (ServiceHeader svc ref) <- serviceFromObject obj - -> do forM_ objs $ store $ storedStorage sidentity - writeChan chanSvc (peer, svc, ref) - - | Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg - , Just tpack <- transportFromObject obj - -> packet sock paddr tpack objs - - | otherwise -> logd $ show paddr ++ ": invalid packet" - - packet sock paddr (AnnouncePacket ref) _ = do + -> do forM_ objs $ storeObject $ peerInStorage peer + copyRef (storedStorage sidentity) ref >>= \case + Just pref -> writeChan chanSvc (peer, svc, pref) + Nothing -> logd $ show paddr ++ ": incomplete service packet" + + | otherwise -> do + ist <- case mbpeer of + Just peer -> return $ peerInStorage peer + Nothing -> derivePartialStorage $ storedStorage sidentity + if | Right (obj:objs) <- runExcept $ deserializeObjects ist $ BL.fromStrict msg + , Just tpack <- transportFromObject obj + -> packet sock paddr tpack objs ist + + | otherwise -> logd $ show paddr ++ ": invalid packet" + + packet sock paddr (AnnouncePacket ref) _ ist = do logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr - when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity) + when (refDigest ref /= refDigest (storedRef sidentity)) $ void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ IdentityRequest ref (partialRef ist $ storedRef sidentity) , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity ]) paddr - packet _ paddr (IdentityRequest ref from) [] = do + packet _ paddr (IdentityRequest ref from) [] _ = do logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content" - packet sock paddr (IdentityRequest ref from) (obj:objs) = do + packet sock paddr (IdentityRequest ref from) (obj:objs) ist = do logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr logd $ show (obj:objs) - from' <- store (storedStorage sidentity) obj + from' <- storeObject ist obj if from == from' - then do forM_ objs $ store $ storedStorage sidentity - let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) [] sock - modifyMVar_ peers $ return . M.insert paddr peer - writeChan chanPeer peer - void $ sendTo sock (BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity) - , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity - ]) paddr + then do forM_ objs $ storeObject ist + copyRef (storedStorage sidentity) from >>= \case + Nothing -> logd $ "Incomplete peer identity" + Just sfrom -> do + let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock ist + modifyMVar_ peers $ return . M.insert paddr peer + writeChan chanPeer peer + void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ IdentityResponse (partialRef ist $ storedRef sidentity) + , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity + ]) paddr else logd $ "Mismatched content" - packet _ paddr (IdentityResponse ref) [] = do + packet _ paddr (IdentityResponse ref) [] _ = do logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content" - packet sock paddr (IdentityResponse ref) (obj:objs) = do + packet sock paddr (IdentityResponse ref) (obj:objs) ist = do logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr logd $ show (obj:objs) - ref' <- store (storedStorage sidentity) obj + ref' <- storeObject ist obj if ref == ref' - then do forM_ objs $ store $ storedStorage sidentity - let pidentity = wrappedLoad ref - peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock - modifyMVar_ peers $ return . M.insert paddr peer - writeChan chanPeer peer - req <- createChannelRequest sidentity pidentity - void $ sendTo sock (BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req) - , lazyLoadBytes $ storedRef req - , lazyLoadBytes $ storedRef $ signedData $ fromStored req - , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req - , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req - ]) paddr + then do forM_ objs $ storeObject ist + copyRef (storedStorage sidentity) ref >>= \case + Nothing -> logd $ "Incomplete peer identity" + Just sref -> do + let pidentity = wrappedLoad sref + peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock ist + modifyMVar_ peers $ return . M.insert paddr peer + writeChan chanPeer peer + req <- createChannelRequest sidentity pidentity + void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req) + , lazyLoadBytes $ storedRef req + , lazyLoadBytes $ storedRef $ signedData $ fromStored req + , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req + , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req + ]) paddr else logd $ "Mismatched content" - packet _ paddr (TrChannelRequest _) [] = do + packet _ paddr (TrChannelRequest _) [] _ = do logd $ "Got channel request: from " ++ show paddr ++ " without content" - packet sock paddr (TrChannelRequest ref) (obj:objs) = do + packet sock paddr (TrChannelRequest ref) (obj:objs) ist = do logd $ "Got channel request: from " ++ show paddr logd $ show (obj:objs) - ref' <- store (storedStorage sidentity) obj + ref' <- storeObject ist obj if ref == ref' - then do forM_ objs $ store $ storedStorage sidentity - let request = wrappedLoad ref :: Stored ChannelRequest - modifyMVar_ peers $ \pval -> case M.lookup paddr pval of - Just peer | Just pid <- peerIdentity peer -> - runExceptT (acceptChannelRequest sidentity pid request) >>= \case - Left errs -> do mapM_ logd ("Invalid channel request" : errs) - return pval - Right (acc, channel) -> do - logd $ "Got channel: " ++ show (storedRef channel) - let peer' = peer { peerChannels = fromStored channel : peerChannels peer } - writeChan chanPeer peer' - void $ sendTo sock (BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc) - , lazyLoadBytes $ storedRef acc - , lazyLoadBytes $ storedRef $ signedData $ fromStored acc - , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc - , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc - ]) paddr - return $ M.insert paddr peer' pval - - _ -> do logd $ "Invalid channel request - no peer identity" - return pval + then do forM_ objs $ storeObject ist + copyRef (storedStorage sidentity) ref >>= \case + Nothing -> logd $ "Incomplete channel request" + Just sref -> do + let request = wrappedLoad sref :: Stored ChannelRequest + modifyMVar_ peers $ \pval -> case M.lookup paddr pval of + Just peer | Just pid <- peerIdentity peer -> + runExceptT (acceptChannelRequest sidentity pid request) >>= \case + Left errs -> do mapM_ logd ("Invalid channel request" : errs) + return pval + Right (acc, channel) -> do + logd $ "Got channel: " ++ show (storedRef channel) + let peer' = peer { peerChannels = fromStored channel : peerChannels peer } + writeChan chanPeer peer' + void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ TrChannelAccept (partialRef ist $ storedRef acc) + , lazyLoadBytes $ storedRef acc + , lazyLoadBytes $ storedRef $ signedData $ fromStored acc + , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc + , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc + ]) paddr + return $ M.insert paddr peer' pval + + _ -> do logd $ "Invalid channel request - no peer identity" + return pval else logd $ "Mismatched content" - packet _ paddr (TrChannelAccept _) [] = do + packet _ paddr (TrChannelAccept _) [] _ = do logd $ "Got channel accept: from " ++ show paddr ++ " without content" - packet _ paddr (TrChannelAccept ref) (obj:objs) = do + packet _ paddr (TrChannelAccept ref) (obj:objs) ist = do logd $ "Got channel accept: from " ++ show paddr logd $ show (obj:objs) - ref' <- store (storedStorage sidentity) obj + ref' <- storeObject ist obj if ref == ref' - then do forM_ objs $ store $ storedStorage sidentity - let accepted = wrappedLoad ref :: Stored ChannelAccept - modifyMVar_ peers $ \pval -> case M.lookup paddr pval of - Just peer | Just pid <- peerIdentity peer -> - runExceptT (acceptedChannel sidentity pid accepted) >>= \case - Left errs -> do mapM_ logd ("Invalid channel accept" : errs) - return pval - Right channel -> do - logd $ "Got channel: " ++ show (storedRef channel) - let peer' = peer { peerChannels = fromStored channel : peerChannels peer } - writeChan chanPeer peer' - return $ M.insert paddr peer' pval - _ -> do logd $ "Invalid channel accept - no peer identity" - return pval + then do forM_ objs $ storeObject ist + copyRef (storedStorage sidentity) ref >>= \case + Nothing -> logd $ "Incomplete channel accept" + Just sref -> do + let accepted = wrappedLoad sref :: Stored ChannelAccept + modifyMVar_ peers $ \pval -> case M.lookup paddr pval of + Just peer | Just pid <- peerIdentity peer -> + runExceptT (acceptedChannel sidentity pid accepted) >>= \case + Left errs -> do mapM_ logd ("Invalid channel accept" : errs) + return pval + Right channel -> do + logd $ "Got channel: " ++ show (storedRef channel) + let peer' = peer { peerChannels = fromStored channel : peerChannels peer } + writeChan chanPeer peer' + return $ M.insert paddr peer' pval + _ -> do logd $ "Invalid channel accept - no peer identity" + return pval else logd $ "Mismatched content" @@ -262,12 +282,13 @@ startServer logd bhost sidentity = do sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO () -sendToPeer self peer@Peer { peerChannels = ch:_ } svc obj = do - let st = storedStorage self +sendToPeer _ peer@Peer { peerChannels = ch:_ } svc obj = do + let st = peerInStorage peer ref <- store st obj + Just bytes <- return $ lazyLoadBytes ref let plain = BL.toStrict $ BL.concat [ serializeObject $ serviceToObject $ ServiceHeader svc ref - , lazyLoadBytes ref + , bytes ] ctext <- channelEncrypt ch plain let DatagramAddress paddr = peerAddress peer diff --git a/src/Storage.hs b/src/Storage.hs index caf9d30..52cda85 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -1,18 +1,22 @@ module Storage ( - Storage, - openStorage, + Storage, PartialStorage, + openStorage, memoryStorage, + deriveEphemeralStorage, derivePartialStorage, - Ref, + Ref, PartialRef, + RefDigest, refDigest, readRef, showRef, + copyRef, partialRef, - Object(..), RecItem(..), + Object, PartialObject, Object'(..), RecItem, RecItem'(..), serializeObject, deserializeObject, deserializeObjects, storeRawBytes, lazyLoadBytes, + storeObject, collectObjects, collectStoredObjects, Head, headName, headRef, headObject, - loadHeads, loadHead, replaceHead, + loadHeads, loadHead, loadHeadDef, replaceHead, Storable(..), StorableText(..), StorableDate(..), @@ -51,8 +55,12 @@ import qualified Codec.MIME.Type as MIME import qualified Codec.MIME.Parse as MIME import Control.Arrow +import Control.Concurrent +import Control.DeepSeq +import Control.Exception import Control.Monad import Control.Monad.Except +import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.Writer @@ -85,29 +93,43 @@ import Data.Time.Format import Data.Time.LocalTime import System.Directory +import System.IO.Error import System.IO.Unsafe import Storage.Internal +type Storage = Storage' Identity +type PartialStorage = Storage' Maybe + openStorage :: FilePath -> IO Storage openStorage path = do createDirectoryIfMissing True $ path ++ "/objects" createDirectoryIfMissing True $ path ++ "/heads" - return $ Storage path + return $ Storage { stBacking = StorageDir path, stParent = Nothing } + +memoryStorage' :: IO (Storage' c') +memoryStorage' = do + backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty + return $ Storage { stBacking = backing, stParent = Nothing } +memoryStorage :: IO Storage +memoryStorage = memoryStorage' -data Ref = Ref Storage (Digest Blake2b_256) - deriving (Eq, Ord) +deriveEphemeralStorage :: Storage -> IO Storage +deriveEphemeralStorage parent = do + st <- memoryStorage + return $ st { stParent = Just parent } -instance Show Ref where - show ref@(Ref (Storage path) _) = path ++ ":" ++ BC.unpack (showRef ref) +derivePartialStorage :: Storage -> IO PartialStorage +derivePartialStorage parent = do + st <- memoryStorage' + return $ st { stParent = Just parent } -instance BA.ByteArrayAccess Ref where - length (Ref _ dgst) = BA.length dgst - withByteArray (Ref _ dgst) = BA.withByteArray dgst +type Ref = Ref' Identity +type PartialRef = Ref' Maybe -zeroRef :: Storage -> Ref +zeroRef :: Storage' c -> Ref' c zeroRef s = Ref s h where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of Nothing -> error $ "Failed to create zero hash" @@ -115,12 +137,12 @@ zeroRef s = Ref s h digestAlgo :: Digest a -> a digestAlgo = undefined -isZeroRef :: Ref -> Bool +isZeroRef :: Ref' c -> Bool isZeroRef (Ref _ h) = all (==0) $ BA.unpack h -unsafeReadRef :: Storage -> ByteString -> Maybe Ref -unsafeReadRef s = Just . Ref s <=< digestFromByteString . B.concat <=< readHex +readRefDigest :: ByteString -> Maybe RefDigest +readRefDigest = digestFromByteString . B.concat <=< readHex where readHex bs | B.null bs = Just [] readHex bs = do (bx, bs') <- B.uncons bs (by, bs'') <- B.uncons bs' @@ -132,59 +154,93 @@ unsafeReadRef s = Just . Ref s <=< digestFromByteString . B.concat <=< readHex | otherwise = Nothing o = fromIntegral . ord +refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c)) +refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst + readRef :: Storage -> ByteString -> IO (Maybe Ref) readRef s b = - case unsafeReadRef s b of + case readRefDigest b of Nothing -> return Nothing - Just ref -> do - doesFileExist (refPath ref) >>= \case - True -> return $ Just ref - False -> return Nothing - -showRef :: Ref -> ByteString -showRef (Ref _ h) = B.concat $ map showHexByte $ BA.unpack h - where showHex x | x < 10 = x + 48 - | otherwise = x + 87 - showHexByte x = B.pack [ showHex (x `div` 16), showHex (x `mod` 16) ] - -refPath :: Ref -> FilePath -refPath ref@(Ref (Storage spath) _) = intercalate "/" [spath, "objects", pref, rest] - where (pref, rest) = splitAt 2 $ BC.unpack $ showRef ref - - -data Object = Blob ByteString - | Rec [(ByteString, RecItem)] - | ZeroObject + Just dgst -> refFromDigest s dgst + +copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c')) +copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref + Nothing -> doCopy + where doCopy = do mbobj' <- ioLoadObject ref' + mbobj <- sequence $ copyObject' st <$> mbobj' + sequence $ storeObject st <$> join mbobj + +copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) +copyObject' _ (Blob bs) = return $ return $ Blob bs +copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs + where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c')) + copyItem (n, item) = fmap (n,) <$> case item of + RecInt x -> return $ return $ RecInt x + RecNum x -> return $ return $ RecNum x + RecText x -> return $ return $ RecText x + RecBinary x -> return $ return $ RecBinary x + RecDate x -> return $ return $ RecDate x + RecJson x -> return $ return $ RecJson x + RecRef x -> fmap RecRef <$> copyRef' st x +copyObject' _ ZeroObject = return $ return ZeroObject + +copyRef :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (LoadResult c (Ref' c')) +copyRef st ref' = returnLoadResult <$> copyRef' st ref' + +copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) +copyObject st obj' = returnLoadResult <$> copyObject' st obj' + +partialRef :: PartialStorage -> Ref -> PartialRef +partialRef st (Ref _ dgst) = Ref st dgst + + +data Object' c + = Blob ByteString + | Rec [(ByteString, RecItem' c)] + | ZeroObject deriving (Show) -data RecItem = RecInt Integer - | RecNum Rational - | RecText Text - | RecBinary ByteString - | RecDate ZonedTime - | RecJson J.Value - | RecRef Ref +type Object = Object' Identity +type PartialObject = Object' Maybe + +data RecItem' c + = RecInt Integer + | RecNum Rational + | RecText Text + | RecBinary ByteString + | RecDate ZonedTime + | RecJson J.Value + | RecRef (Ref' c) deriving (Show) -serializeObject :: Object -> BL.ByteString +type RecItem = RecItem' Identity + +serializeObject :: Object' c -> BL.ByteString serializeObject = \case Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt ZeroObject -> BL.empty -storeObject :: Storage -> Object -> IO Ref +storeObject :: Storage' c -> Object' c -> IO (Ref' c) storeObject storage = \case ZeroObject -> return $ zeroRef storage - obj -> storeRawBytes storage $ serializeObject obj - -storeRawBytes :: Storage -> BL.ByteString -> IO Ref -storeRawBytes st raw = do - let ref = Ref st $ hashFinalize $ hashUpdates hashInit $ BL.toChunks raw - writeFileOnce (refPath ref) $ compress raw - return ref - -serializeRecItem :: ByteString -> RecItem -> [ByteString] + obj -> unsafeStoreRawBytes storage $ serializeObject obj + +storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef +storeRawBytes = unsafeStoreRawBytes + +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 + StorageMemory { memObjs = tobjs } -> + dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written + modifyMVar_ tobjs (return . M.insert dgst raw) + return $ Ref st dgst + +serializeRecItem :: ByteString -> RecItem' c -> [ByteString] serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] @@ -197,27 +253,29 @@ serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pa serializeRecItem name (RecJson x) = [name, BC.pack ":j", BC.singleton ' '] ++ BL.toChunks (J.encode x) ++ [BC.singleton '\n'] serializeRecItem name (RecRef x) = [name, BC.pack ":r.b2 ", showRef x, BC.singleton '\n'] -lazyLoadObject :: Ref -> Object -lazyLoadObject = fst . lazyLoadObject' - -lazyLoadBytes :: Ref -> BL.ByteString -lazyLoadBytes = snd . lazyLoadObject' - -lazyLoadObject' :: Ref -> (Object, BL.ByteString) -lazyLoadObject' ref | isZeroRef ref = (ZeroObject, BL.empty) -lazyLoadObject' ref@(Ref st rhash) = unsafePerformIO $ do - file <- decompress <$> (BL.readFile $ refPath ref) - let Ref _ chash = Ref st $ hashFinalize $ hashUpdates hashInit $ BL.toChunks file - when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} - let obj = case runExcept $ deserializeObject st file of - Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} - Right (x, rest) | BL.null rest -> x - | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} - return (obj, file) - -deserializeObject :: Storage -> BL.ByteString -> Except String (Object, BL.ByteString) -deserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) -deserializeObject st bytes = +lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) +lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject + +ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c)) +ioLoadObject ref | isZeroRef ref = return $ return ZeroObject +ioLoadObject ref@(Ref st rhash) = do + file' <- ioLoadBytes ref + return $ do + file <- file' + let chash = hashFinalize $ hashUpdates hashInit $ BL.toChunks file + when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} + return $ case runExcept $ unsafeDeserializeObject st file of + Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} + Right (x, rest) | BL.null rest -> x + | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} + +lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString +lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) +lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref + +unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString) +unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) +unsafeDeserializeObject st bytes = case BLC.break (=='\n') bytes of (line, rest) | Just (otype, len) <- splitObjPrefix line -> do let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest @@ -251,11 +309,14 @@ deserializeObject st bytes = "b" -> either (const Nothing) (Just . RecBinary) $ convertFromBase Base64 content "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) "j" -> RecJson <$> J.decode (BL.fromStrict content) - "r.b2" -> RecRef <$> unsafeReadRef st content + "r.b2" -> RecRef . Ref st <$> readRefDigest content _ -> Nothing return (name, val) -deserializeObjects :: Storage -> BL.ByteString -> Except String [Object] +deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) +deserializeObject = unsafeDeserializeObject + +deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] deserializeObjects _ bytes | BL.null bytes = return [] deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes (obj:) <$> deserializeObjects st rest @@ -267,17 +328,18 @@ collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) collectStoredObjects :: Stored Object -> [Stored Object] collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) -collectOtherStored :: Set Ref -> Object -> ([Stored Object], Set Ref) +collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items - where helper (RecRef r) (xs, s) | r `S.notMember` s = let o = wrappedLoad r - (xs', s') = collectOtherStored (S.insert r s) $ fromStored o - in ((o : xs') ++ xs, s') + where helper (RecRef ref) (xs, s) | r <- refDigest ref + , r `S.notMember` s + = let o = wrappedLoad ref + (xs', s') = collectOtherStored (S.insert r s) $ fromStored o + in ((o : xs') ++ xs, s') helper _ (xs, s) = (xs, s) collectOtherStored seen _ = ([], seen) -data Head = Head String Ref - deriving (Show) +type Head = Head' Identity headName :: Head -> String headName (Head name _) = name @@ -290,39 +352,63 @@ headObject = load . headRef loadHeads :: Storage -> IO [Head] -loadHeads s@(Storage spath) = do +loadHeads s@(Storage { stBacking = StorageDir spath }) = do let hpath = spath ++ "/heads/" files <- filterM (doesFileExist . (hpath++)) =<< getDirectoryContents hpath forM files $ \hname -> do (h:_) <- BC.lines <$> B.readFile (hpath ++ "/" ++ hname) Just ref <- readRef s h return $ Head hname ref +loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = readMVar theads -loadHead :: Storage -> String -> IO Head -loadHead s@(Storage spath) hname = do - let hpath = spath ++ "/heads/" - (h:_) <- BC.lines <$> B.readFile (hpath ++ hname) - Just ref <- readRef s h - return $ Head hname ref +loadHead :: Storage -> String -> IO (Maybe Head) +loadHead s@(Storage { stBacking = StorageDir spath }) hname = do + handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do + let hpath = spath ++ "/heads/" + (h:_) <- BC.lines <$> B.readFile (hpath ++ hname) + Just ref <- readRef s h + return $ Just $ Head hname ref +loadHead Storage { stBacking = StorageMemory { memHeads = theads } } hname = + find ((==hname) . headName) <$> readMVar theads + +loadHeadDef :: Storable a => Storage -> String -> IO a -> IO Head +loadHeadDef s hname gen = loadHead s hname >>= \case + Just h -> return h + Nothing -> do obj <- gen + Right h <- replaceHead obj (Left (s, hname)) + return h replaceHead :: Storable a => a -> Either (Storage, String) Head -> IO (Either (Maybe Head) Head) replaceHead obj prev = do + let (st, name) = either id (\(Head n (Ref s _)) -> (s, n)) prev ref <- store st obj - writeFileChecked filename (either (const Nothing) (Just . showRefL . headRef) prev) (showRefL ref) >>= \case - Left Nothing -> return $ Left Nothing - Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs - return $ Left $ Just $ Head name oref - Right () -> return $ Right $ Head name ref - where (st@(Storage spath), name) = either id (\(Head n (Ref s _)) -> (s, n)) prev - filename = spath ++ "/heads/" ++ name - showRefL ref = showRef ref `B.append` BC.singleton '\n' + case stBacking st of + StorageDir spath -> do + let filename = spath ++ "/heads/" ++ name + showRefL r = showRef r `B.append` BC.singleton '\n' + + writeFileChecked filename (either (const Nothing) (Just . showRefL . headRef) prev) (showRefL ref) >>= \case + Left Nothing -> return $ Left Nothing + Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs + 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)) class Storable a where store' :: a -> Store load' :: Load a - store :: Storage -> a -> IO Ref + store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c) store st = storeObject st <=< evalStore st . store' load :: Ref -> a load ref = let Load f = load' @@ -332,15 +418,15 @@ class Storable a => ZeroStorable a where fromZero :: Storage -> a data Store = StoreBlob ByteString - | StoreRec (Storage -> [IO [(ByteString, RecItem)]]) + | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) | StoreZero -evalStore :: Storage -> Store -> IO Object +evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) evalStore _ (StoreBlob x) = return $ Blob x evalStore s (StoreRec f) = Rec . concat <$> sequence (f s) evalStore _ StoreZero = return ZeroObject -type StoreRec = ReaderT Storage (Writer [IO [(ByteString, RecItem)]]) () +type StoreRec c = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) () data Load a = Load (Ref -> Object -> Either String a) @@ -349,12 +435,14 @@ type LoadRec a = ReaderT (Ref, [(ByteString, RecItem)]) (Either String) a instance Storable Object where store' (Blob bs) = StoreBlob bs - store' (Rec xs) = StoreRec $ const $ map (return.return) xs + store' (Rec xs) = StoreRec $ \st -> return $ do + Rec xs' <- copyObject st (Rec xs) + return xs' store' ZeroObject = StoreZero load' = Load $ const return - store = storeObject + store st = storeObject st <=< copyObject st load = lazyLoadObject instance Storable ByteString where @@ -382,7 +470,7 @@ instance Storable a => ZeroStorable [a] where storeBlob :: ByteString -> Store storeBlob = StoreBlob -storeRec :: StoreRec -> Store +storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store storeRec r = StoreRec $ execWriter . runReaderT r storeZero :: Store @@ -420,59 +508,63 @@ instance StorableDate Day where fromDate = utctDay . fromDate -storeInt :: Integral a => String -> a -> StoreRec +storeInt :: Integral a => String -> a -> StoreRec c storeInt name x = tell [return [(BC.pack name, RecInt $ toInteger x)]] -storeMbInt :: Integral a => String -> Maybe a -> StoreRec +storeMbInt :: Integral a => String -> Maybe a -> StoreRec c storeMbInt name = maybe (return ()) (storeInt name) -storeNum :: (Real a, Fractional a) => String -> a -> StoreRec +storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c storeNum name x = tell [return [(BC.pack name, RecNum $ toRational x)]] -storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec +storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c storeMbNum name = maybe (return ()) (storeNum name) -storeText :: StorableText a => String -> a -> StoreRec +storeText :: StorableText a => String -> a -> StoreRec c storeText name x = tell [return [(BC.pack name, RecText $ toText x)]] -storeMbText :: StorableText a => String -> Maybe a -> StoreRec +storeMbText :: StorableText a => String -> Maybe a -> StoreRec c storeMbText name = maybe (return ()) (storeText name) -storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec +storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c storeBinary name x = tell [return [(BC.pack name, RecBinary $ BA.convert x)]] -storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec +storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c storeMbBinary name = maybe (return ()) (storeBinary name) -storeDate :: StorableDate a => String -> a -> StoreRec +storeDate :: StorableDate a => String -> a -> StoreRec c storeDate name x = tell [return [(BC.pack name, RecDate $ toDate x)]] -storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec +storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c storeMbDate name = maybe (return ()) (storeDate name) -storeJson :: J.ToJSON a => String -> a -> StoreRec +storeJson :: J.ToJSON a => String -> a -> StoreRec c storeJson name x = tell [return [(BC.pack name, RecJson $ J.toJSON x)]] -storeMbJson :: J.ToJSON a => String -> Maybe a -> StoreRec +storeMbJson :: J.ToJSON a => String -> Maybe a -> StoreRec c storeMbJson name = maybe (return ()) (storeJson name) -storeRef :: Storable a => String -> a -> StoreRec +storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c storeRef name x = do s <- ask tell $ (:[]) $ do ref <- store s x return [(BC.pack name, RecRef ref)] -storeMbRef :: Storable a => String -> Maybe a -> StoreRec +storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c storeMbRef name = maybe (return ()) (storeRef name) -storeRawRef :: String -> Ref -> StoreRec -storeRawRef name ref = tell [return [(BC.pack name, RecRef ref)]] +storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c +storeRawRef name ref = do + st <- ask + tell $ (:[]) $ do + ref' <- copyRef st ref + return [(BC.pack name, RecRef ref')] -storeMbRawRef :: String -> Maybe Ref -> StoreRec +storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c storeMbRawRef name = maybe (return ()) (storeRawRef name) -storeZRef :: ZeroStorable a => String -> a -> StoreRec +storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c storeZRef name x = do s <- ask tell $ (:[]) $ do @@ -588,14 +680,13 @@ data Stored a = Stored Ref a deriving (Show) instance Eq (Stored a) where - Stored r1 _ == Stored r2 _ = r1 == r2 + Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2 instance Ord (Stored a) where - compare (Stored r1 _) (Stored r2 _) = compare r1 r2 + compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2) instance Storable a => Storable (Stored a) where - store st (Stored ref@(Ref st' _) x) | st' == st = return ref - | otherwise = store st x + store st = copyRef st . storedRef store' (Stored _ x) = store' x load' = Load $ \ref obj -> let Load fres = load' @@ -632,7 +723,7 @@ makeStoreInfo = StoreInfo <$> getZonedTime <*> pure Nothing -storeInfoRec :: StoreInfo -> StoreRec +storeInfoRec :: StoreInfo -> StoreRec c storeInfoRec info = do storeDate "date" $ infoDate info storeMbText "note" $ infoNote info @@ -785,23 +876,23 @@ findSListRef _ (Stored _ ListNil) = Nothing findSListRef x (Stored ref (ListItem _ _ y next)) | y == Just x = Just ref | otherwise = findSListRef x next -mapFromSList :: Storable a => StoredList a -> Map Ref (Stored a) +mapFromSList :: Storable a => StoredList a -> Map RefDigest (Stored a) mapFromSList list = helper list M.empty - where helper :: Storable a => StoredList a -> Map Ref (Stored a) -> Map Ref (Stored a) + where helper :: Storable a => StoredList a -> Map RefDigest (Stored a) -> Map RefDigest (Stored a) helper (Stored _ ListNil) cur = cur helper (Stored _ (ListItem (Just rref) _ (Just x) rest)) cur = let rxref = case load rref of ListItem _ _ (Just rx) _ -> sameType rx x $ storedRef rx _ -> error "mapFromSList: malformed list" - in helper rest $ case M.lookup (storedRef x) cur of - Nothing -> M.insert rxref x cur - Just x' -> M.insert rxref x' cur + in helper rest $ case M.lookup (refDigest $ storedRef x) cur of + Nothing -> M.insert (refDigest rxref) x cur + Just x' -> M.insert (refDigest rxref) x' cur helper (Stored _ (ListItem _ _ _ rest)) cur = helper rest cur sameType :: a -> a -> b -> b sameType _ _ x = x -updateOld :: Map Ref (Stored a) -> Stored a -> Stored a -updateOld m x = fromMaybe x $ M.lookup (storedRef x) m +updateOld :: Map RefDigest (Stored a) -> Stored a -> Stored a +updateOld m x = fromMaybe x $ M.lookup (refDigest $ storedRef x) m data StoreUpdate a = StoreKeep diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs index 6a86dea..400af8f 100644 --- a/src/Storage/Internal.hs +++ b/src/Storage/Internal.hs @@ -1,20 +1,113 @@ module Storage.Internal where +import Codec.Compression.Zlib + +import Control.Concurrent import Control.Exception +import Control.Monad +import Control.Monad.Identity + +import Crypto.Hash +import Data.ByteArray (ByteArrayAccess, ScrubbedBytes) +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL +import Data.List +import Data.Map (Map) +import qualified Data.Map as M import System.Directory import System.FilePath import System.IO +import System.IO.Error import System.Posix.Files import System.Posix.IO import System.Posix.Types -data Storage = Storage FilePath - deriving (Eq, Ord) + +data Storage' c = Storage + { stBacking :: StorageBacking c + , stParent :: Maybe (Storage' Identity) + } + deriving (Eq) + +instance Show (Storage' c) where + show st@(Storage { stBacking = StorageDir path }) = "dir" ++ showParentStorage st ++ ":" ++ path + show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st + +showParentStorage :: Storage' c -> String +showParentStorage Storage { stParent = Nothing } = "" +showParentStorage Storage { stParent = Just st } = "@" ++ show st + +data StorageBacking c + = StorageDir FilePath + | StorageMemory { memHeads :: MVar [Head' c] + , memObjs :: MVar (Map RefDigest BL.ByteString) + , memKeys :: MVar (Map RefDigest ScrubbedBytes) + } + deriving (Eq) + + +type RefDigest = Digest Blake2b_256 + +data Ref' c = Ref (Storage' c) RefDigest + deriving (Eq) + +instance Show (Ref' c) where + show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref) + +instance ByteArrayAccess (Ref' c) where + length (Ref _ dgst) = BA.length dgst + withByteArray (Ref _ dgst) = BA.withByteArray dgst + +refDigest :: Ref' c -> RefDigest +refDigest (Ref _ dgst) = dgst + +showRef :: Ref' c -> ByteString +showRef = showRefDigest . refDigest + +showRefDigest :: RefDigest -> ByteString +showRefDigest = B.concat . map showHexByte . BA.unpack + where showHex x | x < 10 = x + 48 + | otherwise = x + 87 + showHexByte x = B.pack [ showHex (x `div` 16), showHex (x `mod` 16) ] + + +data Head' c = Head String (Ref' c) + deriving (Show) + + +class (Traversable compl, Monad compl) => StorageCompleteness compl where + type LoadResult compl a :: * + returnLoadResult :: compl a -> LoadResult compl a + ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString) + +instance StorageCompleteness Identity where + type LoadResult Identity a = a + returnLoadResult = runIdentity + ioLoadBytes ref@(Ref st dgst) = maybe (error $ "Ref not found in complete storage: "++show ref) Identity + <$> ioLoadBytesFromStorage st dgst + +instance StorageCompleteness Maybe where + type LoadResult Maybe a = Maybe a + returnLoadResult = id + ioLoadBytes (Ref st dgst) = ioLoadBytesFromStorage st dgst + +ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString) +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) $ + Just . decompress <$> (BL.readFile $ refPath spath dgst) + loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs + +refPath :: FilePath -> RefDigest -> FilePath +refPath spath dgst = intercalate "/" [spath, "objects", pref, rest] + where (pref, rest) = splitAt 2 $ BC.unpack $ showRefDigest dgst openFdParents :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd diff --git a/src/Storage/Key.hs b/src/Storage/Key.hs index 3ed4a66..8e6d04c 100644 --- a/src/Storage/Key.hs +++ b/src/Storage/Key.hs @@ -3,9 +3,13 @@ module Storage.Key ( storeKey, loadKey, ) where +import Control.Concurrent.MVar +import Control.Monad + import Data.ByteArray import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M import System.FilePath import System.IO.Error @@ -20,17 +24,20 @@ class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec -keyStorage :: Storage -> FilePath -keyStorage (Storage base) = base "keys" - -keyFilePath :: KeyPair sec pub => Stored pub -> FilePath -keyFilePath pkey = keyStorage (storedStorage pkey) (BC.unpack $ showRef $ storedRef pkey) +keyFilePath :: KeyPair sec pub => FilePath -> Stored pub -> FilePath +keyFilePath sdir pkey = sdir "keys" (BC.unpack $ showRef $ storedRef pkey) storeKey :: KeyPair sec pub => sec -> IO () -storeKey key = writeFileOnce (keyFilePath $ keyGetPublic key) (BL.fromStrict $ convert $ keyGetData key) +storeKey key = do + let spub = keyGetPublic key + case stBacking $ storedStorage spub of + StorageDir 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 - tryIOError (BC.readFile (keyFilePath spub)) >>= \case - Right kdata -> return $ keyFromData (convert kdata) spub - Left _ -> return Nothing + case stBacking $ storedStorage spub of + StorageDir 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 -- cgit v1.2.3