From 6f0bcff200598d085c89d167aa126d25fc5df3ed Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 3 Feb 2020 22:29:31 +0100
Subject: Service: stored or ref-only reply packet

Use the ref-only packet to acknowledge successful storage of received
direct message.
---
 src/Service.hs | 26 ++++++++++++++++++++------
 1 file changed, 20 insertions(+), 6 deletions(-)

(limited to 'src/Service.hs')

diff --git a/src/Service.hs b/src/Service.hs
index 59b4e8e..d2848b6 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -6,16 +6,19 @@ module Service (
 
     ServiceHandler,
     ServiceInput(..),
+    ServiceReply(..),
     handleServicePacket,
 
     svcGet, svcSet,
     svcGetLocal, svcSetLocal,
     svcPrint,
+    replyPacket, replyStored, replyStoredRef,
 ) where
 
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.Monad.Writer
 
 import Data.Typeable
 import Data.UUID (UUID)
@@ -32,7 +35,7 @@ class (Typeable s, Storable (ServicePacket s)) => Service s where
     emptyServiceState :: ServiceState s
 
     data ServicePacket s :: *
-    serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
+    serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s ()
 
 data SomeService = forall s. Service s => SomeService (Proxy s)
 
@@ -58,24 +61,26 @@ data ServiceInput = ServiceInput
     , svcPrintOp :: String -> IO ()
     }
 
+data ServiceReply s = ServiceReply (Either (ServicePacket s) (Stored (ServicePacket s))) Bool
+
 data ServiceHandlerState s = ServiceHandlerState
     { svcValue :: ServiceState s
     , svcLocal :: Stored LocalState
     }
 
-newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceHandlerState s) (ExceptT String IO)) a)
-    deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceHandlerState s), MonadError String, MonadIO)
+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 (Maybe (ServicePacket s), ServiceState s)
+handleServicePacket :: Service s => Storage -> ServiceInput -> ServiceState s -> Stored (ServicePacket s) -> IO ([ServiceReply s], ServiceState s)
 handleServicePacket st input svc packet = do
     herb <- loadLocalStateHead st
     let erb = wrappedLoad $ headRef herb
         sstate = ServiceHandlerState { svcValue = svc, svcLocal = erb }
         ServiceHandler handler = serviceHandler packet
-    (runExceptT $ flip runStateT sstate $ flip runReaderT input $ handler) >>= \case
+    (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case
         Left err -> do
             svcPrintOp input $ "service failed: " ++ err
-            return (Nothing, svc)
+            return ([], svc)
         Right (rsp, sstate')
             | svcLocal sstate' == svcLocal sstate -> return (rsp, svcValue sstate')
             | otherwise -> replaceHead (svcLocal sstate') (Right herb) >>= \case
@@ -96,3 +101,12 @@ 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 x = tell [ServiceReply (Left x) True]
+
+replyStored :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStored x = tell [ServiceReply (Right x) True]
+
+replyStoredRef :: Service s => Stored (ServicePacket s) -> ServiceHandler s ()
+replyStoredRef x = tell [ServiceReply (Right x) False]
-- 
cgit v1.2.3