From 0edb161e760197fcc371644a318ba745d966c95e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Thu, 16 Jan 2020 21:54:03 +0100
Subject: Use UUID for service types
---
src/Message/Service.hs | 26 ++++++++++++++++++--------
1 file changed, 18 insertions(+), 8 deletions(-)
(limited to 'src/Message')
diff --git a/src/Message/Service.hs b/src/Message/Service.hs
index 1311e24..0a8f180 100644
--- a/src/Message/Service.hs
+++ b/src/Message/Service.hs
@@ -1,10 +1,10 @@
module Message.Service (
- DirectMessageService(..),
+ DirectMessageService,
+ ServicePacket(DirectMessagePacket),
formatMessage,
) where
import Control.Monad.Reader
-import Control.Monad.State
import Data.List
import qualified Data.Text as T
@@ -18,18 +18,24 @@ import State
import Storage
import Storage.List
-data DirectMessageService = DirectMessageService
+data DirectMessageService
instance Service DirectMessageService where
- type ServicePacket DirectMessageService = DirectMessage
+ serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
+
+ data ServiceState DirectMessageService = DirectMessageService
emptyServiceState = DirectMessageService
- serviceHandler smsg = do
- let msg = fromStored smsg
+
+ newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage)
+
+ serviceHandler packet = do
+ let DirectMessagePacket smsg = fromStored packet
+ msg = fromStored smsg
powner <- asks $ finalOwner . svcPeer
tzone <- liftIO $ getCurrentTimeZone
svcPrint $ formatMessage tzone msg
if | powner `sameIdentity` msgFrom msg
- -> do erb <- gets svcLocal
+ -> do erb <- svcGetLocal
let st = storedStorage erb
erb' <- liftIO $ do
threads <- storedFromSList $ lsMessages $ fromStored erb
@@ -38,12 +44,16 @@ instance Service DirectMessageService where
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' }
+ svcSetLocal erb'
return Nothing
| otherwise -> do svcPrint "Owner mismatch"
return Nothing
+instance Storable (ServicePacket DirectMessageService) where
+ store' (DirectMessagePacket smsg) = store' smsg
+ load' = DirectMessagePacket <$> load'
+
formatMessage :: TimeZone -> DirectMessage -> String
formatMessage tzone msg = concat
[ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
--
cgit v1.2.3