Use UUID for service types

1 files changed, 47 insertions, 15 deletions

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