Helpers for server storage watchers

6 files changed, 18 insertions, 187 deletions

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