summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erebos.cabal5
-rw-r--r--src/Main.hs48
-rw-r--r--src/Message.hs2
-rw-r--r--src/Network.hs213
-rw-r--r--src/Storage.hs363
-rw-r--r--src/Storage/Internal.hs97
-rw-r--r--src/Storage/Key.hs25
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 01:48:20 +0000