{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Control.Monad (when)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.Default (Default (..))
import Data.Foldable (for_)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import qualified Network.HTTP.Client as HC
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types (status500, statusCode)
import Network.Wai
  ( Application
  , rawPathInfo
  , responseLBS
  )
import Network.Wai.Handler.Warp (Port, testWithApplication)
import Network.Wai.Middleware.Delegate
  ( ProxySettings (..)
  , delegateToProxy
  )
import System.Environment (lookupEnv)
import System.IO
import Test.Fetch (fetch)
import Test.Hspec
import Test.Hspec.TmpProc
  ( HList (..)
  , HostIpAddress
  , Pinged (..)
  , Proc (..)
  , ProcHandle
  , SvcURI
  , hAddr
  , handleOf
  , startupAll
  , tdescribe
  , terminateAll
  , toPinged
  , (&:)
  )
import qualified Test.Hspec.TmpProc as TmpProc
import Test.HttpReply
import Test.TestRequests
  ( RequestBuilder (..)
  , buildRequest
  , testNotProxiedRequests
  , testOverRedirectedRequests
  , testRequests
  )
import Test.WithExtras
  ( defaultTlsSettings
  , testWithTLSApplication
  )


defaultTestSettings :: ProxySettings
defaultTestSettings = def {proxyHost = "httpbin.org", proxyTimeout = 2}


redirectTestSettings :: ProxySettings
redirectTestSettings = defaultTestSettings {proxyRedirectCount = 2}


tmpHostSettings :: ByteString -> ProxySettings -> ProxySettings
tmpHostSettings tmpHost settings = settings {proxyHost = tmpHost}


main :: IO ()
main = do
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering
  dumpDebug' <- lookupEnv "DEBUG"
  let dumpDebug = maybe False (const True) dumpDebug'
  hspec $ tdescribe "when accessing http-bin in docker" $ do
    -- TODO: reenable when a secure proxy is added to the docker tests
    -- secureProxyTest dumpDebug
    -- secureNotProxiedTest dumpDebug
    insecureRedirectTest dumpDebug
    insecureNotProxiedTest dumpDebug
    insecureProxyTest dumpDebug


defaultTestDelegate :: ProxySettings -> IO Application
defaultTestDelegate s = do
  -- delegate everything but /status/418
  let handleFunnyStatus req = rawPathInfo req /= "/status/418"
      dummyApp _ respond = respond $ responseLBS status500 [] "I should have been proxied"

  manager <- newTlsManager
  return $ delegateToProxy s manager handleFunnyStatus dummyApp


toHost :: HttpBinFixture -> ByteString
toHost fixture = encodeUtf8 $ hAddr $ handleOf @"tmp-http-bin" Proxy fixture


fixtureApp :: HttpBinFixture -> IO Application
fixtureApp fixture = defaultTestDelegate $ tmpHostSettings (toHost fixture) defaultTestSettings


redirectApp :: HttpBinFixture -> IO Application
redirectApp fixture = defaultTestDelegate $ tmpHostSettings (toHost fixture) redirectTestSettings


testWithInsecureProxy' :: ((HttpBinFixture, Port) -> IO a) -> IO a
testWithInsecureProxy' = TmpProc.testWithApplication onlyHttpBin fixtureApp


testWithSecureProxy' :: ((HttpBinFixture, Port) -> IO a) -> IO a
testWithSecureProxy' action = do
  tls <- defaultTlsSettings
  TmpProc.testWithTLSApplication tls onlyHttpBin fixtureApp action


testWithInsecureProxy :: (Port -> IO ()) -> IO ()
testWithInsecureProxy = testWithApplication (defaultTestDelegate defaultTestSettings)


testWithSecureProxy :: (Port -> IO ()) -> IO ()
testWithSecureProxy withPort = do
  tls <- defaultTlsSettings
  testWithTLSApplication tls (defaultTestDelegate defaultTestSettings) withPort


testWithInsecureRedirects' :: ((HttpBinFixture, Port) -> IO ()) -> IO ()
testWithInsecureRedirects' = TmpProc.testWithApplication onlyHttpBin redirectApp


tmpHostBuilder :: HttpBinFixture -> RequestBuilder -> RequestBuilder
tmpHostBuilder fixture builder = builder {rbHost = toHost fixture}


onDirectAndProxy :: (HttpReply -> HttpReply -> IO ()) -> Bool -> Int -> RequestBuilder -> IO ()
onDirectAndProxy f debug testProxyPort builder = do
  let proxiedBuilder = builder {rbHost = "localhost", rbPort = Just testProxyPort}
  directReq <- buildRequest builder
  proxiedReq <- buildRequest proxiedBuilder

  when debug $ do
    putStrLn "---------------"
    putStrLn "Direct Request:"
    putStrLn "---------------"
    print directReq
    putStrLn "----------------"
    putStrLn "Proxied Request:"
    putStrLn "----------------"
    print proxiedReq
  proxied <- fetch proxiedReq
  direct <- fetch directReq
  when debug $ do
    putStrLn "Direct:"
    putStrLn "-------"
    print direct
    putStrLn "Proxied:"
    putStrLn "--------"
    print proxied
  f direct proxied


insecureNotProxiedTest :: Bool -> Spec
insecureNotProxiedTest debug =
  let scheme = "HTTP"
      desc = "Proxy on " ++ scheme ++ " should fail"
      assertNeq = onDirectAndProxy assertHttpRepliesDiffer debug
   in aroundAll testWithInsecureProxy' $ describe desc $ do
        for_ testNotProxiedRequests $ \(title, modifier) -> do
          let shouldNotMatch (f, p) = assertNeq p $ modifier $ tmpHostBuilder f def
          it (scheme ++ " " ++ title) shouldNotMatch


insecureRedirectTest :: Bool -> Spec
insecureRedirectTest debug =
  let scheme = "HTTP"
      desc = "Proxy over " ++ scheme ++ " with too many redirects differs"
      assertNeq = onDirectAndProxy assertHttpRepliesDiffer debug
   in aroundAll testWithInsecureRedirects' $ describe desc $ do
        for_ testOverRedirectedRequests $ \(title, modifier) -> do
          let shouldNotMatch (f, p) = assertNeq p $ modifier $ tmpHostBuilder f def
          it (scheme ++ " " ++ title) shouldNotMatch


insecureProxyTest :: Bool -> Spec
insecureProxyTest debug =
  let scheme = "HTTP"
      desc = "Simple " ++ scheme ++ " proxying:"
      assertEq = onDirectAndProxy assertHttpRepliesAreEq debug
   in aroundAll testWithInsecureProxy' $ describe desc $ do
        for_ testRequests $ \(title, modifier) -> do
          let shouldMatch (f, p) = assertEq p $ modifier $ tmpHostBuilder f def
          it (scheme ++ " " ++ title) shouldMatch


secureNotProxiedTest :: Bool -> Spec
secureNotProxiedTest debug =
  let scheme = "HTTPS"
      desc = "Proxy on " ++ scheme ++ " should fail"
      assertNeq = onDirectAndProxy assertHttpRepliesDiffer debug
      def' = def {rbSecure = True}
   in aroundAll testWithSecureProxy' $ describe desc $ do
        for_ testNotProxiedRequests $ \(title, modifier) -> do
          let shouldNotMatch (f, p) = assertNeq p $ modifier $ tmpHostBuilder f def'
          it (scheme ++ " " ++ title) shouldNotMatch


secureProxyTest :: Bool -> Spec
secureProxyTest debug =
  let scheme = "HTTPS"
      desc = "Simple " ++ scheme ++ " proxying:"
      assertEq = onDirectAndProxy assertHttpRepliesAreEq debug
      def' = def {rbSecure = True}
   in aroundAll testWithSecureProxy' $ describe desc $ do
        for_ testRequests $ \(title, modifier) -> do
          let shouldMatch (f, p) = assertEq p $ modifier $ tmpHostBuilder f def'
          it (scheme ++ " " ++ title) shouldMatch


-- | A data type representing a connection to a HttpBin server.
data HttpBin = HttpBin


type HttpBinFixture = HList '[ProcHandle HttpBin]


onlyHttpBin :: HList '[HttpBin]
onlyHttpBin = HttpBin &: HNil


setupHttpBin :: IO HttpBinFixture
setupHttpBin = startupAll onlyHttpBin


withHttpBin :: SpecWith HttpBinFixture -> Spec
withHttpBin = beforeAll setupHttpBin . afterAll terminateAll


-- | Run HttpBin using tmp-proc.
instance Proc HttpBin where
  type Image HttpBin = "kennethreitz/httpbin"
  type Name HttpBin = "tmp-http-bin"


  uriOf = mkUri'
  runArgs = []
  reset _ = pure ()
  ping = ping'


-- | Make a uri access the http-bin server.
mkUri' :: HostIpAddress -> SvcURI
mkUri' ip = "http://" <> C8.pack (Text.unpack ip) <> "/"


ping' :: ProcHandle a -> IO Pinged
ping' handle = toPinged @HC.HttpException Proxy $ do
  gotStatus <- handleGet handle "/status/200"
  if gotStatus == 200 then pure OK else pure NotOK


-- | Determine the status from a Get on localhost.
handleGet :: ProcHandle a -> Text -> IO Int
handleGet handle urlPath = do
  let theUri = "http://" <> hAddr handle <> "/" <> Text.dropWhile (== '/') urlPath
  manager <- HC.newManager HC.defaultManagerSettings
  getReq <- HC.parseRequest $ Text.unpack theUri
  statusCode . HC.responseStatus <$> HC.httpLbs getReq manager