{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

{-|
Module      :  GitHub.REST.Monad
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
Stability   :  experimental
Portability :  portable

Defines 'GitHubT' and 'MonadGitHubREST', a monad transformer and type class that gives a monad @m@
the capability to query the GitHub REST API.
-}
module GitHub.REST.Monad (
  -- * MonadGitHubREST API
  MonadGitHubREST (..),
  queryGitHubPageIO,

  -- * GitHubManager
  GitHubManager,
  initGitHubManager,

  -- * GitHubSettings
  GitHubSettings (..),

  -- * GitHubT
  GitHubT,
  runGitHubT,
) where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO (..))
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans (MonadTrans)
import Data.Aeson (FromJSON, eitherDecode, encode)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as ByteStringL
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Network.HTTP.Client (
  Manager,
  Request (..),
  RequestBody (..),
  Response (..),
  httpLbs,
  newManager,
  parseRequest_,
  throwErrorStatusCodes,
 )
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (hAccept, hAuthorization, hUserAgent)
import UnliftIO.Exception (Exception, throwIO)

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif

import GitHub.REST.Auth (Token, fromToken)
import GitHub.REST.Endpoint (GHEndpoint (..), endpointPath, renderMethod)
import GitHub.REST.KeyValue (kvToValue)
import GitHub.REST.Monad.Class
import GitHub.REST.PageLinks (PageLinks, parsePageLinks)

{- GitHubSettings -}

data GitHubSettings = GitHubSettings
  { token :: Maybe Token
  -- ^ The token to use to authenticate with the API.
  , userAgent :: ByteString
  -- ^ The user agent to use when interacting with the API: https://developer.github.com/v3/#user-agent-required
  , apiVersion :: ByteString
  -- ^ The [version of the GitHub REST API](https://docs.github.com/en/rest/overview/api-versions) being used.
  -- If left empty, GitHub will assume a default version.
  }

{- GitHubManager -}

data GitHubManager = GitHubManager
  { ghSettings :: GitHubSettings
  , ghManager :: Manager
  }

-- | Initialize a 'GitHubManager'.
initGitHubManager :: GitHubSettings -> IO GitHubManager
initGitHubManager ghSettings = do
  ghManager <- newManager tlsManagerSettings
  return GitHubManager{..}

-- | Same as 'queryGitHubPage', except explicitly taking in 'GitHubManager' and running
--  in IO.
--
--  Useful for implementing 'MonadGitHubREST' outside of 'GitHubT'.
queryGitHubPageIO :: (FromJSON a) => GitHubManager -> GHEndpoint -> IO (a, PageLinks)
queryGitHubPageIO GitHubManager{..} ghEndpoint = do
  let GitHubSettings{..} = ghSettings

  let apiVersionHeader
        | "" <- apiVersion = []
        | otherwise = [("X-GitHub-Api-Version", apiVersion)]

  let request =
        (parseRequest_ $ Text.unpack $ ghUrl <> endpointPath ghEndpoint)
          { method = renderMethod ghEndpoint
          , requestHeaders =
              [ (hAccept, "application/vnd.github+json")
              , (hUserAgent, userAgent)
              ]
                ++ apiVersionHeader
                ++ maybe [] ((: []) . (hAuthorization,) . fromToken) token
          , requestBody = RequestBodyLBS $ encode $ kvToValue $ ghData ghEndpoint
          , checkResponse = throwErrorStatusCodes
          }

  response <- httpLbs request ghManager

  let body = responseBody response
      -- empty body always errors when decoding, even if the end user doesn't care about the
      -- result, like creating a branch, when the endpoint doesn't return anything.
      --
      -- In this case, pretend like the server sent back an encoded version of the unit type,
      -- so that `queryGitHub endpoint` would be typed to `m ()`.
      nonEmptyBody = if ByteStringL.null body then encode () else body
      pageLinks = maybe mempty parsePageLinks . lookupHeader "Link" $ response

  case eitherDecode nonEmptyBody of
    Right payload -> return (payload, pageLinks)
    Left e ->
      throwIO $
        DecodeError
          { decodeErrorMessage = Text.pack e
          , decodeErrorResponse = Text.decodeUtf8 $ ByteStringL.toStrict body
          }
  where
    ghUrl = "https://api.github.com"
    lookupHeader headerName = fmap Text.decodeUtf8 . lookup headerName . responseHeaders

data DecodeError = DecodeError
  { decodeErrorMessage :: Text
  , decodeErrorResponse :: Text
  }
  deriving (Show)

instance Exception DecodeError

{- GitHubT -}

-- | A simple monad that can run REST calls.
newtype GitHubT m a = GitHubT
  { unGitHubT :: ReaderT GitHubManager m a
  }
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadFail
    , MonadIO
    , MonadTrans
    )

instance (MonadUnliftIO m) => MonadUnliftIO (GitHubT m) where
  withRunInIO inner = GitHubT $
    withRunInIO $ \run ->
      inner (run . unGitHubT)

instance (MonadIO m) => MonadGitHubREST (GitHubT m) where
  queryGitHubPage ghEndpoint = do
    manager <- GitHubT ask
    liftIO $ queryGitHubPageIO manager ghEndpoint

-- | Run the given 'GitHubT' action with the given token and user agent.
--
--  The token will be sent with each API request -- see 'Token'. The user agent is also required for
--  each API request -- see https://developer.github.com/v3/#user-agent-required.
runGitHubT :: (MonadIO m) => GitHubSettings -> GitHubT m a -> m a
runGitHubT settings action = do
  manager <- liftIO $ initGitHubManager settings
  (`runReaderT` manager) . unGitHubT $ action