From 8dc945aae35fffd8e64c524b71d7316297721daf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 4 Feb 2020 23:28:46 +0100 Subject: Service: unify service and packet types Also provide default unit definition for the service state. --- erebos.cabal | 3 ++- src/Attach.hs | 38 ++++++++++++++++++-------------------- src/Main.hs | 2 +- src/Message.hs | 25 +++++-------------------- src/Network.hs | 19 ++++++++++--------- src/Service.hs | 31 ++++++++++++++++--------------- src/Sync.hs | 12 +++--------- 7 files changed, 55 insertions(+), 75 deletions(-) diff --git a/erebos.cabal b/erebos.cabal index e7a8cee..87c3bd2 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -34,7 +34,8 @@ executable erebos Sync Util - default-extensions: ExistentialQuantification + default-extensions: DefaultSignatures + ExistentialQuantification FlexibleContexts, FlexibleInstances, FunctionalDependencies, diff --git a/src/Attach.hs b/src/Attach.hs index 10a87f3..2ce6110 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -26,9 +26,22 @@ import State import Storage import Storage.Key -data AttachService - -instance Storable (ServicePacket AttachService) where +data AttachService = AttachRequest RefDigest + | AttachResponse Bytes + | AttachRequestNonce Bytes + | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] + | AttachDecline + +data AttachState = NoAttach + | OurRequest Bytes + | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes])) + | OurRequestReady + | PeerRequest Bytes RefDigest + | PeerRequestConfirm + | AttachDone + | AttachFailed + +instance Storable AttachService where store' at = storeRec $ do case at of AttachRequest x -> storeBinary "request" x @@ -60,23 +73,8 @@ instance Storable (ServicePacket AttachService) where instance Service AttachService where serviceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f" - data ServiceState AttachService - = NoAttach - | OurRequest Bytes - | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes])) - | OurRequestReady - | PeerRequest Bytes RefDigest - | PeerRequestConfirm - | AttachDone - | AttachFailed - emptyServiceState = NoAttach - - data ServicePacket AttachService - = AttachRequest RefDigest - | AttachResponse Bytes - | AttachRequestNonce Bytes - | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] - | AttachDecline + type ServiceState AttachService = AttachState + emptyServiceState _ = NoAttach serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case (NoAttach, AttachRequest confirm) -> do diff --git a/src/Main.hs b/src/Main.hs index 6da9826..b692357 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -96,7 +96,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do startServer erebosHead extPrintLn bhost [ SomeService @AttachService Proxy , SomeService @SyncService Proxy - , SomeService @DirectMessageService Proxy + , SomeService @DirectMessage Proxy ] peers <- liftIO $ newMVar [] diff --git a/src/Message.hs b/src/Message.hs index ee59dad..0039d7e 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -1,8 +1,5 @@ module Message ( DirectMessage(..), - DirectMessageService, - ServicePacket(DirectMessagePacket), - sendDirectMessage, DirectMessageThread(..), @@ -50,19 +47,11 @@ instance Storable DirectMessage where <*> loadDate "time" <*> loadText "text" -data DirectMessageService - -instance Service DirectMessageService where +instance Service DirectMessage where serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" - data ServiceState DirectMessageService = DirectMessageService - emptyServiceState = DirectMessageService - - newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage) - - serviceHandler packet = do - let DirectMessagePacket smsg = fromStored packet - msg = fromStored smsg + serviceHandler smsg = do + let msg = fromStored smsg powner <- asks $ finalOwner . svcPeer tzone <- liftIO $ getCurrentTimeZone erb <- svcGetLocal @@ -86,14 +75,10 @@ instance Service DirectMessageService where svcSetLocal erb' when (powner `sameIdentity` msgFrom msg) $ do svcPrint $ formatMessage tzone msg - replyStoredRef packet + replyStoredRef smsg else svcPrint "Owner mismatch" -instance Storable (ServicePacket DirectMessageService) where - store' (DirectMessagePacket smsg) = store' smsg - load' = DirectMessagePacket <$> load' - data MessageState = MessageState { msPrev :: [Stored MessageState] @@ -155,7 +140,7 @@ sendDirectMessage self peer text = do } return ([next], smsg) - sendToPeer self peer $ DirectMessagePacket smsg + sendToPeerStored self peer smsg return smsg diff --git a/src/Network.hs b/src/Network.hs index 7e2568e..eb319b2 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -281,17 +281,17 @@ startServer origHead logd bhost services = do 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 s) -> do + Just (SomeServiceState (proxy :: Proxy s) s) -> do let inp = ServiceInput { svcPeer = peerId , svcPrintOp = logd } - (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref) + (rsp, s') <- handleServicePacket storage inp s (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 s') svcs + return $ M.insert svc (SomeServiceState proxy s') svcs | DatagramAddress paddr <- peerAddress peer -> do logd $ "service packet from peer with incomplete identity " ++ show paddr @@ -587,10 +587,10 @@ handleServices chan = gets (peerServiceQueue . phPeer) >>= \case updatePeer $ \p -> p { peerServiceQueue = queue' } -sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> ServicePacket s -> m () +sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> s -> m () sendToPeer self peer packet = sendToPeerList self peer [ServiceReply (Left packet) True] -sendToPeerStored :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Stored (ServicePacket s) -> m () +sendToPeerStored :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Stored s -> m () sendToPeerStored self peer spacket = sendToPeerList self peer [ServiceReply (Right spacket) True] sendToPeerList :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> [ServiceReply s] -> m () @@ -613,12 +613,13 @@ sendToPeerList _ peer@Peer { peerChannel = ChannelEstablished ch } parts = do sendToPeerList _ _ _ = throwError $ "no channel to peer" -sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe (ServicePacket s), ServiceState s)) -> m () +sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m () sendToPeerWith identity peer fobj = do - let sid = serviceID @s Proxy + let sproxy = Proxy @s + sid = serviceID sproxy res <- liftIO $ modifyMVar (peerServiceState peer) $ \svcs -> do - runExceptT (fobj $ fromMaybe emptyServiceState $ fromServiceState =<< M.lookup sid svcs) >>= \case - Right (obj, s') -> return $ (M.insert sid (SomeServiceState s') svcs, Right obj) + runExceptT (fobj $ fromMaybe (emptyServiceState sproxy) $ fromServiceState sproxy =<< M.lookup sid svcs) >>= \case + Right (obj, s') -> return $ (M.insert sid (SomeServiceState sproxy s') svcs, Right obj) Left err -> return $ (svcs, Left err) case res of Right (Just obj) -> sendToPeer identity peer obj diff --git a/src/Service.hs b/src/Service.hs index d2848b6..697934b 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -28,27 +28,28 @@ import Identity import State import Storage -class (Typeable s, Storable (ServicePacket s)) => Service s where +class (Typeable s, Storable s, Typeable (ServiceState s)) => Service s where serviceID :: proxy s -> ServiceID + serviceHandler :: Stored s -> ServiceHandler s () - data ServiceState s :: * - emptyServiceState :: ServiceState s - - data ServicePacket s :: * - serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s () + type ServiceState s :: * + type ServiceState s = () + emptyServiceState :: proxy s -> ServiceState s + default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s + emptyServiceState _ = () data SomeService = forall s. Service s => SomeService (Proxy s) -data SomeServiceState = forall s. Service s => SomeServiceState (ServiceState s) +data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s) someServiceID :: SomeService -> ServiceID someServiceID (SomeService s) = serviceID s -fromServiceState :: Service s => SomeServiceState -> Maybe (ServiceState s) -fromServiceState (SomeServiceState s) = cast s +fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceState s) +fromServiceState _ (SomeServiceState _ s) = cast s someServiceEmptyState :: SomeService -> SomeServiceState -someServiceEmptyState (SomeService (Proxy :: Proxy s)) = SomeServiceState (emptyServiceState :: ServiceState s) +someServiceEmptyState (SomeService p) = SomeServiceState p (emptyServiceState p) newtype ServiceID = ServiceID UUID deriving (Eq, Ord, StorableUUID) @@ -61,7 +62,7 @@ data ServiceInput = ServiceInput , svcPrintOp :: String -> IO () } -data ServiceReply s = ServiceReply (Either (ServicePacket s) (Stored (ServicePacket s))) Bool +data ServiceReply s = ServiceReply (Either s (Stored s)) Bool data ServiceHandlerState s = ServiceHandlerState { svcValue :: ServiceState s @@ -71,7 +72,7 @@ data ServiceHandlerState s = ServiceHandlerState 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 (ServicePacket s) -> IO ([ServiceReply s], ServiceState s) +handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored s -> IO ([ServiceReply s], ServiceState s) handleServicePacket st input svc packet = do herb <- loadLocalStateHead st let erb = wrappedLoad $ headRef herb @@ -102,11 +103,11 @@ svcSetLocal x = modify $ \st -> st { svcLocal = x } svcPrint :: String -> ServiceHandler s () svcPrint str = liftIO . ($str) =<< asks svcPrintOp -replyPacket :: Service s => ServicePacket s -> ServiceHandler s () +replyPacket :: Service s => s -> ServiceHandler s () replyPacket x = tell [ServiceReply (Left x) True] -replyStored :: Service s => Stored (ServicePacket s) -> ServiceHandler s () +replyStored :: Service s => Stored s -> ServiceHandler s () replyStored x = tell [ServiceReply (Right x) True] -replyStoredRef :: Service s => Stored (ServicePacket s) -> ServiceHandler s () +replyStoredRef :: Service s => Stored s -> ServiceHandler s () replyStoredRef x = tell [ServiceReply (Right x) False] diff --git a/src/Sync.hs b/src/Sync.hs index 37941b8..afb45e6 100644 --- a/src/Sync.hs +++ b/src/Sync.hs @@ -1,6 +1,5 @@ module Sync ( - SyncService, - ServicePacket(..), + SyncService(..), ) where import Control.Monad @@ -12,16 +11,11 @@ import State import Storage import Storage.Merge -data SyncService +data SyncService = SyncPacket (Stored SharedState) instance Service SyncService where serviceID _ = mkServiceID "a4f538d0-4e50-4082-8e10-7e3ec2af175d" - data ServiceState SyncService = SyncService - emptyServiceState = SyncService - - newtype ServicePacket SyncService = SyncPacket (Stored SharedState) - serviceHandler packet = do let SyncPacket added = fromStored packet ls <- svcGetLocal @@ -31,6 +25,6 @@ instance Service SyncService where when (current /= updated) $ do svcSetLocal =<< wrappedStore st (fromStored ls) { lsShared = updated } -instance Storable (ServicePacket SyncService) where +instance Storable SyncService where store' (SyncPacket smsg) = store' smsg load' = SyncPacket <$> load' -- cgit v1.2.3