{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Applicative
import Data.ByteString
import Data.Monoid
import Data.Text
import Data.Text.Encoding
import Network.HTTP.Types
import Network.Wai
import Network.Wai.RequestSpec
import Network.Wai.RequestSpec.Internal.Env

import Criterion.Main

--------------------------------------------------------------------------------
                  -- Data Types to Benchmark With --
--------------------------------------------------------------------------------
newtype Unit = Unit ()

instance FromEnv Unit where
  fromEnv _ = pure (Unit ())

newtype Vector = Vector (Int,Int,Int)

instance FromEnv Vector where
  fromEnv e = Vector <$> ((,,) <$> intQ "x" e <*> intQ "y" e <*> intQ "z" e)

newtype Username = Username Text
newtype Password = Password Text
newtype State = State ByteString
data Auth = Auth Username Password State
newtype FormAuth = FormAuth Auth
newtype QueryAuth = HeaderAuth Auth

instance FromEnv FormAuth where
  fromEnv e = FormAuth <$> (Auth <$> (Username <$> textF "username" e)
                                 <*> (Password <$> textF "password" e)
                                 <*> (State <$> bytesQ encodeUtf8 "state" e))

instance FromEnv QueryAuth where
  fromEnv e = HeaderAuth <$> (Auth <$> (Username <$> textQ "username" e)
                                   <*> (Password <$> textQ "password" e)
                                   <*> (State <$> bytesQ encodeUtf8 "state" e))


--------------------------------------------------------------------------------
                           -- Utilities --
--------------------------------------------------------------------------------
type ParseFn a = Env -> Result a

data ContentType
  = FormEncoded
  | Irrelevant

mkR :: ContentType -> [Header] -> Query -> ByteString -> Request
mkR ct hs qs body =
  defaultRequest { requestHeaders = hs <> (case ct of
                                      FormEncoded -> formEncoded
                                      Irrelevant -> [])
                 , queryString = qs
                 , requestBody = pure body
                 }
  where formEncoded = [("content-type", "application/x-www-form-urlencoded")]

vecReq :: Request
vecReq = mkR Irrelevant [] [("x", Just "1"), ("y", Just "2"), ("z", Just "3")] ""

formAuthReq :: Request
formAuthReq = mkR FormEncoded [] [("state", Just "kqwsdbcxk")] "username=cat&password=notcat"

queryAuthReq :: Request
queryAuthReq =
  mkR Irrelevant [] [ ("state", Just "kqwsdbcxk")
                    , ("username", Just "cat")
                    , ("password", Just "notcat")
                    ] ""

--------------------------------------------------------------------------------
                           -- Benchmarks --
--------------------------------------------------------------------------------
parseBench :: Benchmark
parseBench =
  bgroup "parse" [ bench "null" $ whnf (parse fromEnv :: ParseFn Unit) defaultEnv
                 , bench "vector" $ whnf (parse fromEnv :: ParseFn Vector) (toEnv vecReq)

                 , bench "vector_error" $
                   whnf (parse fromEnv :: ParseFn Vector) (toEnv vecReq)

                 , bench "form_auth_raw" $
                   whnf (parse fromEnv :: ParseFn FormAuth)
                        (toEnvRaw formAuthReq "username=cat&password=notcat")

                 , bench "form_auth_with_form" $
                   whnf (parse fromEnv :: ParseFn FormAuth)
                        (toEnvWithForm formAuthReq [("username", "cat"), ("password", "notcat")])

                 , bench "query_auth" $ whnf (parse fromEnv :: ParseFn QueryAuth) (toEnv queryAuthReq)
                 ]

envBench :: Benchmark
envBench =
  bgroup "env" [ bench "null" $ whnf toEnv defaultRequest
               , bench "vector" $ whnf toEnv vecReq
               , bench "form_auth" $ whnf toEnv formAuthReq

               , bench "form_auth_raw" $
                 whnf (toEnvRaw formAuthReq) "username=cat&password=notcat"

               , bench "form_auth_with_form" $
                 whnf (toEnvWithForm formAuthReq) [("username", "cat"), ("password", "notcat")]

               , bench "query_auth" $ whnf toEnv queryAuthReq
               ]

main :: IO ()
main = defaultMain [ parseBench
                   , envBench
                   ]