Call refStorage only internally in Storage modules

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