Service: global state

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