{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module App (app) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson
import Data.Maybe
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as TL
import Idp
import Network.HTTP.Conduit
import Network.HTTP.Types
import Network.OAuth.OAuth2
import Network.OAuth.OAuth2 qualified as OAuth2
import Network.OAuth2.Experiment
import Network.OAuth2.Provider.Auth0 qualified as IAuth0
import Network.OAuth2.Provider.Okta qualified as IOkta
import Network.Wai qualified as WAI
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Static
import Session
import Types
import Utils
import Views
import Web.Scotty
import Prelude

------------------------------
-- App
------------------------------

myServerPort :: Int
myServerPort = 9988

app :: IO ()
app =
  putStrLn ("Starting Server. http://localhost:" ++ show myServerPort)
    >> waiApp
    >>= run myServerPort

waiApp :: IO WAI.Application
waiApp = do
  cache <- initCacheStore
  re <- runExceptT $ do
    myAuth0Idp <- IAuth0.mkAuth0Idp "freizl.auth0.com"
    myOktaIdp <- IOkta.mkOktaIdp "dev-494096.okta.com"
    -- For the sake of simplicity for this demo App,
    -- I store user data in MVar in server side.
    -- It means user session shared across browsers.
    -- which simplify my testing cross browsers.
    -- I am sure you don't want to this for your production services.
    initIdps cache (myAuth0Idp, myOktaIdp)
    pure (myAuth0Idp, myOktaIdp)
  case re of
    Left e -> Prelude.error $ TL.unpack $ "unable to init cache: " <> e
    Right r -> do
      putStrLn "global cache has been initialized."
      initApp cache r

initApp :: CacheStore -> (Idp IAuth0.Auth0, Idp IOkta.Okta) -> IO WAI.Application
initApp cache idps = scottyApp $ do
  middleware $ staticPolicy (addBase "public/assets")
  defaultHandler globalErrorHandler
  get "/" $ indexH cache
  get "/oauth2/callback" $ callbackH cache
  get "/logout" $ logoutH cache
  get "/refresh" $ refreshH cache

  get "/login/password-grant" $ testPasswordGrantTypeH idps
  get "/login/cc-grant" (testClientCredentialGrantTypeH idps)

  get "/login/jwt-grant" testJwtBearerGrantTypeH

--------------------------------------------------

-- * Handlers

--------------------------------------------------

redirectToHomeM :: ActionM ()
redirectToHomeM = redirect "/"

globalErrorHandler :: Text -> ActionM ()
globalErrorHandler t = status status500 >> html t

refreshH :: CacheStore -> ActionM ()
refreshH c = do
  idpData@(DemoAppEnv idp sData) <- readIdpParam c
  exceptToActionM $ do
    newToken <- doRefreshToken idpData
    liftIO $ putStrLn ">>>>>> got new token"
    upsertDemoAppEnv c (DemoAppEnv idp (sData {oauth2Token = Just newToken}))
  redirectToHomeM

logoutH :: CacheStore -> ActionM ()
logoutH c = do
  idpData <- readIdpParam c
  liftIO (removeKey c (toLabel idpData))
  redirectToHomeM

indexH :: CacheStore -> ActionM ()
indexH c = liftIO (allValues c) >>= overviewTpl

callbackH :: CacheStore -> ActionM ()
callbackH c = do
  -- https://hackage.haskell.org/package/scotty-0.12/docs/Web-Scotty.html#t:Param
  -- (Text, Text)
  pas <- params
  let stateP = paramValue "state" pas
  when (null stateP) (raise "callbackH: no state from callback request")
  let codeP = paramValue "code" pas
  when (null codeP) (raise "callbackH: no code from callback request")
  exceptToActionM $ do
    idpData <- lookupKey c (TL.takeWhile (/= '.') (head stateP))
    fetchTokenAndUser c (head codeP) idpData
  redirectToHomeM

testPasswordGrantTypeH :: (Idp IAuth0.Auth0, Idp IOkta.Okta) -> ActionM ()
testPasswordGrantTypeH (auth0, okta) = do
  idpP <- paramValue "i" <$> params
  when (null idpP) (raise "testPasswordGrantTypeH: no idp parameter in the password grant type login request")
  let i = head idpP
  case i of
    "auth0" -> testPasswordGrantType (auth0PasswordGrantApp auth0)
    "okta" -> testPasswordGrantType (oktaPasswordGrantApp okta)
    _ -> raise $ "unable to find password grant type flow for idp " <> i
  where
    testPasswordGrantType ::
      ( HasTokenRequest a
      , 'ResourceOwnerPassword ~ a
      , HasDemoLoginUser b
      , HasUserInfoRequest a
      , FromJSON (IdpUserInfo b)
      ) =>
      IdpApplication a b ->
      ActionM ()
    testPasswordGrantType idpApp = do
      exceptToActionM $ do
        mgr <- liftIO $ newManager tlsManagerSettings
        token <- withExceptT oauth2ErrorToText $ conduitTokenRequest idpApp mgr
        user <- tryFetchUser mgr token idpApp
        liftIO $ print user
      redirectToHomeM

testClientCredentialGrantTypeH :: (Idp IAuth0.Auth0, Idp IOkta.Okta) -> ActionM ()
testClientCredentialGrantTypeH (auth0, okta) = do
  idpP <- paramValue "i" <$> params
  when (null idpP) (raise "testClientCredentialsGrantTypeH: no idp parameter in the password grant type login request")
  let i = head idpP
  case i of
    "auth0" -> testClientCredentialsGrantType (auth0ClientCredentialsGrantApp auth0)
    "okta" -> liftIO (oktaClientCredentialsGrantApp okta) >>= testClientCredentialsGrantType
    _ -> raise $ "unable to find password grant type flow for idp " <> i

testClientCredentialsGrantType ::
  forall a b.
  ( 'ClientCredentials ~ b
  ) =>
  HasTokenRequest b =>
  IdpApplication b a ->
  ActionM ()
testClientCredentialsGrantType testApp = do
  exceptToActionM $ do
    mgr <- liftIO $ newManager tlsManagerSettings
    -- client credentials flow is meant for machine to machine
    -- hence wont be able to hit /userinfo endpoint
    tokenResp <- withExceptT oauth2ErrorToText $ conduitTokenRequest testApp mgr
    liftIO $ print tokenResp
  redirectToHomeM

-- Only testing google for now
testJwtBearerGrantTypeH :: ActionM ()
testJwtBearerGrantTypeH = do
  exceptToActionM $ do
    testApp <- googleServiceAccountApp
    mgr <- liftIO $ newManager tlsManagerSettings
    tokenResp <- withExceptT oauth2ErrorToText $ conduitTokenRequest testApp mgr
    user <- tryFetchUser mgr tokenResp testApp
    liftIO $ print user
  redirectToHomeM

--------------------------------------------------

-- * Services

--------------------------------------------------

exceptToActionM :: Show a => ExceptT Text IO a -> ActionM a
exceptToActionM e = do
  result <- liftIO $ runExceptT e
  either raise return result

readIdpParam :: CacheStore -> ActionM DemoAppEnv
readIdpParam c = do
  pas <- params
  let idpP = paramValue "idp" pas
  when (null idpP) redirectToHomeM
  exceptToActionM $ lookupKey c (head idpP)

fetchTokenAndUser ::
  CacheStore ->
  Text ->
  DemoAppEnv ->
  ExceptT Text IO ()
fetchTokenAndUser c exchangeToken idpData@(DemoAppEnv (DemoAuthorizationApp idpAppConfig) DemoAppPerAppSessionData {..}) = do
  mgr <- liftIO $ newManager tlsManagerSettings
  token <-
    if isSupportPkce idpAppConfig
      then do
        when (isNothing authorizePkceCodeVerifier) (throwE "Unable to find code verifier")
        withExceptT oauth2ErrorToText $
          conduitPkceTokenRequest
            idpAppConfig
            mgr
            (ExchangeToken $ TL.toStrict exchangeToken, fromJust authorizePkceCodeVerifier)
      else withExceptT oauth2ErrorToText $ conduitTokenRequest idpAppConfig mgr (ExchangeToken $ TL.toStrict exchangeToken)
  liftIO $ do
    putStrLn "Found access token"
    print token
  luser <- tryFetchUser mgr token idpAppConfig
  liftIO $ do
    print luser
  updateIdp c idpData luser token
  where
    updateIdp :: MonadIO m => CacheStore -> DemoAppEnv -> DemoLoginUser -> OAuth2Token -> ExceptT Text m ()
    updateIdp c1 (DemoAppEnv iApp sData) luser token =
      upsertDemoAppEnv
        c1
        (DemoAppEnv iApp $ sData {loginUser = Just luser, oauth2Token = Just token})

oauth2ErrorToText :: TokenRequestError -> Text
oauth2ErrorToText e = TL.pack $ "conduitTokenRequest - cannot fetch access token. error detail: " ++ show e

tryFetchUser ::
  forall a b.
  (HasDemoLoginUser a, HasUserInfoRequest b, FromJSON (IdpUserInfo a)) =>
  Manager ->
  OAuth2Token ->
  IdpApplication b a ->
  ExceptT Text IO DemoLoginUser
tryFetchUser mgr at idpAppConfig = do
  user <- withExceptT bslToText $ conduitUserInfoRequest idpAppConfig mgr (accessToken at)
  pure $ toLoginUser @a user

doRefreshToken :: DemoAppEnv -> ExceptT Text IO OAuth2Token
doRefreshToken (DemoAppEnv (DemoAuthorizationApp idpAppConfig) (DemoAppPerAppSessionData {..})) = do
  at <- maybe (throwE "no token response found for idp") pure oauth2Token
  rt <- maybe (throwE "no refresh token found for idp") pure (OAuth2.refreshToken at)
  withExceptT (TL.pack . show) $ do
    mgr <- liftIO $ newManager tlsManagerSettings
    conduitRefreshTokenRequest idpAppConfig mgr rt