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/Message/Service.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 52 insertions(+)
 create mode 100644 src/Message/Service.hs

(limited to 'src/Message/Service.hs')

diff --git a/src/Message/Service.hs b/src/Message/Service.hs
new file mode 100644
index 0000000..a798fb5
--- /dev/null
+++ b/src/Message/Service.hs
@@ -0,0 +1,52 @@
+module Message.Service (
+    DirectMessageService,
+    formatMessage,
+) where
+
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Data.List
+import qualified Data.Text as T
+import Data.Time.Format
+import Data.Time.LocalTime
+
+import Identity
+import Message
+import PubKey
+import Service
+import State
+import Storage
+
+data DirectMessageService = DirectMessageService
+
+instance Service DirectMessageService where
+    type ServicePacket DirectMessageService = DirectMessage
+    emptyServiceState = DirectMessageService
+    serviceHandler smsg = do
+        let msg = fromStored smsg
+        powner <- asks svcPeerOwner
+        tzone <- liftIO $ getCurrentTimeZone
+        svcPrint $ formatMessage tzone msg
+        if | idData powner == msgFrom msg
+           -> do erb <- gets svcLocal
+                 let st = storedStorage erb
+                 erb' <- liftIO $ do
+                     slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of
+                                   Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
+                                                     slistReplaceS thread thread' $ lsMessages $ fromStored erb
+                                   Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb
+                     wrappedStore st (fromStored erb) { lsMessages = slist }
+                 modify $ \s -> s { svcLocal = erb' }
+                 return Nothing
+
+           | otherwise -> do svcPrint "Owner mismatch"
+                             return Nothing
+
+formatMessage :: TimeZone -> DirectMessage -> String
+formatMessage tzone msg = concat
+    [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
+    , maybe "<unnamed>" T.unpack $ iddName $ fromStored $ signedData $ fromStored $ msgFrom msg
+    , ": "
+    , T.unpack $ msgText msg
+    ]
-- 
cgit v1.2.3