{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Hspec.Server.Error where

import Control.Monad (Monad(..), when)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Prelude ((+))
import System.IO (IO)
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec
import Test.Hspec.Wai (liftIO)
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Data.ByteString.Base64 as BS64
import qualified Data.ByteString.Lazy as BSL
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.Types as HTTP
import qualified Network.Wai.Handler.Warp as Warp
import qualified Test.Hspec.Wai as Wai

import Symantic.HTTP

api = "good" </> "path" </> capture @Int "i"
                        <.> queryParams @Int "param"
                        <.> basicAuth @User "realm" ("authorized"::String)
                        <.> body @Int @PlainText
                        <.> post @Int @PlainText
    <!> "unauthorized"  </> basicAuth @User "realm" ("unauthorized"::String)
                        <.> post @Int @PlainText

data User = User
instance ServerBasicAuthable String User where
	serverBasicAuthable context user pass =
		return $
			if user=="user"
			then if pass=="pass"
				then if context=="authorized"
					then BasicAuth_Authorized User
					else BasicAuth_Unauthorized
				else BasicAuth_BadPassword
			else BasicAuth_NoSuchUser

srv = server api $ route_good :!: route_unauthorized
	where
	route_good i params User (ServerBodyArg b) (ServerResponseArg respond) =
		ServerResponse $ \_req res -> do
			res $ respond status200 [] (i+b)
	route_unauthorized User (ServerResponseArg respond) =
		ServerResponse $ \_req res -> do
			res $ respond status200 [] 0

warp :: IO ()
warp = Warp.run 8080 srv

instance MimeSerialize Int PlainText where
	mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
instance MimeUnserialize Int PlainText where
	mimeUnserialize _mt s =
		case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
		 Just n -> Right n
		 _ -> Left "cannot parse Int"

hspec = testSpecs $ describe "Error" $ Wai.with (return srv) $ do
	describe "Path" $ do
		it "checks shorter path" $ do
			Wai.get "/good"
			 `Wai.shouldRespondWith` 404
		it "checks longer path" $ do
			Wai.get "/good/path/bad"
			 `Wai.shouldRespondWith` 404
	describe "BasicAuth" $ do
		it "can decode username and password" $ do
			Wai.request goodMethod goodURI goodHeaders goodBody
			 `Wai.shouldRespondWith` 200
		it "checks username" $ do
			Wai.request goodMethod goodURI
			 [ (HTTP.hAuthorization, "Basic "<>BS64.encode "no-such-user:pass")
			 , goodAccept
			 , goodContentType
			 ] goodBody
			 `Wai.shouldRespondWith` 401
		it "checks password" $ do
			Wai.request goodMethod goodURI
			 [ (HTTP.hAuthorization, "Basic "<>BS64.encode "user:wrong-pass")
			 , goodAccept
			 , goodContentType
			 ] goodBody
			 `Wai.shouldRespondWith` 401
		it "can return Unauthorized" $ do
			Wai.request goodMethod "/unauthorized" goodHeaders goodBody
			 `Wai.shouldRespondWith` 403
	describe "Priorities" $ do
		it "has 404 as its highest priority error (path)" $ do
			Wai.request badMethod badURI [badAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 404
		it "has 405 as its second highest priority error (method)" $ do
			Wai.request badMethod badParam [badAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 405
		it "has 401 as its third highest priority error (auth)" $ do
			Wai.request goodMethod badParam [badAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 401
		it "has 406 as its fourth highest priority error (accept)" $ do
			Wai.request goodMethod badParam [goodAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 406
		it "has 415 as its fifth highest priority error (content type)" $ do
			Wai.request goodMethod badParam [goodAuth, goodAccept, badContentType] badBody
			`Wai.shouldRespondWith` 415
		it "has 400 as its sixth highest priority error (query and body)" $ do
			badParamsRes <- Wai.request goodMethod badParam goodHeaders goodBody
			badBodyRes   <- Wai.request goodMethod goodURI  goodHeaders badBody
			
			-- Both bad body and bad params result in 400
			return badParamsRes `Wai.shouldRespondWith` 400
			return badBodyRes   `Wai.shouldRespondWith` 400
			
			-- Param check should occur before body checks
			badBothRes <- Wai.request goodMethod badParam
			 [goodAuth, goodAccept, goodContentType] badBody
			when (badBothRes /= badParamsRes) $ liftIO $
				expectationFailure $ "badParam + badBody /= badParam: "
				 <> show badBothRes <> ", " <> show badParamsRes
			when (badBothRes == badBodyRes) $ liftIO $
				expectationFailure $ "badParam + badBody == badBody: "
				 <> show badBothRes


badContentType  = (HTTP.hContentType, "application/json")
badAccept       = (HTTP.hAccept, "application/json")
badMethod       = HTTP.methodGet
badURI          = "bad"
badBody         = "bad"
badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
goodAccept      = (HTTP.hAccept, "text/plain")
goodMethod      = HTTP.methodPost
goodPath        = "good/path/4"
goodURI         = goodPath<>"?param=2"
badParam        = goodPath<>"?param=foo"
goodBody        = "42" -- {-encode-} (42::Int)
goodAuth        = (HTTP.hAuthorization, "Basic "<>BS64.encode "user:pass")
goodHeaders     = [goodAuth, goodAccept, goodContentType]