From 896931339ac254c2bbfa0e2d0b780ad918a57b34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 16 Aug 2026 10:54:15 +0200 Subject: Helpers for server storage watchers --- src/Erebos/Chatroom.hs | 2 +- src/Erebos/DirectMessage.hs | 4 +- src/Erebos/Invite.hs | 2 +- src/Erebos/Network.hs | 2 + src/Erebos/Service.hs | 193 +++----------------------------------------- src/Erebos/Sync.hs | 2 +- 6 files changed, 18 insertions(+), 187 deletions(-) (limited to 'src/Erebos') 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 -- cgit v1.2.3