summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2020-05-08 22:45:43 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2020-05-08 22:45:43 +0200
commitfd633795d755049c528d6594e6645fd15a1c57e6 (patch)
tree8d817d0c67a0ababd780e02b265e8aef3d4038e9 /src
parentb80bf0219b9efd4b5eb22d5e5eae98cf07968fb6 (diff)
Service: global state
Diffstat (limited to 'src')
-rw-r--r--src/Network.hs21
-rw-r--r--src/Service.hs57
2 files changed, 58 insertions, 20 deletions
diff --git a/src/Network.hs b/src/Network.hs
index 7b69040..429dee1 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -163,6 +163,7 @@ startServer origHead logd bhost services = do
let storage = refStorage $ headRef origHead
chanPeer <- newChan
chanSvc <- newChan
+ svcStates <- newMVar M.empty
peers <- newMVar M.empty
midentity <- newMVar $ headLocalIdentity origHead
mshared <- newMVar $ lsShared $ load $ headRef origHead
@@ -282,21 +283,27 @@ startServer origHead logd bhost services = do
void $ forkIO $ forever $ readChan chanSvc >>= \case
(peer, svc, ref)
| PeerIdentityFull peerId <- peerIdentity peer
- -> modifyMVar_ (peerServiceState peer) $ \svcs ->
- case maybe (someServiceEmptyState <$> find ((svc ==) . someServiceID) services) Just $ M.lookup svc svcs of
- Nothing -> do logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
- return svcs
- Just (SomeServiceState (proxy :: Proxy s) s) -> do
+ -> modifyMVar_ svcStates $ \global ->
+ modifyMVar (peerServiceState peer) $ \svcs ->
+ case (maybe (someServiceEmptyState <$> find ((svc ==) . someServiceID) services) Just $ M.lookup svc svcs,
+ maybe (someServiceEmptyGlobalState <$> find ((svc ==) . someServiceID) services) Just $ M.lookup svc global) of
+ (Just (SomeServiceState (proxy :: Proxy s) s),
+ Just (SomeServiceGlobalState (_ :: Proxy gs) gs))
+ | Just (Refl :: s :~: gs) <- eqT -> do
let inp = ServiceInput
{ svcPeer = peerId
, svcPrintOp = logd
}
- (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref :: Stored s)
+ (rsp, (s', gs')) <- handleServicePacket storage inp s gs (wrappedLoad ref :: Stored s)
identity <- readMVar midentity
runExceptT (sendToPeerList identity peer rsp) >>= \case
Left err -> logd $ "failed to send response to peer: " ++ show err
Right () -> return ()
- return $ M.insert svc (SomeServiceState proxy s') svcs
+ return (M.insert svc (SomeServiceState proxy s') svcs,
+ M.insert svc (SomeServiceGlobalState proxy gs') global)
+ _ -> do
+ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
+ return (svcs, global)
| DatagramAddress paddr <- peerAddress peer -> do
logd $ "service packet from peer with incomplete identity " ++ show paddr
diff --git a/src/Service.hs b/src/Service.hs
index 697934b..b5106ce 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -1,7 +1,8 @@
module Service (
Service(..),
- SomeService(..), SomeServiceState(..),
- someServiceID, fromServiceState, someServiceEmptyState,
+ SomeService(..), someServiceID,
+ SomeServiceState(..), fromServiceState, someServiceEmptyState,
+ SomeServiceGlobalState(..), fromServiceGlobalState, someServiceEmptyGlobalState,
ServiceID, mkServiceID,
ServiceHandler,
@@ -9,7 +10,8 @@ module Service (
ServiceReply(..),
handleServicePacket,
- svcGet, svcSet,
+ svcGet, svcSet, svcModify,
+ svcGetGlobal, svcSetGlobal, svcModifyGlobal,
svcGetLocal, svcSetLocal,
svcPrint,
replyPacket, replyStored, replyStoredRef,
@@ -28,7 +30,7 @@ import Identity
import State
import Storage
-class (Typeable s, Storable s, Typeable (ServiceState s)) => Service s where
+class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where
serviceID :: proxy s -> ServiceID
serviceHandler :: Stored s -> ServiceHandler s ()
@@ -38,19 +40,35 @@ class (Typeable s, Storable s, Typeable (ServiceState s)) => Service s where
default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s
emptyServiceState _ = ()
-data SomeService = forall s. Service s => SomeService (Proxy s)
+ type ServiceGlobalState s :: *
+ type ServiceGlobalState s = ()
+ emptyServiceGlobalState :: proxy s -> ServiceGlobalState s
+ default emptyServiceGlobalState :: ServiceGlobalState s ~ () => proxy s -> ServiceGlobalState s
+ emptyServiceGlobalState _ = ()
-data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s)
+
+data SomeService = forall s. Service s => SomeService (Proxy s)
someServiceID :: SomeService -> ServiceID
someServiceID (SomeService s) = serviceID s
+data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s)
+
fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceState s)
fromServiceState _ (SomeServiceState _ s) = cast s
someServiceEmptyState :: SomeService -> SomeServiceState
someServiceEmptyState (SomeService p) = SomeServiceState p (emptyServiceState p)
+data SomeServiceGlobalState = forall s. Service s => SomeServiceGlobalState (Proxy s) (ServiceGlobalState s)
+
+fromServiceGlobalState :: Service s => proxy s -> SomeServiceGlobalState -> Maybe (ServiceGlobalState s)
+fromServiceGlobalState _ (SomeServiceGlobalState _ s) = cast s
+
+someServiceEmptyGlobalState :: SomeService -> SomeServiceGlobalState
+someServiceEmptyGlobalState (SomeService p) = SomeServiceGlobalState p (emptyServiceGlobalState p)
+
+
newtype ServiceID = ServiceID UUID
deriving (Eq, Ord, StorableUUID)
@@ -66,27 +84,28 @@ data ServiceReply s = ServiceReply (Either s (Stored s)) Bool
data ServiceHandlerState s = ServiceHandlerState
{ svcValue :: ServiceState s
+ , svcGlobal :: ServiceGlobalState s
, svcLocal :: Stored LocalState
}
newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a)
deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO)
-handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored s -> IO ([ServiceReply s], ServiceState s)
-handleServicePacket st input svc packet = do
+handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> ServiceGlobalState s -> Stored s -> IO ([ServiceReply s], (ServiceState s, ServiceGlobalState s))
+handleServicePacket st input svc global packet = do
herb <- loadLocalStateHead st
let erb = wrappedLoad $ headRef herb
- sstate = ServiceHandlerState { svcValue = svc, svcLocal = erb }
+ sstate = ServiceHandlerState { svcValue = svc, svcGlobal = global, svcLocal = erb }
ServiceHandler handler = serviceHandler packet
(runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case
Left err -> do
svcPrintOp input $ "service failed: " ++ err
- return ([], svc)
+ return ([], (svc, global))
Right (rsp, sstate')
- | svcLocal sstate' == svcLocal sstate -> return (rsp, svcValue sstate')
+ | svcLocal sstate' == svcLocal sstate -> return (rsp, (svcValue sstate', svcGlobal sstate'))
| otherwise -> replaceHead (svcLocal sstate') (Right herb) >>= \case
- Left _ -> handleServicePacket st input svc packet
- Right _ -> return (rsp, svcValue sstate')
+ Left _ -> handleServicePacket st input svc global packet
+ Right _ -> return (rsp, (svcValue sstate', svcGlobal sstate'))
svcGet :: ServiceHandler s (ServiceState s)
svcGet = gets svcValue
@@ -94,6 +113,18 @@ svcGet = gets svcValue
svcSet :: ServiceState s -> ServiceHandler s ()
svcSet x = modify $ \st -> st { svcValue = x }
+svcModify :: (ServiceState s -> ServiceState s) -> ServiceHandler s ()
+svcModify f = modify $ \st -> st { svcValue = f (svcValue st) }
+
+svcGetGlobal :: ServiceHandler s (ServiceGlobalState s)
+svcGetGlobal = gets svcGlobal
+
+svcSetGlobal :: ServiceGlobalState s -> ServiceHandler s ()
+svcSetGlobal x = modify $ \st -> st { svcGlobal = x }
+
+svcModifyGlobal :: (ServiceGlobalState s -> ServiceGlobalState s) -> ServiceHandler s ()
+svcModifyGlobal f = modify $ \st -> st { svcGlobal = f (svcGlobal st) }
+
svcGetLocal :: ServiceHandler s (Stored LocalState)
svcGetLocal = gets svcLocal