summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network.hs7
-rw-r--r--src/Network.hs-boot4
-rw-r--r--src/Service.hs3
-rw-r--r--src/State.hs10
-rw-r--r--src/Test.hs3
5 files changed, 23 insertions, 4 deletions
diff --git a/src/Network.hs b/src/Network.hs
index c9a2d8b..7195129 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -4,7 +4,7 @@ module Network (
getNextPeerChange,
ServerOptions(..), serverIdentity, defaultServerOptions,
- Peer, peerServer,
+ Peer, peerServer, peerStorage,
PeerAddress(..), peerAddress,
PeerIdentity(..), peerIdentity,
PeerChannel(..),
@@ -101,7 +101,7 @@ data Peer = Peer
, peerServer_ :: Server
, peerIdentityVar :: TVar PeerIdentity
, peerChannel :: TVar PeerChannel
- , peerStorage :: Storage
+ , peerStorage_ :: Storage
, peerInStorage :: PartialStorage
, peerOutQueue :: TQueue (Bool, [TransportHeaderItem], TransportPacket)
, peerSentPackets :: TVar [SentPacket]
@@ -120,6 +120,9 @@ data SentPacket = SentPacket
peerServer :: Peer -> Server
peerServer = peerServer_
+peerStorage :: Peer -> Storage
+peerStorage = peerStorage_
+
instance Eq Peer where
(==) = (==) `on` peerIdentityVar
diff --git a/src/Network.hs-boot b/src/Network.hs-boot
index 1ec6daa..f251e5e 100644
--- a/src/Network.hs-boot
+++ b/src/Network.hs-boot
@@ -1,4 +1,8 @@
module Network where
+import Storage
+
data Server
data Peer
+
+peerStorage :: Peer -> Storage
diff --git a/src/Service.hs b/src/Service.hs
index 7d5c7e7..22c983b 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -111,6 +111,9 @@ data ServiceHandlerState s = ServiceHandlerState
newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a)
deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO)
+instance MonadStorage (ServiceHandler s) where
+ getStorage = asks $ peerStorage . svcPeer
+
instance MonadHead LocalState (ServiceHandler s) where
updateLocalHead f = do
(ls, x) <- liftIO . f =<< gets svcLocal
diff --git a/src/State.hs b/src/State.hs
index 358d958..e112aca 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -2,7 +2,7 @@ module State (
LocalState(..),
SharedState, SharedType(..),
SharedTypeID, mkSharedTypeID,
- MonadHead(..),
+ MonadStorage(..), MonadHead(..),
loadLocalStateHead,
updateLocalState, updateLocalState_,
@@ -81,9 +81,15 @@ instance SharedType (Maybe ComposedIdentity) where
sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
-class MonadHead a m where
+class Monad m => MonadStorage m where
+ getStorage :: m Storage
+
+class MonadStorage m => MonadHead a m where
updateLocalHead :: (Stored a -> IO (Stored a, b)) -> m b
+instance Monad m => MonadStorage (ReaderT (Head a) m) where
+ getStorage = asks $ refStorage . headRef
+
instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
updateLocalHead f = do
h <- ask
diff --git a/src/Test.hs b/src/Test.hs
index 9c5319b..8bd34ea 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -167,6 +167,9 @@ instance MonadFail CommandM where
instance MonadRandom CommandM where
getRandomBytes = liftIO . getRandomBytes
+instance MonadStorage CommandM where
+ getStorage = asks tiStorage
+
instance MonadHead LocalState CommandM where
updateLocalHead f = do
Just h <- gets tsHead