diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 175 |
1 files changed, 139 insertions, 36 deletions
diff --git a/src/Main.hs b/src/Main.hs index e6e9d9c..59e6d5c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,12 +3,19 @@ module Main (main) where import Control.Concurrent import Control.Exception import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.Char import Data.List import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Time.Format +import Data.Time.LocalTime +import System.Console.Haskeline import System.Environment import System.IO import System.IO.Error @@ -71,54 +78,150 @@ updateErebosHead st f = do return x main :: IO () -main = do - [bhost] <- getArgs - st <- openStorage "test" - erebosHead <- loadErebosHead st +main = runInputT defaultSettings $ do + bhost <- liftIO getArgs >>= \case [bhost] -> return bhost + _ -> error "Expecting broadcast address" + st <- liftIO $ openStorage "test" + erebosHead <- liftIO $ loadErebosHead st let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos self = erbIdentity $ fromStored serebos - T.putStrLn $ displayIdentity self + outputStrLn $ T.unpack $ displayIdentity self - (chanPeer, chanSvc) <- startServer bhost $ erbIdentity $ fromStored serebos + haveTerminalUI >>= \case True -> return () + False -> error "Requires terminal" + extPrint <- getExternalPrint + let extPrintLn str = extPrint $ str ++ "\n"; + (chanPeer, chanSvc) <- liftIO $ + startServer extPrintLn bhost $ erbIdentity $ fromStored serebos - void $ forkIO $ void $ forever $ do + peers <- liftIO $ newMVar [] + + void $ liftIO $ forkIO $ void $ forever $ do peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer - print addr - T.putStrLn $ maybe (T.pack "<noid>") displayIdentity $ peerIdentity peer - if | Just powner <- finalOwner <$> peerIdentity peer - , _:_ <- peerChannels peer - -> do - msg <- updateErebosHead st $ \erb -> do - (slist, msg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of - Just thread -> do - (msg, thread') <- createDirectMessage self (fromStored thread) (T.pack "Hello") - (,msg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb) - Nothing -> do - (msg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack "Hello") - (,msg) <$> slistAddS thread' (erbMessages $ fromStored erb) - erb' <- wrappedStore st (fromStored erb) { erbMessages = slist } - return (erb', msg) - sendToPeer self peer (T.pack "dmsg") msg - - | otherwise -> return () - - void $ forever $ readChan chanSvc >>= \case + extPrint $ show addr ++ "\n" + extPrintLn $ maybe "<noid>" (T.unpack . displayIdentity) $ peerIdentity peer + let update [] = [peer] + update (p:ps) | peerIdentity p == peerIdentity peer = peer : ps + | otherwise = p : update ps + when (isJust $ peerIdentity peer) $ + modifyMVar_ peers (return . update) + + tzone <- liftIO $ getCurrentTimeZone + void $ liftIO $ forkIO $ forever $ readChan chanSvc >>= \case (peer, svc, ref) | svc == T.pack "dmsg" -> do - let msg = wrappedLoad ref - putStr "Direct message from: " - T.putStrLn $ fromMaybe (T.pack "<unnamed>") $ idName $ fromStored $ signedData $ fromStored $ msgFrom $ fromStored msg + let smsg = wrappedLoad ref + msg = fromStored smsg + extPrintLn $ formatMessage tzone msg if | Just powner <- finalOwner <$> peerIdentity peer - , powner == msgFrom (fromStored msg) + , powner == msgFrom msg -> updateErebosHead_ st $ \erb -> do slist <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of - Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = msg : msgHead (fromStored thread) } + Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) } slistReplaceS thread thread' $ erbMessages $ fromStored erb - Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [msg] } $ erbMessages $ fromStored erb + Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ erbMessages $ fromStored erb wrappedStore st (fromStored erb) { erbMessages = slist } - | otherwise -> putStrLn $ "Owner mismatch" + | otherwise -> extPrint $ "Owner mismatch" + | otherwise -> extPrint $ "Unknown service: " ++ T.unpack svc + + let process cstate = do + let pname = case csPeer cstate of + Nothing -> "" + Just peer -> maybe "<unnamed>" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer + Just input <- lift $ getInputLine $ pname ++ "> " + let (cmd, line) = case input of + '/':rest -> let (scmd, args) = dropWhile isSpace <$> span isAlphaNum rest + in if all isDigit scmd + then (cmdSetPeer $ read scmd, args) + else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) + _ -> (cmdSend, input) + liftIO $ flip execStateT cstate $ runReaderT cmd CommandInput + { ciSelf = self + , ciLine = line + , ciPeers = liftIO $ readMVar peers + } + + let loop (Just cstate) = runMaybeT (process cstate) >>= loop + loop Nothing = return () + loop $ Just $ CommandState { csPeer = Nothing } + - | otherwise -> T.putStrLn $ T.pack "Unknown service: " `T.append` svc +data CommandInput = CommandInput + { ciSelf :: Stored Identity + , ciLine :: String + , ciPeers :: CommandM [Peer] + } + +data CommandState = CommandState + { csPeer :: Maybe Peer + } - return () +type CommandM a = ReaderT CommandInput (StateT CommandState IO) a +type Command = CommandM () + +commands :: [(String, Command)] +commands = + [ ("history", cmdHistory) + , ("peers", cmdPeers) + , ("send", cmdSend) + ] + +cmdUnknown :: String -> Command +cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd + +cmdPeers :: Command +cmdPeers = do + peers <- join $ asks ciPeers + forM_ (zip [1..] peers) $ \(i :: Int, p) -> do + liftIO $ putStrLn $ show i ++ ": " ++ maybe "<noid>" (T.unpack . displayIdentity) (peerIdentity p) + +cmdSetPeer :: Int -> Command +cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index" + | otherwise = do peers <- join $ asks ciPeers + modify $ \s -> s { csPeer = listToMaybe $ drop (n - 1) peers } + +cmdSend :: Command +cmdSend = void $ runMaybeT $ do + self <- asks ciSelf + let st = storedStorage self + Just peer <- gets csPeer + Just powner <- return $ finalOwner <$> peerIdentity peer + _:_ <- return $ peerChannels peer + text <- asks ciLine + smsg <- liftIO $ updateErebosHead st $ \erb -> do + (slist, smsg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of + Just thread -> do + (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text) + (,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb) + Nothing -> do + (smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text) + (,smsg) <$> slistAddS thread' (erbMessages $ fromStored erb) + erb' <- wrappedStore st (fromStored erb) { erbMessages = slist } + return (erb', smsg) + liftIO $ sendToPeer self peer (T.pack "dmsg") smsg + + tzone <- liftIO $ getCurrentTimeZone + liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg + +cmdHistory :: Command +cmdHistory = void $ runMaybeT $ do + self <- asks ciSelf + let st = storedStorage self + Just peer <- gets csPeer + Just powner <- return $ finalOwner <$> peerIdentity peer + + erebosHead <- liftIO $ loadHead st "erebos" + let erebos = wrappedLoad (headRef erebosHead) + Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos + tzone <- liftIO $ getCurrentTimeZone + liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread + + +formatMessage :: TimeZone -> DirectMessage -> String +formatMessage tzone msg = concat + [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg + , maybe "<unnamed>" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg + , ": " + , T.unpack $ msgText msg + ] |