Service: unify service and packet types

Also provide default unit definition for the service state.

6 files changed, 53 insertions, 74 deletions

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'