]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http-test/Hspec/Client/BasicAuth.hs
Optimize static routing with a Map instead of (<!>)
[haskell/symantic-http.git] / 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