{-# 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
  GitHubManager -> IO GitHubManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GitHubManager{Manager
GitHubSettings
$sel:ghSettings:GitHubManager :: GitHubSettings
$sel:ghManager:GitHubManager :: Manager
ghSettings :: GitHubSettings
ghManager :: Manager
..}

-- | 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
$sel:ghSettings:GitHubManager :: GitHubManager -> GitHubSettings
$sel:ghManager:GitHubManager :: GitHubManager -> Manager
ghSettings :: GitHubSettings
ghManager :: Manager
..} GHEndpoint
ghEndpoint = do
  let GitHubSettings{Maybe Token
ByteString
$sel:token:GitHubSettings :: GitHubSettings -> Maybe Token
$sel:userAgent:GitHubSettings :: GitHubSettings -> ByteString
$sel:apiVersion:GitHubSettings :: GitHubSettings -> ByteString
token :: Maybe Token
userAgent :: ByteString
apiVersion :: ByteString
..} = 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_ (String -> Request) -> String -> Request
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
ghUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GHEndpoint -> Text
endpointPath GHEndpoint
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 ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
ghManager

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

  case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
nonEmptyBody of
    Right a
payload -> (a, PageLinks) -> IO (a, PageLinks)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
payload, PageLinks
pageLinks)
    Left String
e ->
      DecodeError -> IO (a, PageLinks)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DecodeError -> IO (a, PageLinks))
-> DecodeError -> IO (a, PageLinks)
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 (ByteString -> Text) -> ByteString -> Text
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 = (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 (Maybe ByteString -> Maybe Text)
-> (Response body -> Maybe ByteString)
-> Response body
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
headerName ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Response body -> [(HeaderName, ByteString)])
-> Response body
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response body -> [(HeaderName, ByteString)]
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
(Int -> DecodeError -> ShowS)
-> (DecodeError -> String)
-> ([DecodeError] -> ShowS)
-> Show DecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeError -> ShowS
showsPrec :: Int -> DecodeError -> ShowS
$cshow :: DecodeError -> String
show :: DecodeError -> String
$cshowList :: [DecodeError] -> ShowS
showList :: [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 -> b) -> GitHubT m a -> GitHubT m b)
-> (forall a b. a -> GitHubT m b -> GitHubT m a)
-> Functor (GitHubT m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GitHubT m a -> GitHubT m b
fmap :: forall a b. (a -> b) -> GitHubT m a -> GitHubT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GitHubT m b -> GitHubT m a
<$ :: forall a b. a -> GitHubT m b -> GitHubT m a
Functor
    , Functor (GitHubT m)
Functor (GitHubT m) =>
(forall a. a -> GitHubT m a)
-> (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 a b. GitHubT m a -> GitHubT m b -> GitHubT m b)
-> (forall a b. GitHubT m a -> GitHubT m b -> GitHubT m a)
-> Applicative (GitHubT m)
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
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GitHubT m a
pure :: forall a. a -> GitHubT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
<*> :: forall a b. GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
liftA2 :: forall a b c.
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GitHubT m a -> GitHubT m b -> GitHubT m b
*> :: 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 a
<* :: forall a b. GitHubT m a -> GitHubT m b -> GitHubT m a
Applicative
    , Applicative (GitHubT m)
Applicative (GitHubT m) =>
(forall a b. GitHubT m a -> (a -> GitHubT m b) -> GitHubT m b)
-> (forall a b. GitHubT m a -> GitHubT m b -> GitHubT m b)
-> (forall a. a -> GitHubT m a)
-> Monad (GitHubT m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GitHubT m a -> (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 -> GitHubT m b -> GitHubT m b
>> :: forall a b. GitHubT m a -> GitHubT m b -> GitHubT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> GitHubT m a
return :: forall a. a -> GitHubT m a
Monad
    , Monad (GitHubT m)
Monad (GitHubT m) =>
(forall a. String -> GitHubT m a) -> MonadFail (GitHubT m)
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
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> GitHubT m a
fail :: forall a. String -> GitHubT m a
MonadFail
    , Monad (GitHubT m)
Monad (GitHubT m) =>
(forall a. IO a -> GitHubT m a) -> MonadIO (GitHubT m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GitHubT m a
liftIO :: forall a. IO a -> GitHubT m a
MonadIO
    , (forall (m :: * -> *). Monad m => Monad (GitHubT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> GitHubT m a)
-> MonadTrans GitHubT
forall (m :: * -> *). Monad m => Monad (GitHubT m)
forall (m :: * -> *) a. Monad m => m a -> GitHubT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> GitHubT m a
lift :: 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 = ReaderT GitHubManager m b -> GitHubT m b
forall (m :: * -> *) a. ReaderT GitHubManager m a -> GitHubT m a
GitHubT (ReaderT GitHubManager m b -> GitHubT m b)
-> ReaderT GitHubManager m b -> GitHubT m b
forall a b. (a -> b) -> a -> b
$
    ((forall a. ReaderT GitHubManager m a -> IO a) -> IO b)
-> ReaderT GitHubManager m b
forall b.
((forall a. ReaderT GitHubManager m a -> IO a) -> IO b)
-> ReaderT GitHubManager m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT GitHubManager m a -> IO a) -> IO b)
 -> ReaderT GitHubManager m b)
-> ((forall a. ReaderT GitHubManager m a -> IO a) -> IO b)
-> ReaderT GitHubManager m b
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 (ReaderT GitHubManager m a -> IO a
forall a. ReaderT GitHubManager m a -> IO a
run (ReaderT GitHubManager m a -> IO a)
-> (GitHubT m a -> ReaderT GitHubManager m a)
-> GitHubT m a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitHubT m a -> ReaderT GitHubManager m a
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 <- ReaderT GitHubManager m GitHubManager -> GitHubT m GitHubManager
forall (m :: * -> *) a. ReaderT GitHubManager m a -> GitHubT m a
GitHubT ReaderT GitHubManager m GitHubManager
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (a, PageLinks) -> GitHubT m (a, PageLinks)
forall a. IO a -> GitHubT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, PageLinks) -> GitHubT m (a, PageLinks))
-> IO (a, PageLinks) -> GitHubT m (a, PageLinks)
forall a b. (a -> b) -> a -> b
$ GitHubManager -> GHEndpoint -> IO (a, PageLinks)
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 <- IO GitHubManager -> m GitHubManager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GitHubManager -> m GitHubManager)
-> IO GitHubManager -> m GitHubManager
forall a b. (a -> b) -> a -> b
$ GitHubSettings -> IO GitHubManager
initGitHubManager GitHubSettings
settings
  (ReaderT GitHubManager m a -> GitHubManager -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` GitHubManager
manager) (ReaderT GitHubManager m a -> m a)
-> (GitHubT m a -> ReaderT GitHubManager m a) -> GitHubT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitHubT m a -> ReaderT GitHubManager m a
forall (m :: * -> *) a. GitHubT m a -> ReaderT GitHubManager m a
unGitHubT (GitHubT m a -> m a) -> GitHubT m a -> m a
forall a b. (a -> b) -> a -> b
$ GitHubT m a
action