{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE QuasiQuotes        #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeOperators      #-}

module Gargantext.MicroServices.ReverseProxy (
  microServicesProxyApp

  -- * Internals
  , removeFromReferer
  ) where

import Prelude

import Conduit
import Data.ByteString qualified as B
import Data.ByteString.Builder
import Data.ByteString.Char8 qualified as C8
import Data.Conduit.List qualified as CC
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import GHC.Generics
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types
import Gargantext.API.Types (HTML)
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_frame_write_url)
import Network.HTTP.ReverseProxy
import Network.HTTP.Types (hCacheControl, RequestHeaders, hReferer, ResponseHeaders, Header)
import Network.HTTP.Types.Header (hHost)
import Network.Wai (Request, rawPathInfo, requestHeaders)
import Servant hiding (Header)
import Servant.Auth.Swagger ()
import Servant.Client.Core.BaseUrl
import Servant.Server.Generic
import Text.RE.Replace hiding (Capture)
import Text.RE.TDFA.ByteString
import Text.RawString.QQ (r)

--
-- Types
--

newtype FrameId = FrameId { _FrameId :: T.Text }
  deriving (Show, Eq, Ord)

-- | The service type that our microservices proxy will handle. At the moment
-- we support only the \"notes\" one.
data ServiceType
  = ST_notes
  deriving Generic

-- | Renders a 'ServiceType' into a string.
renderServiceType :: ServiceType -> String
renderServiceType ST_notes = "notes"

serviceTypeToProxyPath :: ServiceType -> String
serviceTypeToProxyPath ST_notes = "/notes"

instance FromHttpApiData ServiceType where
  parseUrlPiece "notes" = Right ST_notes
  parseUrlPiece x       = Left x

instance FromHttpApiData FrameId where
  parseUrlPiece txt
    | T.all isHexDigit txt = Right (FrameId txt)
    | otherwise            = Left "Invalid FrameId: must be a hexadecimal string"

newtype ProxyDestination =
  ProxyDestination { _ProxyDestination :: BaseUrl }

fwdHost :: ProxyDestination -> C8.ByteString
fwdHost = C8.pack . baseUrlHost . _ProxyDestination

fwdPort :: ProxyDestination -> Int
fwdPort = baseUrlPort . _ProxyDestination

--
-- The API
--

data ReverseProxyAPI mode = ReverseProxyAPI
  { -- | The proxy routes for the \"notes\" microservice (e.g. \"write.frame.gargantext.org\").
    notesServiceProxy :: mode :- "notes" :> NamedRoutes NotesProxy

   -- | proxy everything else. CAREFUL! This has to be the last route, as it will always match.
  , proxyPassAll      :: mode :- Raw
  } deriving Generic

data NotesProxy mode = NotesProxy
  { -- | Turn the notes into slides
    slideEp     :: mode :- Capture "frameId" FrameId :> "slide" :> Raw

  , publishEp   :: mode :- Capture "frameId" FrameId :> "publish" :> Raw

  -- | The config file which contains the server settings for the websocket connection
  -- that we have to overwrite with our settings.
  , configFile    :: mode :- "config"    :> Get '[HTML] T.Text

  -- | Once the connection has been established, this is the websocket endpoint to
  -- poll edits.
  , notesSocket :: mode :- "socket.io" :> NamedRoutes SocketIOProxy

  -- | Called during the websocket connection
  , meEndpoint  :: mode :- "me"        :> Raw

  -- | The initial endpoint which will be hit the first time we want to access the /notes endpoint.
  , notesEp     :: mode :- Capture "frameId" FrameId :> Raw

  -- | The generic routes serving the assets.
  , notesStaticAssets :: mode :- Raw
  } deriving Generic

data SocketIOProxy mode = SocketIOProxy
  { socketIoEp  :: mode :- QueryParam' '[Required] "noteId" FrameId :> Raw
  } deriving Generic

--
-- The Server
--

microServicesProxyApp :: Env -> Application
microServicesProxyApp env = genericServe (server env)

server :: Env -> ReverseProxyAPI AsServer
server env = ReverseProxyAPI {
    notesServiceProxy = notesProxyImplementation env
  , proxyPassAll      = proxyPassServer ST_notes env
  }

-- | A customised configuration file that the \"notes\" service would otherwise send us, that
-- overrides the 'urlpath' to contain the proper service path, so that the websocket connection
-- can be started correctly. If we do not override the 'urlpath', due to the way things work
-- internally, the Javascript of CodiMD would otherwise take the first slice of the URL path
-- (something like `/notes/<frameId>`) and use /that/ as the <frameId>, which would be wrong
-- as it would try to establish a connection to `noteId=notes`.
configJS :: BaseUrl -> ServiceType -> T.Text
configJS bu st = T.pack $ [r|
window.domain  = '|] <> (baseUrlHost bu) <> [r|'
window.urlpath = '|] <> renderServiceType st <> [r|'
window.debug   = false
window.version = '1.2.0'

window.allowedUploadMimeTypes = ["image/jpeg","image/png","image/jpg","image/gif","image/svg+xml"]

window.DROPBOX_APP_KEY = ''
|]

notesProxyImplementation :: Env -> NotesProxy AsServer
notesProxyImplementation env = NotesProxy {
    slideEp     = \frameId  -> slideProxyServer env frameId
  , publishEp   = \frameId  -> publishProxyServer env frameId
  , configFile  = pure $ configJS (proxyUrl env) sty
  , notesSocket = socketIOProxyImplementation sty env
  , meEndpoint  = proxyPassServer sty env
  , notesEp     = \_frameId  -> defaultForwardServer sty id env
  , notesStaticAssets = proxyPassServer sty env
  }
  where
    sty :: ServiceType
    sty = ST_notes

socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer
socketIOProxyImplementation sty env = SocketIOProxy {
    socketIoEp = \_noteId -> defaultForwardServer sty id env
  }

removeServiceFromPath :: ServiceType -> Request -> Request
removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty)
  where
    removeProxyPath :: T.Text -> Request -> Request
    removeProxyPath pth originalRequest =
      originalRequest { rawPathInfo = removePath pth (rawPathInfo originalRequest) }

slideProxyServer :: Env -> FrameId -> ServerT Raw m
slideProxyServer env (FrameId frameId) =
  defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
  where
    changePath :: ByteString -> ByteString
    changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/"

publishProxyServer :: Env -> FrameId -> ServerT Raw m
publishProxyServer env (FrameId frameId) =
  defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
  where
    changePath :: ByteString -> ByteString
    changePath _ = TE.encodeUtf8 $ "/s/" <> frameId

-- Generic server forwarder
proxyPassServer :: ServiceType -> Env -> ServerT Raw m
proxyPassServer sty env = defaultForwardServer sty id env

mkProxyDestination :: Env -> ProxyDestination
mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
  baseUrl <- parseBaseUrl (T.unpack $ env ^. hasConfig . gc_frame_write_url)
  pure $ ProxyDestination baseUrl

--
-- Combinators over the input Request
--

removeFromReferer :: T.Text -> Request -> Request
removeFromReferer pth originalRequest =
  originalRequest { requestHeaders = (Prelude.map tweakReferer (requestHeaders originalRequest))
  }
  where
    tweakReferer :: Header -> Header
    tweakReferer (k,v)
      | k == hReferer
      = (hReferer, removePath pth v)
      | otherwise
      = (k,v)

proxyUrl :: Env -> BaseUrl
proxyUrl env = mkProxyUrl (env ^. hasConfig) (env ^. env_settings . microservicesSettings)


defaultForwardServer :: ServiceType
                     -> (Request -> Request)
                     -> Env
                     -> ServerT Raw m
defaultForwardServer sty presendModifyRequest env =
  Tagged $ waiProxyToSettings forwardRequest (proxySettings) (env ^. env_manager)
  where

    proxyDestination :: ProxyDestination
    proxyDestination = mkProxyDestination env

    proxyUrlStr :: String
    proxyUrlStr = showBaseUrl (proxyUrl env)

    proxySettings :: WaiProxySettings
    proxySettings =
      defaultWaiProxySettings {
          wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks (C8.pack $ proxyUrlStr <> serviceTypeToProxyPath sty)
        , wpsModifyResponseHeaders = \_req _res -> tweakResponseHeaders
        , wpsRedirectCounts = 5
        }

    setHost :: ProxyDestination -> RequestHeaders -> RequestHeaders
    setHost hst hdrs = (hHost, fwdHost hst) : filter ((/=) hHost . fst) hdrs

    setReferer :: RequestHeaders -> RequestHeaders
    setReferer hdrs =
        let hd = (hReferer, C8.pack (proxyUrlStr <> serviceTypeToProxyPath sty))
        in hd : filter ((/=) hReferer . fst) hdrs

    -- | Forwards the request by substituting back the proxied address into the actual one.
    forwardRequest :: Request -> IO WaiProxyResponse
    forwardRequest originalRequest = do
      let proxiedReq = presendModifyRequest . removeServiceFromPath sty $ originalRequest {
                         requestHeaders = (setReferer $ setHost proxyDestination $ noCache $ (requestHeaders originalRequest))
                         }
      pure $ WPRModifiedRequest proxiedReq (ProxyDest (fwdHost proxyDestination) (fwdPort proxyDestination))

--
-- Utility functions
--

noCache :: RequestHeaders -> RequestHeaders
noCache hdrs = (hCacheControl, fromString "no-cache") : filter ((/=) hCacheControl . fst) hdrs

-- | Tweak the response headers so that they will have a bit more permissive
-- 'Content-Security-Policy'.
tweakResponseHeaders :: ResponseHeaders -> ResponseHeaders
tweakResponseHeaders = Prelude.map tweakHeader
  where
    tweakHeader (k,v)
      | k == "Content-Security-Policy"
      = (k, fromString "default-src *; style-src * 'unsafe-inline'; script-src * 'unsafe-inline' 'unsafe-eval'; img-src * data: 'unsafe-inline'; connect-src * 'unsafe-inline'; frame-src *;")
      | otherwise
      = (k,v)

-- | Replaces the relative links in any HTML blob returned by the proxy.
replaceRelativeLinks :: B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
replaceRelativeLinks assetPath = CC.map flushReplace
  where
    --  Replaces the relative links in the proxied page content with proper urls.
    flushReplace :: B.ByteString -> Flush Builder
    flushReplace = Chunk . byteString . replaceIt

    replaceIt :: B.ByteString -> B.ByteString
    replaceIt htmlBlob =
      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~ [re|src="\/build\/|href="\/build\/|src="\/config|src="\/js\/|]
      where
        makeAbsolute _ _loc cap = case capturedText cap of
          "src=\"/build/"  -> Just $ "src=\"" <> assetPath <> "/build/"
          "href=\"/build/" -> Just $ "href=\"" <> assetPath <> "/build/"
          "src=\"/config"  -> Just $ "src=\"" <> assetPath <> "/config"
          "src=\"/js/"     -> Just $ "src=\"" <> assetPath <> "/js/"
          _                -> Just $ assetPath <> capturedText cap

removePath :: T.Text -> ByteString -> ByteString
removePath pth = TE.encodeUtf8 . T.replace pth "" . TE.decodeUtf8
