diff options
| -rw-r--r-- | erebos.cabal | 1 | ||||
| -rw-r--r-- | src/Network.hs | 21 | ||||
| -rw-r--r-- | src/Service.hs | 57 |
3 files changed, 59 insertions, 20 deletions
diff --git a/erebos.cabal b/erebos.cabal index 00fa1c3..c0cd961 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -45,6 +45,7 @@ executable erebos RankNTypes, ScopedTypeVariables, StandaloneDeriving, + TypeOperators TupleSections, TypeApplications, TypeFamilies 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 |