symantic-http-test/Hspec/Client/BasicAuth.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   4 module Hspec.Client.BasicAuth where
   5
   6 import Control.Monad (Monad(..))
   7 import Data.Bool
   8 import Data.Either (Either(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($))
  11 import Data.Functor ((<$>))
  12 import Data.Int (Int)
  13 import Data.Map.Strict (Map)
  14 import Data.Maybe (Maybe(..))
  15 import Data.Text (Text)
  16 import System.IO (IO)
  17 import Test.Hspec
  18 import Test.Tasty
  19 import Test.Tasty.Hspec
  20 import Text.Show (Show(..))
  21 import qualified Data.Map.Strict as Map
  22 import qualified Network.HTTP.Client as Client
  23 import qualified Network.HTTP.Types as HTTP
  24
  25 import Symantic.HTTP
  26 import Symantic.HTTP.Client
  27 import Symantic.HTTP.Server
  28 import Hspec.Utils ()
  29 import Hspec.Utils.Server
  30
  31 api =
  32  "auth" </> basicAuth @User "realm"
  33         <.> get @() @'[PlainText]
  34  <!>
  35  "body" </> body @() @'[PlainText]
  36         <.> post @() @'[PlainText]
  37
  38 srv = server api $
  39         route_auth :!:
  40         route_body
  41         where
  42         route_auth User{} = return ()
  43         route_body (ServerBodyArg _a) = return ()
  44
  45 cli_auth
  46  :!: cli_body
  47  = client api
  48
  49 hspec :: IO [TestTree]
  50 hspec = testSpecs $ describe "BasicAuth" $
  51         beforeAll (runTestServer srv) $
  52         afterAll killTestServer $ do
  53                 it "can allow user (200)" $ \TestServer{..} -> do
  54                         runClient env (cli_auth (user_name alice) (user_pass alice))
  55                          `shouldReturn` Right ()
  56                 it "can deny user (401)" $ \TestServer{..} -> do
  57                         Left (ClientError_FailureResponse r) <-
  58                                 runClient env $ cli_auth "no-user" (user_pass alice)
  59                         Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
  60                 it "can deny pass (401)" $ \TestServer{..} -> do
  61                         Left (ClientError_FailureResponse r) <-
  62                                 runClient env $ cli_auth (user_name alice) "no-pass"
  63                         Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
  64                 it "can deny auth (403)" $ \TestServer{..} -> do
  65                         Left (ClientError_FailureResponse r) <-
  66                                 runClient env $ cli_auth (user_name bob) (user_pass bob)
  67                         Client.responseStatus r `shouldBe` HTTP.Status 403 "Forbidden"
  68
  69 -- * Type "User"
  70 data User
  71  =   User
  72  {   user_name :: Text
  73  ,   user_pass :: Text
  74  ,   user_auth :: Bool
  75  ,   user_age  :: Int
  76  } deriving (Eq, Show)
  77 instance ServerBasicAuth User where
  78         serverBasicAuth user pass =
  79                 return $
  80                         case Map.lookup user users of
  81                          Nothing -> BasicAuth_NoSuchUser
  82                          Just u@User{..}
  83                           | user_pass == pass ->
  84                                 if user_auth
  85                                 then BasicAuth_Authorized u
  86                                 else BasicAuth_Unauthorized
  87                           | otherwise -> BasicAuth_BadPassword
  88
  89 users :: Map Text User
  90 users =
  91         Map.fromList $
  92         (\u -> (user_name u, u)) <$>
  93         [ alice
  94         , bob
  95         ]
  96
  97 alice, bob :: User
  98 alice = User "Alice" "pass" True 19
  99 bob   = User "Bob" "pass" False 31