diff options
Diffstat (limited to 'src/Service.hs')
| -rw-r--r-- | src/Service.hs | 57 |
1 files changed, 44 insertions, 13 deletions
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 |