diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 10 | ||||
| -rw-r--r-- | src/Network.hs | 59 | ||||
| -rw-r--r-- | src/Service.hs | 33 |
3 files changed, 60 insertions, 42 deletions
diff --git a/src/Main.hs b/src/Main.hs index fcdb2c5..9dcbae9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -129,11 +129,11 @@ interactiveLoop st opts = runInputT defaultSettings $ do _ -> str ++ "\n"; server <- liftIO $ do startServer (optServer opts) erebosHead extPrintLn - [ SomeService @AttachService Proxy - , SomeService @SyncService Proxy - , SomeService @ContactService Proxy - , SomeService @DirectMessage Proxy - , SomeService @DiscoveryService Proxy + [ someService @AttachService Proxy + , someService @SyncService Proxy + , someService @ContactService Proxy + , someService @DirectMessage Proxy + , someService @DiscoveryService Proxy ] peers <- liftIO $ newMVar [] diff --git a/src/Network.hs b/src/Network.hs index 5f7d823..6ace27b 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -365,33 +365,38 @@ startServer opt origHead logd' services = do (global, svcs) <- atomically $ (,) <$> takeTMVar svcStates <*> takeTMVar (peerServiceState peer) - 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 = peer - , svcPeerIdentity = peerId - , svcServer = server - , svcPrintOp = atomically . logd - } - reloadHead origHead >>= \case - Nothing -> atomically $ do - logd $ "current head deleted" - putTMVar (peerServiceState peer) svcs - putTMVar svcStates global - Just h -> do - (rsp, (s', gs')) <- handleServicePacket h inp s gs (wrappedLoad ref :: Stored s) - when (not (null rsp)) $ do - sendToPeerList peer rsp - atomically $ do - putTMVar (peerServiceState peer) $ M.insert svc (SomeServiceState proxy s') svcs - putTMVar svcStates $ M.insert svc (SomeServiceGlobalState proxy gs') global - _ -> atomically $ do - logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" - putTMVar (peerServiceState peer) svcs - putTMVar svcStates global + case find ((svc ==) . someServiceID) services of + Just service@(SomeService (proxy :: Proxy s) attr) -> + case (fromMaybe (someServiceEmptyState service) $ M.lookup svc svcs, + fromMaybe (someServiceEmptyGlobalState service) $ M.lookup svc global) of + ((SomeServiceState (_ :: Proxy ps) ps), + (SomeServiceGlobalState (_ :: Proxy gs) gs)) -> do + Just (Refl :: s :~: ps) <- return $ eqT + Just (Refl :: s :~: gs) <- return $ eqT + + let inp = ServiceInput + { svcAttributes = attr + , svcPeer = peer + , svcPeerIdentity = peerId + , svcServer = server + , svcPrintOp = atomically . logd + } + reloadHead origHead >>= \case + Nothing -> atomically $ do + logd $ "current head deleted" + putTMVar (peerServiceState peer) svcs + putTMVar svcStates global + Just h -> do + (rsp, (s', gs')) <- handleServicePacket h inp ps gs (wrappedLoad ref :: Stored s) + when (not (null rsp)) $ do + sendToPeerList peer rsp + atomically $ do + putTMVar (peerServiceState peer) $ M.insert svc (SomeServiceState proxy s') svcs + putTMVar svcStates $ M.insert svc (SomeServiceGlobalState proxy gs') global + _ -> atomically $ do + logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" + putTMVar (peerServiceState peer) svcs + putTMVar svcStates global _ -> do atomically $ logd $ "service packet from peer with incomplete identity " ++ show (peerAddress peer) diff --git a/src/Service.hs b/src/Service.hs index eae43ec..90fd34a 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -1,6 +1,6 @@ module Service ( Service(..), - SomeService(..), someServiceID, + SomeService(..), someService, someServiceAttr, someServiceID, SomeServiceState(..), fromServiceState, someServiceEmptyState, SomeServiceGlobalState(..), fromServiceGlobalState, someServiceEmptyGlobalState, ServiceID, mkServiceID, @@ -38,6 +38,12 @@ class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGloba serviceID :: proxy s -> ServiceID serviceHandler :: Stored s -> ServiceHandler s () + 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 ServiceState s = () emptyServiceState :: proxy s -> ServiceState s @@ -51,10 +57,16 @@ class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGloba emptyServiceGlobalState _ = () -data SomeService = forall s. Service s => SomeService (Proxy s) +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 +someServiceID (SomeService s _) = serviceID s data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s) @@ -62,7 +74,7 @@ fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceSt fromServiceState _ (SomeServiceState _ s) = cast s someServiceEmptyState :: SomeService -> SomeServiceState -someServiceEmptyState (SomeService p) = SomeServiceState p (emptyServiceState p) +someServiceEmptyState (SomeService p _) = SomeServiceState p (emptyServiceState p) data SomeServiceGlobalState = forall s. Service s => SomeServiceGlobalState (Proxy s) (ServiceGlobalState s) @@ -70,7 +82,7 @@ fromServiceGlobalState :: Service s => proxy s -> SomeServiceGlobalState -> Mayb fromServiceGlobalState _ (SomeServiceGlobalState _ s) = cast s someServiceEmptyGlobalState :: SomeService -> SomeServiceGlobalState -someServiceEmptyGlobalState (SomeService p) = SomeServiceGlobalState p (emptyServiceGlobalState p) +someServiceEmptyGlobalState (SomeService p _) = SomeServiceGlobalState p (emptyServiceGlobalState p) newtype ServiceID = ServiceID UUID @@ -79,8 +91,9 @@ newtype ServiceID = ServiceID UUID mkServiceID :: String -> ServiceID mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString -data ServiceInput = ServiceInput - { svcPeer :: Peer +data ServiceInput s = ServiceInput + { svcAttributes :: ServiceAttributes s + , svcPeer :: Peer , svcPeerIdentity :: UnifiedIdentity , svcServer :: Server , svcPrintOp :: String -> IO () @@ -94,10 +107,10 @@ data ServiceHandlerState s = ServiceHandlerState , 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) +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) -handleServicePacket :: Service s => Head LocalState -> ServiceInput -> ServiceState s -> ServiceGlobalState s -> Stored s -> IO ([ServiceReply s], (ServiceState s, ServiceGlobalState s)) +handleServicePacket :: Service s => Head LocalState -> ServiceInput s -> ServiceState s -> ServiceGlobalState s -> Stored s -> IO ([ServiceReply s], (ServiceState s, ServiceGlobalState s)) handleServicePacket h input svc global packet = do let sstate = ServiceHandlerState { svcValue = svc, svcGlobal = global, svcLocal = headStoredObject h } ServiceHandler handler = serviceHandler packet |