diff --git a/Network/SimpleServer.hs b/Network/SimpleServer.hs --- a/Network/SimpleServer.hs +++ b/Network/SimpleServer.hs @@ -1,16 +1,32 @@ {-# LANGUAGE ConstraintKinds #-} -module Network.SimpleServer(CmdHandler, + +{-| +The goal of SimpleServer, as its name implies, is to make it easy to build +simple message passing servers by puting a layer between the programmer and +the concurrent operations between it and the network layer connecting +it to multiple clients. +-} +module Network.SimpleServer(-- * Type Synonyms + -- $types ConnectionHandler, DisconnectHandler, - ClientConn(cid, lookup, modify), + CmdHandler, + -- * Server Construction + -- $server Server(), new, addCommand, start, stop, + -- * Client Interaction + -- $client + ClientConn(), + cid, + lookup, + modify, respond, broadcast, - disconnectClient, + disconnect, clientList) where import Control.Concurrent hiding(modifyMVar) @@ -20,24 +36,29 @@ import Control.Exception import Control.Monad import qualified Data.ByteString.Char8 as ByteS -import Data.Either import Data.Foldable(toList) import qualified Data.HashTable.IO as HT import Data.IORef -import Data.Maybe import Data.Time.Clock import qualified Data.Sequence as Seq import qualified Network as Net import qualified Network.Socket as Net(close) import System.IO(Handle, hSetBuffering, BufferMode(NoBuffering)) +import Prelude hiding(lookup) --- |A CmdHandler is used to handle a command in the form of a list of strings +{-| A server may have any number of CmdHandlers. When a CmdHandler is called it +is passed a list of strings representing the message the server received, the +server that received it, and the client that send the message. The first +part element of the list is the string that triggered the CmdHandler. +-} type CmdHandler = [String] -> Server -> ClientConn -> IO () --- |A ConnectionHandler is called each time a client connects to the server. +{-| Each server has one ConnectionHandler that is called each time a client connects to the server. +-} type ConnectionHandler = Server -> ClientConn -> IO () --- |A DisconnectHandler is called each time a client is disconnected from the server. +{-|A DisconnectHandler is called each time a client is disconnected from the server. +-} type DisconnectHandler = Server -> ClientConn -> IO () {-| @@ -46,38 +67,39 @@ a unique cid and are Eq if their cid's are Eq. A ClientConn comes packaged with two functions for storing additional -information in Strings. `lookup` and `modify`. The lookup function +information in Strings, lookup and modify. The lookup function takes a key and returns the current value of the key or the empty string if it has never been set. The modify function takes a key and value and updates it such that the next call to lookup with that key will return the value provided. -} -data ClientConn = ClientConn { -- | The Unique ID for this client - cid :: Integer, - -- | A lookup function for this client - lookup :: (String -> IO String), - -- | A modify function for this client - modify :: (String -> String -> IO ()), - chandle :: Handle, - host :: Net.HostName, - pid :: Net.PortNumber, - msgList :: List String, - dead :: MVar Bool, - timestamp :: TimeStamp, - tid :: MVar (ThreadId, ThreadId), - lock :: MVar Lock.Lock} +data ClientConn = ClientConn { + -- | The Unique ID for this client + cid :: Integer, + -- | Looks up a property for this client. By default, all properties are the empty string. + lookup :: (String -> IO String), + -- | Modifies a client property. Given a property string, and a value string, the next call to lookup for the given property will result in the value. + modify :: (String -> String -> IO ()), + chandle :: Handle, + host :: Net.HostName, + pid :: Net.PortNumber, + msgList :: List String, + dead :: MVar Bool, + timestamp :: TimeStamp, + tid :: MVar (ThreadId, ThreadId), + serv :: Server} instance Eq ClientConn where (==) c0 c1 = (cid c0) == (cid c1) --- |A Generic Server +-- |A Simple Server data Server = Server { port :: Net.PortID, socket :: IORef (Maybe Net.Socket), clients :: List ClientConn, - cmdList :: List Message, + cmdList :: List Message, lastclean :: TimeStamp, timeout :: NominalDiffTime, - serverLock :: MVar Lock.Lock, + lock :: Lock.Lock, cmdTable :: CmdTable, nextID :: MVar Integer, cHandler :: ConnectionHandler, @@ -89,7 +111,8 @@ {-| -Creates a new server that is not connected to anything. +Creates a new server with the specified ConnectionHandler and DisconnectHandler. +On a call to start, the server will attempt to connect on the specified Port. If a client does not talk to a server for more than 60 seconds it will be disconnected. -} @@ -100,8 +123,7 @@ cmdList <- emptyList time <- getCurrentTime lastClean <- newMVar time - lock <- Lock.new - serverLock <- newMVar lock + serverLock <- Lock.new let allowed = 60 cmdTable <- HT.new nextID <- newMVar 0 @@ -110,13 +132,15 @@ {-| Given a server, a command, and a command handler, adds the command to the -server. If the command already exists, it will be overwritten +server. If the command already exists, it will be overwritten. -} addCommand :: Server -> String -> CmdHandler -> IO () addCommand server cmd handler = HT.insert (cmdTable server) cmd handler {-| -Starts a server if it is currently not started. Otherwise, does nothing. +Starts a server if it is currently not started. Otherwise, does nothing. The +server will be started on a new thread and control will be returned to the +thread that called this function. -} start :: Server -> IO () start server = Net.withSocketsDo $ do @@ -125,7 +149,7 @@ Nothing -> do s <- try $ Net.listenOn (port server) :: IO (Either IOException Net.Socket) case s of - Left e -> debugLn' (serverLock server) $ "The server could not be started: " ++ (show e) + Left e -> debugLn' (lock server) $ "The server could not be started: " ++ (show e) Right s -> do writeIORef (socket server) (Just s) rt <- forkIO $ runServer server @@ -136,7 +160,8 @@ {-| Stops a server if it is running sending a disconnect message -to all clients. Otherwise, does nothing. +to all clients and killing any threads that have been spawned. +Otherwise, does nothing. Any shutdown operations should be run before this is called. -} stop :: Server -> IO () @@ -146,7 +171,7 @@ Nothing -> return () Just s -> do clist <- takeAll $ clients server - mapM_ (disconnect server) (toList clist) + mapM_ (disconnect' server) (toList clist) (rt, at) <- takeMVar (threads server) killThread rt killThread at @@ -154,30 +179,31 @@ writeIORef (socket server) Nothing {-| -Adds a response message to the queue. +Adds a message to the clients message queue to be handled eventually. -} respond :: ClientConn -> String -> IO () respond client string = put (msgList client) string {-| -Broadcasts a message to all clients on the server +Adds a message to all clients message queue to be handled eventually. -} broadcast :: Server -> String -> IO () broadcast server string = do - debugLn' (serverLock server) "Reading client list" + debugLn' (lock server) "Reading client list" q <- readAll (clients server) - debugLn' (serverLock server) "Processing client list" + debugLn' (lock server) "Processing client list" mapM_ ((flip put string) . msgList) q - debugLn' (serverLock server) "Message queued." + debugLn' (lock server) "Message queued." {-| -Disconnects the client if they are on this server. If -they are not on this server, the results are unspecified. +Disconnects the client if they are still connected to the server. -} -disconnectClient :: Server -> ClientConn -> IO () -disconnectClient server client = do - swapMVar (dead client) True - clean server +disconnect :: ClientConn -> IO () +disconnect client = do + d <- readMVar (dead client) + if d then return () else do + swapMVar (dead client) True + clean (serv client) {-| Returns a list of all clients that are currently connected to the server @@ -202,18 +228,16 @@ {-| Creates a new client connection -} -newConn :: Integer -> Handle -> Net.HostName -> Net.PortNumber -> IO ClientConn -newConn id handle host pid = do +newConn :: Integer -> Handle -> Net.HostName -> Net.PortNumber -> Server -> IO ClientConn +newConn id handle host pid server = do queue <- emptyList dead' <- newMVar False tid <- newEmptyMVar timestamp <- newEmptyMVar - lock <- newEmptyMVar table <- HT.new - l <- Lock.new - let lookup = safeLookup l table - modify = safeModify l table - return $ ClientConn id lookup modify handle host pid queue dead' timestamp tid lock + let lookup = safeLookup (lock server) table + modify = safeModify (lock server) table + return $ ClientConn id lookup modify handle host pid queue dead' timestamp tid server safeLookup :: Lock.Lock -> UserTable -> (String -> IO String) safeLookup lock usertable = (\key -> do @@ -253,9 +277,9 @@ if (cmds == []) then delay (1000*100) else do - debugLn' (serverLock server) "Processing Commands..." + debugLn' (lock server) "Processing Commands..." mapM_ (processCommand server) cmds - debugLn' (serverLock server) "Done." + debugLn' (lock server) "Done." runServer server {-| @@ -271,7 +295,7 @@ maybeFunction <- HT.lookup (cmdTable server) (head commands) case maybeFunction of Nothing -> do - debugLn' (serverLock server) $ "Could not process command: " ++ (cmd msg) + debugLn' (lock server) $ "Could not process command: " ++ (cmd msg) put (response_queue msg) ("Invalid command: " ++ (cmd msg)) Just f -> f commands server (client msg) where response_queue = msgList . client @@ -296,7 +320,7 @@ clist <- takeMVar (clients server) (newCList, removed) <- filterM' (timedout server allowed) clist putMVar (clients server) (Seq.fromList newCList) - mapM_ (disconnect server) removed + mapM_ (disconnect' server) removed -- Helper function for filtering Seq with a pred of a -> IO Bool @@ -322,8 +346,8 @@ -- Sends a disconnect message to a client, marks it dead -- and kills any associated threads -disconnect :: Server -> ClientConn -> IO () -disconnect server client = do +disconnect' :: Server -> ClientConn -> IO () +disconnect' server client = do (dHandler server) server client flush server client (wio,rio) <- readMVar $ tid client @@ -346,11 +370,9 @@ hSetBuffering handle NoBuffering id <- takeMVar (nextID server) putMVar (nextID server) (id+1) - conn <- newConn id handle host pid + conn <- newConn id handle host pid server time <- getCurrentTime putMVar (timestamp conn) time - lock' <- readMVar $ serverLock server - putMVar (lock conn) lock' put (clients server) conn wio <- forkIO $ writeClient conn rio <- forkIO $ readClient conn (cmdList server) @@ -387,11 +409,11 @@ delay (1000*100) writeClient client else do - debugLn' (lock client) "Client List non-empty. Writing to client." + debugLn' (lock (serv client)) "Client List non-empty. Writing to client." either <- try $ mapM_ (hPutStrLn (chandle client)) queue :: IO (Either IOException ()) case either of Left e -> do - debugLn' (lock client) $ "Could not read from handle: " ++ (show e) + debugLn' (lock (serv client)) $ "Could not read from handle: " ++ (show e) swapMVar (dead client) True return () Right _ -> writeClient client @@ -399,9 +421,8 @@ -- Debugging putStrLn that takes a lock such that -- the output is readable. -putStrLn' :: MVar Lock.Lock -> String -> IO () -putStrLn' mvar string = do - lock <- readMVar mvar +putStrLn' :: Lock.Lock -> String -> IO () +putStrLn' lock string = do Lock.acquire lock putStrLn string Lock.release lock @@ -416,7 +437,7 @@ debug = False -debugLn' :: MVar Lock.Lock -> String -> IO () +debugLn' :: Lock.Lock -> String -> IO () debugLn' lock str = if debug then putStrLn' lock str else return () emptyList :: IO (List a) @@ -440,3 +461,122 @@ put :: List a -> a -> IO () put queue el = modifyMVar queue (Seq.|> el) +{- $types +To start using simple server, the programmer simply needs to define +the callbacks that occur when a client connects, disconnects, or sends a message +to the server. These three callbacks have type synonyms defined: 'ConnectionHandler', 'DisconnectHandler', and 'CmdHandler'. + +To create a 'ConnectionHandler' that notifies all clients that a new client +has connected and respond to the new client with a simple welcome message +one might define the following: + +@ +simpleConnect :: ConnectionHandler +simpleConnect server client = do + broadcast server \"A new user has joined.\" + respond client \"Welcome!\" +@ + +When a connection is received, a new 'ClientConn' is created and added to +the servers 'clientList'. At this point, the 'ConnectionHandler' is notified +and a message is 'broadcast'ed to all connected clients. After this occurs, +the server `respond`s to the new client. + +To create a 'DisconnectHandler' that notifies all clients that a user has +disconnected and send a goodbye message to the disconnecting client, one +might define the following: + +@ +simpleDisconnect :: DisconnectHandler +simpleDisconnect server client = do + broadcast server \"A user has left the room.\" + respond client \"Goodbye!\" +@ + +When a user disconnects, the server will call the 'DisconnectHandler' so any +cleanup may be done. + +To create a 'CmdHandler' that repeats a received message to all connected +clients, one might define the following: + +@ +repeatHandler :: CmdHandler +repeatHandler (cmd:msg) server client = do + name <- lookup client \"name\" + broadcast server $ name ++ "> " ++ (unwords msg) +@ + +The message 'CmdHandler' is passed a list of strings which is the +message received from the client. +The first element of the list is the \"command\" that triggered the callback. +-} + +{- $server +To start using a simple server, one simply specifies the 'ConnectionHandler', 'DisconnectHandler', and port that the server will use. + +> server <- new simpleConnect simpleDisconnect 10010 + +The server does not start after construction, instead one may now register +any number of 'CmdHandler's on the server using 'addCommand'. + +> addCommand server "/repeat" repeatHandler + +Once all of the desired 'CmdHandler's have been registered on the server +the server may be started using 'start' + +> start server + +If the port specified for the server is available, a new thread is started +and the server will now accept incoming connections. The control will then be returned to the thread that called 'start'. + +The incomming connections will be handed off to the +specified 'ConnectionHandler' and incoming messages +will be handed to the appropriate 'CmdHandler'. If an incoming message has +no 'CmdHandler' the message \"Invalid command: \" will be sent to the +client. If a client does not communicate with the server for more than 60 seconds +the client is disconnected from the server. + +To stop a server use 'stop' + +> stop server + +All client buffers are flushed and disconnected from the server. All threads and +handles that have been created by the server are killed and closed and then the +control is returned to the thread that called stop. + +-} + +{- $client + +Each time a connection is made to a server a new 'ClientConn' is created and +added to the servers 'clientList'. The server then invokes a call to its +'ConnectionHandler'. + +Each 'ClientConn' has a unique 'cid' and property table which can be accessed +with 'lookup' and modified with 'modify'. Each stored property is defined +by a String and stores an associated String. If a property has never been +set using 'modify' it will be the empty string on 'lookup'. + +If you wanted to write a 'CmdHandler' that allowed a user to specify the +value stored in their table called \"name\", one might define: + +@ +nameHandler :: CmdHandler +nameHandler (_:msg) server client = do + case msg of + [] -> respond client \"You did not provide a name to change to.\" + msg -> do + before <- lookup client \"name\" + let name = unwords msg + message = before ++ \" is now known as \" ++ name + modify client \"name\" name + broadcast server message +@ + +This 'CmdHandler' first checks that the client specified a name that +was not entirely white space. Then, it generates a message stating the name +they were using and the name they are now using with 'lookup'. Then using +'modify' the clients property \"name\"is changed to the value specified. +Finally, the generated message is 'broadcast' to all connected clients. + +-} diff --git a/Network/SimpleServer/Examples/ChatServer.hs b/Network/SimpleServer/Examples/ChatServer.hs --- a/Network/SimpleServer/Examples/ChatServer.hs +++ b/Network/SimpleServer/Examples/ChatServer.hs @@ -77,7 +77,7 @@ msgHandler :: S.CmdHandler msgHandler (cmd:msg) server client = do name <- S.lookup client username - S.broadcast server $ name ++ "> " ++ (intercalate " " msg) + S.broadcast server $ name ++ "> " ++ (unwords msg) -- The disconnect command causes the message "Goodbye!" to be sent to -- the client. Then they are disconnected from the server. @@ -85,7 +85,7 @@ disHandler :: S.CmdHandler disHandler _ server client = do S.respond client "Goodbye!" - S.disconnectClient server client + S.disconnect client -- The who command responds to the client with -- a list of usernames diff --git a/simple-server.cabal b/simple-server.cabal --- a/simple-server.cabal +++ b/simple-server.cabal @@ -1,20 +1,24 @@ -Name: simple-server -Version: 0.0.1 -License: GPL -License-File: LICENSE -Author: Joseph Collard -Stability: experimental -Maintainer: jcollard@unm.edu -Category: Network -Synopsis: Simple Server interface -Description: This library provides a very simple interface for creating a server that sends and recieves ByteString messages and attempts to remove concurrency so the programmer can focus on the functionality of the server. A simple ChatServer example is available in the Examples module -Cabal-Version: >= 1.4 -Build-Type: Simple +Name: simple-server +Version: 0.0.2 +License: GPL +License-File: LICENSE +Author: Joseph Collard +Stability: experimental +Maintainer: jcollard@unm.edu +Category: Network +Synopsis: Simple Server interface +Description: This library provides a very simple interface for creating a server that sends and recieves ByteString messages and attempts to remove concurrency so the programmer can focus on the functionality of the server. A simple ChatServer example is available in the Examples module +Cabal-Version: >= 1.6 +Build-Type: Simple Library - Build-Depends: base>=4 && <5, bytestring>=0.9.2.1, concurrent-extra>=0.7.0.5, hashtables>=1.0.1.7, time>=1.4.0.2, containers>=0.4.2.1, network>=2.4.1.0, unbounded-delays>=0.1.0.5 + Build-Depends: base>=4 && <5, bytestring>=0.9, concurrent-extra>=0.1, hashtables>=1.0, time>=1.4, containers>=0.4, network>=2.4, unbounded-delays>=0.1 Extensions: ConstraintKinds Exposed-Modules: Network.SimpleServer Network.SimpleServer.Examples.ChatClient Network.SimpleServer.Examples.ChatServer + +Source-Repository head + type: git + location: https://github.com/jcollard/simple-server.git