summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs38
-rw-r--r--src/Main.hs2
-rw-r--r--src/Message.hs25
-rw-r--r--src/Network.hs19
-rw-r--r--src/Service.hs31
-rw-r--r--src/Sync.hs12
6 files changed, 53 insertions, 74 deletions
diff --git a/src/Attach.hs b/src/Attach.hs
index 10a87f3..2ce6110 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -26,9 +26,22 @@ import State
import Storage
import Storage.Key
-data AttachService
-
-instance Storable (ServicePacket AttachService) where
+data AttachService = AttachRequest RefDigest
+ | AttachResponse Bytes
+ | AttachRequestNonce Bytes
+ | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
+ | AttachDecline
+
+data AttachState = NoAttach
+ | OurRequest Bytes
+ | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes]))
+ | OurRequestReady
+ | PeerRequest Bytes RefDigest
+ | PeerRequestConfirm
+ | AttachDone
+ | AttachFailed
+
+instance Storable AttachService where
store' at = storeRec $ do
case at of
AttachRequest x -> storeBinary "request" x
@@ -60,23 +73,8 @@ instance Storable (ServicePacket AttachService) where
instance Service AttachService where
serviceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
- data ServiceState AttachService
- = NoAttach
- | OurRequest Bytes
- | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes]))
- | OurRequestReady
- | PeerRequest Bytes RefDigest
- | PeerRequestConfirm
- | AttachDone
- | AttachFailed
- emptyServiceState = NoAttach
-
- data ServicePacket AttachService
- = AttachRequest RefDigest
- | AttachResponse Bytes
- | AttachRequestNonce Bytes
- | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
- | AttachDecline
+ type ServiceState AttachService = AttachState
+ emptyServiceState _ = NoAttach
serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
(NoAttach, AttachRequest confirm) -> do
diff --git a/src/Main.hs b/src/Main.hs
index 6da9826..b692357 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -96,7 +96,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
startServer erebosHead extPrintLn bhost
[ SomeService @AttachService Proxy
, SomeService @SyncService Proxy
- , SomeService @DirectMessageService Proxy
+ , SomeService @DirectMessage Proxy
]
peers <- liftIO $ newMVar []
diff --git a/src/Message.hs b/src/Message.hs
index ee59dad..0039d7e 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -1,8 +1,5 @@
module Message (
DirectMessage(..),
- DirectMessageService,
- ServicePacket(DirectMessagePacket),
-
sendDirectMessage,
DirectMessageThread(..),
@@ -50,19 +47,11 @@ instance Storable DirectMessage where
<*> loadDate "time"
<*> loadText "text"
-data DirectMessageService
-
-instance Service DirectMessageService where
+instance Service DirectMessage where
serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
- data ServiceState DirectMessageService = DirectMessageService
- emptyServiceState = DirectMessageService
-
- newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage)
-
- serviceHandler packet = do
- let DirectMessagePacket smsg = fromStored packet
- msg = fromStored smsg
+ serviceHandler smsg = do
+ let msg = fromStored smsg
powner <- asks $ finalOwner . svcPeer
tzone <- liftIO $ getCurrentTimeZone
erb <- svcGetLocal
@@ -86,14 +75,10 @@ instance Service DirectMessageService where
svcSetLocal erb'
when (powner `sameIdentity` msgFrom msg) $ do
svcPrint $ formatMessage tzone msg
- replyStoredRef packet
+ replyStoredRef smsg
else svcPrint "Owner mismatch"
-instance Storable (ServicePacket DirectMessageService) where
- store' (DirectMessagePacket smsg) = store' smsg
- load' = DirectMessagePacket <$> load'
-
data MessageState = MessageState
{ msPrev :: [Stored MessageState]
@@ -155,7 +140,7 @@ sendDirectMessage self peer text = do
}
return ([next], smsg)
- sendToPeer self peer $ DirectMessagePacket smsg
+ sendToPeerStored self peer smsg
return smsg
diff --git a/src/Network.hs b/src/Network.hs
index 7e2568e..eb319b2 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -281,17 +281,17 @@ startServer origHead logd bhost services = do
case maybe (someServiceEmptyState <$> find ((svc ==) . someServiceID) services) Just $ M.lookup svc svcs of
Nothing -> do logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
return svcs
- Just (SomeServiceState s) -> do
+ Just (SomeServiceState (proxy :: Proxy s) s) -> do
let inp = ServiceInput
{ svcPeer = peerId
, svcPrintOp = logd
}
- (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref)
+ (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref :: Stored s)
identity <- readMVar midentity
runExceptT (sendToPeerList identity peer rsp) >>= \case
Left err -> logd $ "failed to send response to peer: " ++ show err
Right () -> return ()
- return $ M.insert svc (SomeServiceState s') svcs
+ return $ M.insert svc (SomeServiceState proxy s') svcs
| DatagramAddress paddr <- peerAddress peer -> do
logd $ "service packet from peer with incomplete identity " ++ show paddr
@@ -587,10 +587,10 @@ handleServices chan = gets (peerServiceQueue . phPeer) >>= \case
updatePeer $ \p -> p { peerServiceQueue = queue' }
-sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> ServicePacket s -> m ()
+sendToPeer :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> s -> m ()
sendToPeer self peer packet = sendToPeerList self peer [ServiceReply (Left packet) True]
-sendToPeerStored :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Stored (ServicePacket s) -> m ()
+sendToPeerStored :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Stored s -> m ()
sendToPeerStored self peer spacket = sendToPeerList self peer [ServiceReply (Right spacket) True]
sendToPeerList :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> [ServiceReply s] -> m ()
@@ -613,12 +613,13 @@ sendToPeerList _ peer@Peer { peerChannel = ChannelEstablished ch } parts = do
sendToPeerList _ _ _ = throwError $ "no channel to peer"
-sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe (ServicePacket s), ServiceState s)) -> m ()
+sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m ()
sendToPeerWith identity peer fobj = do
- let sid = serviceID @s Proxy
+ let sproxy = Proxy @s
+ sid = serviceID sproxy
res <- liftIO $ modifyMVar (peerServiceState peer) $ \svcs -> do
- runExceptT (fobj $ fromMaybe emptyServiceState $ fromServiceState =<< M.lookup sid svcs) >>= \case
- Right (obj, s') -> return $ (M.insert sid (SomeServiceState s') svcs, Right obj)
+ runExceptT (fobj $ fromMaybe (emptyServiceState sproxy) $ fromServiceState sproxy =<< M.lookup sid svcs) >>= \case
+ Right (obj, s') -> return $ (M.insert sid (SomeServiceState sproxy s') svcs, Right obj)
Left err -> return $ (svcs, Left err)
case res of
Right (Just obj) -> sendToPeer identity peer obj
diff --git a/src/Service.hs b/src/Service.hs
index d2848b6..697934b 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -28,27 +28,28 @@ import Identity
import State
import Storage
-class (Typeable s, Storable (ServicePacket s)) => Service s where
+class (Typeable s, Storable s, Typeable (ServiceState s)) => Service s where
serviceID :: proxy s -> ServiceID
+ serviceHandler :: Stored s -> ServiceHandler s ()
- data ServiceState s :: *
- emptyServiceState :: ServiceState s
-
- data ServicePacket s :: *
- serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s ()
+ type ServiceState s :: *
+ type ServiceState s = ()
+ emptyServiceState :: proxy s -> ServiceState s
+ default emptyServiceState :: ServiceState s ~ () => proxy s -> ServiceState s
+ emptyServiceState _ = ()
data SomeService = forall s. Service s => SomeService (Proxy s)
-data SomeServiceState = forall s. Service s => SomeServiceState (ServiceState s)
+data SomeServiceState = forall s. Service s => SomeServiceState (Proxy s) (ServiceState s)
someServiceID :: SomeService -> ServiceID
someServiceID (SomeService s) = serviceID s
-fromServiceState :: Service s => SomeServiceState -> Maybe (ServiceState s)
-fromServiceState (SomeServiceState s) = cast s
+fromServiceState :: Service s => proxy s -> SomeServiceState -> Maybe (ServiceState s)
+fromServiceState _ (SomeServiceState _ s) = cast s
someServiceEmptyState :: SomeService -> SomeServiceState
-someServiceEmptyState (SomeService (Proxy :: Proxy s)) = SomeServiceState (emptyServiceState :: ServiceState s)
+someServiceEmptyState (SomeService p) = SomeServiceState p (emptyServiceState p)
newtype ServiceID = ServiceID UUID
deriving (Eq, Ord, StorableUUID)
@@ -61,7 +62,7 @@ data ServiceInput = ServiceInput
, svcPrintOp :: String -> IO ()
}
-data ServiceReply s = ServiceReply (Either (ServicePacket s) (Stored (ServicePacket s))) Bool
+data ServiceReply s = ServiceReply (Either s (Stored s)) Bool
data ServiceHandlerState s = ServiceHandlerState
{ svcValue :: ServiceState s
@@ -71,7 +72,7 @@ data ServiceHandlerState s = ServiceHandlerState
newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a)
deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO)
-handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO ([ServiceReply s], ServiceState s)
+handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored s -> IO ([ServiceReply s], ServiceState s)
handleServicePacket st input svc packet = do
herb <- loadLocalStateHead st
let erb = wrappedLoad $ headRef herb
@@ -102,11 +103,11 @@ svcSetLocal x = modify $ \st -> st { svcLocal = x }
svcPrint :: String -> ServiceHandler s ()
svcPrint str = liftIO . ($str) =<< asks svcPrintOp
-replyPacket :: Service s => ServicePacket s -> ServiceHandler s ()
+replyPacket :: Service s => s -> ServiceHandler s ()
replyPacket x = tell [ServiceReply (Left x) True]
-replyStored :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStored :: Service s => Stored s -> ServiceHandler s ()
replyStored x = tell [ServiceReply (Right x) True]
-replyStoredRef :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStoredRef :: Service s => Stored s -> ServiceHandler s ()
replyStoredRef x = tell [ServiceReply (Right x) False]
diff --git a/src/Sync.hs b/src/Sync.hs
index 37941b8..afb45e6 100644
--- a/src/Sync.hs
+++ b/src/Sync.hs
@@ -1,6 +1,5 @@
module Sync (
- SyncService,
- ServicePacket(..),
+ SyncService(..),
) where
import Control.Monad
@@ -12,16 +11,11 @@ import State
import Storage
import Storage.Merge
-data SyncService
+data SyncService = SyncPacket (Stored SharedState)
instance Service SyncService where
serviceID _ = mkServiceID "a4f538d0-4e50-4082-8e10-7e3ec2af175d"
- data ServiceState SyncService = SyncService
- emptyServiceState = SyncService
-
- newtype ServicePacket SyncService = SyncPacket (Stored SharedState)
-
serviceHandler packet = do
let SyncPacket added = fromStored packet
ls <- svcGetLocal
@@ -31,6 +25,6 @@ instance Service SyncService where
when (current /= updated) $ do
svcSetLocal =<< wrappedStore st (fromStored ls) { lsShared = updated }
-instance Storable (ServicePacket SyncService) where
+instance Storable SyncService where
store' (SyncPacket smsg) = store' smsg
load' = SyncPacket <$> load'
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 20:16:36 +0000