module Nuthatch.Test.Http
  ( tests
  ) where

import           Control.Monad (forM_)
import           Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import           Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Network.HTTP.Types
  ( HeaderName
  , methodGet
  , methodPost
  , status200
  , status303
  , status400
  , status404
  , status405
  )
import           Network.Wai (Request (..), responseLBS)
import           Network.Wai.Test
  ( SRequest (..)
  , SResponse (..)
  , defaultRequest
  , runSession
  , setPath
  , srequest
  )
import           Nuthatch.Api
import           Nuthatch.Config (Config)
import           Nuthatch.Http.Auth
  ( authenticationHandler
  , loginResponse
  )
import           Nuthatch.Http.Server (utf8Boundary)
import           Nuthatch.Session (mintSession)
import           Nuthatch.Test.Config (testConfig)
import           Nuthatch.Types
import           Servant
import           Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
import           Servant.Types.SourceT (source)
import           Test.Tasty (TestTree, testGroup)
import           Test.Tasty.HUnit ((@?=), assertBool, testCase)

tests :: TestTree
tests = testGroup "typed HTTP boundary"
  [ testCase "Servant selects routes and methods" testRouteSelection
  , testCase "valid query values reach a typed handler" testValidDecoding
  , testCase "invalid roots and paths fail before handler execution"
      testInvalidDomains
  , testCase "malformed UTF-8 fails before handler execution" testMalformedUtf8
  , testCase "upload headers and operation ids decode before streaming handler execution"
      testUploadDecoding
  , testCase "upload and download bodies use Servant streaming endpoints"
      testStreamingEndpoints
  , testCase "operation-specific JSON requests and responses remain distinct"
      testOperationRepresentations
  , testCase "operation-specific errors have closed distinct representations" $ do
      let loginError = A.encode OidcCallbackRejected
          deleteError = A.encode (DeleteMutationRejected "locked")
          prefixError = A.encode (DeletePrefixMutationRejected "partial")
      assertBool "login errors carry the login-specific code"
        ("oidc_callback_rejected" `BS.isInfixOf` BL.toStrict loginError)
      assertBool "delete errors carry the mutation-specific code"
        ("mutation_rejected" `BS.isInfixOf` BL.toStrict deleteError)
      assertBool "operation errors must not share one representation"
        (loginError /= deleteError && deleteError /= prefixError)
      assertBool "prefix errors carry their operation-specific code"
        ("prefix_mutation_rejected" `BS.isInfixOf` BL.toStrict prefixError)
  , testCase "production authentication validates cookies and callback emits secure cookies"
      testAuthenticationBoundary
  , testCase "only canonical product routes are exposed"
      testCanonicalProductRoutes
  , testCase "links derive from the type-level API" $
      show (linkURI (safeLink api (Proxy :: Proxy HealthEndpoint)))
        @?= "healthz"
  ]

testRouteSelection :: IO ()
testRouteSelection = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet "/healthz" [] ""
  simpleStatus response @?= status200
  readIORef calls >>= (@?= 1)
  writeIORef calls 0
  wrongMethod <- apiRequest calls methodPost "/healthz" [] ""
  simpleStatus wrongMethod @?= status405
  readIORef calls >>= (@?= 0)
  missing <- apiRequest calls methodGet "/missing" [] ""
  simpleStatus missing @?= status404
  readIORef calls >>= (@?= 0)

testValidDecoding :: IO ()
testValidDecoding = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet
    "/api/browse?root=personal&prefix=docs%2Freports&q=quarterly&continuation=next"
    []
    ""
  simpleStatus response @?= status200
  readIORef calls >>= (@?= 1)

testInvalidDomains :: IO ()
testInvalidDomains = do
  calls <- newIORef 0
  invalidRoot <- apiRequest calls methodGet "/api/browse?root=PERSONAL" [] ""
  simpleStatus invalidRoot @?= status400
  invalidPath <- apiRequest calls methodGet
    "/api/browse?prefix=docs%2F..%2Fprivate" [] ""
  simpleStatus invalidPath @?= status400
  readIORef calls >>= (@?= 0)

testMalformedUtf8 :: IO ()
testMalformedUtf8 = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet "/api/browse?q=%FF" [] ""
  simpleStatus response @?= status400
  readIORef calls >>= (@?= 0)

testUploadDecoding :: IO ()
testUploadDecoding = do
  calls <- newIORef 0
  let csrf = BS.replicate 43 97
      headers =
        [ ("Content-Type", "application/octet-stream")
        , ("X-Declared-Size", "4")
        , ("X-Content-SHA256", BS.replicate 64 97)
        , ("X-CSRF-Token", csrf)
        ]
  response <- apiRequest calls methodPost
    "/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
    headers
    "body"
  simpleStatus response @?= status400
  invalidSize <- apiRequest calls methodPost
    "/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
    (replaceHeader "X-Declared-Size" "zero" headers)
    "body"
  simpleStatus invalidSize @?= status400
  invalidPagination <- apiRequest calls methodGet
    "/api/browse?continuation=" [] ""
  simpleStatus invalidPagination @?= status400
  readIORef calls >>= (@?= 0)

testStreamingEndpoints :: IO ()
testStreamingEndpoints = do
  calls <- newIORef 0
  let csrf = BS.replicate 43 97
      headers =
        [ ("Content-Type", "application/octet-stream")
        , ("X-Declared-Size", "4")
        , ("X-Content-SHA256", BS.replicate 64 97)
        , ("X-CSRF-Token", csrf)
        ]
  upload <- apiRequest calls methodPost
    "/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
    headers
    "body"
  simpleStatus upload @?= status200
  assertBool "upload advertises the idempotency window"
    ("\"idempotency_window_seconds\":3600"
      `BS.isInfixOf` BL.toStrict (simpleBody upload))
  download <- apiRequest calls methodGet
    "/api/download?root=shared&path=docs%2Ffile.txt"
    []
    ""
  simpleStatus download @?= status200
  simpleBody download @?= "body"
  lookup "Content-Disposition" (simpleHeaders download)
    @?= Just "attachment; filename=\"file.txt\""
  lookup "X-Content-Type-Options" (simpleHeaders download)
    @?= Just "nosniff"
  readIORef calls >>= (@?= 2)

testOperationRepresentations :: IO ()
testOperationRepresentations = do
  calls <- newIORef 0
  login <- apiRequest calls methodGet "/login" [] ""
  simpleStatus login @?= status303
  lookup "Location" (simpleHeaders login)
    @?= Just "https://issuer.example/authorize"
  callback <- apiRequest calls methodGet
    "/oidc/callback?code=code&state=state"
    [("Cookie", "nuthatch_oidc=transaction")]
    ""
  simpleStatus callback @?= status303
  wrongLoginMethod <- apiRequest calls methodPost "/login" [] ""
  simpleStatus wrongLoginMethod @?= status405
  deletion <- apiRequest calls methodPost
    "/api/delete"
    [("Content-Type", "application/json")]
    "{\"root\":\"shared\",\"path\":\"docs/file.txt\",\"operation_id\":\"delete-1\",\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
  simpleStatus deletion @?= status200
  assertBool "delete response must carry a mutation result"
    ("succeeded" `BS.isInfixOf` BL.toStrict (simpleBody deletion))
  assertBool "delete advertises the idempotency window"
    ("\"idempotency_window_seconds\":3600"
      `BS.isInfixOf` BL.toStrict (simpleBody deletion))
  malformed <- apiRequest calls methodPost
    "/api/delete"
    [("Content-Type", "application/json")]
    "{\"root\":\"shared\",\"path\":\"../escape\"}"
  simpleStatus malformed @?= status400
  readIORef calls >>= (@?= 3)

replaceHeader
  :: HeaderName
  -> BS.ByteString
  -> [(HeaderName, BS.ByteString)]
  -> [(HeaderName, BS.ByteString)]
replaceHeader name value =
  map $ \(headerName, headerValue) ->
    if headerName == name
      then (headerName, value)
      else (headerName, headerValue)

apiRequest
  :: IORef Int
  -> BS.ByteString
  -> BS.ByteString
  -> [(HeaderName, BS.ByteString)]
  -> BL.ByteString
  -> IO SResponse
apiRequest calls method path headers body =
  apiRequestWith (typedTestApplication calls) method path headers body

apiRequestWith
  :: Application
  -> BS.ByteString
  -> BS.ByteString
  -> [(HeaderName, BS.ByteString)]
  -> BL.ByteString
  -> IO SResponse
apiRequestWith app method path headers body =
  runSession
    (srequest
      (SRequest
        (setPath defaultRequest
          { requestMethod = method
          , requestHeaders = headers
          }
          path)
        body))
    app

typedTestApplication :: IORef Int -> Application
typedTestApplication calls =
  utf8Boundary $
    serveWithContext api (auth :. EmptyContext) (typedTestServer calls)
  where
    auth :: AuthHandler Request SessionContext
    auth = mkAuthHandler $ \_ -> pure SessionContext
      { sessionUser = SessionUser
          { suIssuer = "issuer"
          , suSubject = "subject"
          , suUserId = UserId "user"
          , suDisplay = Nothing
          }
      , sessionCsrf = Just
          (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
      }

typedTestServer :: IORef Int -> Server Api
typedTestServer calls =
       counted (HealthResponse True)
  :<|> counted (ReadyResponse True)
  :<|> (\_ -> counted (addHeader "default-src 'none'" (HtmlPage "app")))
  :<|> (\_ -> Tagged $ \_ sendResponse ->
        sendResponse (responseLBS status404 [] ""))
  :<|> counted
        (addHeader "transaction=cookie"
          (addHeader "https://issuer.example/authorize" NoContent))
  :<|> (\_ _ _ -> counted
        (addHeader "session=cookie"
          (addHeader "csrf=cookie"
            (addHeader "transaction=expired"
              (addHeader "/app" NoContent)))))
  :<|> (\_ _ -> counted
        (addHeader "session=expired"
          (addHeader "csrf=expired"
            (addHeader "transaction=expired" NoContent))))
  :<|>
    (    (\session -> counted SessionResponse
            { sessionResponseUserId = suUserId (sessionUser session)
            , sessionResponseDisplay = Nothing
            , sessionResponseCsrf =
                CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
            })
    :<|> (\_ _ _ _ _ -> counted emptyBrowse)
    :<|> (\_ _ _ _ -> counted downloadResponse)
    :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
          { uploadResponseOperationId = operation
          , uploadResponseResult = MutationSucceeded
          , uploadResponseIdempotencyWindowSeconds = 3600
          })
    :<|> (\_ request -> counted DeleteResponse
          { deleteResponseOperationId = deleteOperationId request
          , deleteResponseResult = MutationSucceeded
          , deleteResponseIdempotencyWindowSeconds = 3600
          })
    :<|> (\_ _ _ _ -> counted DeletePlanResponse
          { deletePlanPaths = []
          , deletePlanContinuation = Nothing
          })
    :<|> (\_ _ -> counted (DeleteBatchResponse []))
    )
  where
    counted :: a -> Handler a
    counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
    emptyBrowse =
      BrowseResponse
        { browseEntries = []
        , browseContinuation = Nothing
        , browsePartial = False
        }
    downloadResponse =
      addHeader "attachment; filename=\"file.txt\"" $
        addHeader "nosniff" $
          addHeader "sandbox" $
            addHeader 4 (source ["body"])

testAuthenticationBoundary :: IO ()
testAuthenticationBoundary = do
  tokenResult <- mintSession testConfig "issuer" "subject" Nothing
  token <- either (fail . T.unpack) pure tokenResult
  let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
      responseHeaders = getHeaders
        (loginResponse testConfig token csrf)
      cookieHeaders =
        [ value
        | (name, value) <- responseHeaders
        , name == "Set-Cookie"
        ]
  lookup "Location" responseHeaders @?= Just "/app"
  length cookieHeaders @?= 3
  assertBool "login sets the session cookie"
    (any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
  assertBool "login sets the CSRF cookie"
    (any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)
  assertBool "cookies are secure and same-site"
    (all ("Secure" `BS.isInfixOf`) cookieHeaders
      && all ("SameSite=Lax" `BS.isInfixOf`) cookieHeaders)
  assertBool "cookies are host-only"
    (all (not . ("Domain=" `BS.isInfixOf`)) cookieHeaders)
  assertBool "session and CSRF cookies use the root path"
    (length (filter ("Path=/;" `BS.isInfixOf`) cookieHeaders) == 2)
  assertBool "the transaction cookie uses the callback path"
    (any ("Path=/oidc/callback;" `BS.isInfixOf`) cookieHeaders)
  assertBool "session and transaction cookies are HTTP-only"
    (length (filter ("HttpOnly" `BS.isInfixOf`) cookieHeaders) == 2)

  calls <- newIORef 0
  let app = productionAuthTestApplication testConfig calls
      cookie =
        "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token)
          <> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf)
  authenticated <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", cookie)]
    ""
  simpleStatus authenticated @?= status200
  readIORef calls >>= (@?= 1)

  writeIORef calls 0
  malformed <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session=" <> BS.singleton 255
      <> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf))]
    ""
  simpleStatus malformed @?= status400
  readIORef calls >>= (@?= 0)

  malformedGrammar <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session")]
    ""
  simpleStatus malformedGrammar @?= status400
  readIORef calls >>= (@?= 0)

  let tamperedToken =
        case T.unsnoc (unSessionToken token) of
          Just (prefix, final)
            | final == 'a' -> prefix <> "b"
            | otherwise -> prefix <> "a"
          Nothing -> "invalid"
  tampered <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session=" <> TE.encodeUtf8 tamperedToken)]
    ""
  simpleStatus tampered @?= status303
  readIORef calls >>= (@?= 0)

  missingCsrf <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token))]
    ""
  simpleStatus missingCsrf @?= status200
  readIORef calls >>= (@?= 1)

testCanonicalProductRoutes :: IO ()
testCanonicalProductRoutes = do
  calls <- newIORef 0
  forM_
    [ (methodGet, "/")
    , (methodGet, "/nuthatch.js")
    , (methodGet, "/download?root=personal&path=file")
    , (methodPost, "/upload")
    , (methodPost, "/delete")
    , (methodPost, "/delete-prefix")
    ] $ \(method, path) -> do
      response <- apiRequest calls method path [] ""
      simpleStatus response @?= status404
  readIORef calls >>= (@?= 0)

productionAuthTestApplication :: Config -> IORef Int -> Application
productionAuthTestApplication cfg calls =
  utf8Boundary $
    serveWithContext
      api
      (authenticationHandler cfg :. EmptyContext)
      (typedTestServer calls)