content: {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  import           Blaze.ByteString.Builder     (fromByteString)
  import           Control.Applicative          ((<$>))
  import           Control.Concurrent           (forkIO, killThread, newEmptyMVar,
                                                 putMVar, takeMVar, threadDelay)
  import           Control.Exception            (IOException, bracket,
                                                 onException, try)
  import           Control.Monad                (forever, unless)
  import           Control.Monad.IO.Class       (liftIO)
  import           Control.Monad.Trans.Resource (runResourceT)
  import           Data.Maybe                   (fromMaybe)
  import qualified Data.ByteString              as S
  import qualified Data.ByteString.Char8        as S8
  import qualified Data.ByteString.Lazy.Char8   as L8
  import           Data.Char                    (toUpper)
  import           Data.Conduit                 (await, yield, (.|), runConduit,
                                                 awaitForever)
  import qualified Data.Conduit.Binary          as CB
  import qualified Data.Conduit.List            as CL
  import           Data.Conduit.Network         (ServerSettings,
                                                 appSink, appSource,
                                                 clientSettings, runTCPClient,
                                                 runTCPServer, serverSettings)
  import qualified Data.IORef                   as I
  import           Data.Streaming.Network       (AppData,
                                                 bindPortTCP, setAfterBind)
  import qualified Network.HTTP.Conduit         as HC
  import           Network.HTTP.ReverseProxy    (ProxyDest (..),
                                                 WaiProxyResponse (..),
                                                 defaultOnExc, rawProxyTo, rawTcpProxyTo,
                                                 WaiProxySettings (..),
                                                 SetIpHeader (..),
                                                 defaultWaiProxySettings,
                                                 waiProxyToSettings,
                                                 waiProxyTo)
  import           Network.HTTP.Types           (status200, status500)
  import qualified Network.Socket
  import           Network.Wai                  (rawPathInfo, responseLBS,
                                                 responseStream, requestHeaders)
  import qualified Network.Wai
  import           Network.Wai.Handler.Warp     (defaultSettings, runSettings,
                                                 setBeforeMainLoop, setPort)
  import           System.IO.Unsafe             (unsafePerformIO)
  import           UnliftIO                     (timeout)
  import           UnliftIO.IORef
  import           Test.Hspec                   (describe, hspec, it, shouldBe)
  
  nextPort :: I.IORef Int
  nextPort = unsafePerformIO $ I.newIORef 15452
  {-# NOINLINE nextPort #-}
  
  getPort :: IO Int
  getPort = do
      port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
      esocket <- try $ bindPortTCP port "127.0.0.1"
      case esocket of
          Left (_ :: IOException) -> getPort
          Right socket -> do
              Network.Socket.close socket
              return port
  
  withWApp :: Network.Wai.Application -> (Int -> IO ()) -> IO ()
  withWApp app f = do
      port <- getPort
      baton <- newEmptyMVar
      bracket
          (forkIO $ runSettings (settings port baton)
              app `onException` putMVar baton ())
          killThread
          (const $ takeMVar baton >> f port)
    where
      settings port baton
          = setPort port
          $ setBeforeMainLoop (putMVar baton ())
            defaultSettings
  
  withCApp :: (AppData -> IO ()) -> (Int -> IO ()) -> IO ()
  withCApp app f = do
      port <- getPort
      baton <- newEmptyMVar
      let start = putMVar baton ()
          settings = setAfterBind (const start) (serverSettings port "*" :: ServerSettings)
      bracket
          (forkIO $ runTCPServer settings app `onException` start)
          killThread
          (const $ takeMVar baton >> f port)
  
  withMan :: (HC.Manager -> IO ()) -> IO ()
  withMan = (HC.newManager HC.tlsManagerSettings >>=)
  
  main :: IO ()
  main = hspec $
      describe "http-reverse-proxy" $ do
          it "works" $
              let content = "mainApp"
               in withMan $ \manager ->
                  withWApp (\_ f -> f $ responseLBS status200 [] content) $ \port1 ->
                  withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                  withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->
                  withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                      lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port4
                      lbs `shouldBe` content
  
          it "modified path" $
              let content = "/somepath"
                  app req f = f $ responseLBS status200 [] $ L8.fromChunks [rawPathInfo req]
                  modReq pdest req = return $ WPRModifiedRequest
                      (req { rawPathInfo = content })
                      pdest
               in withMan $ \manager ->
                  withWApp app $ \port1 ->
                  withWApp (waiProxyTo (modReq $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                  withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->
                  withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                      lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port4
                      S8.concat (L8.toChunks lbs) `shouldBe` content
          it "deals with streaming data" $
              let app _ f = f $ responseStream status200 [] $ \sendChunk flush -> forever $ do
                      sendChunk $ fromByteString "hello"
                      flush
                      liftIO $ threadDelay 10000000
               in withMan $ \manager ->
                  withWApp app $ \port1 ->
                  withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 -> do
                      req <- HC.parseUrlThrow $ "http://127.0.0.1:" ++ show port2
                      mbs <- runResourceT $ timeout 1000000 $ do
                          res <- HC.http req manager
                          runConduit $ HC.responseBody res .| await
                      mbs `shouldBe` Just (Just "hello")
          it "passes on body length" $
              let app req f = f $ responseLBS
                      status200
                      [("uplength", show' $ Network.Wai.requestBodyLength req)]
                      ""
                  body = "some body"
                  show' Network.Wai.ChunkedBody = "chunked"
                  show' (Network.Wai.KnownLength i) = S8.pack $ show i
               in withMan $ \manager ->
                  withWApp app $ \port1 ->
                  withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 -> do
                      req' <- HC.parseUrlThrow $ "http://127.0.0.1:" ++ show port2
                      let req = req'
                              { HC.requestBody = HC.RequestBodyBS body
                              }
                      mlen <- runResourceT $ do
                          res <- HC.http req manager
                          return $ lookup "uplength" $ HC.responseHeaders res
                      mlen `shouldBe` Just (show'
                                              $ Network.Wai.KnownLength
                                              $ fromIntegral
                                              $ S.length body)
          it "upgrade to raw" $
              let app _ f = f $ flip Network.Wai.responseRaw fallback $ \src sink -> do
                      let src' = do
                              bs <- liftIO src
                              unless (S8.null bs) $ yield bs >> src'
                          sink' = awaitForever $ liftIO . sink
                      runConduit $ src' .| CL.iterM print .| CL.map (S8.map toUpper) .| sink'
                  fallback = responseLBS status500 [] "fallback used"
               in withMan $ \manager ->
                  withWApp app $ \port1 ->
                  withWApp (waiProxyTo (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                      runTCPClient (clientSettings port2 "127.0.0.1") $ \ad -> do
                          runConduit $ yield "GET / HTTP/1.1\r\nUpgrade: websockET\r\n\r\n" .| appSink ad
                          runConduit $ yield "hello" .| appSink ad
                          (runConduit $ appSource ad .| CB.take 5) >>= (`shouldBe` "HELLO")
          it "get real ip" $
              let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req)
                  httpWithForwardedFor url = liftIO $ do
                    man <- HC.newManager HC.tlsManagerSettings
                    oreq <- liftIO $ HC.parseUrlThrow url
                    let req = oreq { HC.requestHeaders = [("X-Forwarded-For", "127.0.1.1, 127.0.0.1"), ("Connection", "close")] }
                    HC.responseBody <$> HC.httpLbs req man
                  waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }
               in withMan $ \manager ->
                  withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 ->
                  withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                  withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->
                  withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                      lbs <- httpWithForwardedFor $ "http://127.0.0.1:" ++ show port4
                      lbs `shouldBe` "127.0.1.1"
          it "get real ip 2" $
              let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req)
                  httpWithForwardedFor url = liftIO $ do
                    man <- HC.newManager HC.tlsManagerSettings
                    oreq <- liftIO $ HC.parseUrlThrow url
                    let req = oreq { HC.requestHeaders = [("X-Forwarded-For", "127.0.1.1"), ("Connection", "close")] }
                    HC.responseBody <$> HC.httpLbs req man
                  waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }
               in withMan $ \manager ->
                  withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 ->
                  withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                  withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->
                  withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                      lbs <- httpWithForwardedFor $ "http://127.0.0.1:" ++ show port4
                      lbs `shouldBe` "127.0.1.1"
          it "get real ip 3" $
              let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req)
                  httpWithForwardedFor url = liftIO $ do
                    man <- HC.newManager HC.tlsManagerSettings
                    oreq <- liftIO $ HC.parseUrlThrow url
                    let req = oreq { HC.requestHeaders = [("Connection", "close")] }
                    HC.responseBody <$> HC.httpLbs req man
                  waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }
               in withMan $ \manager ->
                  withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 ->
                  withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                  withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 -> do
                  withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                      lbs <- httpWithForwardedFor $ "http://127.0.0.1:" ++ show port4
                      lbs `shouldBe` "127.0.0.1"
          it "doesn't fail on invalid utf8 in x-forwarded-for header" $
              let getRealIp req = L8.fromStrict $ fromMaybe "" $ lookup "x-real-ip" (requestHeaders req)
                  httpWithForwardedFor url = liftIO $ do
                    man <- HC.newManager HC.tlsManagerSettings
                    oreq <- liftIO $ HC.parseUrlThrow url
                    let req = oreq { HC.requestHeaders = [("X-Forwarded-For", "\xbf\xf0\x9f\x92\xa1"), ("Connection", "close")] }
                    HC.responseBody <$> HC.httpLbs req man
                  waiProxyTo' getDest onError = waiProxyToSettings getDest defaultWaiProxySettings { wpsOnExc = onError, wpsSetIpHeader = SIHFromHeader }
               in withMan $ \manager ->
                  withWApp (\r f -> f $ responseLBS status200 [] $ getRealIp r ) $ \port1 ->
                  withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 ->
                  withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->
                  withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                      lbs <- httpWithForwardedFor $ "http://127.0.0.1:" ++ show port4
                      lbs `shouldBe` "\xbf\xf0\x9f\x92\xa1"
          it "performs log action" $
            let ioref :: IO (IORef Int)
                ioref = newIORef 1
                performLogAction :: IORef Int -> IO ()
                performLogAction ref = writeIORef ref 2
                waiProxyTo' getDest onError manager ref  =
                  waiProxyToSettings
                    getDest
                    defaultWaiProxySettings
                      { wpsOnExc = onError,
                        wpsSetIpHeader = SIHFromHeader,
                        wpsLogRequest = const (performLogAction ref)
                      }
                    manager
             in withMan $ \manager ->
                  withWApp (\_ f -> f $ responseLBS status200 [] "works") $ \port1 -> do
                    ref <- ioref
                    withWApp (waiProxyTo' (const $ return $ WPRProxyDest $ ProxyDest "127.0.0.1" port1) defaultOnExc manager ref) $ \port2 ->
                      withCApp (rawProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port2)) $ \port3 ->
                        withCApp (rawTcpProxyTo (ProxyDest "127.0.0.1" port3)) $ \port4 -> do
                          _ <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port4
                          lhs <- liftIO $ readIORef ref
                          lhs `shouldBe` 2
      {- FIXME
      describe "waiToRaw" $ do
          it "works" $ do
              let content = "waiToRaw"
                  waiApp = const $ return $ responseLBS status200 [] content
                  rawApp = waiToRaw waiApp
              withCApp (rawProxyTo (const $ return $ Left rawApp)) $ \port -> do
                  lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port
                  lbs `shouldBe` content
          it "sends files" $ do
              let content = "PONG"
                  fp = "pong"
                  waiApp = const $ return $ responseFile status200 [] fp Nothing
                  rawApp = waiToRaw waiApp
              writeFile fp content
              withCApp (rawProxyTo (const $ return $ Left rawApp)) $ \port -> do
                  lbs <- HC.simpleHttp $ "http://127.0.0.1:" ++ show port
                  lbs `shouldBe` L8.pack content
      -}
  