{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | A module for common OAuth flows.
--
-- Consider using authenticate-oauth package
module Biz.Auth
  ( -- * OAuth
    OAuthResponse (..),
    OAuthArgs (..),

    -- * GitHub Authentication
    GitHub (..),
    githubOauth,

    -- * Servant Helpers
    SetCookies,
    liveCookieSettings,
    testCookieSettings,
  )
where

import Alpha
import qualified Data.Aeson as Aeson
import Network.HTTP.Req ((/:), (=:))
import qualified Network.HTTP.Req as Req
import Servant (Header, Headers)
import qualified Servant.Auth.Server as Auth
import qualified System.Envy as Envy

-- | Use this instead of 'mempty' for explicity.
notset :: Text
notset = "notset"

-- | Wrapper around 'Auth.SetCookie' that you can put in a servant path
-- descriptor.
type SetCookies ret =
  (Headers '[Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie] ret)

liveCookieSettings :: Auth.CookieSettings
liveCookieSettings =
  Auth.defaultCookieSettings
    { Auth.cookieIsSecure = Auth.Secure,
      -- disable XSRF protection because we don't use any javascript
      Auth.cookieXsrfSetting = Nothing
    }

testCookieSettings :: Auth.CookieSettings
testCookieSettings =
  Auth.defaultCookieSettings
    { Auth.cookieIsSecure = Auth.NotSecure,
      Auth.cookieXsrfSetting = Nothing
    }

-- | These are arguments that a 3rd-party OAuth provider needs in order for us
-- to authenticate a user.
data OAuthArgs = OAuthArgs
  { clientSecret :: Text,
    clientId :: Text,
    clientState :: Text
  }
  deriving (Generic, Show)

instance Envy.DefConfig OAuthArgs where
  defConfig =
    OAuthArgs
      { clientSecret = notset,
        clientId = notset,
        clientState = notset
      }

instance Envy.FromEnv OAuthArgs

-- | A type for parsing JSON auth responses, used in 'githubOauth' below.
-- Should be moved to Biz.Auth with others.
data OAuthResponse = OAuthResponse
  { access_token :: Text,
    scope :: Text,
    token_type :: Text
  }
  deriving (Generic, Aeson.FromJSON)

newtype GitHub = GitHub OAuthArgs
  deriving (Show, Generic)

instance Envy.DefConfig GitHub where
  defConfig =
    GitHub
      <| OAuthArgs
        { clientSecret = notset,
          clientId = notset,
          clientState = notset
        }

instance Envy.FromEnv GitHub where
  fromEnv Nothing =
    GitHub
      </ Envy.gFromEnvCustom
        Envy.Option
          { Envy.dropPrefixCount = 0,
            Envy.customPrefix = "GITHUB"
          }
        Nothing
  fromEnv (Just (GitHub x)) =
    GitHub
      </ Envy.gFromEnvCustom
        Envy.Option
          { Envy.dropPrefixCount = 0,
            Envy.customPrefix = "GITHUB"
          }
        (Just x)

-- | POST to GitHub's OAuth service and get the user's oAuth token.
githubOauth ::
  GitHub ->
  -- | This should be GitHub.Token but GitHub.Auth doesn't export Token.
  Text ->
  IO OAuthResponse
githubOauth (GitHub OAuthArgs {..}) code =
  accessTokenRequest
    /> Req.responseBody
    |> Req.runReq Req.defaultHttpConfig
  where
    accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse)
    accessTokenRequest =
      Req.req
        Req.POST
        (Req.https "github.com" /: "login" /: "oauth" /: "access_token")
        Req.NoReqBody
        Req.jsonResponse
        <| "client_id"
        =: clientId
        <> "client_secret"
        =: clientSecret
        <> "code"
        =: code
        <> "state"
        =: clientState