{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Dhall.Import.HTTP where

import Control.Exception (Exception)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State.Strict (StateT)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import Data.Dynamic (toDyn)
import Data.Semigroup ((<>))
import Data.Text (Text)

import Dhall.Core
    ( Directory(..)
    , File(..)
    , Import(..)
    , ImportHashed(..)
    , ImportType(..)
    , Scheme(..)
    , URL(..)
    )

import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Text                        as Text
import qualified Data.Text.Encoding
import qualified Dhall.Util
import qualified Network.URI.Encode               as URI.Encode

import Dhall.Import.Types

import qualified Control.Exception
#ifdef __GHCJS__
import qualified JavaScript.XHR
#else
import qualified Data.List.NonEmpty               as NonEmpty
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Encoding
#endif

#if MIN_VERSION_http_client(0,5,0)
import Network.HTTP.Client
    (HttpException(..), HttpExceptionContent(..), Manager)
#else
import Network.HTTP.Client (HttpException(..), Manager)
#endif

import qualified Network.HTTP.Client                     as HTTP
import qualified Network.HTTP.Client.TLS                 as HTTP
import qualified Network.HTTP.Types

mkPrettyHttpException :: String -> HttpException -> PrettyHttpException
mkPrettyHttpException url ex =
    PrettyHttpException (renderPrettyHttpException url ex) (toDyn ex)

renderPrettyHttpException :: String -> HttpException -> String
#if MIN_VERSION_http_client(0,5,0)
renderPrettyHttpException _ (InvalidUrlException _ r) =
      "\n"
  <>  "\ESC[1;31mError\ESC[0m: Invalid URL\n"
  <>  "\n"
  <>  "URL: " <> show r <> "\n"
renderPrettyHttpException url (HttpExceptionRequest _ e) =
  case e of
    ConnectionFailure _ ->
          "\n"
      <>  "\ESC[1;31mError\ESC[0m: Remote host not found\n"
      <>  "\n"
      <>  "URL: " <> url <> "\n"
    InvalidDestinationHost host ->
          "\n"
      <>  "\ESC[1;31mError\ESC[0m: Invalid remote host name:\n"
      <>  "\n"
      <>  "Host: " <> show host <> "\n"
    ResponseTimeout ->
          "\n"
      <>  "\ESC[1;31mError\ESC[0m: The remote host took too long to respond\n"
      <>  "\n"
      <>  "URL: " <> url <> "\n"
    StatusCodeException response body -> prefix <> suffix
      where
        prefix
            | statusCode == 401 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Access unauthorized\n"
            | statusCode == 403 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Access forbidden\n"
            | statusCode == 404 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Remote file not found\n"
            | statusCode == 500 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Server-side failure\n"
            | statusCode == 502 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Upstream failure\n"
            | statusCode == 503 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Server temporarily unavailable\n"
            | statusCode == 504 =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: Upstream timeout\n"
            | otherwise =
                    "\n"
                <>  "\ESC[1;31mError\ESC[0m: HTTP request failure\n"

        suffix =
                "\n"
            <>  "HTTP status code: " <> show statusCode <> "\n"
            <>  "\n"
            <>  "URL: " <> url <> "\n"
            <>  message

        statusCode =
            Network.HTTP.Types.statusCode
                (HTTP.responseStatus response)

        message =
            case Data.Text.Encoding.decodeUtf8' body of
                Left _ ->
                        "\n"
                    <>  "Message (non-UTF8 bytes):\n"
                    <>  "\n"
                    <>  truncatedBodyString <> "\n"
                  where
                    bodyString = show body

                    dots = "…"

                    truncatedLength = 80 - length dots

                    truncatedBodyString
                        | truncatedLength < length bodyString =
                            take truncatedLength bodyString <> dots
                        | otherwise =
                            bodyString
                Right "" ->
                    ""
                Right bodyText ->
                        "\n"
                    <>  "Message:\n"
                    <>  "\n"
                    <>  Text.unpack prefixedText
                  where
                    prefixedLines =
                        zipWith combine prefixes (Text.lines bodyText)
                      where
                        prefixes =
                            map (Text.pack . show) [(1 ::Int)..7] ++ [ "…" ]

                        combine n line = n <> "│ " <> line

                    prefixedText = Text.unlines prefixedLines

    e' -> "\n" <> show e' <> "\n"
#else
renderPrettyHttpException url e = case e of
    FailedConnectionException2 _ _ _ e' ->
            "\n"
        <>  "\ESC[1;31mError\ESC[0m: Wrong host:\n"
        <>  "\n"
        <>  "Host: " <> show e' <> "\n"
    InvalidDestinationHost host ->
            "\n"
        <>  "\ESC[1;31mError\ESC[0m: Invalid host name:\n"
        <>  "\n"
        <>  "Host: " <> show host <> "\n"
    ResponseTimeout ->
            "\ESC[1;31mError\ESC[0m: The host took too long to respond\n"
        <>  "\n"
        <>  "URL: " <> url <> "\n"
    e' ->   "\n"
        <>  show e' <> "\n"
#endif

newManager :: IO Manager
newManager = do
    let settings = HTTP.tlsManagerSettings
#ifdef MIN_VERSION_http_client
#if MIN_VERSION_http_client(0,5,0)
          { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) }  -- 30 seconds
#else
          { HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) }  -- 30 seconds
#endif
#endif
    HTTP.newManager settings

data NotCORSCompliant = NotCORSCompliant
    { expectedOrigins :: [ByteString]
    , actualOrigin    :: ByteString
    }

instance Exception NotCORSCompliant

instance Show NotCORSCompliant where
    show (NotCORSCompliant {..}) =
            Dhall.Util._ERROR <> ": Not CORS compliant\n"
        <>  "\n"
        <>  "Dhall supports transitive imports, meaning that an imported expression can\n"
        <>  "import other expressions.  However, a remote import (the \"parent\" import)\n"
        <>  "cannot import another remote import (the \"child\" import) unless the child\n"
        <>  "import grants permission to do using CORS.  The child import must respond with\n"
        <>  "an `Access-Control-Allow-Origin` response header that matches the parent\n"
        <>  "import, otherwise Dhall rejects the import.\n"
        <>  "\n" <> prologue
      where
        prologue =
            case expectedOrigins of
                [ expectedOrigin ] ->
                        "The following parent import:\n"
                    <>  "\n"
                    <>  "↳ " <> show actualOrigin <> "\n"
                    <>  "\n"
                    <>  "... did not match the expected origin:\n"
                    <>  "\n"
                    <>  "↳ " <> show expectedOrigin <> "\n"
                    <>  "\n"
                    <>  "... so import resolution failed.\n"
                [] ->
                        "The child response did not include any `Access-Control-Allow-Origin` header,\n"
                    <>  "so import resolution failed.\n"
                _:_:_ ->
                        "The child response included more than one `Access-Control-Allow-Origin` header,\n"
                    <>  "when only one such header should have been present, so import resolution\n"
                    <>  "failed.\n"
                    <>  "\n"
                    <>  "This may indicate that the server for the child import is misconfigured.\n"

corsCompliant
    :: MonadIO io
    => ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do
    let toOrigin (URL {..}) =
            Data.Text.Encoding.encodeUtf8 (prefix <> "://" <> authority)
          where
            prefix =
                case scheme of
                    HTTP  -> "http"
                    HTTPS -> "https"

    let actualOrigin = toOrigin parentURL

    let childOrigin = toOrigin childURL

    let predicate (header, _) = header == "Access-Control-Allow-Origin"

    let originHeaders = filter predicate responseHeaders

    let expectedOrigins = map snd originHeaders

    case expectedOrigins of
        [expectedOrigin]
            | expectedOrigin == "*" ->
                return ()
            | expectedOrigin == actualOrigin ->
                return ()
        _   | actualOrigin == childOrigin ->
                return ()
            | otherwise ->
                Control.Exception.throwIO (NotCORSCompliant {..})
corsCompliant _ _ _ = return ()

renderComponent :: Text -> Text
renderComponent component = "/" <> URI.Encode.encodeText component

renderQuery :: Text -> Text
renderQuery query = "?" <> query

renderURL :: URL -> Text
renderURL url =
        schemeText
    <>  authority
    <>  pathText
    <>  queryText
  where
    URL {..} = url

    File {..} = path

    Directory {..} = directory

    schemeText = case scheme of
        HTTP  -> "http://"
        HTTPS -> "https://"

    pathText =
            foldMap renderComponent (reverse components)
        <>  renderComponent file

    queryText = foldMap renderQuery query

type HTTPHeader = Network.HTTP.Types.Header

fetchFromHttpUrl
    :: Manager
    -> URL
    -> Maybe [HTTPHeader]
    -> StateT Status IO Text.Text
#ifdef __GHCJS__
fetchFromHttpUrl _ childURL Nothing = do
    let childURLText = renderURL childURL

    let childURLString = Text.unpack childURLText

    -- No need to add a CORS compliance check when using GHCJS.  The browser
    -- will already check the CORS compliance of the following XHR
    (statusCode, body) <- liftIO (JavaScript.XHR.get childURLText)

    case statusCode of
        200 -> return ()
        _   -> fail (childURLString <> " returned a non-200 status code: " <> show statusCode)

    return body
fetchFromHttpUrl _ _ _ = do
    fail "Dhall does not yet support custom headers when built using GHCJS"
#else
fetchFromHttpUrl manager childURL mheaders = do
    let childURLString = Text.unpack (renderURL childURL)

    request <- liftIO (HTTP.parseUrlThrow childURLString)

    let requestWithHeaders =
            case mheaders of
              Nothing      -> request
              Just headers -> request { HTTP.requestHeaders = headers }

    let io = HTTP.httpLbs requestWithHeaders manager

    let handler e = do
            let _ = e :: HttpException
            Control.Exception.throwIO (mkPrettyHttpException childURLString e)

    response <- liftIO (Control.Exception.handle handler io)

    Status {..} <- State.get

    let Chained parentImport = NonEmpty.head _stack

    let parentImportType = importType (importHashed parentImport)

    corsCompliant parentImportType childURL (HTTP.responseHeaders response)

    let bytes = HTTP.responseBody response

    case Data.Text.Lazy.Encoding.decodeUtf8' bytes of
        Left  err  -> liftIO (Control.Exception.throwIO err)
        Right text -> return (Data.Text.Lazy.toStrict text)
#endif