{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Hspec.Client.BasicAuth where

import Control.Arrow (left)
import Control.Concurrent (ThreadId, forkIO, killThread)
import Control.Monad (Monad(..), when)
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(..), fromJust)
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Text (Text)
import Prelude (fromIntegral, (+))
import System.IO (IO)
import Test.Hspec
import Test.Hspec.Wai (liftIO)
import Test.Tasty
import Test.Tasty.Hspec
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Data.ByteString.Base64 as BS64
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Types as HTTP
import qualified Network.Socket as Net
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Test.Hspec.Wai as Wai

import Symantic.HTTP
import Hspec.Client.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