Service attributes

4 files changed, 61 insertions, 42 deletions

diff --git a/erebos.cabal b/erebos.cabal
index fd1db20..06d96eb 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -53,6 +53,7 @@ executable erebos
                        TupleSections,
                        TypeApplications,
                        TypeFamilies
+                       TypeFamilyDependencies
 
   -- other-extensions:
   build-depends:       aeson >=1.4 && <1.6,
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