Hach 0.0.1.1 → 0.1.0

raw patch · 19 files changed

+464/−263 lines, 19 filesdep ~vtydep ~vty-uiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: vty, vty-ui

API changes (from Hackage documentation)

Files

• Hach.cabal +16/−9
• client/Client.hs +3/−64
• client/Client/Args.hs +25/−0
• client/Client/Connect.hs +41/−0
• client/Client/Format.hs +20/−0
• client/Format.hs +0/−20
• libhach/Hach/Types.hs +22/−22
• nclient/NClient/Connect.hs +7/−10
• nclient/NClient/Format.hs +0/−32
• nclient/NClient/GUI.hs +43/−22
• nclient/NClient/Message/Format.hs +56/−0
• nclient/NClient/Message/History.hs +39/−0
• nclient/NClient/Message/Split.hs +27/−0
• server/Server.hs +16/−47
• server/Server/Client.hs +63/−0
• server/Server/History.hs +30/−0
• server/Server/Message.hs +19/−0
• server/Server/Storage.hs +37/−0
• server/Storage.hs +0/−37

@@ -1,8 +1,8 @@ Name:                   Hach-Version:                0.0.1.1+Version:                0.1.0 Category:               Network-Description:            Simple chat 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).  License:                MIT License-file:           LICENSE@@ -20,8 +20,7 @@   Build-Depends:        base >= 3 && < 5,                         containers,                         old-locale,-                        network,-                        time+                        network    HS-Source-Dirs:       libhach @@ -32,22 +31,30 @@ Executable hach-client   Main-is:              Client.hs   HS-Source-Dirs:       client, libhach-  Other-modules:        Format+  Other-modules:        Client.Args,+                        Client.Connect,+                        Client.Format  Executable hach-nclient-  Build-Depends:        vty < 4.8,-                        vty-ui == 1.5+  Build-Depends:        vty >= 4.7 && < 4.8,+                        vty-ui >= 1.5 && < 1.6   Main-is:              Client.hs   HS-Source-Dirs:       nclient, libhach   Other-modules:        NClient.Args,                         NClient.Connect,-                        NClient.Format,+                        NClient.Message.Format,+                        NClient.Message.History,+                        NClient.Message.Split,                         NClient.GUI  Executable hach-server+  Build-Depends:        time   Main-is:              Server.hs   HS-Source-Dirs:       server, libhach-  Other-modules:        Storage+  Other-modules:        Server.Client+                        Server.History+                        Server.Message+                        Server.Storage  Source-repository head   type: git

@@ -1,71 +1,10 @@ {-# LANGUAGE UnicodeSyntax #-} module Main (main) where -import Control.Applicative ((<$>))-import Control.Concurrent (forkIO)-import Control.Exception-import Control.Monad (forever)-import Data.List (isPrefixOf)-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format-import Network import System.Environment (getArgs)-import System.Console.GetOpt-import System.IO-import System.Locale-import Text.Printf (printf) -import Format-import Hach.Types--client ∷ Nick → Handle → IO ()-client nick h = forkIO-  (handle onDisconnect $ forever $ hGetLine h >>= printMessage . read) >>-  (hPrint h $ CSetNick nick) >>-  (handle onExit $ forever $ getLine >>= hPutStrLn h . processMessage >> hideOwnMessage)-    where processMessage t-            | commandAction  `isPrefixOf` t = show . CAction $ drop (length commandAction) t-            | commandSetNick `isPrefixOf` t = show . CSetNick $ drop (length commandSetNick) t-            | otherwise = show $ CMessage t-          hideOwnMessage = putStrLn "\ESC[2A"-          onExit (SomeException _) = putStrLn $ nick ++" has left"-          onDisconnect (SomeException _) = putStrLn "Server closed connection"--printMessage ∷ S2C → IO ()-printMessage message = do-  timestamp ← formatTime defaultTimeLocale timeFormat <$> getCurrentTime-  printf (format message) timestamp (getText message)-  where getText ∷ S2C → String-        getText (SMessage _ text) = text-        getText (SAction  _ text) = text-        getText (SSetNick _ text) = text-        getText (SSystem    text) = text+import Client.Args+import Client.Connect  main ∷ IO ()-main = do-  (serverIP, nick) ← parseArgs =<< getArgs-  putStrLn $ "Connected to " ++ serverIP-  withSocketsDo $-    do h ← connectTo serverIP $ PortNumber 7123-       hSetBuffering h LineBuffering-       client nick h--data Flag = ServerIP String-          | ClientNick String--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 argv = case getOpt Permute options argv of-  (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-  where usage = "Usage: hach-client [OPTIONS...]"+main = getArgs >>= parseArgs >>= processClient

@@ -0,0 +1,25 @@+{-# LANGUAGE UnicodeSyntax #-}++module Client.Args (parseArgs) where++import System.Console.GetOpt++data Flag = ServerIP String+          | ClientNick String++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 argv = case getOpt Permute options argv of+  (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+  where usage = "Usage: hach-client [OPTIONS...]"

@@ -0,0 +1,41 @@+{-# LANGUAGE UnicodeSyntax #-}++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 Network+import System.IO+import System.Locale+import Text.Printf (printf)++import Client.Format+import Hach.Types++processClient ∷ (String, String) → IO ()+processClient (serverIP, nick) = do+  putStrLn $ "Connected to " ++ serverIP+  withSocketsDo $+    do h ← connectTo serverIP $ PortNumber 7123+       hSetBuffering h LineBuffering+       client nick h++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)+    where processMessage t+            | commandAction  `isPrefixOf` t = show $ C2S (drop (length commandAction) t) CAction+            | commandSetNick `isPrefixOf` t = show $ C2S (drop (length commandSetNick) t) CSetNick+            | otherwise = show $ C2S t CPlain+          hideOwnMessage = putStrLn "\ESC[2A"+          onExit (SomeException _) = 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)

@@ -0,0 +1,20 @@+{-# 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 "

@@ -1,20 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--module Format where--import Hach.Types--format ∷ S2C → String-format (SMessage nick _) = "[%s] <" ++ nick ++ ">: %s\n"-format (SAction  nick _) = "[%s] *" ++ nick ++ " %s\n"-format (SSetNick nick _) = "[%s] "  ++ nick ++ " %s\n"-format (SSystem       _) = "[%s] ! %s\n"--timeFormat ∷ String-timeFormat = "%H:%M:%S"--commandAction ∷ String-commandAction = "/me "--commandSetNick ∷ String-commandSetNick = "/nick "

@@ -1,30 +1,30 @@ {-# LANGUAGE UnicodeSyntax #-}-module Hach.Types where+module Hach.Types+  ( Nick, Text, Timestamp+  , CMessage(..), SMessage(..)+  , C2S(..), S2C(..)+  ) where +import Data.Time+ type Nick = String type Text = String--data S2C = SMessage Nick Text-         | SAction Nick Text-         | SSetNick Nick Text-         | SSystem Text-           deriving (Read, Show)+type Timestamp = UTCTime -data C2S = CMessage Text-         | CAction Text-         | CSetNick Text-           deriving (Read, Show)+data S2C = S2C { text ∷ Text+               , messageType ∷ SMessage+               , time ∷ Timestamp+               } deriving (Read, Show) -class Message α where-  text ∷ α → String+data SMessage = SPlain Nick+              | SAction Nick+              | SSetNick Nick+              | SSystem+                deriving (Read, Show) -instance Message S2C where-  text (SMessage _ τ) = τ-  text (SAction _ τ) = τ-  text (SSetNick _ τ) = τ-  text (SSystem τ) = τ+data C2S = C2S Text CMessage deriving (Read, Show) -instance Message C2S where-  text (CMessage τ) = τ-  text (CAction τ) = τ-  text (CSetNick τ) = τ+data CMessage = CPlain+              | CAction+              | CSetNick+                deriving (Read, Show)

@@ -4,13 +4,13 @@  import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Exception (SomeException, catch, handle)+import Control.Exception (SomeException, catch) import Control.Monad (forever, void) import Hach.Types import Network import Prelude hiding (catch) import System.Exit (exitFailure, exitSuccess)-import System.IO (hFlush, hGetLine, hPrint, hPutStrLn, hSetBuffering, BufferMode(LineBuffering))+import System.IO (hGetLine, hPrint, hSetBuffering, BufferMode(LineBuffering))  type Input = Chan S2C type Output = Chan C2S@@ -24,15 +24,12 @@  client ∷ String → String → Input → Output → IO () client ip nick i o = do-  withSocketsDo . void $+  withSocketsDo $     do h ← connectTo ip $ PortNumber 7123        hSetBuffering h LineBuffering-       hPrint h $ CSetNick nick-       forkIO $ catch (inputThread h) $ \(_ ∷ SomeException) → do-         writeChan i (SSystem "Server has closed the connection.")-         exitFailure-       forkIO $ catch (outputThread h) $ \(_ ∷ SomeException) → do-         writeChan i (SSystem $ nick ++ " has left.")-         exitSuccess+       hPrint h $ C2S nick CSetNick+       void $ do+         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

@@ -1,32 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE ViewPatterns #-}-module NClient.Format (fromS2C, toC2S) where--import Control.Applicative ((<$>))-import Control.Arrow (second)-import Data.Char (isSpace)-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (formatTime)-import Hach.Types-import System.Exit (exitFailure, exitSuccess)-import System.Locale (defaultTimeLocale)-import Text.Printf (printf)--fromS2C ∷ S2C → IO String-fromS2C m = formatMessage m . formatTime defaultTimeLocale timeFormat <$> getCurrentTime-  where timeFormat = "%H:%M:%S"-        messageFormat (SMessage n _) = "[%s] <" ++ n ++ ">: %s\n"-        messageFormat (SAction n _) = "[%s] *" ++ n ++ " %s\n"-        messageFormat (SSetNick n _) = "[%s] "  ++ n ++ " %s\n"-        messageFormat (SSystem _) = "[%s] ! %s\n"-        formatMessage m t = printf (messageFormat m) t (text m)--toC2S ∷ String → IO C2S-toC2S (format → ("/exit", t)) = exitSuccess-toC2S (format → ("/nick", t)) = return $ CSetNick t-toC2S (format → ("/me", t)) = return $ CAction t-toC2S t = return . CMessage . reverse . drop 1 . reverse $ t--format = second (reverse . dropSpaces . reverse . dropSpaces) . break isSpace . dropSpaces-  where dropSpaces = dropWhile isSpace-

@@ -1,40 +1,61 @@ {-# LANGUAGE UnicodeSyntax #-} module NClient.GUI (gui) where +import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.Chan (Chan, readChan, writeChan)-import Control.Monad (forever)-import Graphics.Vty.Attributes+import Control.Concurrent.Chan (readChan, writeChan)+import Control.Monad (forever, forM_, void)+import Data.IORef (newIORef, atomicModifyIORef)+import Graphics.Vty import Graphics.Vty.Widgets.All-import Hach.Types  import NClient.Connect-import NClient.Format+import NClient.Message.Format+import qualified NClient.Message.History as H+import qualified NClient.Message.Split as S  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-  addToFocusGroup fg newMessage+  void $ addToFocusGroup fg newMessage   c ← newCollection-  addToCollection c ui fg+  void $ addToCollection c ui fg+  -- Send message to server   newMessage `onActivate` \this →-    getEditText this >>= toC2S >>= writeChan o >> setEditText this " "-  forkIO . forever $ readChan i >>= \m → fromS2C m >>= \s → do-    schedule $ do-      addToList messages s =<< plainTextWidget m s-      scrollDown messages-    threadDelay 100000+    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+  --+  -- Catch history movements+  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')+        setEditText this t'+        return True+      (KDown, []) → do+        t' ← atomicModifyIORef history $+          \h → let h' = H.previous h in (h', H.line h')+        setEditText this t'+        return True+      _ → return False+  --+  -- Read server messages when they come+  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+         addMessage (formatter Tail m) a messages+         forM_ as $ \γ → addMessage (formatter Full m) γ messages+    threadDelay 10000+  --   runUi c defaultContext--colors ∷ S2C → Attr-colors (SAction _ _) = Attr Default (SetTo green) Default-colors (SSetNick _ _) = Attr Default (SetTo yellow) Default-colors (SSystem _) = Attr Default (SetTo blue) Default-colors _ = getNormalAttr defaultContext--plainTextWidget ∷ S2C → String → IO (Widget FormattedText)-plainTextWidget m s = plainTextWithAttrs [(s, colors m)]

@@ -0,0 +1,56 @@+{-# LANGUAGE UnicodeSyntax #-}+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++data Format = Full | Tail++formatter ∷ Format → S2C → Formatter+formatter f s2c = case f of+  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+        colorizeStreamEntity (T token) = T $ colorizeToken token+        colorizeStreamEntity NL = NL+        colorizeToken ws@(WS {}) = ws+        colorizeToken s = s {tokenAttr = attr}++        attr ∷ Attr+        attr = case messageType s2c of+          SAction {} → fgColor green+          SSetNick {} → fgColor yellow+          SSystem {} → fgColor blue+          _ → def_attr

@@ -0,0 +1,39 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}+module NClient.Message.History+  ( History+  , empty, prepend+  , line+  , next, previous+  ) where++import Data.Sequence (Seq, (<|))+import Prelude hiding (lines)+import qualified Data.Sequence as Seq++data History = History { lines ∷ Seq String, current ∷ Int, capacity ∷ Int }++prepend ∷ String → History → History+prepend l h = h { lines = Seq.take (capacity h + 1) $ " " <| l <| Seq.drop 1 (lines h), current = 0 }++empty ∷ Int → History+empty c = History { lines = Seq.empty, current = 0, capacity = c }++line ∷ History → String+line h = lines h `Seq.index` current h++next ∷ String → History → History+next t = tryNext . trySetCurrent t++tryNext ∷ History → History+tryNext h@(History ls i c)+  | i == Seq.length ls - 1 = h+  | otherwise = h { current = succ i }++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 _ h = h

@@ -0,0 +1,27 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}+module NClient.Message.Split (simple, words) where++import Data.List (intercalate)+import Prelude hiding (words)+import qualified Prelude++simple ∷ Integral α ⇒ String → α → [String]+simple m (fromIntegral → n) = go m+  where go xs+          | length xs < n = [xs]+          | otherwise = let (a,b) = 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]]+        go [] [] = []+        go [] (x:xs)+          | length x < n = go [x] xs+          | otherwise = let (a,b) = 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+          | otherwise = a : go [] (x:xs)

@@ -3,77 +3,46 @@  module Main (main) where -import Control.Applicative ((<$>)) import Control.Exception-import Control.Monad (forever, when)+import Control.Monad (forever) import Control.Concurrent-import Data.Maybe (fromMaybe)+import Data.Time.Clock (getCurrentTime) import Network.Socket import System.IO -import Storage+import Server.Client+import Server.History+import Server.Message+import Server.Storage import Hach.Types -readC ∷ Storage → Chan (Int, S2C) → Handle → Int → IO ()-readC storage ch h cId' = do-  (cId, message) ← readChan ch-  hPrint h message--client ∷ Storage → Chan (Int, S2C) → Handle → Int → IO ()-client storage ch h cId = do-  ch' ← dupChan ch-  forkIO $ handle_ $ forever $ readC storage ch' h cId-  forever $ do-    m ← hGetLine h-    maybeNick ← getNick storage cId-    case maybeNick of-      Just nick → go nick $ read m-        where go ∷ Nick → C2S → IO ()-              go n m@(CMessage text) = writeChan ch' (cId, SMessage n text)-              go n m@(CAction text) = writeChan ch' (cId, SAction n text)-              go n m@(CSetNick text) = do-                nickExists ← doesNickExist storage text-                if nickExists-                  then hPrint h $ SSystem $ "nick " ++ text ++ " is already in use"-                  else do writeChan ch' (cId, SSetNick nick ("is known as " ++ text))-                          putNick storage cId text-      Nothing → do writeChan ch' (cId, SSystem $ nick ++ " is connected")-                   putNick storage cId nick-                   showStorage storage-                   where nick = text (read m ∷ C2S)-  where handle_ = handle $ \(SomeException e) → print e-        convertMessage ∷ Nick → C2S → S2C-        convertMessage n (CMessage t) = SMessage n t-        convertMessage n (CAction t) = SAction n t-        convertMessage n (CSetNick t) = SSetNick n t---serve ∷ Socket → Storage → Chan (Int, S2C) → Int → IO ()-serve sock storage ch !cId = do+serve ∷ Socket → History → Storage → Chan (Int, S2C) → Int → IO ()+serve sock history storage ch !cId = do   (s, _) ← accept sock   h ← socketToHandle s ReadWriteMode   hSetBuffering h LineBuffering-  forkIO $ handle (onDisconnect ch) $ client storage ch h cId-  serve sock storage ch $ cId + 1+  forkIO $ handle (onDisconnect ch) $ clientProcessing history storage ch h cId+  serve sock history storage ch $ cId + 1   where      onDisconnect ∷ Chan (Int, S2C) → SomeException → IO ()     onDisconnect ch' _ = do       maybeNick ← getNick storage cId+      τ ← getCurrentTime       case maybeNick of-        Just nick → do-          writeChan ch' (cId, SSystem $ nick ++ " has quit conversation")+        Just η → do+          writeChan ch' (cId, leftClientM η τ)           delId storage cId           showStorage storage-        Nothing → putStrLn "Error: undefined user has quit conversation"+        Nothing → putStrLn "Error: undefined user has left conversation"  main ∷ IO () main = withSocketsDo $ do   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   forkIO $ forever $ readChan ch >>= const (return ())-  serve sock storage ch 0-+  serve sock history storage ch 0

@@ -0,0 +1,63 @@+{-# LANGUAGE UnicodeSyntax #-}+module Server.Client (clientProcessing) where++import Control.Applicative ((<$>))+import Control.Concurrent+import Control.Exception+import Control.Monad (forever)+import Data.Time.Clock (getCurrentTime)+import System.IO++import qualified Data.Traversable as DT++import Hach.Types+import Server.History+import Server.Message+import Server.Storage++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 storage ch h cId = do+  ch' ← dupChan ch+  forkIO $ handle_ $ forever $ readC ch' h+  forever $ do+    m ← hGetLine h+    maybeNick ← getNick storage cId+    τ ← 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 α+                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 η+                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

@@ -0,0 +1,30 @@+{-# LANGUAGE UnicodeSyntax #-}+module Server.History+  ( History(..)+  , emptyHistory, putMessage, getMessages, lastNMinutes+  ) where++import Control.Applicative ((<$>))+import Control.Concurrent.MVar+import Data.Time.Clock (diffUTCTime, NominalDiffTime)++import qualified Data.Sequence as S++import Hach.Types++newtype History = History (MVar (S.Seq S2C))++emptyHistory ∷ IO History+emptyHistory = History <$> newMVar S.empty++putMessage ∷ History → S2C → IO ()+putMessage (History α) μ = modifyMVar_ α (\h → return $ h S.|> μ)++getMessages ∷ History → IO (S.Seq S2C)+getMessages (History α) = readMVar α++lastNMinutes ∷ Int → Timestamp → S.Seq S2C → S.Seq S2C+lastNMinutes minutes currentTime = S.takeWhileR inLastMinutes+  where inLastMinutes ∷ S2C → Bool+        inLastMinutes μ = diffUTCTime currentTime (time μ) < nominalMinutes+          where nominalMinutes = 60 * fromIntegral minutes ∷ NominalDiffTime

@@ -0,0 +1,19 @@+{-# LANGUAGE UnicodeSyntax #-}+module Server.Message where++import Hach.Types++connectedClientM ∷ Nick → Timestamp → S2C+connectedClientM η = S2C (η ++ " is connected.") SSystem++existedNickM ∷ Nick → Timestamp → S2C+existedNickM η = S2C ("Nickname " ++ η ++ " is already in use.") SSystem++leftClientM ∷  Nick → Timestamp → S2C+leftClientM η = S2C (η ++ " has left conversation.") SSystem++settedNickM ∷ Nick → Nick → Timestamp → S2C+settedNickM nickFrom nickTo = S2C ("is know as " ++ nickTo ++ ".") (SSetNick nickFrom)++undefinedNickM ∷ Timestamp → S2C+undefinedNickM = S2C "To join a chat please set another nick with /nick command." SSystem

@@ -0,0 +1,37 @@+{-# LANGUAGE UnicodeSyntax #-}++module Server.Storage+  ( Storage(..)+  , newStorage, getNick, putNick, delId+  , doesNickExist+  , showStorage+  ) where++import Control.Applicative ((<$>))+import Control.Concurrent.MVar++import qualified Data.Map as M++import Hach.Types++type ClientId = Int++newtype Storage = Storage (MVar (M.Map ClientId Nick))++newStorage ∷ IO Storage+newStorage = Storage <$> newMVar M.empty++getNick ∷ Storage → ClientId → IO (Maybe Nick)+getNick (Storage s) c = M.lookup c <$> readMVar s++putNick ∷ Storage → ClientId → Nick → IO ()+putNick (Storage s) c n = modifyMVar_ s $ return . M.insert c n++delId ∷ Storage → ClientId → IO ()+delId (Storage s) c = modifyMVar_ s $ return . M.delete c++doesNickExist ∷ Storage → Nick → IO Bool+doesNickExist (Storage s) n = elem n <$> M.elems <$> readMVar s++showStorage ∷ Storage → IO ()+showStorage (Storage s) = print =<< readMVar s

@@ -1,37 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--module Storage-  ( Storage(..)-  , newStorage, getNick, putNick, delId-  , doesNickExist-  , showStorage-  ) where--import Control.Applicative ((<$>))-import Control.Concurrent.MVar--import qualified Data.Map as M--import Hach.Types--type ClientId = Int--newtype Storage = Storage (MVar (M.Map ClientId Nick))--newStorage ∷ IO Storage-newStorage = Storage <$> newMVar M.empty--getNick ∷ Storage → ClientId → IO (Maybe Nick)-getNick (Storage s) c = M.lookup c <$> readMVar s--putNick ∷ Storage → ClientId → Nick → IO ()-putNick (Storage s) c n = modifyMVar_ s $ return . M.insert c n--delId ∷ Storage → ClientId → IO ()-delId (Storage s) c = modifyMVar_ s $ return . M.delete c--doesNickExist ∷ Storage → Nick → IO Bool-doesNickExist (Storage s) n = elem n <$> M.elems <$> readMVar s--showStorage ∷ Storage → IO ()-showStorage (Storage s) = print =<< readMVar s