From 4521fc3c4a898f046b030985159c63c5379df46f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 3 Nov 2019 19:59:27 +0100
Subject: Service class to handle network services

---
 src/Service.hs | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 58 insertions(+)
 create mode 100644 src/Service.hs

(limited to 'src/Service.hs')

diff --git a/src/Service.hs b/src/Service.hs
new file mode 100644
index 0000000..667196d
--- /dev/null
+++ b/src/Service.hs
@@ -0,0 +1,58 @@
+module Service (
+    Service(..),
+    SomeService(..),
+
+    ServiceHandler,
+    ServiceInput(..), ServiceState(..),
+    handleServicePacket,
+
+    svcPrint,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Identity
+import State
+import Storage
+
+class Storable (ServicePacket s) => Service s where
+    type ServicePacket s :: *
+    emptyServiceState :: s
+    serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
+
+data SomeService = forall s. Service s => SomeService s
+
+data ServiceInput = ServiceInput
+    { svcPeer :: UnifiedIdentity
+    , svcPeerOwner :: UnifiedIdentity
+    , svcPrintOp :: String -> IO ()
+    }
+
+data ServiceState s = ServiceState
+    { svcValue :: s
+    , svcLocal :: Stored LocalState
+    }
+
+newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a)
+    deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadIO)
+
+handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s)
+handleServicePacket st input svc packet = do
+    herb <- loadLocalState st
+    let erb = wrappedLoad $ headRef herb
+        sstate = ServiceState { svcValue = svc, svcLocal = erb }
+        ServiceHandler handler = serviceHandler packet
+    (runExceptT $ flip runStateT sstate $ flip runReaderT input $ handler) >>= \case
+        Left err -> do
+            svcPrintOp input $ "service failed: " ++ err
+            return (Nothing, svc)
+        Right (rsp, sstate')
+            | svcLocal sstate' == svcLocal sstate -> return (rsp, svcValue sstate')
+            | otherwise -> replaceHead (svcLocal sstate') (Right herb) >>= \case
+                Left  _ -> handleServicePacket st input svc packet
+                Right _ -> return (rsp, svcValue sstate')
+
+svcPrint :: String -> ServiceHandler s ()
+svcPrint str = liftIO . ($str) =<< asks svcPrintOp
-- 
cgit v1.2.3