{-# 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
GitHubManager -> IO GitHubManager
forall (m :: * -> *) a. Monad m => a -> m a
return GitHubManager :: GitHubSettings -> Manager -> GitHubManager
GitHubManager{Manager
GitHubSettings
ghManager :: Manager
ghSettings :: GitHubSettings
$sel:ghManager:GitHubManager :: Manager
$sel:ghSettings:GitHubManager :: GitHubSettings
..}
queryGitHubPageIO :: FromJSON a => GitHubManager -> GHEndpoint -> IO (a, PageLinks)
queryGitHubPageIO :: 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 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 :: ByteString
method = GHEndpoint -> ByteString
renderMethod GHEndpoint
ghEndpoint
, requestHeaders :: RequestHeaders
requestHeaders =
[ (HeaderName
hAccept, ByteString
"application/vnd.github." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
apiVersion ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"+json")
, (HeaderName
hUserAgent, ByteString
userAgent)
]
RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
-> (Token -> RequestHeaders) -> Maybe Token -> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: []) ((HeaderName, ByteString) -> RequestHeaders)
-> (Token -> (HeaderName, ByteString)) -> Token -> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName
hAuthorization,) (ByteString -> (HeaderName, ByteString))
-> (Token -> ByteString) -> Token -> (HeaderName, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> ByteString
fromToken) Maybe Token
token
, requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [KeyValue] -> Value
kvToValue ([KeyValue] -> Value) -> [KeyValue] -> Value
forall a b. (a -> b) -> a -> b
$ GHEndpoint -> [KeyValue]
ghData GHEndpoint
ghEndpoint
, checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = Request -> Response BodyReader -> IO ()
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 = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response
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 (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 :: Text -> Text -> DecodeError
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 (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 -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
headerName (RequestHeaders -> Maybe ByteString)
-> (Response body -> RequestHeaders)
-> Response body
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response body -> RequestHeaders
forall body. Response body -> RequestHeaders
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
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
{ GitHubT m a -> ReaderT GitHubManager m a
unGitHubT :: ReaderT GitHubManager m a
}
deriving
( a -> GitHubT m b -> GitHubT m a
(a -> b) -> GitHubT m a -> GitHubT m b
(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
<$ :: a -> GitHubT m b -> GitHubT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GitHubT m b -> GitHubT m a
fmap :: (a -> b) -> GitHubT m a -> GitHubT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GitHubT m a -> GitHubT m b
Functor
, Functor (GitHubT m)
a -> GitHubT m a
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)
GitHubT m a -> GitHubT m b -> GitHubT m b
GitHubT m a -> GitHubT m b -> GitHubT m a
GitHubT m (a -> b) -> GitHubT m a -> GitHubT m b
(a -> b -> c) -> GitHubT m a -> GitHubT m b -> GitHubT m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> GitHubT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GitHubT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (GitHubT m)
Applicative
, Applicative (GitHubT m)
a -> GitHubT m a
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)
GitHubT m a -> (a -> GitHubT m b) -> GitHubT m b
GitHubT m a -> GitHubT m b -> GitHubT m b
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 :: a -> GitHubT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> GitHubT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (GitHubT m)
Monad
, Monad (GitHubT m)
Monad (GitHubT m)
-> (forall a. String -> GitHubT m a) -> MonadFail (GitHubT m)
String -> GitHubT m a
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 :: String -> GitHubT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> GitHubT m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (GitHubT m)
MonadFail
, Monad (GitHubT m)
Monad (GitHubT m)
-> (forall a. IO a -> GitHubT m a) -> MonadIO (GitHubT m)
IO a -> GitHubT m a
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 :: IO a -> GitHubT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GitHubT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (GitHubT m)
MonadIO
, m a -> GitHubT m a
(forall (m :: * -> *) a. Monad m => m a -> GitHubT m a)
-> MonadTrans GitHubT
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 :: 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 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 (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 :: 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 (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
runGitHubT :: MonadIO m => GitHubSettings -> GitHubT m a -> m a
runGitHubT :: GitHubSettings -> GitHubT m a -> m a
runGitHubT GitHubSettings
settings GitHubT m a
action = do
GitHubManager
manager <- IO GitHubManager -> m GitHubManager
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