Attach device service

1 files changed, 12 insertions, 3 deletions

diff --git a/src/Service.hs b/src/Service.hs
index 667196d..f08a7a2 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -1,11 +1,12 @@
 module Service (
     Service(..),
-    SomeService(..),
+    SomeService(..), fromService,
 
     ServiceHandler,
     ServiceInput(..), ServiceState(..),
     handleServicePacket,
 
+    svcSet,
     svcPrint,
 ) where
 
@@ -13,17 +14,22 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.State
 
+import Data.Typeable
+
 import Identity
 import State
 import Storage
 
-class Storable (ServicePacket s) => Service s where
+class (Typeable s, Storable (ServicePacket s)) => Service s where
     type ServicePacket s :: *
     emptyServiceState :: s
     serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
 
 data SomeService = forall s. Service s => SomeService s
 
+fromService :: Service s => SomeService -> Maybe s
+fromService (SomeService s) = cast s
+
 data ServiceInput = ServiceInput
     { svcPeer :: UnifiedIdentity
     , svcPeerOwner :: UnifiedIdentity
@@ -36,7 +42,7 @@ data ServiceState s = ServiceState
     }
 
 newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a)
-    deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadIO)
+    deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadError String, MonadIO)
 
 handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s)
 handleServicePacket st input svc packet = do
@@ -54,5 +60,8 @@ handleServicePacket st input svc packet = do
                 Left  _ -> handleServicePacket st input svc packet
                 Right _ -> return (rsp, svcValue sstate')
 
+svcSet :: s -> ServiceHandler s ()
+svcSet x = modify $ \st -> st { svcValue = x }
+
 svcPrint :: String -> ServiceHandler s ()
 svcPrint str = liftIO . ($str) =<< asks svcPrintOp