websockets-0.12.7.0: src/Network/WebSockets/Server.hs
--------------------------------------------------------------------------------
-- | This provides a simple stand-alone server for 'WebSockets' applications.
-- Note that in production you want to use a real webserver such as snap or
-- warp.
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Server
( ServerApp
, runServer
, ServerOptions (..)
, defaultServerOptions
, runServerWithOptions
, runServerWith
, makeListenSocket
, makePendingConnection
, makePendingConnectionFromStream
, PongTimeout
) where
--------------------------------------------------------------------------------
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import Control.Exception (Exception, allowInterrupt,
bracket, bracketOnError,
finally, mask_, throwIO)
import Control.Monad (forever, void, when)
import qualified Data.IORef as IORef
import Data.Maybe (isJust)
import Network.Socket (Socket)
import qualified Network.Socket as S
import qualified System.Clock as Clock
--------------------------------------------------------------------------------
import Network.WebSockets.Connection
import Network.WebSockets.Http
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Types
--------------------------------------------------------------------------------
-- | WebSockets application that can be ran by a server. Once this 'IO' action
-- finishes, the underlying socket is closed automatically.
type ServerApp = PendingConnection -> IO ()
--------------------------------------------------------------------------------
-- | Provides a simple server. This function blocks forever. Note that this
-- is merely provided for quick-and-dirty or internal applications, but for real
-- applications, you should use a real server.
--
-- For example:
--
-- * Performance is reasonable under load, but:
-- * No protection against DoS attacks is provided.
-- * No logging is performed.
-- * ...
--
-- Glue for using this package with real servers is provided by:
--
-- * <https://hackage.haskell.org/package/wai-websockets>
--
-- * <https://hackage.haskell.org/package/websockets-snap>
runServer :: String -- ^ Address to bind
-> Int -- ^ Port to listen on
-> ServerApp -- ^ Application
-> IO () -- ^ Never returns
runServer host port app = runServerWith host port defaultConnectionOptions app
--------------------------------------------------------------------------------
-- | A version of 'runServer' which allows you to customize some options.
runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()
runServerWith host port opts = runServerWithOptions defaultServerOptions
{ serverHost = host
, serverPort = port
, serverConnectionOptions = opts
}
{-# DEPRECATED runServerWith "Use 'runServerWithOptions' instead" #-}
--------------------------------------------------------------------------------
data ServerOptions = ServerOptions
{ serverHost :: String
, serverPort :: Int
, serverConnectionOptions :: ConnectionOptions
-- | Require a pong from the client every N seconds; otherwise kill the
-- connection. If you use this, you should also use 'withPingThread' to
-- send a ping at a smaller interval; for example N/2.
, serverRequirePong :: Maybe Int
}
--------------------------------------------------------------------------------
defaultServerOptions :: ServerOptions
defaultServerOptions = ServerOptions
{ serverHost = "127.0.0.1"
, serverPort = 8080
, serverConnectionOptions = defaultConnectionOptions
, serverRequirePong = Nothing
}
--------------------------------------------------------------------------------
-- | Customizable version of 'runServer'. Never returns until killed.
--
-- Please use the 'defaultServerOptions' combined with record updates to set the
-- fields you want. This way your code is unlikely to break on future changes.
runServerWithOptions :: ServerOptions -> ServerApp -> IO a
runServerWithOptions opts app = S.withSocketsDo $
bracket
(makeListenSocket host port)
S.close $ \sock -> mask_ $ forever $ do
allowInterrupt
(conn, _) <- S.accept sock
-- This IORef holds a time at which the thread may be killed. This time
-- can be extended by calling 'tickle'.
killRef <- IORef.newIORef =<< (+ killDelay) <$> getSecs
let tickle = IORef.writeIORef killRef =<< (+ killDelay) <$> getSecs
-- Update the connection options to call 'tickle' whenever a pong is
-- received.
let connOpts'
| not useKiller = connOpts
| otherwise = connOpts
{ connectionOnPong = tickle >> connectionOnPong connOpts
}
-- Run the application.
appAsync <- Async.asyncWithUnmask $ \unmask ->
(unmask $ do
runApp conn connOpts' app) `finally`
(S.close conn)
-- Install the killer if required.
when useKiller $ void $ Async.async (killer killRef appAsync)
where
host = serverHost opts
port = serverPort opts
connOpts = serverConnectionOptions opts
-- Get the current number of seconds on some clock.
getSecs = Clock.sec <$> Clock.getTime Clock.Monotonic
-- Parse the 'serverRequirePong' options.
useKiller = isJust $ serverRequirePong opts
killDelay = maybe 0 fromIntegral (serverRequirePong opts)
-- Thread that reads the killRef, and kills the application if enough time
-- has passed.
killer killRef appAsync = do
killAt <- IORef.readIORef killRef
now <- getSecs
appState <- Async.poll appAsync
case appState of
-- Already finished/killed/crashed, we can give up.
Just _ -> return ()
-- Should not be killed yet. Wait and try again.
Nothing | now < killAt -> do
threadDelay (fromIntegral killDelay * 1000 * 1000)
killer killRef appAsync
-- Time to kill.
_ -> Async.cancelWith appAsync PongTimeout
--------------------------------------------------------------------------------
-- | Create a standardized socket on which you can listen for incomming
-- connections. Should only be used for a quick and dirty solution! Should be
-- preceded by the call 'Network.Socket.withSocketsDo'.
makeListenSocket :: String -> Int -> IO Socket
makeListenSocket host port = do
addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port))
bracketOnError
(S.socket (S.addrFamily addr) S.Stream S.defaultProtocol)
S.close
(\sock -> do
_ <- S.setSocketOption sock S.ReuseAddr 1
_ <- S.setSocketOption sock S.NoDelay 1
S.bind sock (S.addrAddress addr)
S.listen sock 5
return sock
)
where
hints = S.defaultHints { S.addrSocketType = S.Stream }
--------------------------------------------------------------------------------
runApp :: Socket
-> ConnectionOptions
-> ServerApp
-> IO ()
runApp socket opts app =
bracket
(makePendingConnection socket opts)
(Stream.close . pendingStream)
app
--------------------------------------------------------------------------------
-- | Turns a socket, connected to some client, into a 'PendingConnection'. The
-- 'PendingConnection' should be closed using 'Stream.close' later.
makePendingConnection
:: Socket -> ConnectionOptions -> IO PendingConnection
makePendingConnection socket opts = do
stream <- Stream.makeSocketStream socket
makePendingConnectionFromStream stream opts
-- | More general version of 'makePendingConnection' for 'Stream.Stream'
-- instead of a 'Socket'.
makePendingConnectionFromStream
:: Stream.Stream -> ConnectionOptions -> IO PendingConnection
makePendingConnectionFromStream stream opts = do
-- TODO: we probably want to send a 40x if the request is bad?
mbRequest <- Stream.parse stream (decodeRequestHead False)
case mbRequest of
Nothing -> throwIO ConnectionClosed
Just request -> return PendingConnection
{ pendingOptions = opts
, pendingRequest = request
, pendingOnAccept = \_ -> return ()
, pendingStream = stream
}
--------------------------------------------------------------------------------
-- | Internally used exception type used to kill connections if there
-- is a pong timeout.
data PongTimeout = PongTimeout deriving Show
--------------------------------------------------------------------------------
instance Exception PongTimeout