{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE ViewPatterns        #-}
{-# OPTIONS_GHC -Wno-orphans     #-}

module Gargantext.MicroServices.ReverseProxy (
  microServicesProxyApp

  -- * Internals
  , removeFromReferer
  , ReverseProxyAPI(..)
  , NotesProxy(..)
  , FrameId(..)
  ) where

import Conduit
import Data.ByteString qualified as B
import Data.ByteString.Builder
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Search qualified as BS
import Data.Cache qualified as InMemory
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.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Node.ShareURL qualified as Share
import Gargantext.API.Routes.Named.Private
import Gargantext.API.Routes.Named.Share (ShareLink(..))
import Gargantext.API.ThrowAll (throwAllRoutes)
import Gargantext.Core.Config (gc_frames, gc_frontend_config, mkProxyUrl, hasConfig)
import Gargantext.Core.Config.Types (f_write_url, fc_cookie_settings)
import Gargantext.Database.Admin.Types.Node (NodeType(..), NodeId (..))
import Gargantext.Prelude hiding (Handler)
import Network.HTTP.ReverseProxy
import Network.HTTP.Types (hCacheControl, RequestHeaders, hReferer, ResponseHeaders, Header)
import Network.HTTP.Types.Header (hHost, hSetCookie)
import Network.HTTP.Types.Status (status302)
import Network.Wai
import Network.Wai.Util (redirect')
import Servant hiding (Header)
import Servant.Auth.Server
import Servant.Auth.Server.Internal.AddSetCookie ()
import Servant.Auth.Swagger ()
import Servant.Client.Core.BaseUrl
import Servant.Server.Generic
import Text.RE.Replace hiding (Capture)
import Text.RE.TDFA.ByteString


-- -- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
-- instance {-# OVERLAPPING #-}
--   ( AddSetCookies ('S n) a a
--   , AddSetCookies ('S n) b b'
--   )
--   => AddSetCookies ('S n) (a :<|> b) (a :<|> b') where
--   addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

--
-- Types
--

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

instance ToHttpApiData FrameId where
  toUrlPiece = toUrlPiece . _FrameId

-- | 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" :> MkProtectedAPI (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"    :> Raw

  -- | 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
                        :> QueryParam "node_id" NodeId
                        :> 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
--

type ProxyCache = InMemory.Cache FrameId NodeId


microServicesProxyApp :: ProxyCache -> Env -> Application
microServicesProxyApp cache env = genericServeTWithContext identity (server cache env) cfg
  where
    cfg :: Context AuthContext
    cfg = env ^. env_jwt_settings
       :. env ^. env_config . gc_frontend_config . fc_cookie_settings
       :. EmptyContext

server :: ProxyCache -> Env -> ReverseProxyAPI (AsServerT Handler)
server cache env = ReverseProxyAPI {
    notesServiceProxy = \case
      (Authenticated _autUser) -> notesProxyImplementation cache env
      _ -> throwAllRoutes err401 $ notesProxyImplementation cache env
   , proxyPassAll      = proxyPassServer ST_notes env
   }

-- | Customise the 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`.
customiseConfigJS :: BaseUrl -> ServiceType -> ConduitT B.ByteString (Flush Builder) IO ()
customiseConfigJS bu st = CC.map flushReplace
  where
    --  Replaces the relative links in the proxied page content with proper urls.
    flushReplace :: B.ByteString -> Flush Builder
    flushReplace = Chunk . byteString . replaceWindowDomain . replaceUrlPath

    replaceWindowDomain :: B.ByteString -> B.ByteString
    replaceWindowDomain htmlBlob =
      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~
        [re|window.domain.*=*'.*'$|]
      where
        makeAbsolute _ _loc cap = case capturedText cap of
          _                -> Just $ C8.pack $ "window.domain = '" <> (baseUrlHost bu) <> "'"

    replaceUrlPath :: B.ByteString -> B.ByteString
    replaceUrlPath htmlBlob =
      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~
        [re|window.urlpath.*=*'.*'$|]
      where
        makeAbsolute _ _loc cap = case capturedText cap of
          _                -> Just $ C8.pack $ "window.urlpath = '" <> renderServiceType st <> "'"

configFileSettings :: Env -> ServiceType -> WaiProxySettings
configFileSettings env sty =
  defaultWaiProxySettings
    { wpsProcessBody = \_req _res -> Just $ customiseConfigJS (proxyUrl env) sty
    }

notesProxyImplementation :: ProxyCache -> Env -> NotesProxy AsServer
notesProxyImplementation cache env = NotesProxy {
    slideEp     = \frameId  -> slideProxyServer env frameId
  , publishEp   = \frameId  -> publishProxyServer cache env frameId
  , configFile  = defaultForwardServerWithSettings sty identity env (configFileSettings env sty)
  , notesSocket = socketIOProxyImplementation sty env
  , meEndpoint  = proxyPassServer sty env
  , notesEp     = \frameId mbNodeId -> notesForwardServer cache frameId mbNodeId sty identity env
  , notesStaticAssets = proxyPassServer sty env
  }
  where
    sty :: ServiceType
    sty = ST_notes

socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer
socketIOProxyImplementation sty env = SocketIOProxy {
    socketIoEp = \_noteId -> defaultForwardServer sty identity identity 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) }) identity env
  where
    changePath :: ByteString -> ByteString
    changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/"

-- | Rather than using the publish feature of HedgeDoc / CodiMD, we rely on our
-- own URL sharing feauture.
publishProxyServer :: ProxyCache -> Env -> FrameId -> ServerT Raw m
publishProxyServer cache env frameId = Tagged $ \req res -> do
  -- Lookup the cookie (indexed by frameId) which will contain the node id.
  mbNodeId <- InMemory.lookup cache frameId
  case mbNodeId of
    Nothing -> do
     forwardRaw req res
    Just nodeId
      -> do
        -- Using a mock for now.
        case Share.get_url (Just Notes) (Just nodeId) (_env_config env) of
          Left _e ->
            -- Invalid link, treat this as a normal proxy
           forwardRaw req res
          Right (ShareLink uri) ->
            -- Follow the redirect
            res =<< redirect' status302 [] uri

  where

    forwardRaw =
      unTagged (defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) identity env)

    changePath :: ByteString -> ByteString
    changePath _ = TE.encodeUtf8 $ "/s/" <> (_FrameId frameId)

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

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

--
-- Combinators over the input Request
--

removeFromReferer :: T.Text -> Request -> Request
removeFromReferer pth originalRequest =
  originalRequest { requestHeaders = 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)

notesForwardServer :: ProxyCache
                   -> FrameId
                   -> Maybe NodeId
                   -> ServiceType
                   -> (Request -> Request)
                   -> Env
                   -> ServerT Raw m
notesForwardServer cache frameId mbNodeId sty presendModifyRequest env =
  case mbNodeId of
    Nothing
      -> defaultForwardServer sty presendModifyRequest identity env
    Just nid
      -> do
       -- Persist the node id in the cache
       Tagged $ \req res -> do
         InMemory.insert cache frameId nid
         unTagged (defaultForwardServer sty presendModifyRequest (setFrameIdCookie frameId nid) env) req res
  where
    setFrameIdCookie :: FrameId -> NodeId -> (ResponseHeaders -> ResponseHeaders)
    setFrameIdCookie (FrameId (T.unpack -> fid)) (UnsafeMkNodeId nid) origHeaders
      = let sk = (hSetCookie, fromString $ fid <> "=" <> show nid)
      in sk : origHeaders

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

    proxyDestination :: ProxyDestination
    proxyDestination = mkProxyDestination env

    proxyUrlStr :: String
    proxyUrlStr = showBaseUrl (proxyUrl env)

    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))

defaultForwardServer :: ServiceType
                     -> (Request -> Request)
                     -> (ResponseHeaders -> ResponseHeaders)
                     -> Env
                     -> ServerT Raw m
defaultForwardServer sty presendModifyRequest mapRespHeaders env =
  defaultForwardServerWithSettings sty presendModifyRequest env $
    defaultWaiProxySettings {
        wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks proxyDestination proxyPath
      , wpsModifyResponseHeaders = \_req _res -> mapRespHeaders . tweakResponseHeaders
      , wpsRedirectCounts = 5
      }
  where
    proxyPath = C8.pack $ proxyUrlStr <> serviceTypeToProxyPath sty

    proxyDestination :: ProxyDestination
    proxyDestination = mkProxyDestination env

    proxyUrlStr :: String
    proxyUrlStr = showBaseUrl (proxyUrl env)

--
-- 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 = 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 :: ProxyDestination -> B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
replaceRelativeLinks proxyTarget 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
                         . BL.toStrict
                         . BS.replace (C8.pack . showBaseUrl . _ProxyDestination $ proxyTarget) assetPath
                         . 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
