diff options
| -rw-r--r-- | src/Main.hs | 2 | ||||
| -rw-r--r-- | src/Network.hs | 6 | ||||
| -rw-r--r-- | src/State.hs | 2 | ||||
| -rw-r--r-- | src/Storage.hs | 9 |
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 |