test/Hspec/Client.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 module Hspec.Client where
   6
   7 import Control.Arrow (left)
   8 import Control.Concurrent (ThreadId, forkIO, killThread)
   9 import Control.Monad (Monad(..), when)
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Function (($), (.))
  14 import Data.Functor ((<$>))
  15 import Data.Int (Int)
  16 import Data.Map.Strict (Map)
  17 import Data.Maybe (Maybe(..), fromJust)
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.String (String)
  20 import Data.Text (Text)
  21 import Prelude (fromIntegral, (+))
  22 import System.IO (IO)
  23 import Test.Hspec
  24 import Test.Hspec.Wai (liftIO)
  25 import Test.Tasty
  26 import Test.Tasty.Hspec
  27 import Text.Read (readMaybe)
  28 import Text.Show (Show(..))
  29 import qualified Data.ByteString.Base64 as BS64
  30 import qualified Data.ByteString as BS
  31 import qualified Data.ByteString.Lazy as BSL
  32 import qualified Data.Map.Strict as Map
  33 import qualified Data.Text as Text
  34 import qualified Data.Text.Encoding as Text
  35 import qualified Data.Text.Lazy as TL
  36 import qualified Data.Text.Lazy.Encoding as TL
  37 import qualified Network.HTTP.Client as Client
  38 import qualified Network.HTTP.Types as HTTP
  39 import qualified Network.Socket as Net
  40 import qualified Network.Wai as Wai
  41 import qualified Network.Wai.Handler.Warp as Warp
  42 import qualified Test.Hspec.Wai as Wai
  43
  44 import Symantic.HTTP
  45
  46 api = "auth"  </> basicAuth @User "realm"
  47               <.> get @() @PlainText
  48
  49 srv = server api $ route_auth
  50         where
  51         route_auth User{} (ServerRespond respond) =
  52                 ServerResponse $ \_req res -> do
  53                         res $ respond status200 [] ()
  54
  55 alice, carol :: User
  56 alice = User "Alice" "pass" 19
  57 carol = User "Carol" "pass" 31
  58
  59 -- * Type "User"
  60 data User
  61  =   User
  62  {   user_name :: Text
  63  ,   user_pass :: Text
  64  ,   user_age  :: Int
  65  } deriving (Eq, Show)
  66 instance ServerBasicAuth User where
  67         serverBasicAuth user pass =
  68                 return $
  69                         case Map.lookup user users of
  70                          Nothing -> BasicAuth_NoSuchUser
  71                          Just u@User{..}
  72                           | user_pass == pass -> BasicAuth_Authorized u
  73                           | otherwise -> BasicAuth_BadPassword
  74
  75 users :: Map Text User
  76 users =
  77         Map.fromList $
  78         (\u -> (user_name u, u)) <$>
  79         [ alice
  80         , carol
  81         ]
  82
  83 {-
  84 instance ToJSON   User
  85 instance ToForm   User
  86 instance FromJSON User
  87 instance FromForm User
  88
  89 instance Arbitrary User where
  90   arbitrary = User <$> arbitrary <*> arbitrary
  91 -}
  92
  93 hspec :: IO [TestTree]
  94 hspec = testSpecs $ describe "Client" $
  95         beforeAll (runTestServer srv) $
  96         afterAll killTestServer $ do
  97                 describe "BasicAuth" $ do
  98                         it "can authenticate" $ \TestServer{..} -> do
  99                                 runClient (clientConnection $ client api (user_name alice) (user_pass alice))
 100                                  `shouldReturn` Right ()
 101
 102 -- * Type 'TestServer'
 103 data TestServer = TestServer
 104  { thread    :: ThreadId
 105  , socket    :: Net.Socket
 106  , runClient :: forall a. ClientConnection a -> IO (Either ClientError a)
 107  }
 108
 109 runTestServer :: Wai.Application -> IO TestServer
 110 runTestServer waiApp = do
 111         let baseURI = fromJust $ parseURI "http://localhost:8080"
 112         (port, socket) <- openTestSocket
 113         thread <- forkIO $
 114                 Warp.runSettingsSocket
 115                  (Warp.setPort port $ Warp.defaultSettings)
 116                  socket waiApp
 117         manager <- Client.newManager Client.defaultManagerSettings
 118         let runClient = runClientConnection $ clientEnv manager baseURI
 119         return $ TestServer{..}
 120
 121 killTestServer :: TestServer -> IO ()
 122 killTestServer TestServer{..} = do
 123         Net.close socket
 124         killThread thread
 125
 126 openTestSocket :: IO (Warp.Port, Net.Socket)
 127 openTestSocket = do
 128         let host = Net.tupleToHostAddress (127, 0, 0, 1)
 129         let port = 8080
 130         sock <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol
 131         Net.setSocketOption sock Net.ReuseAddr 1
 132         Net.bind sock (Net.SockAddrInet port host)
 133         Net.listen sock 1000
 134         return (port, sock)