Hach 0.1.0 → 0.1.1
raw patch · 18 files changed
+235/−258 lines, 18 filesdep +textdep ~vtydep ~vty-uiPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: text
Dependency ranges changed: vty, vty-ui
API changes (from Hackage documentation)
- Hach.Types: type Text = String
+ Hach.Types: fromS2C :: S2C -> Text
+ Hach.Types: toC2S :: Text -> IO C2S
- Hach.Types: type Nick = String
+ Hach.Types: type Nick = Text
Files
- Hach.cabal +6/−6
- client/Client.hs +1/−2
- client/Client/Args.hs +8/−9
- client/Client/Connect.hs +20/−18
- client/Client/Format.hs +0/−20
- libhach/Hach/Types.hs +31/−7
- nclient/Client.hs +1/−2
- nclient/NClient/Args.hs +8/−9
- nclient/NClient/Connect.hs +15/−12
- nclient/NClient/GUI.hs +23/−24
- nclient/NClient/Message/Format.hs +11/−33
- nclient/NClient/Message/History.hs +12/−12
- nclient/NClient/Message/Split.hs +12/−13
- server/Server.hs +14/−15
- server/Server/Client.hs +38/−39
- server/Server/History.hs +8/−9
- server/Server/Message.hs +12/−10
- server/Server/Storage.hs +15/−18
Hach.cabal view
@@ -1,5 +1,5 @@ Name: Hach-Version: 0.1.0+Version: 0.1.1 Category: Network Synopsis: Simple chat Description: Simple example of chat application. Consists of 3 components: hach-server, hach-client (simple console client), hach-nclient (vty-ui client).@@ -17,7 +17,7 @@ Homepage: http://github.com/dmalikov/HaCh Library- Build-Depends: base >= 3 && < 5,+ Build-Depends: base >= 3 && <5, containers, old-locale, network@@ -32,12 +32,12 @@ Main-is: Client.hs HS-Source-Dirs: client, libhach Other-modules: Client.Args,- Client.Connect,- Client.Format+ Client.Connect Executable hach-nclient- Build-Depends: vty >= 4.7 && < 4.8,- vty-ui >= 1.5 && < 1.6+ Build-Depends: vty >= 4.7,+ vty-ui >= 1.5,+ text Main-is: Client.hs HS-Source-Dirs: nclient, libhach Other-modules: NClient.Args,
client/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module Main (main) where import System.Environment (getArgs)@@ -6,5 +5,5 @@ import Client.Args import Client.Connect -main ∷ IO ()+main :: IO () main = getArgs >>= parseArgs >>= processClient
client/Client/Args.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module Client.Args (parseArgs) where @@ -7,19 +6,19 @@ data Flag = ServerIP String | ClientNick String -options ∷ [OptDescr Flag]+options :: [OptDescr Flag] options = [ Option "s" ["server"] (ReqArg ServerIP "server_ip") "set server ip adress" , Option "n" ["nick"] (ReqArg ClientNick "user nickname") "set user nickname" ] -parseArgs ∷ [String] → IO (String, String)+parseArgs :: [String] -> IO (String, String) parseArgs argv = case getOpt Permute options argv of- (os, _, []) → do- let ips = [ s | ServerIP s ← os ]- let nicks = [ n | ClientNick n ← os ]+ (os, _, []) -> do+ let ips = [ s | ServerIP s <- os ]+ let nicks = [ n | ClientNick n <- os ] case (ips, nicks) of- ([ip], [nick]) → return (ip, nick)- (_, _) → error $ usageInfo usage options- (_, _, es) → error $ concat es ++ usageInfo usage options+ ([ip], [nick]) -> return (ip, nick)+ (_, _) -> error $ usageInfo usage options+ (_, _, es) -> error $ concat es ++ usageInfo usage options where usage = "Usage: hach-client [OPTIONS...]"
client/Client/Connect.hs view
@@ -1,41 +1,43 @@-{-# LANGUAGE UnicodeSyntax #-}-+{-# LANGUAGE OverloadedStrings #-} module Client.Connect (processClient) where import Control.Concurrent (forkIO) import Control.Exception import Control.Monad (forever)-import Data.List (isPrefixOf)-import Data.Time.Format+import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.IO as TIO import Network import System.IO-import System.Locale-import Text.Printf (printf) -import Client.Format import Hach.Types -processClient ∷ (String, String) → IO ()+processClient :: (String, String) -> IO () processClient (serverIP, nick) = do putStrLn $ "Connected to " ++ serverIP withSocketsDo $- do h ← connectTo serverIP $ PortNumber 7123+ do h <- connectTo serverIP $ PortNumber 7123 hSetBuffering h LineBuffering- client nick h+ client (T.pack nick) h -client ∷ Nick → Handle → IO ()+client :: Nick -> Handle -> IO () client nick h = forkIO (handle onDisconnect $ forever $ hGetLine h >>= printMessage . read) >> (hPrint h $ C2S nick CSetNick) >>- (handle onExit $ forever $ getLine >>= hPutStrLn h . processMessage >> hideOwnMessage)+ (handle onExit $ forever $ TIO.getLine >>= hPutStrLn h . processMessage >> hideOwnMessage) where processMessage t- | commandAction `isPrefixOf` t = show $ C2S (drop (length commandAction) t) CAction- | commandSetNick `isPrefixOf` t = show $ C2S (drop (length commandSetNick) t) CSetNick+ | commandAction `T.isPrefixOf` t = show $ C2S (T.drop (T.length commandAction) t) CAction+ | commandSetNick `T.isPrefixOf` t = show $ C2S (T.drop (T.length commandSetNick) t) CSetNick | otherwise = show $ C2S t CPlain hideOwnMessage = putStrLn "\ESC[2A"- onExit (SomeException _) = putStrLn $ nick ++" has left"+ onExit (SomeException _) = TIO.putStrLn $ nick <> " has left" onDisconnect (SomeException _) = putStrLn "Server closed connection" -printMessage ∷ S2C → IO ()-printMessage message =- printf (format message) (formatTime defaultTimeLocale timeFormat (time message)) (text message)+printMessage :: S2C -> IO ()+printMessage message = print $ fromS2C message++commandAction :: T.Text+commandAction = "/me "++commandSetNick :: T.Text+commandSetNick = "/nick "
− client/Client/Format.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--module Client.Format where--import Hach.Types--format ∷ S2C → String-format (S2C _ (SPlain nick) _) = "[%s] <" ++ nick ++ ">: %s\n"-format (S2C _ (SAction nick) _) = "[%s] *" ++ nick ++ " %s\n"-format (S2C _ (SSetNick nick) _) = "[%s] " ++ nick ++ " %s\n"-format (S2C _ SSystem _) = "[%s] ! %s\n"--timeFormat ∷ String-timeFormat = "%H:%M:%S"--commandAction ∷ String-commandAction = "/me "--commandSetNick ∷ String-commandSetNick = "/nick "
libhach/Hach/Types.hs view
@@ -1,19 +1,25 @@-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-} module Hach.Types- ( Nick, Text, Timestamp+ ( Nick, Timestamp , CMessage(..), SMessage(..) , C2S(..), S2C(..)+ , fromS2C, toC2S ) where +import Control.Arrow (second)+import Data.Char (isSpace)+import Data.Monoid ((<>))+import Data.Text as T import Data.Time+import System.Exit (exitSuccess)+import System.Locale (defaultTimeLocale) -type Nick = String-type Text = String+type Nick = Text type Timestamp = UTCTime -data S2C = S2C { text ∷ Text- , messageType ∷ SMessage- , time ∷ Timestamp+data S2C = S2C { text :: Text+ , messageType :: SMessage+ , time :: Timestamp } deriving (Read, Show) data SMessage = SPlain Nick@@ -28,3 +34,21 @@ | CAction | CSetNick deriving (Read, Show)++fromS2C :: S2C -> Text+fromS2C (S2C message (SPlain n) t) = "[" <> formatTime' t <> "] <" <> n <> ">: " <> message <> "\n"+fromS2C (S2C message (SAction n) t) = "[" <> formatTime' t <> "] *" <> n <> " " <> message <> "\n"+fromS2C (S2C message (SSetNick n) t) = "[" <> formatTime' t <> "] " <> n <> " " <> message <> "\n"+fromS2C (S2C message SSystem t) = "[" <> formatTime' t <> "] ! " <> message <> "\n"++formatTime' :: Timestamp -> Text+formatTime' = T.pack . formatTime defaultTimeLocale "%T"++toC2S :: T.Text -> IO C2S+toC2S m = case format m of+ ("/exit", _) -> exitSuccess+ ("/nick", t) -> return $ C2S t CSetNick+ ("/me", t) -> return $ C2S t CAction+ _ -> return $ C2S (T.reverse . T.drop 1 $ T.reverse m) CPlain+ where format = second (T.reverse . dropSpaces . T.reverse . dropSpaces) . T.break isSpace . dropSpaces+ dropSpaces = T.dropWhile isSpace
nclient/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module Main (main) where import System.Environment (getArgs)@@ -7,5 +6,5 @@ import NClient.Connect import NClient.GUI -main ∷ IO ()+main :: IO () main = getArgs >>= parseArgs >>= connect >>= gui
nclient/NClient/Args.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module NClient.Args (parseArgs) where import System.Console.GetOpt@@ -6,20 +5,20 @@ data Options = ServerIP String | Name String -options ∷ [OptDescr Options]+options :: [OptDescr Options] options = [ Option "s" ["server"] (ReqArg ServerIP "Server IP") "Set server IP address." , Option "n" ["nick"] (ReqArg Name "User nickname") "Set user nickname." ] -parseArgs ∷ [String] → IO (String, String)+parseArgs :: [String] -> IO (String, String) parseArgs argv = case getOpt Permute options argv of- (os, _, []) →- let ips = [ s | ServerIP s ← os ]- nicks = [ n | Name n ← os ]+ (os, _, []) ->+ let ips = [ s | ServerIP s <- os ]+ nicks = [ n | Name n <- os ] in case (ips, nicks) of- ([ip], [nick]) → return (ip, nick)- (_, _) → error $ usageInfo usage options- (_, _, es) → error $ concat es ++ usageInfo usage options+ ([ip], [nick]) -> return (ip, nick)+ (_, _) -> error $ usageInfo usage options+ (_, _, es) -> error $ concat es ++ usageInfo usage options where usage = "Usage: hach-nclient [OPTIONS]"
nclient/NClient/Connect.hs view
@@ -1,35 +1,38 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} module NClient.Connect (connect, Input, Output) where import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Exception (SomeException, catch) import Control.Monad (forever, void)-import Hach.Types+import Data.Text (pack) import Network+#if ! MIN_VERSION_base(4,6,0) import Prelude hiding (catch)+#endif import System.Exit (exitFailure, exitSuccess) import System.IO (hGetLine, hPrint, hSetBuffering, BufferMode(LineBuffering)) +import Hach.Types+ type Input = Chan S2C type Output = Chan C2S -connect ∷ (String, String) → IO (Input, Output)+connect :: (String, String) -> IO (Input, Output) connect (ip, nick) = do- i ← newChan- o ← newChan+ i <- newChan+ o <- newChan client ip nick i o return (i,o) -client ∷ String → String → Input → Output → IO ()+client :: String -> String -> Input -> Output -> IO () client ip nick i o = do withSocketsDo $- do h ← connectTo ip $ PortNumber 7123+ do h <- connectTo ip $ PortNumber 7123 hSetBuffering h LineBuffering- hPrint h $ C2S nick CSetNick+ hPrint h $ C2S (pack nick) CSetNick void $ do- forkIO $ catch (inputThread h) $ \(_ ∷ SomeException) → exitFailure- forkIO $ catch (outputThread h) $ \(_ ∷ SomeException) → exitSuccess+ forkIO $ catch (inputThread h) $ \(_ :: SomeException) -> exitFailure+ forkIO $ catch (outputThread h) $ \(_ :: SomeException) -> exitSuccess where inputThread h = forever $ hGetLine h >>= writeChan i . read- outputThread h = forever $ readChan o >>= \m → hPrint h m+ outputThread h = forever $ readChan o >>= \m -> hPrint h m
nclient/NClient/GUI.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module NClient.GUI (gui) where import Control.Applicative ((<$>))@@ -14,48 +13,48 @@ import qualified NClient.Message.History as H import qualified NClient.Message.Split as S -gui ∷ (Input, Output) → IO ()+gui :: (Input, Output) -> IO () gui (i,o) = do- history ← newIORef $ H.empty 10- messages ← newList (getNormalAttr defaultContext)- newMessage ← editWidget- box ← vBox messages newMessage- ui ← centered box- fg ← newFocusGroup+ history <- newIORef $ H.empty 10+ messages <- newList (getNormalAttr defaultContext)+ newMessage <- editWidget+ box <- vBox messages newMessage+ ui <- centered box+ fg <- newFocusGroup void $ addToFocusGroup fg newMessage- c ← newCollection+ c <- newCollection void $ addToCollection c ui fg -- Send message to server- newMessage `onActivate` \this →+ newMessage `onActivate` \this -> getEditText this >>= toC2S >>= writeChan o -- -- Add send message to history- newMessage `onActivate` \this →- getEditText this >>= \t → atomicModifyIORef history (\h → let α = H.prepend t h in (α, H.line α)) >>= setEditText this+ newMessage `onActivate` \this ->+ getEditText this >>= \t -> atomicModifyIORef history (\h -> let a = H.prepend t h in (a, H.line a)) >>= setEditText this -- -- Catch history movements- newMessage `onKeyPressed` \this k m →+ newMessage `onKeyPressed` \this k m -> case (k,m) of- (KUp, []) → do- t ← getEditText this- t' ← atomicModifyIORef history $- \h → let h' = H.next t h in (h', H.line h')+ (KUp, []) -> do+ t <- getEditText this+ t' <- atomicModifyIORef history $+ \h -> let h' = H.next t h in (h', H.line h') setEditText this t' return True- (KDown, []) → do- t' ← atomicModifyIORef history $- \h → let h' = H.previous h in (h', H.line h')+ (KDown, []) -> do+ t' <- atomicModifyIORef history $+ \h -> let h' = H.previous h in (h', H.line h') setEditText this t' return True- _ → return False+ _ -> return False -- -- Read server messages when they come- void . forkIO . forever $ readChan i >>= \m → do+ void . forkIO . forever $ readChan i >>= \m -> do let addMessage f xs ys = textWidget f xs >>= addToList ys xs >> scrollDown ys schedule $- do a:as ← S.words (fromS2C m) . region_width <$> getCurrentSize messages+ do a:as <- S.words (fromS2C m) . region_width <$> getCurrentSize messages addMessage (formatter Tail m) a messages- forM_ as $ \γ → addMessage (formatter Full m) γ messages+ forM_ as $ \γ -> addMessage (formatter Full m) γ messages threadDelay 10000 -- runUi c defaultContext
nclient/NClient/Message/Format.hs view
@@ -1,45 +1,23 @@-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+ module NClient.Message.Format ( fromS2C, toC2S , Format(..), formatter ) where -import Control.Applicative ((<$>))-import Control.Arrow (second)-import Data.Char (isSpace)-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (formatTime) import Graphics.Vty.Attributes import Graphics.Vty.Widgets.Text import Graphics.Vty.Widgets.Util-import Hach.Types-import System.Exit (exitSuccess)-import System.Locale (defaultTimeLocale)-import Text.Printf (printf) import Text.Trans.Tokenize -fromS2C ∷ S2C → String-fromS2C m = printf (format $ messageType m) (formatTime defaultTimeLocale "%T" $ time m) (text m)- where format (SPlain n) = "[%s] <" ++ n ++ ">: %s\n"- format (SAction n) = "[%s] *" ++ n ++ " %s\n"- format (SSetNick n) = "[%s] " ++ n ++ " %s\n"- format SSystem = "[%s] ! %s\n"--toC2S ∷ String → IO C2S-toC2S m = case format m of- ("/exit", _) → exitSuccess- ("/nick", t) → return $ C2S t CSetNick- ("/me", t) → return $ C2S t CAction- _ → return $ C2S (reverse . drop 1 $ reverse m) CPlain- where format = second (reverse . dropSpaces . reverse . dropSpaces) . break isSpace . dropSpaces- dropSpaces = dropWhile isSpace+import Hach.Types data Format = Full | Tail -formatter ∷ Format → S2C → Formatter+formatter :: Format -> S2C -> Formatter formatter f s2c = case f of- Full → Formatter $ \_ → return . colorizeStream- Tail → Formatter $ \_ → return . colorizeStreamTail+ Full -> Formatter $ \_ -> return . colorizeStream+ Tail -> Formatter $ \_ -> return . colorizeStreamTail where colorizeStream = TS . map colorizeStreamEntity . streamEntities colorizeStreamTail ts = let x:xs = streamEntities ts in TS $ x:map colorizeStreamEntity xs@@ -48,9 +26,9 @@ colorizeToken ws@(WS {}) = ws colorizeToken s = s {tokenAttr = attr} - attr ∷ Attr+ attr :: Attr attr = case messageType s2c of- SAction {} → fgColor green- SSetNick {} → fgColor yellow- SSystem {} → fgColor blue- _ → def_attr+ SAction {} -> fgColor green+ SSetNick {} -> fgColor yellow+ SSystem {} -> fgColor blue+ _ -> def_attr
nclient/NClient/Message/History.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns, OverloadedStrings #-} module NClient.Message.History ( History , empty, prepend@@ -10,30 +9,31 @@ import Data.Sequence (Seq, (<|)) import Prelude hiding (lines) import qualified Data.Sequence as Seq+import Data.Text (Text) -data History = History { lines ∷ Seq String, current ∷ Int, capacity ∷ Int }+data History = History { lines :: Seq Text, current :: Int, capacity :: Int } -prepend ∷ String → History → History+prepend :: Text -> History -> History prepend l h = h { lines = Seq.take (capacity h + 1) $ " " <| l <| Seq.drop 1 (lines h), current = 0 } -empty ∷ Int → History+empty :: Int -> History empty c = History { lines = Seq.empty, current = 0, capacity = c } -line ∷ History → String+line :: History -> Text line h = lines h `Seq.index` current h -next ∷ String → History → History+next :: Text -> History -> History next t = tryNext . trySetCurrent t -tryNext ∷ History → History-tryNext h@(History ls i c)+tryNext :: History -> History+tryNext h@(History ls i _) | i == Seq.length ls - 1 = h | otherwise = h { current = succ i } -previous ∷ History → History+previous :: History -> History previous h@(History _ 0 _) = h previous h = h { current = pred $ current h } -trySetCurrent ∷ String → History → History-trySetCurrent α h@(current → 0) = h { lines = α <| Seq.drop 1 (lines h) }+trySetCurrent :: Text -> History -> History+trySetCurrent a h@(current -> 0) = h { lines = a <| Seq.drop 1 (lines h) } trySetCurrent _ h = h
nclient/NClient/Message/Split.hs view
@@ -1,27 +1,26 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings, ViewPatterns #-} module NClient.Message.Split (simple, words) where -import Data.List (intercalate)+import qualified Data.Text as T import Prelude hiding (words) import qualified Prelude -simple ∷ Integral α ⇒ String → α → [String]-simple m (fromIntegral → n) = go m+simple :: Integral a => T.Text -> a -> [T.Text]+simple m (fromIntegral -> n) = go m where go xs- | length xs < n = [xs]- | otherwise = let (a,b) = splitAt n xs+ | T.length xs < n = [xs]+ | otherwise = let (a,b) = T.splitAt n xs in a : go b -words ∷ Integral α ⇒ String → α → [String]-words m (fromIntegral → n) = map (intercalate " " . reverse) . go [] $ Prelude.words m- where go ∷ [String] → [String] → [[String]]+words :: Integral a => T.Text -> a -> [T.Text]+words m (fromIntegral -> n) = map (T.intercalate " " . reverse) . go [] $ T.words m+ where go :: [T.Text] -> [T.Text] -> [[T.Text]] go [] [] = [] go [] (x:xs)- | length x < n = go [x] xs- | otherwise = let (a,b) = splitAt n x+ | T.length x < n = go [x] xs+ | otherwise = let (a,b) = T.splitAt n x in [a] : go [] (b:xs) go a [] = [a] go a (x:xs)- | length a + sum (map length a) + length x <= n = go (x:a) xs+ | length a + sum (map T.length a) + T.length x <= n = go (x:a) xs | otherwise = a : go [] (x:xs)
server/Server.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE UnicodeSyntax #-} module Main (main) where @@ -16,33 +15,33 @@ import Server.Storage import Hach.Types -serve ∷ Socket → History → Storage → Chan (Int, S2C) → Int → IO ()+serve :: Socket -> History -> NickStorage -> Chan (Int, S2C) -> Int -> IO () serve sock history storage ch !cId = do- (s, _) ← accept sock- h ← socketToHandle s ReadWriteMode+ (s, _) <- accept sock+ h <- socketToHandle s ReadWriteMode hSetBuffering h LineBuffering forkIO $ handle (onDisconnect ch) $ clientProcessing history storage ch h cId serve sock history storage ch $ cId + 1- where - onDisconnect ∷ Chan (Int, S2C) → SomeException → IO ()+ where+ onDisconnect :: Chan (Int, S2C) -> SomeException -> IO () onDisconnect ch' _ = do- maybeNick ← getNick storage cId- τ ← getCurrentTime+ maybeNick <- getNick storage cId+ τ <- getCurrentTime case maybeNick of- Just η → do+ Just η -> do writeChan ch' (cId, leftClientM η τ) delId storage cId showStorage storage- Nothing → putStrLn "Error: undefined user has left conversation"+ Nothing -> putStrLn "Error: undefined user has left conversation" -main ∷ IO ()+main :: IO () main = withSocketsDo $ do- storage ← newStorage- history ← emptyHistory- sock ← socket AF_INET Stream 0+ storage <- newStorage+ history <- emptyHistory+ sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 bindSocket sock (SockAddrInet 7123 iNADDR_ANY) listen sock 1024- ch ← newChan+ ch <- newChan forkIO $ forever $ readChan ch >>= const (return ()) serve sock history storage ch 0
server/Server/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module Server.Client (clientProcessing) where import Control.Applicative ((<$>))@@ -15,49 +14,49 @@ import Server.Message import Server.Storage -readC ∷ Chan (Int, S2C) → Handle → IO ()+readC :: Chan (Int, S2C) -> Handle -> IO () readC ch h = hPrint h =<< snd <$> readChan ch -clientProcessing ∷ History → Storage → Chan (Int, S2C) → Handle → Int → IO ()+clientProcessing :: History -> NickStorage -> Chan (Int, S2C) -> Handle -> Int -> IO () clientProcessing history storage ch h cId = do- ch' ← dupChan ch+ ch' <- dupChan ch forkIO $ handle_ $ forever $ readC ch' h forever $ do- m ← hGetLine h- maybeNick ← getNick storage cId- τ ← getCurrentTime+ message <- hGetLine h+ maybeNick <- getNick storage cId+ t <- getCurrentTime case maybeNick of- Just nick → do- go nick $ read m- putStrLn m- where go ∷ Nick → C2S → IO ()- go η (C2S α CPlain) = do writeChan ch' (cId, μ)- putMessage history μ- where μ = S2C α (SPlain η) τ- go η (C2S α CAction) = do writeChan ch' (cId, μ)- putMessage history μ- where μ = S2C α (SAction η) τ- go η (C2S α CSetNick) = do- nickExists ← doesNickExist storage α+ Just nick -> do+ go nick $ read message+ putStrLn message+ where go :: Nick -> C2S -> IO ()+ go n (C2S a CPlain) = do writeChan ch' (cId, m)+ putMessage history m+ where m = S2C a (SPlain n) t+ go n (C2S a CAction) = do writeChan ch' (cId, m)+ putMessage history m+ where m = S2C a (SAction n) t+ go n (C2S a CSetNick) = do+ nickExists <- doesNickExist storage a if nickExists- then hPrint h $ existedNickM α τ- else do writeChan ch' (cId, μ)- putMessage history μ- putNick storage cId α- where μ = settedNickM η α τ- Nothing → do- go $ read m- putStrLn m- where go ∷ C2S → IO ()- go (C2S η CSetNick) = do- nickExists ← doesNickExist storage η+ then hPrint h $ existedNickM a t+ else do writeChan ch' (cId, m)+ putMessage history m+ putNick storage cId a+ where m = settedNickM n a t+ Nothing -> do+ go $ read message+ putStrLn message+ where go :: C2S -> IO ()+ go (C2S n CSetNick) = do+ nickExists <- doesNickExist storage n if nickExists- then do hPrint h $ existedNickM η τ- hPrint h $ undefinedNickM τ- else do DT.mapM (hPrint h) . lastNMinutes 10 τ =<< getMessages history- writeChan ch' (cId, μ)- putMessage history μ- putNick storage cId η- where μ = connectedClientM η τ- go (C2S _ _) = hPrint h $ undefinedNickM τ- where handle_ = handle $ \(SomeException e) → print e+ then do hPrint h $ existedNickM n t+ hPrint h $ undefinedNickM t+ else do DT.mapM (hPrint h) . lastNMinutes 10 t =<< getMessages history+ writeChan ch' (cId, m)+ putMessage history m+ putNick storage cId n+ where m = connectedClientM n t+ go (C2S _ _) = hPrint h $ undefinedNickM t+ where handle_ = handle $ \(SomeException e) -> print e
server/Server/History.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UnicodeSyntax #-} module Server.History ( History(..) , emptyHistory, putMessage, getMessages, lastNMinutes@@ -14,17 +13,17 @@ newtype History = History (MVar (S.Seq S2C)) -emptyHistory ∷ IO History+emptyHistory :: IO History emptyHistory = History <$> newMVar S.empty -putMessage ∷ History → S2C → IO ()-putMessage (History α) μ = modifyMVar_ α (\h → return $ h S.|> μ)+putMessage :: History -> S2C -> IO ()+putMessage (History a) μ = modifyMVar_ a (\h -> return $ h S.|> μ) -getMessages ∷ History → IO (S.Seq S2C)-getMessages (History α) = readMVar α+getMessages :: History -> IO (S.Seq S2C)+getMessages (History a) = readMVar a -lastNMinutes ∷ Int → Timestamp → S.Seq S2C → S.Seq S2C+lastNMinutes :: Int -> Timestamp -> S.Seq S2C -> S.Seq S2C lastNMinutes minutes currentTime = S.takeWhileR inLastMinutes- where inLastMinutes ∷ S2C → Bool+ where inLastMinutes :: S2C -> Bool inLastMinutes μ = diffUTCTime currentTime (time μ) < nominalMinutes- where nominalMinutes = 60 * fromIntegral minutes ∷ NominalDiffTime+ where nominalMinutes = 60 * fromIntegral minutes :: NominalDiffTime
server/Server/Message.hs view
@@ -1,19 +1,21 @@-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+ module Server.Message where +import Data.Monoid ((<>)) import Hach.Types -connectedClientM ∷ Nick → Timestamp → S2C-connectedClientM η = S2C (η ++ " is connected.") SSystem+connectedClientM :: Nick -> Timestamp -> S2C+connectedClientM n = S2C (n <> " is connected.") SSystem -existedNickM ∷ Nick → Timestamp → S2C-existedNickM η = S2C ("Nickname " ++ η ++ " is already in use.") SSystem+existedNickM :: Nick -> Timestamp -> S2C+existedNickM n = S2C ("Nickname " <> n <> " is already in use.") SSystem -leftClientM ∷ Nick → Timestamp → S2C-leftClientM η = S2C (η ++ " has left conversation.") SSystem+leftClientM :: Nick -> Timestamp -> S2C+leftClientM n = S2C (n <> " has left conversation.") SSystem -settedNickM ∷ Nick → Nick → Timestamp → S2C-settedNickM nickFrom nickTo = S2C ("is know as " ++ nickTo ++ ".") (SSetNick nickFrom)+settedNickM :: Nick -> Nick -> Timestamp -> S2C+settedNickM nickFrom nickTo = S2C ("is know as " <> nickTo <> ".") (SSetNick nickFrom) -undefinedNickM ∷ Timestamp → S2C+undefinedNickM :: Timestamp -> S2C undefinedNickM = S2C "To join a chat please set another nick with /nick command." SSystem
server/Server/Storage.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE UnicodeSyntax #-} module Server.Storage- ( Storage(..)+ ( NickStorage(..) , newStorage, getNick, putNick, delId , doesNickExist , showStorage@@ -9,29 +8,27 @@ import Control.Applicative ((<$>)) import Control.Concurrent.MVar- import qualified Data.Map as M--import Hach.Types+import Data.Text type ClientId = Int -newtype Storage = Storage (MVar (M.Map ClientId Nick))+data NickStorage = NickStorage (MVar (M.Map ClientId Text)) -newStorage ∷ IO Storage-newStorage = Storage <$> newMVar M.empty+newStorage :: IO NickStorage+newStorage = NickStorage <$> newMVar M.empty -getNick ∷ Storage → ClientId → IO (Maybe Nick)-getNick (Storage s) c = M.lookup c <$> readMVar s+getNick :: NickStorage -> ClientId -> IO (Maybe Text)+getNick (NickStorage s) c = M.lookup c <$> readMVar s -putNick ∷ Storage → ClientId → Nick → IO ()-putNick (Storage s) c n = modifyMVar_ s $ return . M.insert c n+putNick :: NickStorage -> ClientId -> Text -> IO ()+putNick (NickStorage s) c n = modifyMVar_ s $ return . M.insert c n -delId ∷ Storage → ClientId → IO ()-delId (Storage s) c = modifyMVar_ s $ return . M.delete c+delId :: NickStorage -> ClientId -> IO ()+delId (NickStorage s) c = modifyMVar_ s $ return . M.delete c -doesNickExist ∷ Storage → Nick → IO Bool-doesNickExist (Storage s) n = elem n <$> M.elems <$> readMVar s+doesNickExist :: NickStorage -> Text -> IO Bool+doesNickExist (NickStorage s) n = elem n <$> M.elems <$> readMVar s -showStorage ∷ Storage → IO ()-showStorage (Storage s) = print =<< readMVar s+showStorage :: NickStorage -> IO ()+showStorage (NickStorage s) = print =<< readMVar s