module Network.GitHub.Client
( github
, AuthToken
, GitHub
, runGitHubClientM
, runGitHubNotApiClientM
, runGitHub'
, runGitHub
, GitHubState(..)
, HasGitHub
, embedGitHub
, EmbedGitHub
, AddHeaders
, ReadHeaders
, Single
, Paginated
, setUserAgent
, resetPagination
, recurseOff
, recurseOn
, pageSize
, getLinks
)
where
import Control.Monad (when)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Proxy
import GHC.TypeLits
import Data.String
import Data.Text as T
import Data.Maybe (fromMaybe)
import Servant.API hiding (Link)
import Servant.Client
import Web.HttpApiData
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Client (newManager, Manager)
import Network.HTTP.Link.Types
import Network.HTTP.Link.Parser (parseLinkHeaderBS)
import Network.GitHub.Types (CountedList(..))
newtype AuthToken = AuthToken Text deriving (Eq)
instance IsString AuthToken where
fromString s = AuthToken (fromString s)
instance ToHttpApiData AuthToken where
toQueryParam (AuthToken t) = T.concat ["token ", t]
host :: BaseUrl
host = BaseUrl Https "api.github.com" 443 ""
hostNotApi :: BaseUrl
hostNotApi = BaseUrl Https "github.com" 443 ""
type GitHub = ReaderT (Maybe AuthToken) (StateT GitHubState ClientM)
runGitHubClientM :: ClientM a -> IO (Either ServantError a)
runGitHubClientM comp = do
manager <- newManager tlsManagerSettings
runClientM comp (ClientEnv manager host)
runGitHubNotApiClientM :: ClientM a -> IO (Either ServantError a)
runGitHubNotApiClientM comp = do
manager <- newManager tlsManagerSettings
runClientM comp (ClientEnv manager hostNotApi)
runGitHub' :: GitHub a -> Maybe AuthToken -> ClientM a
runGitHub' comp token = evalStateT (runReaderT comp token) defGitHubState
runGitHub :: GitHub a -> Maybe AuthToken -> IO (Either ServantError a)
runGitHub comp token = runGitHubClientM $ runGitHub' comp token
type family AddHeaders a :: * where
AddHeaders ((sym :: Symbol) :> last)
= (sym :: Symbol) :> AddHeaders last
AddHeaders (first :> last)
= first :> AddHeaders last
AddHeaders last
= Header "User-Agent" Text
:> Header "Authorization" AuthToken
:> ReadHeaders last
type family ReadHeaders a :: * where
ReadHeaders (Get cts [res])
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Get cts (Headers '[Header "Link" Text] [res])
ReadHeaders (Post cts [res])
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Post cts (Headers '[Header "Link" Text] [res])
ReadHeaders (Delete cts [res])
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Delete cts (Headers '[Header "Link" Text] [res])
ReadHeaders (Put cts [res])
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Put cts (Headers '[Header "Link" Text] [res])
ReadHeaders (Patch cts [res])
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Patch cts (Headers '[Header "Link" Text] [res])
ReadHeaders (Get cts (CountedList name res))
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Get cts (Headers '[Header "Link" Text] (CountedList name res))
ReadHeaders (Post cts (CountedList name res))
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Post cts (Headers '[Header "Link" Text] (CountedList name res))
ReadHeaders (Delete cts (CountedList name res))
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Delete cts (Headers '[Header "Link" Text] (CountedList name res))
ReadHeaders (Put cts (CountedList name res))
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Put cts (Headers '[Header "Link" Text] (CountedList name res))
ReadHeaders (Patch cts (CountedList name res))
= QueryParam "page" Int :> QueryParam "per_page" Int
:> Patch cts (Headers '[Header "Link" Text] (CountedList name res))
ReadHeaders otherwise = otherwise
type Single a = Maybe Text -> Maybe AuthToken
-> ClientM a
type Paginated a = Maybe Text -> Maybe AuthToken
-> Maybe Int -> Maybe Int
-> ClientM (Headers '[Header "Link" Text] [a])
type CountedPaginated name a = Maybe Text -> Maybe AuthToken
-> Maybe Int -> Maybe Int
-> ClientM (Headers '[Header "Link" Text] (CountedList name a))
type family EmbedGitHub a :: * where
EmbedGitHub (Single a) = GitHub a
EmbedGitHub (Paginated a) = GitHub [a]
EmbedGitHub (CountedPaginated name a) = GitHub (CountedList name a)
EmbedGitHub (a -> b) = a -> EmbedGitHub b
class HasGitHub a where
embedGitHub :: a -> EmbedGitHub a
instance HasGitHub (Paginated a) where
embedGitHub comp = do
token <- ask
r <- lift $ gets recurse
when r resetPagination
let accumPages acc = do
ua <- gets useragent
p <- gets page
pp <- gets perPage
hres <- lift $ comp (Just ua) token (Just p) (Just pp)
case getHeaders hres of
[("Link", lks)] -> modify $ \pg -> pg {links = parseLinkHeaderBS lks}
_ -> return ()
let acc' = acc ++ getResponse hres
rec <- gets recurse
next <- gets hasNextLink
if rec && next
then do
modify $ \pg -> pg {page = p + 1}
accumPages acc'
else return acc'
lift $ accumPages []
instance HasGitHub (CountedPaginated name a) where
embedGitHub comp = do
token <- ask
r <- lift $ gets recurse
when r resetPagination
let accumPages mbCount acc = do
ua <- gets useragent
p <- gets page
pp <- gets perPage
hres <- lift $ comp (Just ua) token (Just p) (Just pp)
case getHeaders hres of
[("Link", lks)] -> modify $ \pg -> pg {links = parseLinkHeaderBS lks}
_ -> return ()
let response = getResponse hres
count = fromMaybe (totalCount response) mbCount
acc' = acc ++ items response
rec <- gets recurse
next <- gets hasNextLink
if rec && next
then do
modify $ \pg -> pg {page = p + 1}
accumPages (Just count) acc'
else return (CountedList count acc')
lift $ accumPages Nothing []
instance HasGitHub (Single a) where
embedGitHub comp = do
token <- ask
lift $ do
ua <- gets useragent
lift $ comp (Just ua) token
instance HasGitHub (a -> Single b) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> Single c) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> Single d) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> Single e) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> Single f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> Paginated b) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> Paginated c) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> Paginated d) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> Paginated e) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> m -> Paginated f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> CountedPaginated name b) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> CountedPaginated name c) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> CountedPaginated name d) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> CountedPaginated name e) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> m -> CountedPaginated name f) where
embedGitHub comp arg = embedGitHub (comp arg)
github :: (HasClient (AddHeaders api), HasGitHub (Client (AddHeaders api)))
=> Proxy api -> EmbedGitHub (Client (AddHeaders api))
github px = embedGitHub (clientWithHeaders px)
clientWithHeaders :: HasClient (AddHeaders api) => Proxy api -> Client (AddHeaders api)
clientWithHeaders (Proxy :: Proxy api) = client (Proxy :: Proxy (AddHeaders api))
data GitHubState
= GitHubState
{ perPage :: Int
, page :: Int
, links :: Maybe [Link]
, recurse :: Bool
, useragent :: Text
}
defGitHubState :: GitHubState
defGitHubState = GitHubState 100 1 Nothing True "servant-github"
setUserAgent :: Text -> GitHub ()
setUserAgent ua = lift $ modify $ \ghs -> ghs { useragent = ua }
hasNextLink :: GitHubState -> Bool
hasNextLink ghs = maybe False hnl (links ghs)
where hnl = Prelude.any (\ln -> (Rel, "next") `elem` linkParams ln)
resetPagination :: GitHub ()
resetPagination = lift $ modify $ \ghs -> ghs { page = 1, links = Nothing }
recurseOff, recurseOn :: GitHub ()
recurseOff = lift $ modify $ \ghs -> ghs { recurse = False }
recurseOn = lift $ modify $ \ghs -> ghs { recurse = True }
pageSize :: Int -> GitHub ()
pageSize ps = lift $ modify $ \ghs -> ghs { perPage = ps }
getLinks :: GitHub (Maybe [Link])
getLinks = lift $ gets links