Helpers for server storage watchers

8 files changed, 237 insertions, 187 deletions

diff --git a/erebos.cabal b/erebos.cabal
index a8178a1..5972a4e 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -133,6 +133,7 @@ library
         Erebos.TextFormat.Types
         Erebos.UUID
         Erebos.Util
+        Service
 
     c-sources:
         src/Erebos/Network/ifaddrs.c
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index a7ba46d..9c15c57 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -614,7 +614,7 @@ instance Service ChatroomService where
         replyPacket emptyPacket { chatRoomQuery = True }
 
     serviceStorageWatchers _ = (:[]) $
-        SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncChatroomsToPeer
+        someStorageWatcher (lookupSharedValue . lsShared . fromStored) syncChatroomsToPeer
 
 syncChatroomsToPeer :: Set ChatroomState -> ServiceHandler ChatroomService ()
 syncChatroomsToPeer set = do
diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
index 6eb8a8c..6697d53 100644
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -152,8 +152,8 @@ instance Service DirectMessage where
         updateDirectMessagePeer . finalOwner =<< asks svcPeerIdentity
 
     serviceStorageWatchers _ =
-        [ SomeStorageWatcherHC lookupSharedValueHC syncDirectMessageToPeer
-        , GlobalStorageWatcherH lookupSharedValueH findMissingPeers
+        [ someStorageWatcherHC lookupSharedValueHC syncDirectMessageToPeer
+        , globalStorageWatcherH lookupSharedValueH findMissingPeers
         ]
 
 
diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs
index 890450b..65adaa7 100644
--- a/src/Erebos/Invite.hs
+++ b/src/Erebos/Invite.hs
@@ -355,7 +355,7 @@ instance Service InviteService where
             _ -> return ()
 
     serviceStorageWatchers _ = (:[]) $
-        GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) sendAcceptedInvites
+        globalStorageWatcher (lookupSharedValue . lsShared . fromStored) sendAcceptedInvites
 
 
 sendAcceptedInvites :: Server -> Set AcceptedInvite -> ExceptT ErebosError IO ()
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 64c2c44..fd30b8c 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -79,6 +79,8 @@ import Erebos.Storage.Head
 import Erebos.Storage.Key
 import Erebos.Storage.Merge
 
+import Service
+
 
 discoveryPort :: PortNumber
 discoveryPort = 29665
diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs
index dcc3df5..e61e3e8 100644
--- a/src/Erebos/Service.hs
+++ b/src/Erebos/Service.hs
@@ -3,7 +3,8 @@ module Erebos.Service (
     SomeService(..), someService, someServiceAttr, someServiceID,
     SomeServiceState(..), fromServiceState, someServiceEmptyState,
     SomeServiceGlobalState(..), fromServiceGlobalState, someServiceEmptyGlobalState,
-    SomeStorageWatcher(..),
+    SomeStorageWatcher(SomeStorageWatcher, GlobalStorageWatcher),
+    someStorageWatcher, someStorageWatcherHC, globalStorageWatcher, globalStorageWatcherH,
     ServiceID, mkServiceID,
 
     ServiceHandler,
@@ -23,196 +24,24 @@ module Erebos.Service (
 ) where
 
 import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Writer
 
-import Data.Kind
-import Data.Typeable
-
-import Erebos.Identity
 import {-# SOURCE #-} Erebos.Network
 import Erebos.Network.Protocol
 import Erebos.State
 import Erebos.Storable
 import Erebos.Storage.Head
-import Erebos.UUID qualified as U
-
-class (
-        Typeable s, Storable s,
-        Typeable (ServiceAttributes s),
-        Typeable (ServiceState s),
-        Typeable (ServiceGlobalState s)
-    ) => Service s where
-
-    serviceID :: proxy s -> ServiceID
-    serviceHandler :: Stored s -> ServiceHandler s ()
-
-    serviceNewPeer :: ServiceHandler s ()
-    serviceNewPeer = return ()
-
-    serviceUpdatedPeer :: ServiceHandler s ()
-    serviceUpdatedPeer = return ()
-
-    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
-    type ServiceState s = ()
-    emptyServiceState :: proxy s -> ServiceState s
-    default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s
-    emptyServiceState _ = ()
-
-    type ServiceGlobalState s :: Type
-    type ServiceGlobalState s = ()
-    emptyServiceGlobalState :: proxy s -> ServiceGlobalState s
-    default emptyServiceGlobalState :: ServiceGlobalState s ~ () => proxy s -> ServiceGlobalState s
-    emptyServiceGlobalState _ = ()
-
-    serviceStorageWatchers :: proxy s -> [SomeStorageWatcher s]
-    serviceStorageWatchers _ = []
-
-    serviceStopServer :: proxy s -> Server -> ServiceGlobalState s -> [ ( Peer, ServiceState s ) ] -> IO ()
-    serviceStopServer _ _ _ _ = return ()
-
-
-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
-
-data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s)
-
-fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceState s)
-fromServiceState _ (SomeServiceState _ s) = cast s
-
-someServiceEmptyState :: SomeService -> SomeServiceState
-someServiceEmptyState (SomeService p _) = SomeServiceState p (emptyServiceState p)
-
-data SomeServiceGlobalState = forall s. Service s => SomeServiceGlobalState (Proxy s) (ServiceGlobalState s)
-
-fromServiceGlobalState :: Service s => proxy s -> SomeServiceGlobalState -> Maybe (ServiceGlobalState s)
-fromServiceGlobalState _ (SomeServiceGlobalState _ s) = cast s
-
-someServiceEmptyGlobalState :: SomeService -> SomeServiceGlobalState
-someServiceEmptyGlobalState (SomeService p _) = SomeServiceGlobalState p (emptyServiceGlobalState p)
-
-
-data SomeStorageWatcher s
-    = forall a. Eq a => SomeStorageWatcher (Stored LocalState -> a) (a -> ServiceHandler s ())
-    | forall a. Eq a => SomeStorageWatcherHC (Stored LocalState -> HeadCacheType LocalState -> a) (a -> ServiceHandler s ())
-    | forall a. Eq a => GlobalStorageWatcher (Stored LocalState -> a) (Server -> a -> ExceptT ErebosError IO ())
-    | forall a. Eq a => GlobalStorageWatcherH (Head LocalState -> a) (Server -> a -> ExceptT ErebosError IO ())
-
-
-mkServiceID :: String -> ServiceID
-mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString
-
-data ServiceInput s = ServiceInput
-    { svcAttributes :: ServiceAttributes s
-    , svcPeer :: Peer
-    , svcPeerAddress :: PeerAddress
-    , svcPeerIdentity :: UnifiedIdentity
-    , svcServer :: Server
-    , svcPrintOp :: String -> IO ()
-    , svcNewStreams :: [ RawStreamReader ]
-    }
-
-data ServiceReply s
-    = ServiceReply (Either s (Stored s)) Bool
-    | ServiceOpenStream (RawStreamWriter -> IO ())
-    | ServiceFinally (IO ())
-
-data ServiceHandlerState s = ServiceHandlerState
-    { svcValue :: ServiceState s
-    , svcGlobal :: ServiceGlobalState s
-    , svcLocal :: Stored LocalState
-    , svcLocalCache :: HeadCacheType LocalState
-    }
-
-newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT ErebosError IO))) a)
-    deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError ErebosError, MonadIO)
-
-instance MonadStorage (ServiceHandler s) where
-    getStorage = asks $ peerStorage . svcPeer
-
-instance MonadHead LocalState (ServiceHandler s) where
-    updateLocalHead f = do
-        ls <- gets svcLocal
-        c <- gets svcLocalCache
-        ( ls', x ) <- f ls
-        let c' = headCacheUpdate ls' c
-        modify $ \s -> s { svcLocal = ls', svcLocalCache = c' }
-        return x
-    getLocalHeadCache _ = gets svcLocalCache
-
-runServiceHandler
-    :: Service s
-    => Head LocalState -> ServiceInput s -> ServiceState s -> ServiceGlobalState s
-    -> ServiceHandler s ()
-    -> IO ( [ ServiceReply s], ( ServiceState s, ServiceGlobalState s, Head LocalState ) )
-runServiceHandler h input svc global shandler = do
-    let sstate = ServiceHandlerState { svcValue = svc, svcGlobal = global, svcLocal = headStoredObject h, svcLocalCache = headCache h }
-        ServiceHandler handler = shandler
-    (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case
-        Left err -> do
-            svcPrintOp input $ "service failed: " ++ showErebosError err
-            return ( [], ( svc, global, h ) )
-        Right (rsp, sstate')
-            | svcLocal sstate' == svcLocal sstate -> return ( rsp, ( svcValue sstate', svcGlobal sstate', h ))
-            | otherwise -> replaceHead h (svcLocal sstate') >>= \case
-                Left (Just h') -> runServiceHandler h' input svc global shandler
-                Left Nothing   -> return ( rsp, ( svcValue sstate', svcGlobal sstate', h ) )
-                Right h'       -> return ( rsp, ( svcValue sstate', svcGlobal sstate', h' ) )
-
-svcGet :: ServiceHandler s (ServiceState s)
-svcGet = gets svcValue
-
-svcSet :: ServiceState s -> ServiceHandler s ()
-svcSet x = modify $ \st -> st { svcValue = x }
-
-svcModify :: (ServiceState s -> ServiceState s) -> ServiceHandler s ()
-svcModify f = modify $ \st -> st { svcValue = f (svcValue st) }
-
-svcGetGlobal :: ServiceHandler s (ServiceGlobalState s)
-svcGetGlobal = gets svcGlobal
-
-svcSetGlobal :: ServiceGlobalState s -> ServiceHandler s ()
-svcSetGlobal x = modify $ \st -> st { svcGlobal = x }
-
-svcModifyGlobal :: (ServiceGlobalState s -> ServiceGlobalState s) -> ServiceHandler s ()
-svcModifyGlobal f = modify $ \st -> st { svcGlobal = f (svcGlobal st) }
-
-svcGetLocal :: ServiceHandler s (Stored LocalState)
-svcGetLocal = gets svcLocal
-
-svcSetLocal :: Stored LocalState -> ServiceHandler s ()
-svcSetLocal x = modify $ \st -> st { svcLocal = x }
 
-svcSelf :: ServiceHandler s UnifiedIdentity
-svcSelf = maybe (throwOtherError "failed to validate own identity") return .
-        validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal
+import Service
 
-svcPrint :: String -> ServiceHandler s ()
-svcPrint str = afterCommit . ($ str) =<< asks svcPrintOp
 
-replyPacket :: Service s => s -> ServiceHandler s ()
-replyPacket x = tell [ServiceReply (Left x) True]
+someStorageWatcher :: forall s a. (Service s, Eq a) => (Stored LocalState -> a) -> (a -> ServiceHandler s ()) -> SomeStorageWatcher s
+someStorageWatcher = SomeStorageWatcher
 
-replyStored :: Service s => Stored s -> ServiceHandler s ()
-replyStored x = tell [ServiceReply (Right x) True]
+someStorageWatcherHC :: forall s a. (Service s, Eq a) => (Stored LocalState -> HeadCacheType LocalState -> a) -> (a -> ServiceHandler s ()) -> SomeStorageWatcher s
+someStorageWatcherHC = SomeStorageWatcherHC
 
-replyStoredRef :: Service s => Stored s -> ServiceHandler s ()
-replyStoredRef x = tell [ServiceReply (Right x) False]
+globalStorageWatcher :: forall s a. (Service s, Eq a) => (Stored LocalState -> a) -> (Server -> a -> ExceptT ErebosError IO ()) -> SomeStorageWatcher s
+globalStorageWatcher = GlobalStorageWatcher
 
-afterCommit :: IO () -> ServiceHandler s ()
-afterCommit x = tell [ServiceFinally x]
+globalStorageWatcherH :: forall s a. (Service s, Eq a) => (Head LocalState -> a) -> (Server -> a -> ExceptT ErebosError IO ()) -> SomeStorageWatcher s
+globalStorageWatcherH = GlobalStorageWatcherH
diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs
index 5f5fdec..52251e3 100644
--- a/src/Erebos/Sync.hs
+++ b/src/Erebos/Sync.hs
@@ -32,7 +32,7 @@ instance Service SyncService where
 
     serviceNewPeer = notifyPeer . lsShared . fromStored =<< svcGetLocal
     serviceUpdatedPeer = serviceNewPeer
-    serviceStorageWatchers _ = (:[]) $ SomeStorageWatcher (lsShared . fromStored) notifyPeer
+    serviceStorageWatchers _ = (:[]) $ someStorageWatcher (lsShared . fromStored) notifyPeer
 
 instance Storable SyncService where
     store' (SyncPacket smsg) = store' smsg
diff --git a/src/Service.hs b/src/Service.hs
new file mode 100644
index 0000000..01b659f
--- /dev/null
+++ b/src/Service.hs
@@ -0,0 +1,218 @@
+module Service (
+    Service(..),
+    SomeService(..), someService, someServiceAttr, someServiceID,
+    SomeServiceState(..), fromServiceState, someServiceEmptyState,
+    SomeServiceGlobalState(..), fromServiceGlobalState, someServiceEmptyGlobalState,
+    SomeStorageWatcher(..),
+    ServiceID, mkServiceID,
+
+    ServiceHandler,
+    ServiceInput(..),
+    ServiceReply(..),
+    runServiceHandler,
+
+    svcGet, svcSet, svcModify,
+    svcGetGlobal, svcSetGlobal, svcModifyGlobal,
+    svcGetLocal, svcSetLocal,
+
+    svcSelf,
+    svcPrint,
+
+    replyPacket, replyStored, replyStoredRef,
+    afterCommit,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Data.Kind
+import Data.Typeable
+
+import Erebos.Identity
+import {-# SOURCE #-} Erebos.Network
+import Erebos.Network.Protocol
+import Erebos.State
+import Erebos.Storable
+import Erebos.Storage.Head
+import Erebos.UUID qualified as U
+
+class (
+        Typeable s, Storable s,
+        Typeable (ServiceAttributes s),
+        Typeable (ServiceState s),
+        Typeable (ServiceGlobalState s)
+    ) => Service s where
+
+    serviceID :: proxy s -> ServiceID
+    serviceHandler :: Stored s -> ServiceHandler s ()
+
+    serviceNewPeer :: ServiceHandler s ()
+    serviceNewPeer = return ()
+
+    serviceUpdatedPeer :: ServiceHandler s ()
+    serviceUpdatedPeer = return ()
+
+    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
+    type ServiceState s = ()
+    emptyServiceState :: proxy s -> ServiceState s
+    default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s
+    emptyServiceState _ = ()
+
+    type ServiceGlobalState s :: Type
+    type ServiceGlobalState s = ()
+    emptyServiceGlobalState :: proxy s -> ServiceGlobalState s
+    default emptyServiceGlobalState :: ServiceGlobalState s ~ () => proxy s -> ServiceGlobalState s
+    emptyServiceGlobalState _ = ()
+
+    serviceStorageWatchers :: proxy s -> [SomeStorageWatcher s]
+    serviceStorageWatchers _ = []
+
+    serviceStopServer :: proxy s -> Server -> ServiceGlobalState s -> [ ( Peer, ServiceState s ) ] -> IO ()
+    serviceStopServer _ _ _ _ = return ()
+
+
+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
+
+data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s)
+
+fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceState s)
+fromServiceState _ (SomeServiceState _ s) = cast s
+
+someServiceEmptyState :: SomeService -> SomeServiceState
+someServiceEmptyState (SomeService p _) = SomeServiceState p (emptyServiceState p)
+
+data SomeServiceGlobalState = forall s. Service s => SomeServiceGlobalState (Proxy s) (ServiceGlobalState s)
+
+fromServiceGlobalState :: Service s => proxy s -> SomeServiceGlobalState -> Maybe (ServiceGlobalState s)
+fromServiceGlobalState _ (SomeServiceGlobalState _ s) = cast s
+
+someServiceEmptyGlobalState :: SomeService -> SomeServiceGlobalState
+someServiceEmptyGlobalState (SomeService p _) = SomeServiceGlobalState p (emptyServiceGlobalState p)
+
+
+data SomeStorageWatcher s
+    = forall a. Eq a => SomeStorageWatcher (Stored LocalState -> a) (a -> ServiceHandler s ())
+    | forall a. Eq a => SomeStorageWatcherHC (Stored LocalState -> HeadCacheType LocalState -> a) (a -> ServiceHandler s ())
+    | forall a. Eq a => GlobalStorageWatcher (Stored LocalState -> a) (Server -> a -> ExceptT ErebosError IO ())
+    | forall a. Eq a => GlobalStorageWatcherH (Head LocalState -> a) (Server -> a -> ExceptT ErebosError IO ())
+
+
+mkServiceID :: String -> ServiceID
+mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString
+
+data ServiceInput s = ServiceInput
+    { svcAttributes :: ServiceAttributes s
+    , svcPeer :: Peer
+    , svcPeerAddress :: PeerAddress
+    , svcPeerIdentity :: UnifiedIdentity
+    , svcServer :: Server
+    , svcPrintOp :: String -> IO ()
+    , svcNewStreams :: [ RawStreamReader ]
+    }
+
+data ServiceReply s
+    = ServiceReply (Either s (Stored s)) Bool
+    | ServiceOpenStream (RawStreamWriter -> IO ())
+    | ServiceFinally (IO ())
+
+data ServiceHandlerState s = ServiceHandlerState
+    { svcValue :: ServiceState s
+    , svcGlobal :: ServiceGlobalState s
+    , svcLocal :: Stored LocalState
+    , svcLocalCache :: HeadCacheType LocalState
+    }
+
+newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT ErebosError IO))) a)
+    deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError ErebosError, MonadIO)
+
+instance MonadStorage (ServiceHandler s) where
+    getStorage = asks $ peerStorage . svcPeer
+
+instance MonadHead LocalState (ServiceHandler s) where
+    updateLocalHead f = do
+        ls <- gets svcLocal
+        c <- gets svcLocalCache
+        ( ls', x ) <- f ls
+        let c' = headCacheUpdate ls' c
+        modify $ \s -> s { svcLocal = ls', svcLocalCache = c' }
+        return x
+    getLocalHeadCache _ = gets svcLocalCache
+
+runServiceHandler
+    :: Service s
+    => Head LocalState -> ServiceInput s -> ServiceState s -> ServiceGlobalState s
+    -> ServiceHandler s ()
+    -> IO ( [ ServiceReply s], ( ServiceState s, ServiceGlobalState s, Head LocalState ) )
+runServiceHandler h input svc global shandler = do
+    let sstate = ServiceHandlerState { svcValue = svc, svcGlobal = global, svcLocal = headStoredObject h, svcLocalCache = headCache h }
+        ServiceHandler handler = shandler
+    (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case
+        Left err -> do
+            svcPrintOp input $ "service failed: " ++ showErebosError err
+            return ( [], ( svc, global, h ) )
+        Right (rsp, sstate')
+            | svcLocal sstate' == svcLocal sstate -> return ( rsp, ( svcValue sstate', svcGlobal sstate', h ))
+            | otherwise -> replaceHead h (svcLocal sstate') >>= \case
+                Left (Just h') -> runServiceHandler h' input svc global shandler
+                Left Nothing   -> return ( rsp, ( svcValue sstate', svcGlobal sstate', h ) )
+                Right h'       -> return ( rsp, ( svcValue sstate', svcGlobal sstate', h' ) )
+
+svcGet :: ServiceHandler s (ServiceState s)
+svcGet = gets svcValue
+
+svcSet :: ServiceState s -> ServiceHandler s ()
+svcSet x = modify $ \st -> st { svcValue = x }
+
+svcModify :: (ServiceState s -> ServiceState s) -> ServiceHandler s ()
+svcModify f = modify $ \st -> st { svcValue = f (svcValue st) }
+
+svcGetGlobal :: ServiceHandler s (ServiceGlobalState s)
+svcGetGlobal = gets svcGlobal
+
+svcSetGlobal :: ServiceGlobalState s -> ServiceHandler s ()
+svcSetGlobal x = modify $ \st -> st { svcGlobal = x }
+
+svcModifyGlobal :: (ServiceGlobalState s -> ServiceGlobalState s) -> ServiceHandler s ()
+svcModifyGlobal f = modify $ \st -> st { svcGlobal = f (svcGlobal st) }
+
+svcGetLocal :: ServiceHandler s (Stored LocalState)
+svcGetLocal = gets svcLocal
+
+svcSetLocal :: Stored LocalState -> ServiceHandler s ()
+svcSetLocal x = modify $ \st -> st { svcLocal = x }
+
+svcSelf :: ServiceHandler s UnifiedIdentity
+svcSelf = maybe (throwOtherError "failed to validate own identity") return .
+        validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal
+
+svcPrint :: String -> ServiceHandler s ()
+svcPrint str = afterCommit . ($ str) =<< asks svcPrintOp
+
+replyPacket :: Service s => s -> ServiceHandler s ()
+replyPacket x = tell [ServiceReply (Left x) True]
+
+replyStored :: Service s => Stored s -> ServiceHandler s ()
+replyStored x = tell [ServiceReply (Right x) True]
+
+replyStoredRef :: Service s => Stored s -> ServiceHandler s ()
+replyStoredRef x = tell [ServiceReply (Right x) False]
+
+afterCommit :: IO () -> ServiceHandler s ()
+afterCommit x = tell [ServiceFinally x]