Data commit

Task/Chat-server/Haskell/chat-server-1.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Network
+import System.IO
+import Control.Concurrent
+import qualified Data.Text as T
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+import qualified Data.Map as M
+import Data.Map (Map)
+import Control.Monad.Reader
+import Control.Monad.Error
+import Control.Exception
+import Data.Monoid
+import Control.Applicative
+
+type ServerApp = ReaderT ThreadData IO
+data Speaker = Server | Client Text
+data ThreadData = ThreadData { threadHandle :: Handle
+                             , userTableMV :: MVar (Map Text Handle)}
+
+echoLocal = liftIO . T.putStrLn
+echoRemote = echoMessage . (">> "<>)
+echoMessage msg = viewHandle >>= \h -> liftIO $ T.hPutStrLn h msg
+getRemoteLine = viewHandle >>= liftIO . T.hGetLine
+putMVarT = (liftIO.) . putMVar
+takeMVarT = liftIO . takeMVar
+readMVarT = liftIO . readMVar
+modifyUserTable fn = viewUsers >>= \mv ->
+                     liftIO $ modifyMVar_ mv (return . fn)
+viewHandle = threadHandle <$> ask
+viewUsers = userTableMV <$> ask
+
+userChat :: ServerApp ()
+userChat = do
+    name <- addUser
+    echoLocal name
+    h <- viewHandle
+    (flip catchError) (\_ -> removeUser name) $
+      do echoLocal $ "Accepted " <> name
+         forever $ getRemoteLine >>= broadcast (Client name)
+
+removeUser :: Text -> ServerApp ()
+removeUser name = do
+    echoLocal $ "Exception with " <> name <> ", removing from userTable"
+    broadcast Server $ name <> " has left the server"
+    modifyUserTable (M.delete name)
+
+addUser :: ServerApp Text
+addUser = do
+    h <- viewHandle
+    usersMV <- viewUsers
+    echoRemote "Enter username"
+    name <- T.filter (/='\r') <$> getRemoteLine
+    userTable <- takeMVarT usersMV
+    if name `M.member` userTable
+      then do echoRemote "Username already exists!"
+              putMVarT usersMV userTable
+              addUser
+      else do putMVarT usersMV (M.insert name h userTable)
+              broadcast Server $ name <> " has joined the server"
+              echoRemote "Welcome to the server!\n>> Other users:"
+              readMVarT usersMV >>=
+                  mapM_ (echoRemote . ("*" <>) . fst)
+                . filter ((/=name). fst) . M.toList
+              return name
+
+broadcast :: Speaker -> Text -> ServerApp ()
+broadcast user msg =
+    viewUsers >>= readMVarT >>= mapM_ (f . snd) . fn . M.toList
+  where f h = liftIO $ T.hPutStrLn h $ nm <> msg
+        (fn, nm) = case user of
+                    Server -> (id, ">> ")
+                    Client t -> (filter ((/=t) . fst), t <> "> ")
+
+clientLoop socket users = do
+    (h, _, _) <- accept socket
+    hSetBuffering h LineBuffering
+    forkIO $ runReaderT userChat (ThreadData h users)
+    clientLoop socket users
+
+main = do
+    server <- listenOn $ PortNumber 5002
+    T.putStrLn "Server started"
+    newMVar (M.empty) >>= clientLoop server

Task/Chat-server/Haskell/chat-server-2.hs

@@ -0,0 +1,27 @@
+global mlck, nCons, cons
+
+procedure main()
+    mlck := mutex()
+    nCons := 0
+    cons := mutex(set())
+    while f := open(":12321","na") do {
+        handle_client(f)
+        critical mlck: if nCons <= 0 then close(f)
+        }
+end
+
+procedure handle_client(f)
+    critical mlck: nCons +:= 1
+    thread {
+        select(f,1000) & {
+            writes(f, "Name? ")
+            nick := (read(f) ? tab(upto('\n\r')))
+            every write(!cons, nick," has joined.")
+            insert(cons, f)
+            while s := read(f) do every write(!cons, nick,": ",s)
+            }
+        delete(cons, f)
+        every write(!cons, nick," has left.")
+        critical mlck: nCons -:= 1
+        }
+end