{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
module GitHub.REST.Monad.Class
( MonadGitHubREST(..)
) where
import Control.Monad (void, (<=<))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Identity (IdentityT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Reader (ReaderT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import Data.Aeson (FromJSON, Value)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as Text
import GitHub.REST.Endpoint
import GitHub.REST.PageLinks (PageLinks(..))
class Monad m => MonadGitHubREST m where
{-# MINIMAL queryGitHubPage' #-}
queryGitHubPage' :: FromJSON a => GHEndpoint -> m (Either (Text, Text) (a, PageLinks))
queryGitHubPage :: FromJSON a => GHEndpoint -> m (a, PageLinks)
queryGitHubPage = either fail' pure <=< queryGitHubPage'
where
fail' (message, response) =
let ellipses s = if Text.length s > 100 then take 100 (Text.unpack s) ++ "..." else Text.unpack s
in error $ "Could not decode response:\nmessage = " ++ ellipses message ++ "\nresponse = " ++ ellipses response
queryGitHub :: FromJSON a => GHEndpoint -> m a
queryGitHub = fmap fst . queryGitHubPage
queryGitHubAll :: (FromJSON a, Monoid a) => GHEndpoint -> m a
queryGitHubAll ghEndpoint = do
(payload, pageLinks) <- queryGitHubPage ghEndpoint
case pageNext pageLinks of
Just next -> do
rest <- queryGitHubAll ghEndpoint { endpoint = next, endpointVals = [] }
return $ payload <> rest
Nothing -> return payload
queryGitHub_ :: GHEndpoint -> m ()
queryGitHub_ = void . queryGitHub @_ @Value
instance MonadGitHubREST m => MonadGitHubREST (ReaderT r m) where
queryGitHubPage' = lift . queryGitHubPage'
instance MonadGitHubREST m => MonadGitHubREST (ExceptT e m) where
queryGitHubPage' = lift . queryGitHubPage'
instance MonadGitHubREST m => MonadGitHubREST (IdentityT m) where
queryGitHubPage' = lift . queryGitHubPage'
instance MonadGitHubREST m => MonadGitHubREST (MaybeT m) where
queryGitHubPage' = lift . queryGitHubPage'
instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Lazy.RWST r w s m) where
queryGitHubPage' = lift . queryGitHubPage'
instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Strict.RWST r w s m) where
queryGitHubPage' = lift . queryGitHubPage'
instance MonadGitHubREST m => MonadGitHubREST (Lazy.StateT s m) where
queryGitHubPage' = lift . queryGitHubPage'
instance MonadGitHubREST m => MonadGitHubREST (Strict.StateT s m) where
queryGitHubPage' = lift . queryGitHubPage'
instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Lazy.WriterT w m) where
queryGitHubPage' = lift . queryGitHubPage'
instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Strict.WriterT w m) where
queryGitHubPage' = lift . queryGitHubPage'