{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}


module Servant.ServerSpec where


-------------------------------------------------------------------------------
import           Control.Lens               (makeLenses)
import           Control.Monad              (forM_, unless, void, when)
import           Control.Monad.IO.Class     (liftIO)
import           Data.Aeson                 (FromJSON, ToJSON)
import qualified Data.Aeson                 as A
import qualified Data.ByteString.Base64     as B64
import qualified Data.ByteString.Char8      as B8
import qualified Data.ByteString.Lazy       as BL
import           Data.CaseInsensitive       (mk)
import           Data.Char                  (toUpper)
import           Data.Functor               ((<$>))
import           Data.Maybe                 (fromMaybe)
import           Data.Monoid
import           Data.Proxy                 (Proxy (Proxy))
import qualified Data.Set                   as Set
import qualified Data.Text                  as T
import qualified Data.Text.Lazy             as TL
import qualified Data.Text.Encoding         as T
import qualified Data.Text.Lazy.Encoding    as TL
import           GHC.Generics               (Generic)
import           Network.HTTP.Types         (hAccept, hContentType)
import qualified Network.HTTP.Types
import           Snap.Core                  hiding (Headers, addHeader)
import qualified Snap.Core                  as SC
import           Snap.CORS
import           Snap.Snaplet
import qualified Snap.Snaplet.Test          as SST
import qualified Snap.Test                  as ST
-------------------------------------------------------------------------------
import           Test.Hspec
import           Test.Hspec.Snap            hiding (NotFound)
import qualified Test.Hspec.Snap            as THS
import qualified Test.HUnit                 as HU
import           Servant.API                ((:<|>) (..), (:>),
                                             addHeader, BasicAuth, Capture,
                                             CaptureAll, Header (..), Headers,
                                             IsSecure(..), JSON, NoContent(..),
                                             PlainText, QueryFlag, QueryParam,
                                             QueryParams, Raw, RemoteHost,
                                             ReqBody)
import           Servant.API.Verbs          (Verb, Get, Post, Put, Delete,
                                             Patch)
import qualified Servant.API.Verbs          as V
import           Servant.Server              hiding (route)
import           Servant.Server.Internal     (HasServer)
import           Servant.Server.Internal.BasicAuth
import           Servant.Server.Internal.Context
import           Snap.Snaplet.Auth
import           Snap.Snaplet.Auth.Backends.JsonFile
import qualified Snap.Util.CORS as CORS
import           Snap.Snaplet.Session
import           Snap.Snaplet.Session.Backends.CookieSession

-------------------------------------------------------------------------------
-- * test data types

data App = App { _auth :: Snaplet (AuthManager App)
               , _sess :: Snaplet SessionManager}
makeLenses 'App

type AppHandler = Handler App App

app :: SnapletInit App App
app = app' []

app' :: [(B8.ByteString, AppHandler ())] -> SnapletInit App App
app' rs = makeSnaplet "servantsnap" "A test app for servant-snap" Nothing $ do
  s <- nestSnaplet "sess" sess $
           initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)
  a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json"
  addRoutes rs
  wrapSite (\h -> createTestUserIfMissing >> CORS.applyCORS CORS.defaultOptions h)
  return (App a s)

createTestUserIfMissing :: Handler App App ()
createTestUserIfMissing =
  with auth $ usernameExists testLogin >>= \case
    True  -> return ()
    False -> void $ createUser testLogin testPassword

testLogin    = "greg"
testPassword = "p@ssword"

-------------------------------------------------------------------------------


-- * Specs

spec :: Spec
spec = do
  verbSpec
  captureSpec
  captureAllSpec
  queryParamSpec
  reqBodySpec
  headerSpec
  rawSpec
  alternativeSpec
  responseHeadersSpec
  miscCombinatorSpec
  fallthroughSpec
  basicAuthSpec

------------------------------------------------------------------------------
-- * verbSpec {{{
------------------------------------------------------------------------------

type VerbApi method status
    =                Verb method status '[JSON] Person
 :<|> "noContent" :> Verb method status '[JSON] NoContent
 :<|> "header"    :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
 :<|> "headerNC"  :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
 :<|> "accept"    :> (    Verb method status '[JSON] Person
                     :<|> Verb method status '[PlainText] String
                     )


verbSpec :: Spec
verbSpec = do
  let server :: Server (VerbApi method status) '[] AppHandler
      server = return alice
          :<|> return NoContent
          :<|> return (addHeader 5 alice)
          :<|> return (addHeader 10 NoContent)
          :<|> (return alice :<|> return "B")
      get200     = Proxy :: Proxy (VerbApi 'V.GET 200)
      post210    = Proxy :: Proxy (VerbApi 'V.POST 210)
      put203     = Proxy :: Proxy (VerbApi 'V.PUT 203)
      delete280  = Proxy :: Proxy (VerbApi 'V.DELETE 280)
      patch214   = Proxy :: Proxy (VerbApi 'V.PATCH 214)
      wrongMethod m  = if m == SC.PUT then SC.POST else SC.PUT
      test (desc :: String) api verbRoutes (method :: SC.Method) (status :: Int) =
       describe ("Servant.API.Verb " ++ desc) $ do

        -- This group is run with hspec-snap
        snap (route verbRoutes) app $ do

          -- HEAD should not return body
          when (method == SC.HEAD) $
            it "HEAD returns no content body" $ do
              response <- runRequest $ mkRequest method  "/" "" [] ""
              liftIO $ bodyIs response "" `shouldBe` True

          it "throws 405 on wrong method " $ do
            response <- runRequest $ mkRequest (wrongMethod method) "/" "" [] ""
            liftIO $ statusIs response 405 `shouldBe` True

          it "handles trailing '/' gracefully" $ do
            response <- runRequest $ mkRequest method "/headerNC/" "" [] ""
            liftIO $ statusIs response status `shouldBe` True

          it "returns 406 if the Accept header is not supported" $ do
            response <- runRequest $ mkRequest method "" ""
                                     [(hAccept, "crazy/mime")] ""
            liftIO $ statusIs response 406  `shouldBe` True

          it "responds if the Accept header is supported" $ do
            response <- runRequest $ mkRequest method "" ""
               [(hAccept, "application/json;charset=utf-8")] ""
            liftIO $ statusIs response status `shouldBe` True

        let sInit = app' verbRoutes
            runUrl p = SST.runHandler Nothing
                       (mkRequest method p "" [] "")
                       (serveSnap api server) sInit

        -- This group is run with hspec directly

          -- HEAD and 214/215 need not return bodies
        unless (status `elem` [214, 215] || method == SC.HEAD) $
          it "returns the person" $ do
             resp <- runUrl "/"
             resp `shouldDecodeTo` alice
             resp `shouldHaveStatus` status

        it "returns no content on NoContent" $ do
          resp <- runUrl "/noContent"
          resp `shouldHaveStatus` status
          resp `shouldHaveBody` ""

        it "returs headers" $ do
          resp  <- SST.runHandler Nothing
                  (mkRequest method "/header" "" [] "")
                  (serveSnap api server) sInit
          shouldHaveHeaders resp  [("H","5")]

        it "returs CORS headers" $ do
          (_, snapm, _) <- runSnaplet Nothing sInit
          resp <- fmap Right $ ST.runHandler (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") snapm
          shouldHaveHeaders resp  [("access-control-allow-origin"
                                  ,"http://example.com")]

        it "sets the content-type header" $ do
          resp <- SST.runHandler Nothing (mkRequest method "" "" [] "")
                  (serveSnap api server) sInit
          resp `shouldHaveHeaders` [("Content-Type", "application/json;charset=utf-8")]

        unless (status `elem` [214, 215] || method == SC.HEAD) $
          it "allows modular specification of supported content types" $ do
            resp <- SST.runHandler Nothing
                    (mkRequest method "/accept" ""
                     [(hAccept, "text/plain")] "")
                    (serveSnap api server) sInit
            resp `shouldHaveStatus` status
            resp `shouldHaveBody` "B"

  test "GET 200" get200 (routes get200 EmptyContext server) SC.GET 200
  test "POST 210" post210 (routes post210 EmptyContext server) SC.POST 210
  test "PUT 203" put203 (routes put203 EmptyContext server) SC.PUT 203
  test "DELETE 280" delete280 (routes delete280 EmptyContext server) SC.DELETE  280
  test "PATCH 214" patch214 (routes patch214 EmptyContext server) SC.PATCH 214
  test "GET 200 with HEAD" get200 (routes get200 EmptyContext server) SC.HEAD 200

-- }}}

------------------------------------------------------------------------------
-- * captureSpec {{{
------------------------------------------------------------------------------

type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi
captureApi = Proxy
captureServer :: Integer -> AppHandler Animal
captureServer legs = case legs of
  4 -> return jerry
  2 -> return tweety
  _ -> throwError err404

type CaptureApi2 = Capture "captured" String :> Raw

captureApi2 :: Proxy CaptureApi2
captureApi2 = Proxy

captureServer2 :: Server CaptureApi2 '[] AppHandler
captureServer2 _ = do
  rq <- getRequest
  writeBS (SC.rqPathInfo rq) 

captureSpec :: Spec
captureSpec = do -- snap (route (routes captureApi captureServer)) app $  

  let ( sInit , _ ) = mkInitAndServer captureApi  EmptyContext captureServer
      ( sInit2, _ ) = mkInitAndServer captureApi2 EmptyContext captureServer2
      runReq r method api serv i =
        SST.runHandler Nothing (mkRequest method r "" [] "")
        (serveSnap api serv) i

  describe "Servant.API.Capture" $ do

      it "can capture parts of the 'pathInfo'" $ do
        runReq "/2" SC.GET captureApi captureServer sInit >>=
          (`shouldDecodeTo` tweety)

      it "returns 400 if the decoding fails" $ do
        runReq "/notAnInt" SC.GET captureApi captureServer sInit >>=
          (`shouldHaveStatus` 400)

      it "strips the captured path snippet from pathInfo" $ do
        runReq "/captured/foo" SC.GET captureApi2 captureServer2 sInit2 >>=
          (`shouldHaveBody` "foo")

-- }}}
------------------------------------------------------------------------------
-- * captureAllSpec {{{
------------------------------------------------------------------------------

type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal
captureAllApi :: Proxy CaptureAllApi
captureAllApi = Proxy
captureAllServer :: [Integer] -> AppHandler Animal
captureAllServer legs = case sum legs of
  4 -> return jerry
  2 -> return tweety
  0 -> return beholder
  _ -> throwError err404

captureAllSpec :: Spec
captureAllSpec = do
  describe "Servant.API.CaptureAll" $ do

      let runUrl u = runReqOnApi captureAllApi EmptyContext captureAllServer SC.GET u "" [] ""
      it "can capture a single element of the 'pathInfo'" $ do
        runUrl "/2" >>= (`shouldDecodeTo` tweety)
        -- liftIO $ decodesTo response tweety `shouldBe` True

      it "can capture multiple elements of the 'pathInfo'" $ do
        runUrl "/2/2" >>= (`shouldDecodeTo` jerry)
        -- liftIO $ decodesTo response jerry `shouldBe` True

      it "can capture arbitrarily many elements of the 'pathInfo'" $ do
        runUrl "/1/1/0/1/0/1" >>= (`shouldDecodeTo` jerry)
        -- liftIO $ decodesTo response jerry `shouldBe` True

      it "can capture when there are no elements in 'pathInfo'" $ do
        runUrl "/" >>= (`shouldDecodeTo` beholder)
        -- liftIO $ decodesTo response jerry `shouldBe` True

      it "returns 400 if the decoding fails" $ do
        runUrl "/notAnInt" >>= (`shouldHaveStatus` 400)
        -- liftIO $ statusIs response 400 `shouldBe` True

      it "returns 400 if the decoding fails, regardless of which element" $ do
        runUrl "/1/0/0/notAnInt/3/" >>= (`shouldHaveStatus` 400)
        -- liftIO $ statusIs response 400 `shouldBe` True

      it "returns 400 if the decoding fails, even when it's multiple elements" $ do
        runUrl "/1/0/0/notAnInt/3/orange/" >>= (`shouldHaveStatus` 400)
        -- liftIO $ statusIs response 400 `shouldBe` True

      it "consumes everything from pathInfo" $ do
        let api' = (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
            srv' = (\_ -> getRequest >>= writeBS . rqPathInfo)
        req <- runReqOnApi api' EmptyContext srv' SC.GET "/captured/foo/bar/baz" "" [] ""
        req `shouldHaveBody` ""

        -- (\ _captured request_ respond ->
        --     respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
        -- get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))


-- }}}
------------------------------------------------------------------------------
-- * queryParamSpec {{{
------------------------------------------------------------------------------

type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
                :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
                :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person

queryParamApi :: Proxy QueryParamApi
queryParamApi = Proxy

qpServer :: Server QueryParamApi '[] AppHandler
qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize

  where qpNames (_:name2:_) = return alice { name = name2 }
        qpNames _           = return alice

        qpCapitalize False = return alice
        qpCapitalize True  = return alice { name = map toUpper (name alice) }

        queryParamServer (Just name_) = return alice{name = name_}
        queryParamServer Nothing = return alice

queryParamSpec :: Spec
queryParamSpec = do
  describe "Servant.API.QueryParam" $ do

      let runTest :: B8.ByteString -> B8.ByteString -> IO (Either T.Text Response)
          runTest p qs = runReqOnApi queryParamApi EmptyContext qpServer SC.GET p qs [(hContentType,"application/json;charset=utf-8")] ""

      it "allows retrieving simple GET parameters" $
        runTest "" "?name=bob" >>= (`shouldDecodeTo` alice {name="bob"})

{-
(flip runSession) (serve queryParamApi qpServer) $ do
          let params1 = "?name=bob"
          response1 <- Network.Wai.Test.request defaultRequest{
            rawQueryString = params1,
            queryString = parseQuery params1
           }
          liftIO $ do
            decode' (simpleBody response1) `shouldBe` Just alice{
              name = "bob"
             }
-}

      it "allows retrieving lists in GET parameters" $
        runTest "a" "?names[]=bob&names[]=john" >>= (`shouldDecodeTo` alice{name="john"})

{-
        (flip runSession) (serve queryParamApi qpServer) $ do
          let params2 = "?names[]=bob&names[]=john"
          response2 <- Network.Wai.Test.request defaultRequest{
            rawQueryString = params2,
            queryString = parseQuery params2,
            pathInfo = ["a"]
           }
          liftIO $
            decode' (simpleBody response2) `shouldBe` Just alice{
              name = "john"
             }
-}


      it "allows retrieving value-less GET parameters" $ do
        runTest "b" "?capitalize" >>= (`shouldDecodeTo` alice{name="ALICE"})

{-
        (flip runSession) (serve queryParamApi qpServer) $ do
          let params3 = "?capitalize"
          response3 <- Network.Wai.Test.request defaultRequest{
            rawQueryString = params3,
            queryString = parseQuery params3,
            pathInfo = ["b"]
           }
          liftIO $
            decode' (simpleBody response3) `shouldBe` Just alice{
              name = "ALICE"
             }
-}

          -- let params3' = "?capitalize="
        runTest "b" "?capitalize=" >>= (`shouldDecodeTo` alice{name="ALICE"})
{-
          response3' <- Network.Wai.Test.request defaultRequest{
            rawQueryString = params3',
            queryString = parseQuery params3',
            pathInfo = ["b"]
           }
          liftIO $
            decode' (simpleBody response3') `shouldBe` Just alice{
              name = "ALICE"
             }
-}

          -- let params3'' = "?unknown="
        runTest "b" "?unknown=" >>= (`shouldDecodeTo` alice{name="Alice"})
{-
          response3'' <- Network.Wai.Test.request defaultRequest{
            rawQueryString = params3'',
            queryString = parseQuery params3'',
            pathInfo = ["b"]
           }
          liftIO $
            decode' (simpleBody response3'') `shouldBe` Just alice{
              name = "Alice"
             }
-}

-- }}}
------------------------------------------------------------------------------
-- * reqBodySpec {{{
------------------------------------------------------------------------------
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
           :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer

reqBodyApi :: Proxy ReqBodyApi
reqBodyApi = Proxy

reqBodySpec :: Spec
reqBodySpec = do
  describe "Servant.API.ReqBody" $ do

    let runTest m p ct bod = runReqOnApi reqBodyApi EmptyContext server m p "" [(hContentType,ct)] bod
        goodCT = "application/json;charset=utf-8"
                 -- "application/json"
        badCT  = "application/nonsense"

    it "passes the argument to the handler" $ do
      -- response <- mkReq post "" (encode alice)
      runTest SC.POST "" goodCT (BL.toStrict $ A.encode alice) >>=
        (`shouldDecodeTo` alice)
      -- liftIO $ decodesTo response alice `shouldBe` True

    it "rejects invalid request bodies with status 400" $ do
      -- runReqOnApi reqBodyApi server SC.PUT "/blah"
      runTest SC.PUT "/blah" goodCT "some invalid body" >>= (`shouldHaveStatus` 400)
    --   mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400

    it "responds with 415 if the request body media type is unsupported" $ do
      runTest SC.POST "/" badCT ""
        >>= (`shouldHaveStatus` 415)
    --   post "/"
    --     [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415

  where server :: Server ReqBodyApi '[] AppHandler
        server = return :<|> return . age
        -- mkReq handler method x = mkRequest x
        --    [(hContentType, "application/json;charset=utf-8")] ""


-- }}}
------------------------------------------------------------------------------
-- * headerSpec {{{
------------------------------------------------------------------------------

type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy


headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do

    let expectsInt :: Maybe Int -> AppHandler NoContent
        expectsInt (Just x) = do
          when (x /= 5) $ error "Expected 5"
          return NoContent
        expectsInt Nothing  = error "Expected an int"

    let expectsString :: Maybe String -> AppHandler NoContent
        expectsString (Just x) = do
          when (x /= "more from you") $ error "Expected more from you"
          return NoContent
        expectsString Nothing  = error "Expected a string"

    --with (return (serve headerApi expectsInt)) $ do
    -- let delete' x = delete x [("MyHeader", "5")]

    -- TODO: Fix this
    -- it "passes the header to the handler (Int)" $ do
    --   runReqOnApi headerApi EmptyContext expectsInt SC.DELETE "/" "" [("MyHeader","5")] "" >>= (`shouldHaveStatus` 200)
    --         --delete' "/" "" `shouldRespondWith` 200

    -- with (return (serve headerApi expectsString)) $ do
    --     let delete' x = delete x [("MyHeader", "more from you")]

    -- TODO: Fix this
    -- it "passes the header to the handler (String)" $ do
    --   runReqOnApi headerApi EmptyContext expectsString SC.DELETE "/" "" [("MyHeader","more from you")] "" >>= (`shouldHaveStatus` 200)
    --         -- delete' "/" "" `shouldRespondWith` 200
    return ()


-- }}}
------------------------------------------------------------------------------
-- * rawSpec {{{
------------------------------------------------------------------------------

type RawApi = "foo" :> Raw

rawApi :: Proxy RawApi
rawApi = Proxy

rawServer :: Show a => (Request -> a) -> AppHandler ()
rawServer f  = do
  (writeBS . B8.pack . show . f) =<< getRequest

rawSpec :: Spec
rawSpec = do
  describe "Servant.API.Raw" $ do

    it "runs applications" $ do
      runReqOnApi rawApi EmptyContext (rawServer (const (42 :: Integer))) SC.GET "foo" "" [] "" >>= (`shouldHaveBody` "42")

{-
      (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
        response <- Network.Wai.Test.request defaultRequest{
          pathInfo = ["foo"]
         }
        liftIO $ do
          simpleBody response `shouldBe` "42"
-}

    it "gets the pathInfo modified" $ do
      runReqOnApi rawApi EmptyContext (rawServer rqPathInfo) SC.GET "foo/bar" "" [] "" >>=
        (`shouldHaveBody` (T.pack (show ("bar" :: B8.ByteString))))

{-
      (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
        response <- Network.Wai.Test.request defaultRequest{
          pathInfo = ["foo", "bar"]
         }
        liftIO $ do
          simpleBody response `shouldBe` cs (show ["bar" :: String])
-}

-- }}}
------------------------------------------------------------------------------
-- * alternativeSpec {{{
------------------------------------------------------------------------------
type AlternativeApi =
       "foo" :> Get '[JSON] Person
  :<|> "bar" :> Get '[JSON] Animal
  :<|> "foo" :> Get '[PlainText] T.Text
  :<|> "bar" :> Post '[JSON] Animal
  :<|> "bar" :> Put '[JSON] Animal
  :<|> "bar" :> Delete '[JSON] NoContent

alternativeApi :: Proxy AlternativeApi
alternativeApi = Proxy

alternativeServer :: Server AlternativeApi '[] AppHandler
alternativeServer =
       return alice
  :<|> return jerry
  :<|> return "a string"
  :<|> return jerry
  :<|> return jerry
  :<|> return NoContent

alternativeSpec :: Spec
alternativeSpec = do
  describe "Servant.API.Alternative" $ do

      it "unions endpoints" $ do
        -- response <- get "/foo"
        response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/foo" "" [] ""
        response `shouldDecodeTo` alice
        -- liftIO $ do
        --   decodesTo response alice `shouldBe` True
        -- response_ <- get "/bar"
        response_ <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/bar" "" [] ""
        response_ `shouldDecodeTo` jerry
        -- liftIO $ do
        --   decodesTo response_ jerry `shouldBe`
        --     True

      it "checks all endpoints before returning 415" $ do
        -- response <- get "/foo"
        response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/foo" "" [] ""
        response `shouldHaveStatus` 200
        -- liftIO $ statusIs response 200 `shouldBe` True

      it "returns 404 if the path does not exist" $ do
        -- response <- get "/nonexistent"
        response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/nonexistent" "" [] ""
        response `shouldHaveStatus` 404
        -- liftIO $ statusIs response 404 `shouldBe` True
-- }}}
------------------------------------------------------------------------------
-- * responseHeaderSpec {{{
------------------------------------------------------------------------------
type ResponseHeadersApi =
       Get   '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
  :<|> Post  '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
  :<|> Put   '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
  :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

responseHeadersApi :: Proxy ResponseHeadersApi
responseHeadersApi = Proxy

responseHeadersServer :: Server ResponseHeadersApi '[] AppHandler
responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
  in h :<|> h :<|> h :<|> h


responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do

    let methods = [SC.GET, SC.POST, SC.PUT, SC.PATCH]

    it "includes the headers in the response" $
      forM_ methods $ \method -> do
        req <- runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "/" "" [] ""
        req `shouldHaveStatus` 200
        req `shouldHaveHeaders` [("H1","5"),("H2","kilroy")]

{-
        method "/" [] ""
          `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
                                      , matchStatus  = 200
                                      }
-}

    it "responds with not found for non-existent endpoints" $
      forM_ methods $ \method ->
        runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "blahblah" "" [] "" >>= (`shouldHaveStatus` 404)
        -- method "blahblah" [] ""
        --  `shouldRespondWith` 404

    it "returns 406 if the Accept header is not supported" $
      forM_ methods $ \method ->
        runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "" "" [(hAccept, "crazy/mime")] "" >>= (`shouldHaveStatus` 406)
        -- method "" [(hAccept, "crazy/mime")] ""
        --   `shouldRespondWith` 406


-- }}}
------------------------------------------------------------------------------
-- * miscCombinatorSpec {{{
------------------------------------------------------------------------------

type MiscCombinatorsAPI
  =    "version" :> HttpVersion :> Get '[JSON] HttpVersion
  :<|> "secure"  :> IsSecure :> Get '[JSON] String
  :<|> "host"    :> RemoteHost :> Get '[PlainText] String

miscApi :: Proxy MiscCombinatorsAPI
miscApi = Proxy

miscServ :: Server MiscCombinatorsAPI '[] AppHandler
miscServ = versionHandler
      :<|> secureHandler
      :<|> hostHandler

  where versionHandler = return :: HttpVersion -> AppHandler HttpVersion
        secureHandler :: IsSecure -> AppHandler String
        secureHandler Secure = return "secure"
        secureHandler NotSecure = return "not secure"
        hostHandler = return . B8.unpack  :: B8.ByteString -> AppHandler String

miscCombinatorSpec :: Spec
miscCombinatorSpec = do
  describe "Misc. combinators for request inspection" $ do
    it "Successfully gets the HTTP version specified in the request" $
      go "/version" (T.decodeUtf8 . BL.toStrict $
      A.encode ((1,1) :: HttpVersion))

    it "Checks that hspec-wai uses HTTP, not HTTPS" $
      go "/secure" "\"not secure\""

    it "Checks that hspec-wai issues request from 0.0.0.0" $
      go "/host" "localhost"

  where go path res = do
          runReqOnApi miscApi EmptyContext miscServ SC.GET path "" [] "" >>=
            (`shouldHaveBody` res)

-- }}}

type FFApi1 = "1" :> Get '[JSON] Int
p1 = Proxy :: Proxy FFApi1
ffServe1 = return 1
type FFApi2 = "2" :> Get '[JSON] Int
p2 = Proxy :: Proxy FFApi2
ffServe2 = return 2

fallthroughSpec :: Spec
fallthroughSpec = do
  describe "Allow multiple servant apis in the same snap router" $ do
    let rts =      [("", serveSnap p1 ffServe1)
                   ,("", serveSnap p2 ffServe2)
                   ]
        sInit = makeSnaplet "servantsnap" "test" Nothing $ do
          addRoutes rts
          return App
        expectRoute r b =
          SST.runHandler Nothing (mkRequest GET r "" [] "") (route rts) sInit
          >>= b
    it "Successfully matches"       $ expectRoute "1" (`shouldHaveBody` "1")
    it "Successfully falls through" $ expectRoute "2" (`shouldHaveBody` "2")
    it "404s when expected"         $ expectRoute "3" (`shouldHaveStatus` 404)


------------------------------------------------------------------------------
-- * BasicAuthCombinatorSpec {{{
------------------------------------------------------------------------------

type BasicAuthAPI = "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

baApi :: Proxy BasicAuthAPI
baApi = Proxy

baServ :: Server BasicAuthAPI '[BasicAuthCheck AppHandler ()] AppHandler
baServ () = return 1337

basicAuthSpec :: Spec
basicAuthSpec = do
  let baCheck :: BasicAuthCheck AppHandler ()
      baCheck = BasicAuthCheck $ \_ -> return (Authorized ())

      getSecret :: () -> AppHandler Int
      getSecret () = return 1337

      authHeader un pw = "Basic " <> B64.encode (T.encodeUtf8 un <> ":" <> pw)

  describe "Checks auth" $ do
    
    it "returns 401 when not logged  in" $ do
      response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" "" [] ""
      response `shouldHaveStatus` 401

    it "returns 200 when logged in" $ do
      response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" ""
                  [("Authorization", authHeader testLogin testPassword)] ""
      response `shouldHaveBody` "1337"

-- }}}
------------------------------------------------------------------------------
-- * Test data types {{{
------------------------------------------------------------------------------

data Person = Person {
  name :: String,
  age  :: Integer
 }
  deriving (Eq, Show, Generic)

instance ToJSON Person
instance FromJSON Person

alice :: Person
alice = Person "Alice" 42

data Animal = Animal {
  species      :: String,
  numberOfLegs :: Integer
 }
  deriving (Eq, Show, Generic)

instance ToJSON Animal
instance FromJSON Animal

jerry :: Animal
jerry = Animal "Mouse" 4

tweety :: Animal
tweety = Animal "Bird" 2

beholder :: Animal
beholder = Animal "Beholder" 0
-- }}}


------------------------------------------------------------------------------
-- * hspec-snap helpers
------------------------------------------------------------------------------

getStatus :: TestResponse -> Maybe Int
getStatus (Html (RespCode s) _) = Just s
getStatus (Json (RespCode s) _) = Just s
getStatus THS.NotFound = Nothing
getStatus (Redirect (RespCode s) _) = Just s
getStatus (Other (RespCode s)) = Just s
getStatus Empty = Nothing

statusIs :: TestResponse -> Int -> Bool
statusIs r s = getStatus r == Just s

decodesTo :: (FromJSON a, Eq a) => TestResponse -> a -> Bool
decodesTo (Json _ bs) a = A.decode' bs == Just a
decodesTo _ _ = False

bodyIs :: TestResponse -> TL.Text -> Bool
bodyIs (Html _ t) target = t == TL.toStrict target
bodyIs (Json _ b) target = b == TL.encodeUtf8 target
bodyIs _ _ = False

------------------------------------------------------------------------------
-- * hspec helpers
------------------------------------------------------------------------------

shouldHaveBody :: Either T.Text Response -> T.Text -> IO ()
shouldHaveBody (Left e) _ = HU.assertFailure $
                            "Failed to respond: " ++ T.unpack e
shouldHaveBody (Right r) a = do
  bod <- ST.getResponseBody r
  bod `shouldBe` T.encodeUtf8 a

shouldHaveStatus :: Either T.Text Response -> Int -> IO ()
shouldHaveStatus (Left e) _ = HU.assertFailure $
                              "Failed to respond: " ++ T.unpack e
shouldHaveStatus (Right r) a = do
  SC.rspStatus r `shouldBe` a


shouldDecodeTo :: (FromJSON a, Eq a, Show a)
               => Either T.Text Response
               -> a
               -> IO ()
shouldDecodeTo (Left e) _ = HU.assertFailure $
                            "Failed to respond: " ++ T.unpack e
shouldDecodeTo (Right resp) a = do
  bod <- ST.getResponseBody resp
  case A.decode' $ BL.fromStrict bod of
    Just x | x == a -> return ()
    Just _ -> HU.assertFailure $
              "Failed to decode response to " ++ show a ++
              " from body: " ++ B8.unpack bod
    Nothing -> HU.assertFailure $ "Failed to decode respone from body: " ++
               B8.unpack bod ++ "\nResponse: " ++ show resp
    
shouldHaveHeaders :: Either T.Text Response
                  -> [(B8.ByteString, B8.ByteString)]
                  -> Expectation
shouldHaveHeaders (Left e) _ = expectationFailure $ T.unpack e
shouldHaveHeaders (Right resp) hs = do
  let respHs  = Set.fromList $ SC.listHeaders resp
      hs'     = Set.fromList $  (\(k,v) -> (mk k,v)) <$> hs
      missing = Set.toList $ Set.difference hs' respHs
  case missing of
    [] -> return ()
    _  -> expectationFailure $
     "These expected headers and values were missing: " ++ show missing ++
     " from the response's: " ++ show (Set.toList respHs)


------------------------------------------------------------------------------
-- * Assorted Snap helpers
------------------------------------------------------------------------------

mkInitAndServer :: (HasServer api context m, m ~ AppHandler)
                => Proxy (api :: *)
                -> Context context
                -> Server api context AppHandler
                -> (SnapletInit App App, AppHandler ())
mkInitAndServer api ctx serv =
  let sRoute = serveSnapWithContext api ctx serv
  in  (app' [("", sRoute)], sRoute)


mkRequest :: Method
          -> B8.ByteString
          -> B8.ByteString
          -> [Network.HTTP.Types.Header]
          -> B8.ByteString
          -> ST.RequestBuilder IO ()
mkRequest mth pth qs hds bdy = do
  let ct = fromMaybe "" (Prelude.lookup hContentType hds)
  ST.postRaw pth ct bdy
  ST.setQueryStringRaw qs
  unless (mth == SC.POST) $ ST.setRequestType (ST.RequestWithRawBody mth bdy)
  forM_ hds (\(k, v) -> unless (k == hContentType) $ ST.addHeader k v)
  -- req <- State.get -- Useful for debugging
  -- liftIO $ print req

runReqOnApi :: (HasServer api context m, m ~ AppHandler)
            => Proxy (api :: *)
            -> Context context
            -> Server api context AppHandler
            -> Method
            -> B8.ByteString
            -> B8.ByteString
            -> [Network.HTTP.Types.Header]
            -> B8.ByteString
            -> IO (Either T.Text Response)
runReqOnApi api ctx serv method route qs hds bod =
  let (sInit, serv') = mkInitAndServer api ctx serv
  in SST.runHandler Nothing (mkRequest method route qs hds bod) serv' sInit

routes :: (HasServer api context m, m ~ AppHandler)
       => Proxy (api :: *)
       -> Context context
       -> Server api context AppHandler
       -> [(B8.ByteString, AppHandler ())]
routes p ctx s = [("", serveSnapWithContext p ctx s)]