diff --git a/link.cabal b/link.cabal index 9be75d6..b684602 100644 --- a/link.cabal +++ b/link.cabal @@ -16,7 +16,8 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Link.Server, - Link.Types + Link.Types, + Link.Protocol default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, BangPatterns, TupleSections, NamedFieldPuns build-depends: base >= 4.7 && < 5, diff --git a/src/Link/Protocol.hs b/src/Link/Protocol.hs new file mode 100644 index 0000000..a31cac7 --- /dev/null +++ b/src/Link/Protocol.hs @@ -0,0 +1,8 @@ +module Link.Protocol where + +import Link.Types + +parseCommand :: String -> Maybe Message +parseCommand command = case (words command) of + "PRIVMSG" : userName : msg -> Just $ PrivMsg (User userName) (unwords msg) + _ -> Nothing diff --git a/src/Link/Server.hs b/src/Link/Server.hs index dd16126..0856059 100644 --- a/src/Link/Server.hs +++ b/src/Link/Server.hs @@ -1,7 +1,8 @@ module Link.Server where import Control.Exception (finally) -import Control.Concurrent (forkFinally, newMVar, modifyMVar, modifyMVar_) +import Control.Concurrent (forkFinally, newMVar, modifyMVar, modifyMVar_, newChan, + writeChan, withMVar) import Control.Monad (forever) import Network (withSocketsDo, listenOn, accept, PortID(..)) import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..), @@ -10,6 +11,7 @@ import Text.Printf (printf, hPrintf) import qualified Data.Map.Strict as Map +import Link.Protocol import Link.Types runServer :: Int -> IO () @@ -22,10 +24,10 @@ runServer port = withSocketsDo $ do forever $ do (handle, host, port') <- accept sock printf "Accepted connection from %s: %s\n" host (show port') - forkFinally (talk server handle) (\_ -> hClose handle) + forkFinally (connectClient server handle) (\_ -> hClose handle) -talk :: Server -> Handle -> IO () -talk server handle = do +connectClient :: Server -> Handle -> IO () +connectClient server handle = do hSetNewlineMode handle universalNewlineMode hSetBuffering handle LineBuffering readName @@ -45,20 +47,33 @@ talk server handle = do Just client -> runClient server client `finally` removeClient server user +sendMessage :: Message -> Client -> IO () +sendMessage message Client {..} = writeChan clientChan message + 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 + clientChan <- newChan + let client = Client user handle clientChan printf "New user connected: %s\n" userName return (Map.insert user client clientMap, Just client) runClient :: Server -> Client -> IO () -runClient server Client {..} = forever $ do +runClient Server {..} Client {..} = forever $ do command <- hGetLine clientHandle - print command + printf "<%s>: %s\n" (userName clientUser) command + case parseCommand command of + Nothing -> return () + Just com -> handleCommand com + where + handleCommand message@(PrivMsg user _) = + withMVar serverUsers $ \clientMap -> + case Map.lookup user clientMap of + Nothing -> printf "No such user: %s\n" (userName user) + Just client -> sendMessage message client removeClient :: Server -> User -> IO () removeClient Server {..} user = diff --git a/src/Link/Types.hs b/src/Link/Types.hs index 37b50de..d77fe68 100644 --- a/src/Link/Types.hs +++ b/src/Link/Types.hs @@ -1,17 +1,21 @@ module Link.Types where import System.IO (Handle) -import Control.Concurrent (MVar) +import Control.Concurrent (MVar, Chan) import qualified Data.Map as Map data User = User { userName :: !String } deriving (Show, Eq, Ord) data Client = Client { - clientUser :: !User + clientUser :: !User , clientHandle :: !Handle - } deriving (Show, Eq) + , clientChan :: !(Chan Message) + } data Server = Server { serverUsers :: MVar (Map.Map User Client) } + +data Message = PrivMsg User String + deriving (Show, Eq)