pong-server (empty) → 0.0.1.0

raw patch · 5 files changed

+202/−0 lines, 5 filesdep +QuickCheckdep +basedep +hspecsetup-changed

Dependencies added: QuickCheck, base, hspec, network, pong-server

Files

• Setup.hs +2/−0
• UNLICENSE +24/−0
• pong-server.cabal +47/−0
• src/Axial/Pong.hs +45/−0
• test/Spec.hs +84/−0

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

@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>

@@ -0,0 +1,47 @@+name:                pong-server+version:             0.0.1.0+synopsis:            A simple embedded pingable server that runs in the background.+description:         Please see README.md+homepage:            http://github.com/RobertFischer/pong-server#readme+license:             PublicDomain+license-file:        UNLICENSE+author:              Robert Fischer+maintainer:          smokejumperit+pong-server@gmail.com+copyright:           2016 Robert Fischer+category:            utilities+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Axial.Pong+  build-depends:       base >= 4.7 && < 5+                     , network >= 2.6.2.1 && < 2.7+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  default-extensions:  OverloadedStrings+                    ,  LambdaCase+                    ,  MultiWayIf+                    ,  TransformListComp+                    ,  FlexibleInstances+                    ,  NoMonomorphismRestriction+                    ,  DeriveGeneric+                    ,  ScopedTypeVariables++test-suite pong-server-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , pong-server+                     , hspec >= 2.2.2 && < 3+                     , QuickCheck >= 2.8.1 && < 3+                     , network >= 2.6.2.1 && < 2.7+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  default-extensions:  ScopedTypeVariables++source-repository head+  type:     git+  location: https://github.com/RobertFischer/pong-server

@@ -0,0 +1,45 @@+module Axial.Pong+    (+      PongConfig(..)+    , defaultPongConfig+    , withPongServer+    ) where++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 $ const $ pure "pong"++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

@@ -0,0 +1,84 @@+import Axial.Pong++import Data.Maybe (isJust, fromJust)++import Test.Hspec+import Test.QuickCheck+import Control.Exception (catch, SomeException)++import Network++import System.Timeout++import GHC.IO.Handle (Handle, hGetLine, hClose)+++main :: IO ()+main = hspec $ do+  describe "Axial Pong server" $ do++    it "cannot be reached when not running" $ do+      reached <- serverReachable ()+      reached `shouldBe` False++    it "can be started and stopped twice" $ do+      reachedBefore <- serverReachable ()+      reachedBefore `shouldBe` False++      withPongServer defaultPongConfig $ do+        reached <- serverReachable ()+        reached `shouldBe` True++      reachedBetween <- serverReachable ()+      reachedBetween `shouldBe` False++      withPongServer defaultPongConfig $ do+        reached <- serverReachable ()+        reached `shouldBe` True++      reachedAfter <- serverReachable ()+      reachedAfter `shouldBe` False++    context "when running" $ around_ (withPongServer defaultPongConfig) $ do+      it "can be reached" $ do+        reached <- serverReachable ()+        reached `shouldBe` True++      it "can be reached twice" $ do+        reached1 <- serverReachable ()+        reached1 `shouldBe` True+        reached2 <- serverReachable ()+        reached2 `shouldBe` True++      it "survives after a client pre-emptively closes the connection" $ do+        handle <- connectServer ()+        hClose handle+        reached <- serverReachable ()+        reached `shouldBe` True++connectServer :: () -> IO Handle+connectServer () = withSocketsDo $ do+  connResult <- timeout (1000 * 1000) $ doConnect+  connResult `shouldSatisfy` isJust+  pure $ fromJust connResult+  where+    doConnect = connectTo serverName portNum+    portNum = PortNumber 10411+    serverName = "localhost"++serverReachable :: () -> IO Bool+serverReachable () = withSocketsDo $ catch tryConnect (\(e::SomeException) -> pure False)+  where+    tryConnect = do+      connResult <- timeout (1000 * 1000) doConnect+      pure $ isJust connResult+    doConnect = do+      socket <- connectTo serverName portNum+      receivedMessage <- hGetLine socket+      pure $ validateMessage receivedMessage+    portNum = PortNumber 10411+    serverName = "localhost"++validateMessage :: String -> Bool+validateMessage = (==) "pong"+