summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs10
-rw-r--r--src/Network.hs59
-rw-r--r--src/Service.hs33
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-20 10:03:52 +0000