Use UUID for service types

5 files changed, 126 insertions, 78 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index 9861f15..298ed29 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -5,7 +5,6 @@ module Attach (
 
 import Control.Monad.Except
 import Control.Monad.Reader
-import Control.Monad.State
 
 import Crypto.Hash
 import Crypto.Random
@@ -27,22 +26,9 @@ import State
 import Storage
 import Storage.Key
 
-data AttachService = NoAttach
-                   | OurRequest Bytes
-                   | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes]))
-                   | OurRequestReady
-                   | PeerRequest Bytes RefDigest
-                   | PeerRequestConfirm
-                   | AttachDone
-                   | AttachFailed
-
-data AttachStage = AttachRequest RefDigest
-                 | AttachResponse Bytes
-                 | AttachRequestNonce Bytes
-                 | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
-                 | AttachDecline
-
-instance Storable AttachStage where
+data AttachService
+
+instance Storable (ServicePacket AttachService) where
     store' at = storeRec $ do
         case at of
              AttachRequest x -> storeBinary "request" x
@@ -72,10 +58,27 @@ instance Storable AttachStage where
              [] -> throwError "invalid attach stange"
 
 instance Service AttachService where
-    type ServicePacket AttachService = AttachStage
+    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
 
-    serviceHandler spacket = gets ((,fromStored spacket) . svcValue) >>= \case
+    data ServicePacket AttachService
+        = AttachRequest RefDigest
+        | AttachResponse Bytes
+        | AttachRequestNonce Bytes
+        | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
+        | AttachDecline
+
+    serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
         (NoAttach, AttachRequest confirm) -> do
             peer <- asks $ svcPeer
             svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
@@ -86,8 +89,8 @@ instance Service AttachService where
 
         (OurRequest nonce, AttachResponse pnonce) -> do
             peer <- asks $ svcPeer
-            self <- maybe (throwError "failed to verify own identity") return =<<
-                gets (validateIdentity . lsIdentity . fromStored . svcLocal)
+            self <- maybe (throwError "failed to verify own identity") return .
+                validateIdentity . lsIdentity . fromStored =<< svcGetLocal
             svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce)
             svcSet $ OurRequestConfirm Nothing
             return $ Just $ AttachRequestNonce nonce
@@ -113,7 +116,7 @@ instance Service AttachService where
             verifyAttachedIdentity sdata >>= \case
                 Just identity -> do
                     svcPrint $ "Accepted updated identity"
-                    st <- gets $ storedStorage . svcLocal
+                    st <- storedStorage <$> svcGetLocal
                     finalizeAttach st identity keys
                     return Nothing
                 Nothing -> do
@@ -126,8 +129,8 @@ instance Service AttachService where
 
         (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do
             peer <- asks $ svcPeer
-            self <- maybe (throwError "failed to verify own identity") return =<<
-                gets (validateIdentity . lsIdentity . fromStored . svcLocal)
+            self <- maybe (throwError "failed to verify own identity") return .
+                validateIdentity . lsIdentity . fromStored =<< svcGetLocal
             if dgst == nonceDigest peer self pnonce BA.empty
                then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce)
                        svcSet PeerRequestConfirm
@@ -151,14 +154,14 @@ attachToOwner _ self peer = do
     pid <- case peerIdentity peer of
                 PeerIdentityFull pid -> return pid
                 _ -> throwError "incomplete peer identity"
-    sendToPeerWith self peer (T.pack "attach") $ \case
+    sendToPeerWith self peer $ \case
         NoAttach -> return (Just $ AttachRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
         _ -> throwError "alredy in progress"
 
 attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
 attachAccept printMsg self peer = do
     let st = storedStorage $ idData self
-    sendToPeerWith self peer (T.pack "attach") $ \case
+    sendToPeerWith self peer $ \case
         NoAttach -> throwError $ "none in progress"
         OurRequest {} -> throwError $ "waiting for peer"
         OurRequestConfirm Nothing -> do
@@ -202,7 +205,7 @@ confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst ::
 
 verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity)
 verifyAttachedIdentity sdata = do
-    curid <- gets $ lsIdentity . fromStored . svcLocal
+    curid <- lsIdentity . fromStored <$> svcGetLocal
     secret <- maybe (throwError "failed to load own secret key") return =<<
         liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid)
     sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata)
diff --git a/src/Main.hs b/src/Main.hs
index b143253..e23e1b5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,6 +19,7 @@ import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Time.LocalTime
+import Data.Typeable
 
 import System.Console.Haskeline
 import System.Environment
@@ -94,8 +95,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
     chanPeer <- liftIO $ do
         erebosHead <- loadLocalStateHead st
         startServer erebosHead extPrintLn bhost
-            [ (T.pack "attach", SomeService (emptyServiceState :: AttachService))
-            , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService))
+            [ SomeService @AttachService Proxy
+            , SomeService @DirectMessageService Proxy
             ]
 
     peers <- liftIO $ newMVar []
@@ -224,7 +225,7 @@ cmdSend = void $ do
                 (,smsg) <$> slistAddS thread' (lsMessages $ fromStored erb)
         erb' <- wrappedStore st (fromStored erb) { lsMessages = slist }
         return (erb', smsg)
-    sendToPeer self peer (T.pack "dmsg") smsg
+    sendToPeer self peer $ DirectMessagePacket smsg
 
     tzone <- liftIO $ getCurrentTimeZone
     liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
diff --git a/src/Message/Service.hs b/src/Message/Service.hs
index 1311e24..0a8f180 100644
--- a/src/Message/Service.hs
+++ b/src/Message/Service.hs
@@ -1,10 +1,10 @@
 module Message.Service (
-    DirectMessageService(..),
+    DirectMessageService,
+    ServicePacket(DirectMessagePacket),
     formatMessage,
 ) where
 
 import Control.Monad.Reader
-import Control.Monad.State
 
 import Data.List
 import qualified Data.Text as T
@@ -18,18 +18,24 @@ import State
 import Storage
 import Storage.List
 
-data DirectMessageService = DirectMessageService
+data DirectMessageService
 
 instance Service DirectMessageService where
-    type ServicePacket DirectMessageService = DirectMessage
+    serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
+
+    data ServiceState DirectMessageService = DirectMessageService
     emptyServiceState = DirectMessageService
-    serviceHandler smsg = do
-        let msg = fromStored smsg
+
+    newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage)
+
+    serviceHandler packet = do
+        let DirectMessagePacket smsg = fromStored packet
+            msg = fromStored smsg
         powner <- asks $ finalOwner . svcPeer
         tzone <- liftIO $ getCurrentTimeZone
         svcPrint $ formatMessage tzone msg
         if | powner `sameIdentity` msgFrom msg
-           -> do erb <- gets svcLocal
+           -> do erb <- svcGetLocal
                  let st = storedStorage erb
                  erb' <- liftIO $ do
                      threads <- storedFromSList $ lsMessages $ fromStored erb
@@ -38,12 +44,16 @@ instance Service DirectMessageService where
                                                      slistReplaceS thread thread' $ lsMessages $ fromStored erb
                                    Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb
                      wrappedStore st (fromStored erb) { lsMessages = slist }
-                 modify $ \s -> s { svcLocal = erb' }
+                 svcSetLocal erb'
                  return Nothing
 
            | otherwise -> do svcPrint "Owner mismatch"
                              return Nothing
 
+instance Storable (ServicePacket DirectMessageService) where
+    store' (DirectMessagePacket smsg) = store' smsg
+    load' = DirectMessagePacket <$> load'
+
 formatMessage :: TimeZone -> DirectMessage -> String
 formatMessage tzone msg = concat
     [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
diff --git a/src/Network.hs b/src/Network.hs
index d71e9d8..eceeaff 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -18,9 +18,10 @@ import Control.Monad.State
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
 import Data.Either
+import Data.List
 import qualified Data.Map as M
 import Data.Maybe
-import qualified Data.Text as T
+import Data.Typeable
 
 import Network.Socket
 import Network.Socket.ByteString (recvFrom, sendTo)
@@ -48,8 +49,8 @@ data Peer = Peer
     , peerSocket :: Socket
     , peerStorage :: Storage
     , peerInStorage :: PartialStorage
-    , peerServiceState :: MVar (M.Map T.Text SomeService)
-    , peerServiceQueue :: [(T.Text, WaitingRef)]
+    , peerServiceState :: MVar (M.Map ServiceID SomeServiceState)
+    , peerServiceQueue :: [(ServiceID, WaitingRef)]
     , peerWaitingRefs :: [WaitingRef]
     }
 
@@ -75,7 +76,7 @@ data TransportHeaderItem
     | AnnounceUpdate PartialRef
     | TrChannelRequest PartialRef
     | TrChannelAccept PartialRef
-    | ServiceType T.Text
+    | ServiceType ServiceID
     | ServiceRef PartialRef
 
 data TransportHeader = TransportHeader [TransportHeaderItem]
@@ -90,7 +91,7 @@ transportToObject (TransportHeader items) = Rec $ map single items
               AnnounceUpdate ref -> (BC.pack "ANU", RecRef ref)
               TrChannelRequest ref -> (BC.pack "CRQ", RecRef ref)
               TrChannelAccept ref -> (BC.pack "CAC", RecRef ref)
-              ServiceType stype -> (BC.pack "STP", RecText stype)
+              ServiceType stype -> (BC.pack "STP", RecUUID $ toUUID stype)
               ServiceRef ref -> (BC.pack "SRF", RecRef ref)
 
 transportFromObject :: PartialObject -> Maybe TransportHeader
@@ -105,12 +106,12 @@ transportFromObject (Rec items) = case catMaybes $ map single items of
               | name == BC.pack "ANU", RecRef ref <- content -> Just $ AnnounceUpdate ref
               | name == BC.pack "CRQ", RecRef ref <- content -> Just $ TrChannelRequest ref
               | name == BC.pack "CAC", RecRef ref <- content -> Just $ TrChannelAccept ref
-              | name == BC.pack "STP", RecText stype <- content -> Just $ ServiceType stype
+              | name == BC.pack "STP", RecUUID uuid <- content -> Just $ ServiceType $ fromUUID uuid
               | name == BC.pack "SRF", RecRef ref <- content -> Just $ ServiceRef ref
               | otherwise -> Nothing
 transportFromObject _ = Nothing
 
-lookupServiceType :: [TransportHeaderItem] -> Maybe T.Text
+lookupServiceType :: [TransportHeaderItem] -> Maybe ServiceID
 lookupServiceType (ServiceType stype : _) = Just stype
 lookupServiceType (_ : hs) = lookupServiceType hs
 lookupServiceType [] = Nothing
@@ -152,7 +153,7 @@ receivedWaitingRef nref wr@(WaitingRef _ _ mvar) = do
     checkWaitingRef wr
 
 
-startServer :: Head -> (String -> IO ()) -> String -> [(T.Text, SomeService)] -> IO (Chan Peer)
+startServer :: Head -> (String -> IO ()) -> String -> [SomeService] -> IO (Chan Peer)
 startServer origHead logd bhost services = do
     let storage = refStorage $ headRef origHead
     chanPeer <- newChan
@@ -242,20 +243,20 @@ startServer origHead logd bhost services = do
         (peer, svc, ref)
             | PeerIdentityFull peerId <- peerIdentity peer
             -> modifyMVar_ (peerServiceState peer) $ \svcs ->
-                   case maybe (lookup svc services) Just $ M.lookup svc svcs of
-                        Nothing -> do logd $ "unhandled service '" ++ T.unpack svc ++ "'"
+                   case maybe (someServiceEmptyState <$> find ((svc ==) . someServiceID) services) Just $ M.lookup svc svcs of
+                        Nothing -> do logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
                                       return svcs
-                        Just (SomeService s) -> do
+                        Just (SomeServiceState s) -> do
                             let inp = ServiceInput
                                     { svcPeer = peerId
                                     , svcPrintOp = logd
                                     }
                             (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref)
                             identity <- readMVar midentity
-                            runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case
+                            runExceptT (maybe (return ()) (sendToPeer identity peer) rsp) >>= \case
                                 Left err -> logd $ "failed to send response to peer: " ++ show err
                                 Right () -> return ()
-                            return $ M.insert svc (SomeService s') svcs
+                            return $ M.insert svc (SomeServiceState s') svcs
 
             | DatagramAddress paddr <- peerAddress peer -> do
                 logd $ "service packet from peer with incomplete identity " ++ show paddr
@@ -281,7 +282,7 @@ addBody :: Ref -> PacketHandler ()
 addBody r = modify $ \ph -> ph { phBody = r : phBody ph }
 
 handlePacket :: (String -> IO ()) -> UnifiedIdentity -> Bool
-    -> Peer -> Chan (Peer, T.Text, Ref)
+    -> Peer -> Chan (Peer, ServiceID, Ref)
     -> TransportHeader -> IO (Maybe Peer)
 handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do
     let sidentity = idData identity
@@ -513,7 +514,7 @@ handleIdentityUpdate = do
          _ -> return ()
 
 
-handleServices :: Chan (Peer, T.Text, Ref) -> PacketHandler ()
+handleServices :: Chan (Peer, ServiceID, Ref) -> PacketHandler ()
 handleServices chan = gets (peerServiceQueue . phPeer) >>= \case
     [] -> return ()
     queue -> do
@@ -527,30 +528,31 @@ handleServices chan = gets (peerServiceQueue . phPeer) >>= \case
         updatePeer $ \p -> p { peerServiceQueue = queue' }
 
 
-sendToPeer :: (Storable a, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> T.Text -> a -> m ()
-sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } svc obj = do
+sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> ServicePacket s -> m ()
+sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } packet = do
     let st = peerInStorage peer
-    ref <- liftIO $ store st obj
+    ref <- liftIO $ store st packet
     bytes <- case lazyLoadBytes ref of
                   Right bytes -> return bytes
                   Left dgst -> throwError $ "incomplete ref " ++ show ref ++ ", missing " ++ BC.unpack (showRefDigest dgst)
     let plain = BL.toStrict $ BL.concat
-            [ serializeObject $ transportToObject $ TransportHeader [ServiceType svc, ServiceRef ref]
+            [ serializeObject $ transportToObject $ TransportHeader [ServiceType $ serviceID packet, ServiceRef ref]
             , bytes
             ]
     ctext <- channelEncrypt ch plain
     let DatagramAddress paddr = peerAddress peer
     void $ liftIO $ sendTo (peerSocket peer) ctext paddr
 
-sendToPeer _ _ _ _ = throwError $ "no channel to peer"
+sendToPeer _ _ _ = throwError $ "no channel to peer"
 
-sendToPeerWith :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> T.Text -> (s -> ExceptT String IO (Maybe (ServicePacket s), s)) -> m ()
-sendToPeerWith identity peer svc fobj = do
+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 identity peer fobj = do
+    let sid = serviceID @s Proxy
     res <- liftIO $ modifyMVar (peerServiceState peer) $ \svcs -> do
-        runExceptT (fobj $ fromMaybe emptyServiceState $ fromService =<< M.lookup svc svcs) >>= \case
-            Right (obj, s') -> return $ (M.insert svc (SomeService s') svcs, Right obj)
+        runExceptT (fobj $ fromMaybe emptyServiceState $ fromServiceState =<< M.lookup sid svcs) >>= \case
+            Right (obj, s') -> return $ (M.insert sid (SomeServiceState s') svcs, Right obj)
             Left err -> return $ (svcs, Left err)
     case res of
-         Right (Just obj) -> sendToPeer identity peer svc obj
+         Right (Just obj) -> sendToPeer identity peer obj
          Right Nothing -> return ()
          Left err -> throwError err
diff --git a/src/Service.hs b/src/Service.hs
index 6b490ff..59b4e8e 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -1,12 +1,15 @@
 module Service (
     Service(..),
-    SomeService(..), fromService,
+    SomeService(..), SomeServiceState(..),
+    someServiceID, fromServiceState, someServiceEmptyState,
+    ServiceID, mkServiceID,
 
     ServiceHandler,
-    ServiceInput(..), ServiceState(..),
+    ServiceInput(..),
     handleServicePacket,
 
-    svcSet,
+    svcGet, svcSet,
+    svcGetLocal, svcSetLocal,
     svcPrint,
 ) where
 
@@ -15,39 +18,59 @@ import Control.Monad.Reader
 import Control.Monad.State
 
 import Data.Typeable
+import Data.UUID (UUID)
+import qualified Data.UUID as U
 
 import Identity
 import State
 import Storage
 
 class (Typeable s, Storable (ServicePacket s)) => Service s where
-    type ServicePacket s :: *
-    emptyServiceState :: s
+    serviceID :: proxy s -> ServiceID
+
+    data ServiceState s :: *
+    emptyServiceState :: ServiceState s
+
+    data ServicePacket s :: *
     serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
 
-data SomeService = forall s. Service s => SomeService s
+data SomeService = forall s. Service s => SomeService (Proxy s)
+
+data SomeServiceState = forall s. Service s => SomeServiceState (ServiceState s)
+
+someServiceID :: SomeService -> ServiceID
+someServiceID (SomeService s) = serviceID s
+
+fromServiceState :: Service s => SomeServiceState -> Maybe (ServiceState s)
+fromServiceState (SomeServiceState s) = cast s
 
-fromService :: Service s => SomeService -> Maybe s
-fromService (SomeService s) = cast s
+someServiceEmptyState :: SomeService -> SomeServiceState
+someServiceEmptyState (SomeService (Proxy :: Proxy s)) = SomeServiceState (emptyServiceState :: ServiceState s)
+
+newtype ServiceID = ServiceID UUID
+    deriving (Eq, Ord, StorableUUID)
+
+mkServiceID :: String -> ServiceID
+mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString
 
 data ServiceInput = ServiceInput
     { svcPeer :: UnifiedIdentity
     , svcPrintOp :: String -> IO ()
     }
 
-data ServiceState s = ServiceState
-    { svcValue :: s
+data ServiceHandlerState s = ServiceHandlerState
+    { svcValue :: ServiceState s
     , svcLocal :: Stored LocalState
     }
 
-newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a)
-    deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadError String, MonadIO)
+newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceHandlerState s) (ExceptT String IO)) a)
+    deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceHandlerState s), MonadError String, MonadIO)
 
-handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s)
+handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), ServiceState s)
 handleServicePacket st input svc packet = do
     herb <- loadLocalStateHead st
     let erb = wrappedLoad $ headRef herb
-        sstate = ServiceState { svcValue = svc, svcLocal = erb }
+        sstate = ServiceHandlerState { svcValue = svc, svcLocal = erb }
         ServiceHandler handler = serviceHandler packet
     (runExceptT $ flip runStateT sstate $ flip runReaderT input $ handler) >>= \case
         Left err -> do
@@ -59,8 +82,17 @@ handleServicePacket st input svc packet = do
                 Left  _ -> handleServicePacket st input svc packet
                 Right _ -> return (rsp, svcValue sstate')
 
-svcSet :: s -> ServiceHandler s ()
+svcGet :: ServiceHandler s (ServiceState s)
+svcGet = gets svcValue
+
+svcSet :: ServiceState s -> ServiceHandler s ()
 svcSet x = modify $ \st -> st { svcValue = x }
 
+svcGetLocal :: ServiceHandler s (Stored LocalState)
+svcGetLocal = gets svcLocal
+
+svcSetLocal :: Stored LocalState -> ServiceHandler s ()
+svcSetLocal x = modify $ \st -> st { svcLocal = x }
+
 svcPrint :: String -> ServiceHandler s ()
 svcPrint str = liftIO . ($str) =<< asks svcPrintOp