networked-game (empty) → 0.1.0.0

raw patch · 6 files changed

+269/−0 lines, 6 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, containers, network, time, transformers

Files

LICENSE +30/−0
Setup.hs +2/−0
networked-game.cabal +21/−0
src/NetworkedGame/Handles.hs +33/−0
src/NetworkedGame/Packet.hs +25/−0
src/NetworkedGame/Server.hs +158/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2012, Eric Mertens++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 Eric Mertens 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ networked-game.cabal view

@@ -0,0 +1,21 @@+-- Initial networked-game.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                networked-game+version:             0.1.0.0+synopsis:            Networked-game support library+-- description:         +license:             BSD3+license-file:        LICENSE+author:              Eric Mertens+maintainer:          emertens@gmail.com+-- copyright:           +category:            Network+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     NetworkedGame.Handles, NetworkedGame.Packet, NetworkedGame.Server+  -- other-modules:       +  build-depends:       base == 4.6.*, containers, bytestring, binary, transformers, time, network+  hs-source-dirs:      src

+ src/NetworkedGame/Handles.hs view

@@ -0,0 +1,33 @@+module NetworkedGame.Handles+ (ConnectionId(..), Handles,+  emptyHandles, removeHandle, lookupHandle,+  nullHandles, addHandle, forHandles_)+ where++import Data.Foldable (forM_)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import System.IO (Handle)++newtype Handles = Handles (IntMap Handle)++newtype ConnectionId = ConnectionId Int+  deriving (Eq, Show, Ord)++emptyHandles :: Handles+emptyHandles = Handles IntMap.empty++addHandle :: ConnectionId -> Handle -> Handles -> Handles+addHandle (ConnectionId i) h (Handles hs) = Handles (IntMap.insert i h hs)++removeHandle :: ConnectionId -> Handles -> Handles+removeHandle (ConnectionId i) (Handles hs) = Handles (IntMap.delete i hs)++lookupHandle :: ConnectionId -> Handles -> Maybe Handle+lookupHandle (ConnectionId i) (Handles m) = IntMap.lookup i m++nullHandles :: Handles -> Bool+nullHandles (Handles m) = IntMap.null m++forHandles_ :: Monad m => Handles -> (Handle -> m a) -> m ()+forHandles_ (Handles m) f = forM_ m f

+ src/NetworkedGame/Packet.hs view

@@ -0,0 +1,25 @@+module NetworkedGame.Packet where++import qualified Data.ByteString.Lazy as B+import Data.Binary (Binary,encode,decode)+import Data.Int (Int64)+import System.IO (Handle, hFlush)++newtype Packet = Packet B.ByteString++mkPacket :: Binary a => a -> Packet+mkPacket x = Packet $ B.append (encode n) bs+  where+  n = B.length bs+  bs = encode x++hPutPacket :: Handle -> Packet -> IO ()+hPutPacket h (Packet bs) = B.hPutStr h bs >> hFlush h++hGetPacketed :: Binary a => Handle -> IO a+hGetPacketed h =+  do nEnc <- B.hGet h 8+     let n :: Int64+         n = decode nEnc+     bs  <- B.hGet h $ fromIntegral n+     return $ decode bs

+ src/NetworkedGame/Server.hs view

@@ -0,0 +1,158 @@+module NetworkedGame.Server+  (NetworkServer(..), Handles, ConnectionId,++   serverMain, announce, announceOne+  )+  where++import Control.Concurrent (forkIO, threadDelay, ThreadId,+                           Chan, newChan, readChan, writeChan)+import Control.Exception (SomeException, handle, bracket_)+import Control.Monad (forM_, forever)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Binary (Binary, encode, decode)+import Data.Foldable (for_)+import Data.Int (Int64)+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)+import Network (PortID, accept, listenOn, Socket)+import Network.Socket (getSocketName)+import System.IO (Handle)+import qualified Data.ByteString.Lazy as B++import NetworkedGame.Handles+import NetworkedGame.Packet++data NetworkServer c w = NetworkServer+  { serverPort   :: PortID+  , eventsPerSecond :: Int+  , onTick       :: Handles -> Float             -> w -> IO w+  , onConnect    :: Handles -> ConnectionId      -> w -> IO w+  , onDisconnect :: Handles -> ConnectionId      -> w -> IO w+  , onCommand    :: Handles -> ConnectionId -> c -> w -> IO w+  }++-- | Main entry point for server+serverMain ::+  Binary c =>+  NetworkServer c w {- ^ callbacks and settings -} ->+  w                 {- ^ initial state value    -} ->+  IO ()+serverMain env w =+  do events             <- newChan+     _acceptThreadId    <- startNetwork env events+     lastTick           <- getCurrentTime+     _tickThreadId      <- forkIO $ tickThread env events+     eventLoop env events emptyHandles w lastTick++-- | Create a thread which will accept new connections.+-- Connections and disconnections will be announced to the event channel.+startNetwork ::+  Binary c =>+  NetworkServer c w ->+  Chan (ServerEvent c) ->+  IO ThreadId+startNetwork env events =+  do sock       <- listenOn $ serverPort env+     sockName   <- getSocketName sock+     putStrLn $ "Server listening on " ++ show sockName+     forkIO $ mapM_ (acceptClient events sock . ConnectionId) [0..]++-- | Accept a connection and create a thread to manage incoming data+-- from that connection.+acceptClient ::+  Binary c => +  Chan (ServerEvent c) {- ^ channel to report connects to -} ->+  Socket       {- ^ listening socket             -} ->+  ConnectionId {- ^ next available connection id -} ->+  IO ThreadId+acceptClient events sock i =+  do (h,host,port) <- accept sock+     putStrLn $ concat ["Got connection from ", host, ":", show port]+     forkIO $ bracket_ (writeChan events $ JoinEvent i h)+                       (writeChan events $ DisconnectEvent i)+                       (clientSocketLoop i h events)++-- | Read incoming packets, decode them, and pass them along to+-- the event channel.+clientSocketLoop ::+  Binary c =>+  ConnectionId -> Handle -> Chan (ServerEvent c) -> IO ()+clientSocketLoop i h events =+  handle ignoreExceptions $+  forever $ do msg <- hGetPacketed h+               writeChan events $ ClientEvent i msg++-- | Send a command to a collection of clients+announce :: (MonadIO m, Binary c) =>+  Handles {- ^ Handles to send to -} ->+  c       {- ^ Message to send    -} ->+  m ()+announce hs msg = liftIO $+  do let p = mkPacket msg+     forHandles_ hs $ \h ->+       handle ignoreExceptions $+       hPutPacket h p++-- | Send a command to a single client identified by id.+announceOne ::+  (MonadIO m, Binary c) =>+  Handles      {- ^ Current set of handles     -} ->+  ConnectionId {- ^ Index of handle to send to -} ->+  c            {- ^ Message to send            -} ->+  m ()+announceOne hs i msg = liftIO $+  let p = mkPacket msg in+  for_ (lookupHandle i hs) $ \h ->+  handle ignoreExceptions  $+  hPutPacket h p++-- | Ignore all exceptions+ignoreExceptions :: SomeException -> IO ()+ignoreExceptions _ = return ()++-- | Thread which periodically enqueues tick events+tickThread ::+  NetworkServer c w    {- ^ game settings and callbacks     	-} ->+  Chan (ServerEvent c) {- ^ outgoing tick queue             	-} ->+  IO ()+tickThread env events =+  forever $ do writeChan events TickEvent+               threadDelay $ 1000000 `div` eventsPerSecond env++data ServerEvent c+  = TickEvent+  | JoinEvent       ConnectionId Handle+  | DisconnectEvent ConnectionId+  | ClientEvent     ConnectionId c++eventLoop ::+  NetworkServer c w    {- ^ game settings and callbacks      -} ->+  Chan (ServerEvent c) {- ^ incoming event queue             -} ->+  Handles              {- ^ handles to current connections   -} ->+  w                    {- ^ initial state                    -} ->+  UTCTime              {- ^ time previous tick was processed -} ->+  IO ()+eventLoop env events = loop+  where+  loop hs w lastTick = do+     event <- readChan events+     case event of+       JoinEvent i h ->+         do let hs' = addHandle i h hs+            w' <- onConnect env hs' i w+            loop hs' w' lastTick++       TickEvent ->+         do now <- getCurrentTime+            let elapsed = realToFrac (diffUTCTime now lastTick)+            w' <- onTick env hs elapsed w+            loop hs w' now++       ClientEvent i c ->+         do w' <- onCommand env hs i c w+            loop hs w' lastTick++       DisconnectEvent i ->+         do let hs' = removeHandle i hs+            w' <- onDisconnect env hs i w+            loop hs' w' lastTick