test/Hspec/Client/BasicAuth.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 module Hspec.Client.BasicAuth where
   5
   6 import Control.Arrow (left)
   7 import Control.Concurrent (ThreadId, forkIO, killThread)
   8 import Control.Monad (Monad(..), when)
   9 import Data.Bool
  10 import Data.Either (Either(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Map.Strict (Map)
  16 import Data.Maybe (Maybe(..), fromJust)
  17 import Data.Proxy (Proxy(..))
  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 import Hspec.Client.Server
  46
  47 api = "auth" </> basicAuth @User "realm"
  48              <.> get @() @'[PlainText]
  49   <!> "body" </> body @() @'[PlainText]
  50              <.> post @() @'[PlainText]
  51
  52 srv = server api $
  53         route_auth :!:
  54         route_body
  55         where
  56         route_auth User{} = return ()
  57         route_body (ServerBodyArg a) = return ()
  58
  59 cli_auth
  60  :!: cli_body
  61  = client api
  62
  63 hspec :: IO [TestTree]
  64 hspec = testSpecs $ describe "BasicAuth" $
  65         beforeAll (runTestServer srv) $
  66         afterAll killTestServer $ do
  67                 it "can allow user (200)" $ \TestServer{..} -> do
  68                         runClient env (cli_auth (user_name alice) (user_pass alice))
  69                          `shouldReturn` Right ()
  70                 it "can deny user (401)" $ \TestServer{..} -> do
  71                         Left (ClientError_FailureResponse r) <-
  72                                 runClient env $ cli_auth "no-user" (user_pass alice)
  73                         Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
  74                 it "can deny pass (401)" $ \TestServer{..} -> do
  75                         Left (ClientError_FailureResponse r) <-
  76                                 runClient env $ cli_auth (user_name alice) "no-pass"
  77                         Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
  78                 it "can deny auth (403)" $ \TestServer{..} -> do
  79                         Left (ClientError_FailureResponse r) <-
  80                                 runClient env $ cli_auth (user_name bob) (user_pass bob)
  81                         Client.responseStatus r `shouldBe` HTTP.Status 403 "Forbidden"
  82
  83 -- * Type "User"
  84 data User
  85  =   User
  86  {   user_name :: Text
  87  ,   user_pass :: Text
  88  ,   user_auth :: Bool
  89  ,   user_age  :: Int
  90  } deriving (Eq, Show)
  91 instance ServerBasicAuth User where
  92         serverBasicAuth user pass =
  93                 return $
  94                         case Map.lookup user users of
  95                          Nothing -> BasicAuth_NoSuchUser
  96                          Just u@User{..}
  97                           | user_pass == pass ->
  98                                 if user_auth
  99                                 then BasicAuth_Authorized u
 100                                 else BasicAuth_Unauthorized
 101                           | otherwise -> BasicAuth_BadPassword
 102
 103 users :: Map Text User
 104 users =
 105         Map.fromList $
 106         (\u -> (user_name u, u)) <$>
 107         [ alice
 108         , bob
 109         ]
 110
 111 alice, bob :: User
 112 alice = User "Alice" "pass" True 19
 113 bob   = User "Bob" "pass" False 31