summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2019-11-03 19:59:27 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2019-11-03 19:59:27 +0100
commit4521fc3c4a898f046b030985159c63c5379df46f (patch)
treee7a0ea42519a790fa2071df25ba5124e6212f0c1 /src/Main.hs
parent78cb83e2f4918bbc199e06e06f2dbbd816b4dcbc (diff)
Service class to handle network services
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs35
1 files changed, 5 insertions, 30 deletions
diff --git a/src/Main.hs b/src/Main.hs
index d473f2e..9e87af5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -17,7 +17,6 @@ import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Text as T
-import Data.Time.Format
import Data.Time.LocalTime
import System.Console.Haskeline
@@ -25,8 +24,10 @@ import System.Environment
import Identity
import Message
+import Message.Service
import Network
import PubKey
+import Service
import State
import Storage
@@ -67,8 +68,10 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
False -> error "Requires terminal"
extPrint <- getExternalPrint
let extPrintLn str = extPrint $ str ++ "\n";
- (chanPeer, chanSvc) <- liftIO $
+ chanPeer <- liftIO $
startServer extPrintLn bhost self
+ [ (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService))
+ ]
peers <- liftIO $ newMVar []
@@ -83,25 +86,6 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
let shown = showPeer peer
when (Just shown /= (showPeer <$> op)) $ extPrint shown
- tzone <- liftIO $ getCurrentTimeZone
- void $ liftIO $ forkIO $ forever $ readChan chanSvc >>= \case
- (peer, svc, ref)
- | svc == T.pack "dmsg" -> do
- let smsg = wrappedLoad ref
- msg = fromStored smsg
- extPrintLn $ formatMessage tzone msg
- if | PeerIdentityFull powner <- peerOwner peer
- , idData powner == msgFrom msg
- -> updateLocalState_ st $ \erb -> 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 }
-
- | otherwise -> extPrint $ "Owner mismatch"
- | otherwise -> extPrint $ "Unknown service: " ++ T.unpack svc
-
let getInputLines prompt = do
Just input <- lift $ getInputLine prompt
case reverse input of
@@ -229,12 +213,3 @@ cmdUpdateIdentity :: Command
cmdUpdateIdentity = void $ do
st <- asks $ storedStorage . idData . ciSelf
liftIO $ updateIdentity st
-
-
-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
- ]