hoauth2-demo-1.6.0: src/Types.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}

module Types where

import Data.Aeson
import Data.Default
import Data.Maybe
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as TL
import Network.OAuth.OAuth2 hiding (RefreshToken)
import Network.OAuth2.Experiment
import Network.OAuth2.Provider.Auth0 qualified as IAuth0
import Network.OAuth2.Provider.AzureAD qualified as IAzureAD
import Network.OAuth2.Provider.Dropbox qualified as IDropbox
import Network.OAuth2.Provider.Facebook qualified as IFacebook
import Network.OAuth2.Provider.Fitbit qualified as IFitbit
import Network.OAuth2.Provider.Github qualified as IGithub
import Network.OAuth2.Provider.Google qualified as IGoogle
import Network.OAuth2.Provider.Linkedin qualified as ILinkedin
import Network.OAuth2.Provider.Okta qualified as IOkta
import Network.OAuth2.Provider.Slack qualified as ISlack
import Network.OAuth2.Provider.StackExchange qualified as IStackExchange
import Network.OAuth2.Provider.Twitter qualified as ITwitter
import Network.OAuth2.Provider.Weibo qualified as IWeibo
import Network.OAuth2.Provider.ZOHO qualified as IZOHO
import Text.Mustache
import Text.Mustache qualified as M
import Prelude hiding (id)

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

-- * Demo Login User

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

newtype DemoLoginUser = DemoLoginUser
  { loginUserName :: TL.Text
  -- TODO: maybe email
  }
  deriving (Eq, Show)

class HasDemoLoginUser a where
  toLoginUser :: IdpUserInfo a -> DemoLoginUser

instance HasDemoLoginUser IAuth0.Auth0 where
  toLoginUser :: IAuth0.Auth0User -> DemoLoginUser
  toLoginUser IAuth0.Auth0User {..} = DemoLoginUser {loginUserName = name}

instance HasDemoLoginUser IGoogle.Google where
  toLoginUser :: IGoogle.GoogleUser -> DemoLoginUser
  toLoginUser IGoogle.GoogleUser {..} = DemoLoginUser {loginUserName = name}

instance HasDemoLoginUser IZOHO.ZOHO where
  toLoginUser resp =
    let us = IZOHO.users resp
     in case us of
          [] -> DemoLoginUser {loginUserName = "ZOHO: no user found"}
          (a : _) -> DemoLoginUser {loginUserName = IZOHO.fullName a}

instance HasDemoLoginUser IAzureAD.AzureAD where
  toLoginUser :: IAzureAD.AzureADUser -> DemoLoginUser
  toLoginUser ouser =
    DemoLoginUser
      { loginUserName = IAzureAD.email ouser <> " " <> IAzureAD.name ouser
      }

instance HasDemoLoginUser IWeibo.Weibo where
  toLoginUser :: IWeibo.WeiboUID -> DemoLoginUser
  toLoginUser ouser = DemoLoginUser {loginUserName = TL.pack $ show $ IWeibo.uid ouser}

instance HasDemoLoginUser IDropbox.Dropbox where
  toLoginUser :: IDropbox.DropboxUser -> DemoLoginUser
  toLoginUser ouser = DemoLoginUser {loginUserName = IDropbox.displayName $ IDropbox.name ouser}

instance HasDemoLoginUser IFacebook.Facebook where
  toLoginUser :: IFacebook.FacebookUser -> DemoLoginUser
  toLoginUser ouser = DemoLoginUser {loginUserName = IFacebook.name ouser}

instance HasDemoLoginUser IFitbit.Fitbit where
  toLoginUser :: IFitbit.FitbitUser -> DemoLoginUser
  toLoginUser ouser = DemoLoginUser {loginUserName = IFitbit.userName ouser}

instance HasDemoLoginUser IGithub.Github where
  toLoginUser :: IGithub.GithubUser -> DemoLoginUser
  toLoginUser guser = DemoLoginUser {loginUserName = IGithub.name guser}

instance HasDemoLoginUser ILinkedin.Linkedin where
  toLoginUser :: ILinkedin.LinkedinUser -> DemoLoginUser
  toLoginUser ILinkedin.LinkedinUser {..} =
    DemoLoginUser
      { loginUserName = localizedFirstName <> " " <> localizedLastName
      }

instance HasDemoLoginUser ITwitter.Twitter where
  toLoginUser :: ITwitter.TwitterUserResp -> DemoLoginUser
  toLoginUser ITwitter.TwitterUserResp {..} = DemoLoginUser {loginUserName = ITwitter.name twitterUserRespData}

instance HasDemoLoginUser IOkta.Okta where
  toLoginUser :: IOkta.OktaUser -> DemoLoginUser
  toLoginUser ouser = DemoLoginUser {loginUserName = IOkta.name ouser}

instance HasDemoLoginUser ISlack.Slack where
  toLoginUser :: ISlack.SlackUser -> DemoLoginUser
  toLoginUser ouser = DemoLoginUser {loginUserName = ISlack.name ouser}

instance HasDemoLoginUser IStackExchange.StackExchange where
  toLoginUser :: IStackExchange.StackExchangeResp -> DemoLoginUser
  toLoginUser IStackExchange.StackExchangeResp {..} =
    case items of
      [] -> DemoLoginUser {loginUserName = TL.pack "Cannot find stackexchange user"}
      (user : _) -> DemoLoginUser {loginUserName = IStackExchange.displayName user}

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

-- * Authorization Apps

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

-- | Use for creating list of IDPs
-- Heterogenous collections
-- https://wiki.haskell.org/Heterogenous_collections
data DemoAuthorizationApp
  = forall a b.
    ( HasDemoLoginUser b
    , FromJSON (IdpUserInfo b)
    , 'AuthorizationCode ~ a
    , HasPkceAuthorizeRequest a
    , HasPkceTokenRequest a
    , HasUserInfoRequest a
    , HasIdpAppName a
    , HasAuthorizeRequest a
    , HasTokenRequest a
    , HasRefreshTokenRequest a
    ) =>
    DemoAuthorizationApp (IdpApplication a b)

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

-- * Env

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

data DemoAppPerAppSessionData = DemoAppPerAppSessionData
  { loginUser :: Maybe DemoLoginUser
  , oauth2Token :: Maybe OAuth2Token
  , authorizePkceCodeVerifier :: Maybe CodeVerifier
  , authorizeAbsUri :: TL.Text
  }

data DemoAppEnv = DemoAppEnv DemoAuthorizationApp DemoAppPerAppSessionData

instance Default DemoAppPerAppSessionData where
  def =
    DemoAppPerAppSessionData
      { loginUser = Nothing
      , oauth2Token = Nothing
      , authorizePkceCodeVerifier = Nothing
      , authorizeAbsUri = ""
      }

instance Show DemoAppEnv where
  show :: DemoAppEnv -> String
  show = TL.unpack . toLabel

toLabel :: DemoAppEnv -> TL.Text
toLabel (DemoAppEnv (DemoAuthorizationApp idpAppConfig) _) = getIdpAppName idpAppConfig

-- simplify use case to only allow one idp instance for now.
instance Eq DemoAppEnv where
  a == b = toLabel a == toLabel b

instance Ord DemoAppEnv where
  a `compare` b = toLabel a `compare` toLabel b

newtype TemplateData = TemplateData
  { idpTemplateData :: [DemoAppEnv]
  }
  deriving (Eq)

-- * Mustache instances

instance ToMustache DemoAppEnv where
  toMustache (DemoAppEnv (DemoAuthorizationApp idpAppConfig) DemoAppPerAppSessionData {..}) =
    M.object
      [ "codeFlowUri" ~> authorizeAbsUri
      , "isLogin" ~> isJust loginUser
      , "user" ~> loginUser
      , "name" ~> TL.unpack (getIdpAppName idpAppConfig)
      ]

instance ToMustache DemoLoginUser where
  toMustache t' =
    M.object
      ["name" ~> loginUserName t']

instance ToMustache TemplateData where
  toMustache td' =
    M.object
      [ "idps" ~> idpTemplateData td'
      ]

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

-- * HasIdpAppName

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

class HasIdpAppName (a :: GrantTypeFlow) where
  getIdpAppName :: IdpApplication a i -> Text

instance HasIdpAppName 'ClientCredentials where
  getIdpAppName :: IdpApplication 'ClientCredentials i -> Text
  getIdpAppName ClientCredentialsIDPApplication {..} = idpAppName

instance HasIdpAppName 'ResourceOwnerPassword where
  getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text
  getIdpAppName ResourceOwnerPasswordIDPApplication {..} = idpAppName

instance HasIdpAppName 'AuthorizationCode where
  getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text
  getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName