Hach (empty) → 0.0.1

raw patch · 13 files changed

+451/−0 lines, 13 filesdep +basedep +containersdep +networksetup-changed

Dependencies added: base, containers, network, old-locale, time, vty, vty-ui

Files

• Hach.cabal +54/−0
• LICENSE +7/−0
• Setup.hs +2/−0
• client/Client.hs +71/−0
• client/Format.hs +25/−0
• libhach/Hach/Types.hs +30/−0
• nclient/Client.hs +11/−0
• nclient/NClient/Args.hs +25/−0
• nclient/NClient/Connect.hs +38/−0
• nclient/NClient/Format.hs +32/−0
• nclient/NClient/GUI.hs +40/−0
• server/Server.hs +79/−0
• server/Storage.hs +37/−0

@@ -0,0 +1,54 @@+Name:                   Hach+Version:                0.0.1+Category:               Network+Description:            Simple chat+Synopsis:               Simple chat++License:                MIT+License-file:           LICENSE++Author:                 Matvey Aksenov,+                        Dmitry Malikov++Maintainer:             Dmitry Malikov <malikov.d.y@gmail.com>++Build-type:             Simple+Cabal-version:          >= 1.6+Homepage:               http://github.com/dmalikov/HaCh++Library+  Build-Depends:        base >= 3 && < 5,+                        containers,+                        old-locale,+                        network,+                        time++  HS-Source-Dirs:       libhach++  Exposed-Modules:      Hach.Types++  GHC-Options:          -Wall++Executable hach-client+  Main-is:              Client.hs+  HS-Source-Dirs:       client, libhach+  Other-modules:        Format++Executable hach-nclient+  Build-Depends:        vty == 4.7.0.12,+                        vty-ui == 1.5+  Main-is:              Client.hs+  HS-Source-Dirs:       nclient, libhach+  Other-modules:        NClient.Args,+                        NClient.Connect,+                        NClient.Format,+                        NClient.GUI++Executable hach-server+  Main-is:              Server.hs+  HS-Source-Dirs:       server, libhach+  Other-modules:        Storage++Source-repository head+  type: git+  location: https://github.com/dmalikov/HaCh

@@ -0,0 +1,7 @@+Copyright (C) 2012 Dmitry Malikov++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

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

@@ -0,0 +1,25 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | Client format module++module Format where++import Hach.Types++-- | Format of message in client+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"++-- | Format of timestamp in client+timeFormat ∷ String+timeFormat = "%H:%M:%S"++-- | Special prefix of CAction message+commandAction ∷ String+commandAction = "/me "++-- | Special prefix of CSetNick message+commandSetNick ∷ String+commandSetNick = "/nick "

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

@@ -0,0 +1,11 @@+{-# LANGUAGE UnicodeSyntax #-}+module Main (main) where++import System.Environment (getArgs)++import NClient.Args+import NClient.Connect+import NClient.GUI++main ∷ IO ()+main = getArgs >>= parseArgs >>= connect >>= gui

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

@@ -0,0 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}+module NClient.Connect (connect, Input, Output) where++import Control.Concurrent (forkIO)+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)+import Control.Exception (SomeException, catch, handle)+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))++type Input = Chan S2C+type Output = Chan C2S++connect ∷ (String, String) → IO (Input, Output)+connect (ip, nick) = do+  i ← newChan+  o ← newChan+  client ip nick i o+  return (i,o)++client ∷ String → String → Input → Output → IO ()+client ip nick i o = do+  withSocketsDo . void $+    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+  where inputThread h = forever $ hGetLine h >>= writeChan i . read+        outputThread h = forever $ readChan o >>= \m → hPrint h m

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

@@ -0,0 +1,40 @@+{-# LANGUAGE UnicodeSyntax #-}+module NClient.GUI (gui) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Chan (Chan, readChan, writeChan)+import Control.Monad (forever)+import Graphics.Vty.Attributes+import Graphics.Vty.Widgets.All+import Hach.Types++import NClient.Connect+import NClient.Format++gui ∷ (Input, Output) → IO ()+gui (i,o) = do+  messages ← newList (getNormalAttr defaultContext)+  newMessage ← editWidget+  box ← vBox messages newMessage+  ui ← centered box+  fg ← newFocusGroup+  addToFocusGroup fg newMessage+  c ← newCollection+  addToCollection c ui fg+  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+  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,79 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnicodeSyntax #-}++module Main (main) where++import Control.Applicative ((<$>))+import Control.Exception+import Control.Monad (forever, when)+import Control.Concurrent+import Data.Maybe (fromMaybe)+import Network.Socket+import System.IO++import 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+  (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+  where +    onDisconnect ∷ Chan (Int, S2C) → SomeException → IO ()+    onDisconnect ch' _ = do+      maybeNick ← getNick storage cId+      case maybeNick of+        Just nick → do+          writeChan ch' (cId, SSystem $ nick ++ " has quit conversation")+          delId storage cId+          showStorage storage+        Nothing → putStrLn "Error: undefined user has quit conversation"++main ∷ IO ()+main = withSocketsDo $ do+  storage ← newStorage+  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+

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