{-# 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
  { GitHubSettings -> Maybe Token
token :: Maybe Token
  -- ^ The token to use to authenticate with the API.
  , GitHubSettings -> ByteString
userAgent :: ByteString
  -- ^ The user agent to use when interacting with the API: https://developer.github.com/v3/#user-agent-required
  , GitHubSettings -> ByteString
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
  { GitHubManager -> GitHubSettings
ghSettings :: GitHubSettings
  , GitHubManager -> Manager
ghManager :: Manager
  }

-- | Initialize a 'GitHubManager'.
initGitHubManager :: GitHubSettings -> IO GitHubManager
initGitHubManager :: GitHubSettings -> IO GitHubManager
initGitHubManager GitHubSettings
ghSettings = do
  Manager
ghManager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  forall (m :: * -> *) a. Monad m => a -> m a
return GitHubManager{Manager
GitHubSettings
ghManager :: Manager
ghSettings :: GitHubSettings
$sel:ghManager:GitHubManager :: Manager
$sel:ghSettings:GitHubManager :: GitHubSettings
..}

-- | 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 :: forall a.
FromJSON a =>
GitHubManager -> GHEndpoint -> IO (a, PageLinks)
queryGitHubPageIO GitHubManager{Manager
GitHubSettings
ghManager :: Manager
ghSettings :: GitHubSettings
$sel:ghManager:GitHubManager :: GitHubManager -> Manager
$sel:ghSettings:GitHubManager :: GitHubManager -> GitHubSettings
..} GHEndpoint
ghEndpoint = do
  let GitHubSettings{Maybe Token
ByteString
apiVersion :: ByteString
userAgent :: ByteString
token :: Maybe Token
$sel:apiVersion:GitHubSettings :: GitHubSettings -> ByteString
$sel:userAgent:GitHubSettings :: GitHubSettings -> ByteString
$sel:token:GitHubSettings :: GitHubSettings -> Maybe Token
..} = GitHubSettings
ghSettings

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

  let request :: Request
request =
        (String -> Request
parseRequest_ forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ Text
ghUrl forall a. Semigroup a => a -> a -> a
<> GHEndpoint -> Text
endpointPath GHEndpoint
ghEndpoint)
          { method :: ByteString
method = GHEndpoint -> ByteString
renderMethod GHEndpoint
ghEndpoint
          , requestHeaders :: [(HeaderName, ByteString)]
requestHeaders =
              [ (HeaderName
hAccept, ByteString
"application/vnd.github+json")
              , (HeaderName
hUserAgent, ByteString
userAgent)
              ]
                forall a. [a] -> [a] -> [a]
++ [(HeaderName, ByteString)]
apiVersionHeader
                forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName
hAuthorization,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> ByteString
fromToken) Maybe Token
token
          , requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ [KeyValue] -> Value
kvToValue forall a b. (a -> b) -> a -> b
$ GHEndpoint -> [KeyValue]
ghData GHEndpoint
ghEndpoint
          , checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = forall (m :: * -> *).
MonadIO m =>
Request -> Response BodyReader -> m ()
throwErrorStatusCodes
          }

  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
ghManager

  let body :: ByteString
body = forall body. Response body -> body
responseBody Response ByteString
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 :: ByteString
nonEmptyBody = if ByteString -> Bool
ByteStringL.null ByteString
body then forall a. ToJSON a => a -> ByteString
encode () else ByteString
body
      pageLinks :: PageLinks
pageLinks = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Text -> PageLinks
parsePageLinks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {body}. HeaderName -> Response body -> Maybe Text
lookupHeader HeaderName
"Link" forall a b. (a -> b) -> a -> b
$ Response ByteString
response

  case forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
nonEmptyBody of
    Right a
payload -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
payload, PageLinks
pageLinks)
    Left String
e ->
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
        DecodeError
          { $sel:decodeErrorMessage:DecodeError :: Text
decodeErrorMessage = String -> Text
Text.pack String
e
          , $sel:decodeErrorResponse:DecodeError :: Text
decodeErrorResponse = ByteString -> Text
Text.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
ByteStringL.toStrict ByteString
body
          }
  where
    ghUrl :: Text
ghUrl = Text
"https://api.github.com"
    lookupHeader :: HeaderName -> Response body -> Maybe Text
lookupHeader HeaderName
headerName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
headerName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders

data DecodeError = DecodeError
  { DecodeError -> Text
decodeErrorMessage :: Text
  , DecodeError -> Text
decodeErrorResponse :: Text
  }
  deriving (Int -> DecodeError -> ShowS
[DecodeError] -> ShowS
DecodeError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodeError] -> ShowS
$cshowList :: [DecodeError] -> ShowS
show :: DecodeError -> String
$cshow :: DecodeError -> String
showsPrec :: Int -> DecodeError -> ShowS
$cshowsPrec :: Int -> DecodeError -> ShowS
Show)

instance Exception DecodeError

{- GitHubT -}

-- | A simple monad that can run REST calls.
newtype GitHubT m a = GitHubT
  { forall (m :: * -> *) a. GitHubT m a -> ReaderT GitHubManager m a
unGitHubT :: ReaderT GitHubManager m a
  }
  deriving
    ( forall a b. a -> GitHubT m b -> GitHubT m a
forall a b. (a -> b) -> GitHubT m a -> GitHubT m b
forall (m :: * -> *) a b.
Functor m =>
a -> GitHubT m b -> GitHubT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GitHubT m a -> GitHubT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GitHubT m b -> GitHubT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GitHubT m b -> GitHubT m a
fmap :: forall a b. (a -> b) -> GitHubT m a -> GitHubT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GitHubT m a -> GitHubT m b
Functor
    , forall a. a -> GitHubT m a
forall a b. GitHubT m a -> GitHubT m b -> GitHubT m a
forall a b. GitHubT m a -> GitHubT m b -> GitHubT m b
forall a b. GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
forall a b c.
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (GitHubT m)
forall (m :: * -> *) a. Applicative m => a -> GitHubT m a
forall (m :: * -> *) a b.
Applicative m =>
GitHubT m a -> GitHubT m b -> GitHubT m a
forall (m :: * -> *) a b.
Applicative m =>
GitHubT m a -> GitHubT m b -> GitHubT m b
forall (m :: * -> *) a b.
Applicative m =>
GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
<* :: forall a b. GitHubT m a -> GitHubT m b -> GitHubT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
GitHubT m a -> GitHubT m b -> GitHubT m a
*> :: forall a b. GitHubT m a -> GitHubT m b -> GitHubT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GitHubT m a -> GitHubT m b -> GitHubT m b
liftA2 :: forall a b c.
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
<*> :: forall a b. GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
pure :: forall a. a -> GitHubT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GitHubT m a
Applicative
    , forall a. a -> GitHubT m a
forall a b. GitHubT m a -> GitHubT m b -> GitHubT m b
forall a b. GitHubT m a -> (a -> GitHubT m b) -> GitHubT m b
forall {m :: * -> *}. Monad m => Applicative (GitHubT m)
forall (m :: * -> *) a. Monad m => a -> GitHubT m a
forall (m :: * -> *) a b.
Monad m =>
GitHubT m a -> GitHubT m b -> GitHubT m b
forall (m :: * -> *) a b.
Monad m =>
GitHubT m a -> (a -> GitHubT m b) -> GitHubT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> GitHubT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> GitHubT m a
>> :: forall a b. GitHubT m a -> GitHubT m b -> GitHubT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GitHubT m a -> GitHubT m b -> GitHubT m b
>>= :: forall a b. GitHubT m a -> (a -> GitHubT m b) -> GitHubT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GitHubT m a -> (a -> GitHubT m b) -> GitHubT m b
Monad
    , forall a. String -> GitHubT m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}. MonadFail m => Monad (GitHubT m)
forall (m :: * -> *) a. MonadFail m => String -> GitHubT m a
fail :: forall a. String -> GitHubT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> GitHubT m a
MonadFail
    , forall a. IO a -> GitHubT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (GitHubT m)
forall (m :: * -> *) a. MonadIO m => IO a -> GitHubT m a
liftIO :: forall a. IO a -> GitHubT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GitHubT m a
MonadIO
    , forall (m :: * -> *) a. Monad m => m a -> GitHubT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> GitHubT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> GitHubT m a
MonadTrans
    )

instance (MonadUnliftIO m) => MonadUnliftIO (GitHubT m) where
  withRunInIO :: forall b. ((forall a. GitHubT m a -> IO a) -> IO b) -> GitHubT m b
withRunInIO (forall a. GitHubT m a -> IO a) -> IO b
inner = forall (m :: * -> *) a. ReaderT GitHubManager m a -> GitHubT m a
GitHubT forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT GitHubManager m a -> IO a
run ->
      (forall a. GitHubT m a -> IO a) -> IO b
inner (forall a. ReaderT GitHubManager m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. GitHubT m a -> ReaderT GitHubManager m a
unGitHubT)

instance (MonadIO m) => MonadGitHubREST (GitHubT m) where
  queryGitHubPage :: forall a. FromJSON a => GHEndpoint -> GitHubT m (a, PageLinks)
queryGitHubPage GHEndpoint
ghEndpoint = do
    GitHubManager
manager <- forall (m :: * -> *) a. ReaderT GitHubManager m a -> GitHubT m a
GitHubT forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON a =>
GitHubManager -> GHEndpoint -> IO (a, PageLinks)
queryGitHubPageIO GitHubManager
manager GHEndpoint
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 :: forall (m :: * -> *) a.
MonadIO m =>
GitHubSettings -> GitHubT m a -> m a
runGitHubT GitHubSettings
settings GitHubT m a
action = do
  GitHubManager
manager <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GitHubSettings -> IO GitHubManager
initGitHubManager GitHubSettings
settings
  (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` GitHubManager
manager) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. GitHubT m a -> ReaderT GitHubManager m a
unGitHubT forall a b. (a -> b) -> a -> b
$ GitHubT m a
action