summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Main.hs2
-rw-r--r--src/Network.hs6
-rw-r--r--src/State.hs2
-rw-r--r--src/Storage.hs9
4 files changed, 11 insertions, 8 deletions
diff --git a/src/Main.hs b/src/Main.hs
index b51fa0d..b3f503d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -251,7 +251,7 @@ instance MonadRandom CommandM where
getRandomBytes = liftIO . getRandomBytes
instance MonadStorage CommandM where
- getStorage = gets $ refStorage . headRef . csHead
+ getStorage = gets $ headStorage . csHead
instance MonadHead LocalState CommandM where
updateLocalHead f = do
diff --git a/src/Network.hs b/src/Network.hs
index 6685045..3614de0 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -178,7 +178,7 @@ forkServerThread server act = modifyMVar_ (serverThreads server) $ \ts -> do
startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server
startServer opt serverOrigHead logd' serverServices = do
- let serverStorage = refStorage $ headRef serverOrigHead
+ let serverStorage = headStorage serverOrigHead
serverIdentity_ <- newMVar $ headLocalIdentity serverOrigHead
serverThreads <- newMVar []
serverSocket <- newEmptyMVar
@@ -342,14 +342,14 @@ dataResponseWorker server = forever $ do
return (Nothing, [])
Left dgst -> do
atomically (writeTVar tvar $ Left [dgst])
- return (Just wr, [partialRefFromDigest (refStorage $ wrefPartial wr) dgst])
+ return (Just wr, [dgst])
ds' -> do
atomically (writeTVar tvar $ Left ds')
return (Just wr, [])
Right _ -> return (Nothing, [])
atomically $ putTMVar (peerWaitingRefs peer) $ catMaybes $ map fst list
- let reqs = map refDigest $ concat $ map snd list
+ let reqs = concat $ map snd list
when (not $ null reqs) $ do
let packet = TransportPacket (TransportHeader $ map DataRequest reqs) []
ackedBy = concat [[ Rejected r, DataResponse r ] | r <- reqs ]
diff --git a/src/State.hs b/src/State.hs
index afdddc8..12f9db9 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -94,7 +94,7 @@ updateLocalHead_ f = updateLocalHead (fmap (,()) . f)
instance Monad m => MonadStorage (ReaderT (Head a) m) where
- getStorage = asks $ refStorage . headRef
+ getStorage = asks $ headStorage
instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
updateLocalHead f = do
diff --git a/src/Storage.hs b/src/Storage.hs
index 47477df..93a34c5 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -4,7 +4,7 @@ module Storage (
deriveEphemeralStorage, derivePartialStorage,
Ref, PartialRef, RefDigest,
- refStorage, refDigest,
+ refDigest,
readRef, showRef, showRefDigest,
refDigestFromByteString, hashToRefDigest,
copyRef, partialRef, partialRefFromDigest,
@@ -18,7 +18,7 @@ module Storage (
Head, HeadType(..),
HeadTypeID, mkHeadTypeID,
- headId, headRef, headObject, headStoredObject,
+ headId, headStorage, headRef, headObject, headStoredObject,
loadHeads, loadHead, reloadHead,
storeHead, replaceHead, updateHead, updateHead_,
@@ -359,6 +359,9 @@ type Head = Head' Complete
headId :: Head a -> HeadID
headId (Head uuid _) = uuid
+headStorage :: Head a -> Storage
+headStorage = refStorage . headRef
+
headRef :: Head a -> Ref
headRef (Head _ sx) = storedRef sx
@@ -431,7 +434,7 @@ storeHead st obj = liftIO $ do
replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
replaceHead prev@(Head hid pobj) stored = liftIO $ do
- let st = storedStorage pobj
+ let st = headStorage prev
tid = headTypeID @a Proxy
case stBacking st of
StorageDir { dirPath = spath } -> do