BasicAuth.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Hspec.Client.BasicAuth where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Text (Text)
import System.IO (IO)
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec
import Text.Show (Show(..))
import qualified Data.Map.Strict as Map
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Types as HTTP

import Symantic.HTTP
import Symantic.HTTP.Client
import Symantic.HTTP.Server
import Hspec.Utils ()
import Hspec.Utils.Server

api =
 "auth" </> basicAuth @User "realm"
        <.> get @() @'[PlainText]
 <!>
 "body" </> body @() @'[PlainText]
        <.> post @() @'[PlainText]

srv = server api $
	route_auth :!:
	route_body
	where
	route_auth User{} = return ()
	route_body (ServerBodyArg _a) = return ()

cli_auth
 :!: cli_body
 = client api

hspec :: IO [TestTree]
hspec = testSpecs $ describe "BasicAuth" $
	beforeAll (runTestServer srv) $
	afterAll killTestServer $ do
		it "can allow user (200)" $ \TestServer{..} -> do
			runClient env (cli_auth (user_name alice) (user_pass alice))
			 `shouldReturn` Right ()
		it "can deny user (401)" $ \TestServer{..} -> do
			Left (ClientError_FailureResponse r) <-
				runClient env $ cli_auth "no-user" (user_pass alice)
			Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
		it "can deny pass (401)" $ \TestServer{..} -> do
			Left (ClientError_FailureResponse r) <-
				runClient env $ cli_auth (user_name alice) "no-pass"
			Client.responseStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
		it "can deny auth (403)" $ \TestServer{..} -> do
			Left (ClientError_FailureResponse r) <-
				runClient env $ cli_auth (user_name bob) (user_pass bob)
			Client.responseStatus r `shouldBe` HTTP.Status 403 "Forbidden"

-- * Type "User"
data User
 =   User
 {   user_name :: Text
 ,   user_pass :: Text
 ,   user_auth :: Bool
 ,   user_age  :: Int
 } deriving (Eq, Show)
instance ServerBasicAuth User where
	serverBasicAuth user pass =
		return $
			case Map.lookup user users of
			 Nothing -> BasicAuth_NoSuchUser
			 Just u@User{..}
			  | user_pass == pass ->
				if user_auth
				then BasicAuth_Authorized u
				else BasicAuth_Unauthorized
			  | otherwise -> BasicAuth_BadPassword

users :: Map Text User
users =
	Map.fromList $
	(\u -> (user_name u, u)) <$>
	[ alice
	, bob
	]

alice, bob :: User
alice = User "Alice" "pass" True 19
bob   = User "Bob" "pass" False 31