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.Server
  29
  30 api =
  31  "auth" </> basicAuth @User "realm"
  32         <.> get @() @'[PlainText]
  33  <!>
  34  "body" </> body @() @'[PlainText]
  35         <.> post @() @'[PlainText]
  36
  37 srv = server api $
  38         route_auth :!:
  39         route_body
  40         where
  41         route_auth User{} = return ()
  42         route_body (ServerBodyArg _a) = return ()
  43
  44 cli_auth
  45  :!: cli_body
  46  = client api
  47
  48 hspec :: IO [TestTree]
  49 hspec = testSpecs $ describe "BasicAuth" $
  50         beforeAll (runTestServer srv) $
  51         afterAll killTestServer $ do
  52                 it "can allow user (200)" $ \TestServer{..} -> do
  53                         runClient env (cli_auth (user_name alice) (user_pass alice))
  54                          `shouldReturn` Right ()
  55                 it "can deny user (401)" $ \TestServer{..} -> do
  56                         Left (ClientError_FailureResponse r) <-
  57                                 runClient env $ cli_auth "no-user" (user_pass alice)
  58                         Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
  59                 it "can deny pass (401)" $ \TestServer{..} -> do
  60                         Left (ClientError_FailureResponse r) <-
  61                                 runClient env $ cli_auth (user_name alice) "no-pass"
  62                         Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
  63                 it "can deny auth (403)" $ \TestServer{..} -> do
  64                         Left (ClientError_FailureResponse r) <-
  65                                 runClient env $ cli_auth (user_name bob) (user_pass bob)
  66                         Client.responseStatus r `shouldBe` HTTP.Status 403 "Forbidden"
  67
  68 -- * Type "User"
  69 data User
  70  =   User
  71  {   user_name :: Text
  72  ,   user_pass :: Text
  73  ,   user_auth :: Bool
  74  ,   user_age  :: Int
  75  } deriving (Eq, Show)
  76 instance ServerBasicAuth User where
  77         serverBasicAuth user pass =
  78                 return $
  79                         case Map.lookup user users of
  80                          Nothing -> BasicAuth_NoSuchUser
  81                          Just u@User{..}
  82                           | user_pass == pass ->
  83                                 if user_auth
  84                                 then BasicAuth_Authorized u
  85                                 else BasicAuth_Unauthorized
  86                           | otherwise -> BasicAuth_BadPassword
  87
  88 users :: Map Text User
  89 users =
  90         Map.fromList $
  91         (\u -> (user_name u, u)) <$>
  92         [ alice
  93         , bob
  94         ]
  95
  96 alice, bob :: User
  97 alice = User "Alice" "pass" True 19
  98 bob   = User "Bob" "pass" False 31