commit 887b385879f9d02c561a174837d8e09de43c5c9b Author: Abhinav Sarkar Date: Wed Sep 9 00:23:47 2015 +0530 Adds types and a basic server. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b9df080 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.cabal-sandbox/ +.stack-work/ +cabal.sandbox.config +dist/ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..2df6183 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..1977104 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Link.Server +import System.Environment (getArgs) + +main :: IO () +main = do + port <- fmap (read . (!! 0)) getArgs + runServer port + diff --git a/link.cabal b/link.cabal new file mode 100644 index 0000000..9be75d6 --- /dev/null +++ b/link.cabal @@ -0,0 +1,46 @@ +name: link +version: 0.1.0.0 +synopsis: A simple multithreded chat server +description: Please see README.md +homepage: http://github.com/abhin4v/link#readme +license: BSD3 +license-file: LICENSE +author: Abhinav Sarkar +maintainer: abhinav@abhinavsarkar.net +copyright: 2010 Abhinav Sarkar +category: Network +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Link.Server, + Link.Types + default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, + BangPatterns, TupleSections, NamedFieldPuns + build-depends: base >= 4.7 && < 5, + network >= 2.6 && < 2.7, + containers >= 0.5 && < 0.6 + default-language: Haskell2010 + +executable link-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , link + default-language: Haskell2010 + +test-suite link-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , link + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/abhin4v/link diff --git a/src/Link/Server.hs b/src/Link/Server.hs new file mode 100644 index 0000000..ac02249 --- /dev/null +++ b/src/Link/Server.hs @@ -0,0 +1,66 @@ +module Link.Server where + +import Control.Exception (finally) +import Control.Concurrent (forkFinally, newMVar, modifyMVar, modifyMVar_) +import Control.Monad (forever) +import Network (withSocketsDo, listenOn, accept, PortID(..)) +import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..), + universalNewlineMode, hGetLine, Handle) +import Text.Printf (printf, hPrintf) + +import qualified Data.Map as Map + +import Link.Types + +runServer :: Int -> IO () +runServer port = withSocketsDo $ do + serverUsers <- newMVar Map.empty + let server = Server serverUsers + sock <- listenOn . PortNumber . fromIntegral $ port + printf "Listening on port %d\n" port + forever $ do + (handle, host, port') <- accept sock + printf "Accepted connection from %s: %s\n" host (show port') + forkFinally (talk server handle) (\_ -> hClose handle) + +talk :: Server -> Handle -> IO () +talk server handle = do + hSetNewlineMode handle universalNewlineMode + hSetBuffering handle LineBuffering + readName + where + readName = do + name <- hGetLine handle + if null name + then readName + else do + let user = User name + ok <- checkAddClient server user handle + case ok of + Nothing -> do + hPrintf handle + "The name %s is in use, please choose another\n" name + readName + Just client -> + runClient server client + `finally` removeClient server user + +checkAddClient :: Server -> User -> Handle -> IO (Maybe Client) +checkAddClient Server {..} user@User {..} handle = do + modifyMVar serverUsers $ \clientMap -> + if Map.member user clientMap + then return (clientMap, Nothing) + else do + let client = Client user handle + printf "New user connected: %s" userName + return (Map.insert user client clientMap, Just client) + +runClient :: Server -> Client -> IO () +runClient server Client {..} = forever $ do + command <- hGetLine clientHandle + print command + +removeClient :: Server -> User -> IO () +removeClient Server {..} user = + modifyMVar_ serverUsers $ \clientMap -> + return $ Map.delete user clientMap diff --git a/src/Link/Types.hs b/src/Link/Types.hs new file mode 100644 index 0000000..c0ac4c1 --- /dev/null +++ b/src/Link/Types.hs @@ -0,0 +1,17 @@ +module Link.Types where + +import System.IO (Handle) +import Control.Concurrent (MVar) +import qualified Data.Map as Map + +data User = User { userName :: String } + deriving (Show, Eq, Ord) + +data Client = Client { + clientUser :: User + , clientHandle :: Handle + } deriving (Show, Eq) + +data Server = Server { + serverUsers :: MVar (Map.Map User Client) + } diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..bee0443 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: lts-3.4 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"