{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module GitHub.REST.Monad (
MonadGitHubREST (..),
queryGitHubPageIO,
GitHubManager,
initGitHubManager,
GitHubSettings (..),
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)
data GitHubSettings = GitHubSettings
{ GitHubSettings -> Maybe Token
token :: Maybe Token
, GitHubSettings -> ByteString
userAgent :: ByteString
, GitHubSettings -> ByteString
apiVersion :: ByteString
}
data GitHubManager = GitHubManager
{ GitHubManager -> GitHubSettings
ghSettings :: GitHubSettings
, GitHubManager -> Manager
ghManager :: Manager
}
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
..}
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
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
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
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