diff --git a/pong-server.cabal b/pong-server.cabal --- a/pong-server.cabal +++ b/pong-server.cabal @@ -1,5 +1,5 @@ name: pong-server -version: 0.0.2.1 +version: 0.0.3.0 synopsis: A simple embedded pingable server that runs in the background. description: Please see README.md on GitHub homepage: http://github.com/RobertFischer/pong-server#readme @@ -7,7 +7,7 @@ license-file: UNLICENSE author: Robert Fischer maintainer: smokejumperit+pong-server@gmail.com -copyright: 2016 Robert Fischer +copyright: 2017 Robert Fischer category: utilities build-type: Simple -- extra-source-files: @@ -15,20 +15,17 @@ library hs-source-dirs: src - exposed-modules: Axial.Pong - build-depends: base >= 4.7 && < 5 - , network >= 2.6.2.1 && < 2.7 - , data-default >= 0.7.1.1 && < 0.8 + exposed-modules: Network.Pong + build-depends: base >= 4.9.1.0 && < 5 + , network >= 2.6.3.1 && < 2.7 + , classy-prelude >= 1.2.0.1 && < 2 + , bytestring >= 0.10.8.1 && < 0.11 + , http-types >= 0.9.1 && < 1 + , exceptions >= 0.8.3 && < 0.9 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -O3 default-extensions: OverloadedStrings - , LambdaCase - , MultiWayIf - , TransformListComp - , FlexibleInstances - , NoMonomorphismRestriction - , DeriveGeneric - , ScopedTypeVariables + , AllowAmbiguousTypes test-suite pong-server-test type: exitcode-stdio-1.0 diff --git a/src/Axial/Pong.hs b/src/Axial/Pong.hs deleted file mode 100644 --- a/src/Axial/Pong.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Axial.Pong - ( - PongConfig(..) - , defaultPongConfig - , withPongServer - ) where - -import Data.Default (Default, def) -import Network (withSocketsDo, listenOn, accept, sClose, PortID(..)) -import System.IO (hClose, hPutStr, hSetBuffering, BufferMode(..)) -import Control.Exception (bracket, finally) -import Control.Concurrent (forkIO, forkFinally, ThreadId, killThread) - -data PongConfig = PongConfig { - pongPort :: Int, - pongMessage :: IO String -} - -newtype PongServer = PongServer ThreadId - -defaultPongConfig :: PongConfig -defaultPongConfig = PongConfig 10411 $ pure "pong" - -instance Default PongConfig where - def = defaultPongConfig - -withPongServer :: PongConfig -> IO a -> IO a -withPongServer cfg action = bracket (startServer cfg) stopServer $ const action - -startServer :: PongConfig -> IO PongServer -startServer cfg = withSocketsDo $ do - socket <- listenOn portNum - threadId <- forkIO $ socketHandler socket - pure $ PongServer threadId - where - socketHandler sock = finally (socketHandlerLoop sock) (sClose sock) - socketHandlerLoop sock = do - (handle, _, _) <- accept sock - _ <- forkFinally (body handle) (const $ hClose handle) - socketHandlerLoop sock - body handle = do - msg <- (pongMessage cfg) - hSetBuffering handle NoBuffering - hPutStr handle msg - portNum = PortNumber $ fromIntegral pongPortNum - pongPortNum = pongPort cfg - -stopServer :: PongServer -> IO () -stopServer (PongServer threadId) = killThread threadId diff --git a/src/Network/Pong.hs b/src/Network/Pong.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pong.hs @@ -0,0 +1,135 @@ +{-| +Module : Network.Pong +Description : Ping server that runs in the background. +Copyright : (c) Robert Fischer, 2017 +License : Unlicense +Maintainer : smokejumper+network.pong@gmail.com +Stability : experimental +Portability : POSIX + + +This is an exceedingly simple server: it listens on the given port on all interfaces, +and when it retrieves a connection, it simply prints out the result of the 'pongMessage' +action, which is just the four characters @pong@ by default. + +The purpose of this server is to provide something for automated smoke checks (such as +load balancers) to hit against. It provides a rudimentary server smoke check while +requiring a minimal amount of overhead. + +There are two customary ways to use this server. The first customary way uses whether +the response is empty or not to signal whether there is an error or not. If the resulting +body is empty, there is an error. If the response is non-empty, the server is fine. This +is supported by 'pongCatch'. The +second customary way to use this server is to treat it as a server running @HTTP/0.9@, +and to use 200 response status codes to mean the server is good and 500 response status codes +to mean the server is having a problem. This is supported by the 'pongCatchHttp' and the other +@pong*Http*@ functions. + +A third way to use this server is to have the body of the message actually contain some +meaningful values about the state of the system. The reason the response is a 'ByteString' +is specifically so that you could implement a binary protocol if you deeply wanted to. +If you are heading down that path, though, please first look into the @ekg@ package. Keep +'Network.Pong' in play for automated smoke checks, and use @ekg@ for more precise status +monitoring. + +To run this server, simply add this into your main function: + +@ + main = withPongServer defaultPongConfig $ do +@ + +It will then run the pong server on port @10411@. Of course, you can customize the +server through the configuration object. + +-} +module Network.Pong + ( + PongConfig(..) + , defaultPongConfig + , pongMessageHttp200 + , pongMessageHttp500 + , pongMessageHttp + , pongCatch + , pongCatchHttp + , withPongServer + ) where + +import Prelude () +import ClassyPrelude hiding (handle) + +import Control.Concurrent (forkIO) +import Network.HTTP.Types.Status (ok200, internalServerError500, Status(..)) +import Network (withSocketsDo, listenOn, accept, sClose, PortID(..)) +import System.IO (hClose, hSetBuffering, BufferMode(..)) + +import qualified Data.ByteString.Char8 as C + +-- | This is the type of the response. It is mostly aliased to make type signatures more obvious. +type PongAction = IO ByteString + +-- | This is the type of the response for HTTP-based responses. It is mostly aliased to make type signatures more obvious. +type PongHttpAction = IO Status + +-- | This provides the configuration for the pong server. +data PongConfig = PongConfig { + pongPort :: Int, -- ^ The port that this server will run on + pongMessage :: PongAction -- ^ The action which generates a response message +} + +pongMessageHttp200 :: PongAction +-- ^ Provides an action generating an @HTTP/0.9@ response message for the 'ok200' 'Status'. +pongMessageHttp200 = pongMessageHttp ok200 + +pongMessageHttp500 :: PongAction +-- ^ Provides an action generating an @HTTP/0.9@ response message for the 'internalServerError500' 'Status'. +pongMessageHttp500 = pongMessageHttp internalServerError500 + +pongMessageHttp :: Status -> PongAction +-- ^ Provides an action generating an @HTTP/0.9@ response message for the given 'Status'. +pongMessageHttp status = + return $ concat ["HTTP/0.9 ", statusCodeBS status, " ", statusMessage status] + where + statusCodeBS :: Status -> ByteString + statusCodeBS = C.pack . show . statusCode + +pongCatchHttp :: (Exception e) => PongHttpAction -> (e -> PongHttpAction) -> PongAction +-- ^ Allows for customization of the result 'Status' given different exceptions. +pongCatchHttp good bad = (catch good bad) >>= pongMessageHttp + +pongCatch :: (Exception e) => PongAction -> (e -> PongAction) -> PongAction +-- ^ Allows for customization of the result message given different exceptions. +pongCatch = catch -- Yes, we could have just let people use 'catch', but it may be non-obvious + +-- | Handle for a running server +newtype PongServer = PongServer ThreadId + +defaultPongConfig :: PongConfig +-- ^ Default config that runs on port @10411@ and just prints out the four characters @pong@. +defaultPongConfig = PongConfig 10411 $ (return $ C.pack $ "pong") + +withPongServer :: PongConfig -> IO a -> IO a +-- ^ Entry point to the pong server. +withPongServer cfg action = bracket (startServer cfg) stopServer $ const action + +startServer :: PongConfig -> IO PongServer +-- ^ Implementation of actually starting the server. +startServer cfg = do + socket <- withSocketsDo $ listenOn portNum + threadId <- forkIO $ socketHandler socket + return $ PongServer threadId + where + portNum = PortNumber . fromIntegral $ pongPortNum + pongPortNum = pongPort cfg + socketHandler sock = finally (socketHandlerLoop sock) (sClose sock) + socketHandlerLoop sock = do + (handle, _, _) <- accept sock + _ <- forkFinally (body handle) (const $ hClose handle) + socketHandlerLoop sock + body handle = do + hSetBuffering handle NoBuffering + msg <- pongMessage cfg + C.hPutStr handle msg + +stopServer :: (MonadIO m) => PongServer -> m () +-- ^ Implementation of actually stopping the server +stopServer (PongServer threadId) = liftIO $ killThread threadId diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,4 @@ -import Axial.Pong +import Network.Pong import Data.Maybe (isJust, fromJust) @@ -15,7 +15,7 @@ main :: IO () main = hspec $ do - describe "Axial Pong server" $ do + describe "Pong server" $ do it "cannot be reached when not running" $ do reached <- serverReachable ()