1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# OPTIONS_GHC -Wno-missing-signatures #-}
4 module Hspec.Client.BasicAuth where
6 import Control.Monad (Monad(..))
8 import Data.Either (Either(..))
9 import Data.Eq (Eq(..))
10 import Data.Function (($))
11 import Data.Functor ((<$>))
13 import Data.Map.Strict (Map)
14 import Data.Maybe (Maybe(..))
15 import Data.Text (Text)
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
26 import Symantic.HTTP.Client
27 import Symantic.HTTP.Server
29 import Hspec.Utils.Server
32 "auth" </> basicAuth @User "realm"
33 <.> get @() @'[PlainText]
35 "body" </> body @() @'[PlainText]
36 <.> post @() @'[PlainText]
42 route_auth User{} = return ()
43 route_body (ServerBodyArg _a) = return ()
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"
77 instance ServerBasicAuth User where
78 serverBasicAuth user pass =
80 case Map.lookup user users of
81 Nothing -> BasicAuth_NoSuchUser
83 | user_pass == pass ->
85 then BasicAuth_Authorized u
86 else BasicAuth_Unauthorized
87 | otherwise -> BasicAuth_BadPassword
89 users :: Map Text User
92 (\u -> (user_name u, u)) <$>
98 alice = User "Alice" "pass" True 19
99 bob = User "Bob" "pass" False 31