simple-server 0.0.1 → 0.0.2
raw patch · 3 files changed
+226/−82 lines, 3 filesdep ~bytestringdep ~concurrent-extradep ~containers
Dependency ranges changed: bytestring, concurrent-extra, containers, hashtables, network, time, unbounded-delays
Files
- Network/SimpleServer.hs +207/−67
- Network/SimpleServer/Examples/ChatServer.hs +2/−2
- simple-server.cabal +17/−13
Network/SimpleServer.hs view
@@ -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: <cmd>\" 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.++-}
Network/SimpleServer/Examples/ChatServer.hs view
@@ -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
simple-server.cabal view
@@ -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