From b3dd410bb4ed093b74fe349d3a51a5767c76f952 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 19 May 2019 22:19:15 +0200
Subject: Direct message service basics

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

(limited to 'src/Message.hs')

diff --git a/src/Message.hs b/src/Message.hs
new file mode 100644
index 0000000..8eaf7f1
--- /dev/null
+++ b/src/Message.hs
@@ -0,0 +1,77 @@
+module Message (
+    DirectMessage(..), DirectMessageThread(..),
+    emptyDirectThread, createDirectMessage,
+    threadToList,
+) where
+
+import Data.List
+import Data.Ord
+import Data.Text (Text)
+import Data.Time.LocalTime
+
+import Identity
+import Storage
+
+data DirectMessage = DirectMessage
+    { msgFrom :: Stored Identity
+    , msgPrev :: [Stored DirectMessage]
+    , msgTime :: ZonedTime
+    , msgText :: Text
+    }
+
+data DirectMessageThread = DirectMessageThread
+    { msgPeer :: Stored Identity
+    , msgHead :: [Stored DirectMessage]
+    , msgSeen :: [Stored DirectMessage]
+    }
+
+instance Storable DirectMessage where
+    store' msg = storeRec $ do
+        storeRef "from" $ msgFrom msg
+        mapM_ (storeRef "prev") $ msgPrev msg
+        storeDate "time" $ msgTime msg
+        storeText "text" $ msgText msg
+
+    load' = loadRec $ DirectMessage
+        <$> loadRef "from"
+        <*> loadRefs "prev"
+        <*> loadDate "time"
+        <*> loadText "text"
+
+instance Storable DirectMessageThread where
+    store' msg = storeRec $ do
+        storeRef "peer" $ msgPeer msg
+        mapM_ (storeRef "head") $ msgHead msg
+        mapM_ (storeRef "seen") $ msgSeen msg
+
+    load' = loadRec $ DirectMessageThread
+        <$> loadRef "peer"
+        <*> loadRefs "head"
+        <*> loadRefs "seen"
+
+
+emptyDirectThread :: Stored Identity -> DirectMessageThread
+emptyDirectThread peer = DirectMessageThread peer [] []
+
+createDirectMessage :: Stored Identity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread)
+createDirectMessage self thread msg = do
+    let st = storedStorage self
+    time <- getZonedTime
+    smsg <- wrappedStore st DirectMessage
+        { msgFrom = finalOwner self
+        , msgPrev = msgHead thread
+        , msgTime = time
+        , msgText = msg
+        }
+    sthread <- wrappedStore st thread
+        { msgHead = [smsg]
+        , msgSeen = [smsg]
+        }
+    return (smsg, sthread)
+
+threadToList :: DirectMessageThread -> [DirectMessage]
+threadToList thread = helper $ msgHead thread
+    where helper msgs | msg : msgs' <- sortBy (comparing cmpView) msgs =
+              fromStored msg : helper (dropWhile (== msg) msgs')
+                      | otherwise = []
+          cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, storedRef msg)
-- 
cgit v1.2.3