{-# LANGUAGE CPP #-}

module Servant.QuickCheck.InternalSpec (spec) where

import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
import Control.Exception (SomeException)
import Control.Monad (replicateM)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Functor
import Data.Maybe (fromJust)
import Network.HTTP.Client (path, queryString)
import Prelude.Compat
import Servant
import Servant.HTML.Blaze (HTML)
import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)
import Test.Hspec.Core.Spec
  ( Arg
  , Example
  , Result (..)
  , ResultStatus (..)
  , defaultParams
  , safeEvaluateExample
  )
import Test.QuickCheck.Gen (generate, unGen)
import Test.QuickCheck.Random (mkQCGen)
import qualified Text.Blaze.Html as Blaze
import qualified Text.Blaze.Html5 as Blaze5

import Servant.QuickCheck
import Servant.QuickCheck.Internal
  ( genRequest
  , runGenRequest
  , serverDoesntSatisfy
  )

spec :: Spec
spec = do
  serversEqualSpec
  serverSatisfiesSpec
  isComprehensiveSpec
  onlyJsonObjectSpec
  notLongerThanSpec
  queryParamsSpec
  queryFlagsSpec
  deepPathSpec
  htmlDocTypesSpec
  unbiasedGenerationSpec

serversEqualSpec :: Spec
serversEqualSpec = describe "serversEqual" $ do
  it "considers equal servers equal" $ do
    withServantServerAndContext api ctx server $ \burl1 ->
      withServantServerAndContext api ctx server $ \burl2 -> do
        serversEqual api burl1 burl2 args bodyEquality

  context "when servers are not equal" $ do
    it "provides the failing responses in the error message" $ do
      FailedWith err <- withServantServer api2 server2 $ \burl1 ->
        withServantServer api2 server3 $ \burl2 -> do
          evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
      show err `shouldContain` "Server equality failed"
      show err `shouldContain` "Body: 1"
      show err `shouldContain` "Body: 2"
      show err `shouldContain` "Path: /failplz"

  context "when JSON is equal but looks a bit different as a ByteString" $ do
    it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
      FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
        withServantServer jsonApi jsonServer2 $ \burl2 -> do
          evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
      show err `shouldContain` "Server equality failed"

    it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
      withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
        withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
          serversEqual jsonApi burl1 burl2 args jsonEquality

    it "sees when JSON apis are not equal because any value is different" $ do
      FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
        withServantServer jsonApi jsonServer3 $ \burl2 -> do
          evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
      show err `shouldContain` "Server equality failed"
      show err `shouldContain` "Path: /jsonComparison"

    it "sees when JSON apis are not equal due to different keys but same values" $ do
      FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
        withServantServer jsonApi jsonServer4 $ \burl2 -> do
          evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
      show err `shouldContain` "Server equality failed"
      show err `shouldContain` "Path: /jsonComparison"

serverSatisfiesSpec :: Spec
serverSatisfiesSpec = describe "serverSatisfies" $ do
  it "succeeds for true predicates" $ do
    withServantServerAndContext api ctx server $ \burl ->
      serverSatisfies
        api
        burl
        args
        ( unauthorizedContainsWWWAuthenticate
            <%> not500
            <%> mempty
        )

  it "fails for false predicates" $ do
    withServantServerAndContext api ctx server $ \burl -> do
      serverDoesntSatisfy
        api
        burl
        args
        ( onlyJsonObjects
            <%> getsHaveCacheControlHeader
            <%> headsHaveCacheControlHeader
            <%> notAllowedContainsAllowHeader
            <%> mempty
        )

  context "when predicates are false" $ do
    it "fails with informative error messages" $ do
      FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
        evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
      show err `shouldContain` "notAllowedContainsAllowHeader"
      show err `shouldContain` "Headers"
      show err `shouldContain` "Body"

onlyJsonObjectSpec :: Spec
onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
  it "fails correctly" $ do
    FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
      evalExample
        $ serverSatisfies
          (Proxy :: Proxy (Get '[JSON] Int))
          burl
          args
          (onlyJsonObjects <%> mempty)
    show err `shouldContain` "onlyJsonObjects"

  it "accepts non-JSON endpoints" $ do
    withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
      serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)

  it "does not fail when there is no content-type" $ do
    withServantServerAndContext api2 ctx serverFailing $ \burl ->
      serverSatisfies api2 burl args (onlyJsonObjects <%> mempty)

notLongerThanSpec :: Spec
notLongerThanSpec = describe "notLongerThan" $ do
  it "fails correctly" $ do
    FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
      evalExample
        $ serverSatisfies
          (Proxy :: Proxy (Get '[JSON] Int))
          burl
          args
          (notLongerThan 1 <%> mempty)
    show err `shouldContain` "notLongerThan"

  it "succeeds correctly" $ do
    withServantServerAndContext api ctx server $ \burl ->
      serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)

isComprehensiveSpec :: Spec
isComprehensiveSpec = describe "HasGenRequest" $ do
  it "has instances for all 'servant' combinators" $ do
    let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
    True `shouldBe` True -- This is a type-level check

deepPathSpec :: Spec
deepPathSpec = describe "Path components" $ do
  it "are separated by slashes, without a trailing slash" $ do
    let rng = mkQCGen 0
        burl = BaseUrl Http "localhost" 80 ""
        gen = runGenRequest deepAPI
        req = unGen gen rng 0 burl
    path req `shouldBe` "/one/two/three"

queryParamsSpec :: Spec
queryParamsSpec = describe "QueryParams" $ do
  it "reduce to an HTTP query string correctly" $ do
    let rng = mkQCGen 0
        burl = BaseUrl Http "localhost" 80 ""
        gen = runGenRequest paramsAPI
        req = unGen gen rng 0 burl
        qs = C.unpack $ queryString req
    qs `shouldBe` "one=_&two=_"

queryFlagsSpec :: Spec
queryFlagsSpec = describe "QueryFlags" $ do
  it "reduce to an HTTP query string correctly" $ do
    let rng = mkQCGen 0
        burl = BaseUrl Http "localhost" 80 ""
        gen = runGenRequest flagsAPI
        req = unGen gen rng 0 burl
        qs = C.unpack $ queryString req
    qs `shouldBe` "one&two"

htmlDocTypesSpec :: Spec
htmlDocTypesSpec = describe "HtmlDocTypes" $ do
  it "fails HTML without doctype correctly" $ do
    err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
      evalExample
        $ serverSatisfies
          docTypeApi
          burl
          args
          (htmlIncludesDoctype <%> mempty)
    show err `shouldContain` "htmlIncludesDoctype"

  it "passes HTML with a doctype at start" $ do
    withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
      serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)

  it "accepts json endpoints and passes over them in silence" $ do
    withServantServerAndContext api ctx server $ \burl -> do
      serverSatisfies
        (Proxy :: Proxy (Get '[JSON] Int))
        burl
        args
        (htmlIncludesDoctype <%> mempty)

makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
makeRandomRequest large burl = do
  req <- generate $ runGenRequest large
  pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl

unbiasedGenerationSpec :: Spec
unbiasedGenerationSpec = describe "Unbiased Generation of requests"
  $ it "frequency paired with generated endpoint should be more randomly distributed"
  $ do
    let burl = BaseUrl Http "localhost" 80 ""
    let runs = 10000 :: Double
    someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
    let mean = sum (map fromIntegral someRequests) / runs
    let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
    let variance = sum (map variancer someRequests) / runs - 1
    -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
    mean > 8 `shouldBe` True
    mean < 9 `shouldBe` True
    -- Std dev is likely around 4. Variance is probably greater than 20.
    variance > 19.5 `shouldBe` True

------------------------------------------------------------------------------
-- APIs
------------------------------------------------------------------------------

type API =
  ReqBody '[JSON] String :> Post '[JSON] String
    :<|> Get '[JSON] Int
    :<|> BasicAuth "some-realm" () :> Get '[JSON] ()

api :: Proxy API
api = Proxy

type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()

paramsAPI :: Proxy ParamsAPI
paramsAPI = Proxy

type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()

flagsAPI :: Proxy FlagsAPI
flagsAPI = Proxy

server :: IO (Server API)
server = do
  mvar <- newMVar ""
  pure $ (liftIO . swapMVar mvar)
    :<|> liftIO (readMVar mvar <&> length)
    :<|> const (pure ())

type API2 = "failplz" :> Get '[JSON] Int

api2 :: Proxy API2
api2 = Proxy

type DeepAPI = "one" :> "two" :> "three" :> Get '[JSON] ()

deepAPI :: Proxy DeepAPI
deepAPI = Proxy

server2 :: IO (Server API2)
server2 = pure $ pure 1

server3 :: IO (Server API2)
server3 = pure $ pure 2

serverFailing :: IO (Server API2)
serverFailing = pure . throwError $ err405

-- With Doctypes
type HtmlDoctype = Get '[HTML] Blaze.Html

docTypeApi :: Proxy HtmlDoctype
docTypeApi = Proxy

docTypeServer :: IO (Server HtmlDoctype)
docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"

noDocTypeServer :: IO (Server HtmlDoctype)
noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"

-- Api for unbiased generation of requests tests
largeApi :: Proxy LargeAPI
largeApi = Proxy

type LargeAPI =
  "1" :> Get '[JSON] Int
    :<|> "2" :> Get '[JSON] Int
    :<|> "3" :> Get '[JSON] Int
    :<|> "4" :> Get '[JSON] Int
    :<|> "5" :> Get '[JSON] Int
    :<|> "6" :> Get '[JSON] Int
    :<|> "7" :> Get '[JSON] Int
    :<|> "8" :> Get '[JSON] Int
    :<|> "9" :> Get '[JSON] Int
    :<|> "10" :> Get '[JSON] Int
    :<|> "11" :> Get '[JSON] Int
    :<|> "12" :> Get '[JSON] Int
    :<|> "13" :> Get '[JSON] Int
    :<|> "14" :> Get '[JSON] Int
    :<|> "15" :> Get '[JSON] Int
    :<|> "16" :> Get '[JSON] Int

type OctetAPI = Get '[OctetStream] BS.ByteString

octetAPI :: Proxy OctetAPI
octetAPI = Proxy

serverOctetAPI :: IO (Server OctetAPI)
serverOctetAPI = pure $ pure "blah"

type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString

jsonApi :: Proxy JsonApi
jsonApi = Proxy

jsonServer1 :: IO (Server JsonApi)
jsonServer1 = pure $ pure "{ \"b\": [\"b\"], \"a\": 1 }" -- whitespace, ordering different

jsonServer2 :: IO (Server JsonApi)
jsonServer2 = pure $ pure "{\"a\": 1,\"b\":[\"b\"]}"

jsonServer3 :: IO (Server JsonApi)
jsonServer3 = pure $ pure "{\"a\": 2, \"b\": [\"b\"]}"

jsonServer4 :: IO (Server JsonApi)
jsonServer4 = pure $ pure "{\"c\": 1, \"d\": [\"b\"]}"

ctx :: Context '[BasicAuthCheck ()]
ctx = BasicAuthCheck (const . pure $ NoSuchUser) :. EmptyContext

------------------------------------------------------------------------------
-- Utils
------------------------------------------------------------------------------
evalExample :: (Arg e ~ (), Example e) => e -> IO EvalResult
evalExample e = do
  r <- safeEvaluateExample e defaultParams ($ ()) progCallback
  case resultStatus r of
    Success -> pure AllGood
    Failure _ reason -> pure $ FailedWith $ show reason
    Pending{} -> error "should not happen"
  where
    progCallback _ = pure ()

data EvalResult
  = AnException SomeException
  | AllGood
  | FailedWith String
  deriving (Show)

args :: Args
args = defaultArgs{maxSuccess = noOfTestCases}

noOfTestCases :: Int
noOfTestCases = 1000
