From 88a7bb50033baab3c2d0eed7e4be868e8966300a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Fri, 17 Nov 2023 20:28:44 +0100 Subject: Split to library and executable parts --- src/Service.hs | 190 --------------------------------------------------------- 1 file changed, 190 deletions(-) delete mode 100644 src/Service.hs (limited to 'src/Service.hs') diff --git a/src/Service.hs b/src/Service.hs deleted file mode 100644 index f15662e..0000000 --- a/src/Service.hs +++ /dev/null @@ -1,190 +0,0 @@ -module Service ( - Service(..), - SomeService(..), someService, someServiceAttr, someServiceID, - SomeServiceState(..), fromServiceState, someServiceEmptyState, - SomeServiceGlobalState(..), fromServiceGlobalState, someServiceEmptyGlobalState, - SomeStorageWatcher(..), - ServiceID, mkServiceID, - - ServiceHandler, - ServiceInput(..), - ServiceReply(..), - runServiceHandler, - - svcGet, svcSet, svcModify, - svcGetGlobal, svcSetGlobal, svcModifyGlobal, - svcGetLocal, svcSetLocal, - - svcSelf, - svcPrint, - - replyPacket, replyStored, replyStoredRef, - afterCommit, -) where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer - -import Data.Kind -import Data.Typeable -import Data.UUID (UUID) -import qualified Data.UUID as U - -import Identity -import {-# SOURCE #-} Network -import State -import Storage - -class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where - serviceID :: proxy s -> ServiceID - serviceHandler :: Stored s -> ServiceHandler s () - - serviceNewPeer :: ServiceHandler s () - serviceNewPeer = return () - - type ServiceAttributes s = attr | attr -> s - type ServiceAttributes s = Proxy s - defaultServiceAttributes :: proxy s -> ServiceAttributes s - default defaultServiceAttributes :: ServiceAttributes s ~ Proxy s => proxy s -> ServiceAttributes s - defaultServiceAttributes _ = Proxy - - type ServiceState s :: Type - type ServiceState s = () - emptyServiceState :: proxy s -> ServiceState s - default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s - emptyServiceState _ = () - - type ServiceGlobalState s :: Type - type ServiceGlobalState s = () - emptyServiceGlobalState :: proxy s -> ServiceGlobalState s - default emptyServiceGlobalState :: ServiceGlobalState s ~ () => proxy s -> ServiceGlobalState s - emptyServiceGlobalState _ = () - - serviceStorageWatchers :: proxy s -> [SomeStorageWatcher s] - serviceStorageWatchers _ = [] - - -data SomeService = forall s. Service s => SomeService (Proxy s) (ServiceAttributes s) - -someService :: forall s proxy. Service s => proxy s -> SomeService -someService _ = SomeService @s Proxy (defaultServiceAttributes @s Proxy) - -someServiceAttr :: forall s. Service s => ServiceAttributes s -> SomeService -someServiceAttr attr = SomeService @s Proxy attr - -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) - - -data SomeStorageWatcher s = forall a. Eq a => SomeStorageWatcher (Stored LocalState -> a) (a -> ServiceHandler s ()) - - -newtype ServiceID = ServiceID UUID - deriving (Eq, Ord, Show, StorableUUID) - -mkServiceID :: String -> ServiceID -mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString - -data ServiceInput s = ServiceInput - { svcAttributes :: ServiceAttributes s - , svcPeer :: Peer - , svcPeerIdentity :: UnifiedIdentity - , svcServer :: Server - , svcPrintOp :: String -> IO () - } - -data ServiceReply s = ServiceReply (Either s (Stored s)) Bool - | ServiceFinally (IO ()) - -data ServiceHandlerState s = ServiceHandlerState - { svcValue :: ServiceState s - , svcGlobal :: ServiceGlobalState s - , svcLocal :: Stored LocalState - } - -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) <- f =<< gets svcLocal - modify $ \s -> s { svcLocal = ls } - return x - -runServiceHandler :: Service s => Head LocalState -> ServiceInput s -> ServiceState s -> ServiceGlobalState s -> ServiceHandler s () -> IO ([ServiceReply s], (ServiceState s, ServiceGlobalState s)) -runServiceHandler h input svc global shandler = do - let sstate = ServiceHandlerState { svcValue = svc, svcGlobal = global, svcLocal = headStoredObject h } - ServiceHandler handler = shandler - (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case - Left err -> do - svcPrintOp input $ "service failed: " ++ err - return ([], (svc, global)) - Right (rsp, sstate') - | svcLocal sstate' == svcLocal sstate -> return (rsp, (svcValue sstate', svcGlobal sstate')) - | otherwise -> replaceHead h (svcLocal sstate') >>= \case - Left (Just h') -> runServiceHandler h' input svc global shandler - _ -> return (rsp, (svcValue sstate', svcGlobal sstate')) - -svcGet :: ServiceHandler s (ServiceState s) -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 - -svcSetLocal :: Stored LocalState -> ServiceHandler s () -svcSetLocal x = modify $ \st -> st { svcLocal = x } - -svcSelf :: ServiceHandler s UnifiedIdentity -svcSelf = maybe (throwError "failed to validate own identity") return . - validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal - -svcPrint :: String -> ServiceHandler s () -svcPrint str = afterCommit . ($ str) =<< asks svcPrintOp - -replyPacket :: Service s => s -> ServiceHandler s () -replyPacket x = tell [ServiceReply (Left x) True] - -replyStored :: Service s => Stored s -> ServiceHandler s () -replyStored x = tell [ServiceReply (Right x) True] - -replyStoredRef :: Service s => Stored s -> ServiceHandler s () -replyStoredRef x = tell [ServiceReply (Right x) False] - -afterCommit :: IO () -> ServiceHandler s () -afterCommit x = tell [ServiceFinally x] -- cgit v1.2.3