packages feed

servant-github (empty) → 0.1.0.0

raw patch · 9 files changed

+594/−0 lines, 9 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, either, hspec, http-link-header, servant, servant-client, servant-github, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Finlay Thompson (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import System.Exit+import System.Environment+import Control.Monad.IO.Class+import Control.Monad+import Data.Monoid+import Data.Maybe+import Data.String+import Data.Text as T+import Data.Text.IO as T++import Network.GitHub++main :: IO ()+main = do++    -- Get AuthToken from environment variable+    token <- fmap fromString <$> lookupEnv "GITHUB_TOKEN"++    -- Require the token for this to work+    when (not $ isJust token) $ do+        T.putStrLn "Please set the GITHUB_TOKEN env variable" +        exitFailure++    -- Run GitHub computation, print errors if there are any+    errors <- runGitHub (printTeams "dragonfly-science") token+    case errors of+        Left e  -> liftIO $ print e+        Right _ -> exitSuccess++printOrgsAndTeams :: GitHub ()+printOrgsAndTeams = do+    os <- userOrganisations+    forM_ os $ \o -> do+        liftIO $ T.putStrLn (orgLogin o)+        printTeams (orgLogin o)++printTeams :: OrgLogin -> GitHub ()+printTeams ol = do+    teams <- organisationTeams ol+    forM_ teams $ \t -> do+        liftIO $ T.putStrLn $ "  " <> teamName t+        members <- teamMembers (teamId t)+        liftIO $ T.putStrLn $ "    " <> T.intercalate ", " [ memberLogin m | m <- members]+        repos <- teamRepositories (teamId t)+        liftIO $ T.putStrLn $ "    " <> T.intercalate ", " [ repositoryName r | r <- repos]
+ servant-github.cabal view
@@ -0,0 +1,74 @@+name:                servant-github+version:             0.1.0.0+synopsis:            Bindings to GitHub API using servant.+description:         This package provides a servant-client based client+                     for accessing the <https://developer.github.com/v3/ GitHub API v3>.+                     .+                     The github client is provided through the 'Network.GitHub.GitHub' monad,+                     which provides support for managing the user-agent (a requirement +                     for github), an authentication token, and, pagination+                     support when the resulting value is a list.+                     .+                     >+                     >  import System.Environment+                     >  import Network.Github+                     >  +                     >  main = do+                     >      token <- fmap fromString <$> lookupEnv "GITHUB_TOKEN"+                     >      result <- runGitHub userOrganisations token+                     >      case result of+                     >          Left e  ->  print e+                     >          Right orgs -> mapM_ print orgs+                     >+                            +homepage:            http://github.com/finlay/servant-github#readme+license:             BSD3+license-file:        LICENSE+author:              Finlay Thompson+maintainer:          finlay.thompson@gmail.com+copyright:           2015 Finlay Thompson+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Network.GitHub+                     , Network.GitHub.API+                     , Network.GitHub.Client+                     , Network.GitHub.Types+  build-depends:       base >= 4.7 && < 5+                     , aeson+                     , either+                     , http-link-header+                     , servant+                     , servant-client+                     , text+                     , transformers+  default-language:    Haskell2010++executable servant-github-example+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , either+                     , text+                     , transformers+                     , servant-github+  default-language:    Haskell2010++test-suite servant-github-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , hspec+                     , QuickCheck+                     , servant-github+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/finlay/servant-github
+ src/Network/GitHub.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Network.GitHub+-- Copyright   : (c) Finlay Thompson, 2015+-- License     : BSD3+-- Maintainer  : finlay.thompson@gmail.com+-- Stability   : experimental+-- +-- The GitHub monad provides support for:+-- +--     - Managing the authentication token. It can be Nothing, in which case+--       no Authentication header is sent to the API,+-- +--     - Setting the User-agent header string. This defaults to "servant-github",+--       but can be set inside the GitHub monad using the 'setUserAgent', and+-- +--     - Keeping track of the pagination in the case of calls that return lists +--       of objects.++module Network.GitHub +    ( +    -- * GitHub API calls+    -- $client+      userOrganisations+    , organisationTeams+    , getTeam+    , teamMembers+    , teamRepositories+    -- * GitHub monad+    -- $github+    , GitHub+    , runGitHub+    , AuthToken+    , setUserAgent+    -- * Pagination+    -- $pagination+    , resetPagination+    , recurseOff+    , recurseOn+    , pageSize+    , getLinks+    , module Network.GitHub.API+    , module Network.GitHub.Types+    )+where++import Data.Proxy++import Network.GitHub.API+import Network.GitHub.Types+import Network.GitHub.Client++-- $client+--+-- Functions that directly access the GitHub API. These functions all run +-- in the 'GitHub' monad.+--++-- | Get list of 'Organisation' records for authorised user+userOrganisations :: GitHub [Organisation]+userOrganisations = github (Proxy :: Proxy UserOrganisations)++-- | Get list of 'Team' records, given the organisation login+organisationTeams :: OrgLogin -> GitHub [Team]+organisationTeams = github (Proxy :: Proxy OrganisationTeams)++-- | Get the 'Team' record associated to a TeamId+getTeam :: TeamId -> GitHub Team+getTeam = github (Proxy :: Proxy GetTeam)++-- | Get list of 'Member' records assoctiated to 'Team' given by Team Id+teamMembers :: TeamId -> GitHub [Member]+teamMembers = github (Proxy :: Proxy TeamMembers)++-- | Get list of 'Repository' records assoctiated to 'Team' given by Team Id+teamRepositories :: TeamId -> GitHub [Repository]+teamRepositories = github (Proxy :: Proxy TeamRepositories)++-- $github+--+-- Use the 'runGitHub' function to execute the 'GitHub' client function.+++-- $pagination+--+-- Functions for managing the pagination features of the GitHub API+--
+ src/Network/GitHub/API.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module      : Network.GitHub.API+-- Copyright   : (c) Finlay Thompson, 2015+-- License     : BSD3+-- Maintainer  : finlay.thompson@gmail.com+-- Stability   : experimental+ +module Network.GitHub.API+where++import Servant.API++import Network.GitHub.Types++-- | <https://developer.github.com/v3/orgs/#list-your-organizations>+type UserOrganisations = "user" :> "orgs" :> Get '[JSON] [Organisation]++-- | <https://developer.github.com/v3/orgs/teams/#list-teams>+type OrganisationTeams = "orgs" :> Capture "org" OrgLogin :> "teams" :> Get '[JSON] [Team]++-- | <https://developer.github.com/v3/orgs/teams/#list-team-members>+type TeamMembers = "teams" :> Capture "id" TeamId :> "members" :> Get '[JSON] [Member]++-- | <https://developer.github.com/v3/orgs/teams/#list-team-repos>+type TeamRepositories = "teams" :> Capture "id" TeamId :> "repos" :> Get '[JSON] [Repository]++-- | <https://developer.github.com/v3/orgs/teams/#get-team>+type GetTeam = "teams" :> Capture "id" TeamId :> Get '[JSON] Team+
+ src/Network/GitHub/Client.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Network.GitHub.Client+-- Copyright   : (c) Finlay Thompson, 2015+-- License     : BSD3+-- Maintainer  : finlay.thompson@gmail.com+-- Stability   : experimental+ +module Network.GitHub.Client+    ( github+    , AuthToken+    , GitHub+    , 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.Either+import Data.Proxy+import GHC.TypeLits+import Data.String+import Data.Text as T++import Servant.API+import Servant.Client++import Network.HTTP.Link.Types+import Network.HTTP.Link.Parser (parseLinkHeaderBS)++-- | Token used to authorize access to the GitHub API.+-- see <https://developer.github.com/v3/oauth/>+newtype AuthToken = AuthToken Text deriving (Eq)+instance IsString AuthToken where+    fromString s = AuthToken (fromString s)+instance ToText AuthToken where+    toText (AuthToken t) = T.concat ["token ",  t]++host :: BaseUrl+host = BaseUrl Https "api.github.com" 443++-- | The 'GitHub' monad provides execution context+type GitHub = ReaderT (Maybe AuthToken) (StateT GitHubState (EitherT ServantError IO))++-- | You need to provide a 'Maybe AuthToken' to lift a 'GitHub' computation+-- into the 'IO' monad. +runGitHub :: GitHub a -> Maybe AuthToken -> IO (Either ServantError a)+runGitHub comp token = runEitherT $ evalStateT (runReaderT comp token) defGitHubState++-- | Closed type family that adds standard headers to the incoming +-- servant API type. The extra headers are put after any arguments types.+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+-- | Closed type family that adds headers necessary for pagination. In particular,+-- it captures the "Link" header from the response.+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 otherwise = otherwise++-- | Client function that returns a single result+type Single a = Maybe Text -> Maybe AuthToken +            -> EitherT ServantError IO a++-- | Client function that returns a list of results, and is therefore paginated+type Paginated a = Maybe Text -> Maybe AuthToken +                -> Maybe Int -> Maybe Int+                -> EitherT ServantError IO (Headers '[Header "Link" Text] [a])++-- | Closed type family for recursively defining the GitHub client funciton types+type family EmbedGitHub a :: * where+    EmbedGitHub (Single a)  = GitHub a+    EmbedGitHub (Paginated a) = GitHub [a]+    EmbedGitHub (a -> b) = a -> EmbedGitHub b++-- | This class defines how the client code is actually called.+class HasGitHub a where+    embedGitHub :: a -> EmbedGitHub a+-- | Instance for the case where we have paginated results+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 for the case where we have single result+instance HasGitHub (Single a) where+    embedGitHub comp = do+        token <- ask+        lift $ do +            ua <- gets useragent+            lift $ comp (Just ua) token+                    +-- This instance is a bit too literal. Should be possible to do it reursively+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 -> 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)++-- | Wrapper around the servant 'client' function, that takes care of the +-- extra headers that required for the 'GitHub' monad.+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)) host +++-- | GitHubState options that control which headers are provided to the API+-- and stores the 'Link' header result+data GitHubState +    = GitHubState +    { perPage    :: Int   -- ^ The number of records returned per page+    , page       :: Int   -- ^ The page number returned+    , links      :: Maybe [Link] -- ^ Contains the returned 'Link' header, if available.+    , recurse    :: Bool  -- ^ Flag to set the recursive mode on+    , useragent  :: Text -- ^ Text to send as "User-agent"+    } deriving Show+defGitHubState :: GitHubState+defGitHubState = GitHubState 100 1 Nothing True "servant-github"++-- | Overide default value for User-agent header.+-- Note, GitHub requires that a User-agent header be set.+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)+    +-- | Set next page back to 1, and remove the links+resetPagination :: GitHub ()+resetPagination = lift $ modify $ \ghs -> ghs { page = 1, links = Nothing }++-- | Turn automatic recusive behaviour on and off.+--+-- If recursive is on, paginated results will be automatically+-- followed and concated together.+recurseOff, recurseOn :: GitHub ()+recurseOff =  lift $ modify $ \ghs -> ghs { recurse = False } +recurseOn  =  lift $ modify $ \ghs -> ghs { recurse = True } ++-- | The default number of records per page is set to 100. Smaller pages can be+-- set, but not bigger than 100.+pageSize :: Int -> GitHub ()+pageSize ps = lift $ modify $ \ghs -> ghs { perPage = ps }++-- | Return the 'Link' header. This is only set when there are futher pages.+getLinks :: GitHub (Maybe [Link])+getLinks = lift $ gets links
+ src/Network/GitHub/Types.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Network.GitHub.Types+-- Copyright   : (c) Finlay Thompson, 2015+-- License     : BSD3+-- Maintainer  : finlay.thompson@gmail.com+-- Stability   : experimental+--+-- Most of the types only parse part of the data availble in the return+-- values from the GitHub API. These will be added to as required.+ +module Network.GitHub.Types+    ( Organisation(..)+    , OrgLogin+    , Team(..)+    , TeamId+    , Member(..)+    , MemberId+    , Repository(..)+    , RepositoryName+    )+where++import Control.Monad+import Data.Aeson+import Data.Text++-- | Organisation +data Organisation = Organisation +    { orgLogin        :: OrgLogin+    , orgId           :: Int+    , orgDescription  :: Maybe Text+    } deriving (Eq, Show)+-- | Primary identifier for an organisation is the login+type OrgLogin = Text+++instance FromJSON Organisation where+  parseJSON (Object o) =+   Organisation <$> o .: "login"+                <*> o .: "id"+                <*> o .: "description"+  parseJSON _ = mzero++-- | Team+data Team = Team+    { teamId          :: TeamId+    , teamName        :: Text+    , teamDescription :: Maybe Text+    , teamPermission  :: Maybe Text+    } deriving (Eq, Show)+-- | Identifier for a team id+type TeamId = Integer++instance FromJSON Team where+  parseJSON (Object o) =+   Team <$> o .: "id"+        <*> o .: "name"+        <*> o .: "description"+        <*> o .: "permission"+  parseJSON _ = mzero++-- | Member+data Member = Member+    { memberId        :: MemberId+    , memberLogin     :: Text+    } deriving (Eq, Show)+-- | members are identified by ids+type MemberId = Integer++instance FromJSON Member where+  parseJSON (Object o) =+   Member <$> o .: "id"+          <*> o .: "login"+  parseJSON _ = mzero++-- | Repository+data Repository = Repository+    { repositoryName  :: RepositoryName+    , repositoryDescription :: Maybe Text+    , repositoryPrivate :: Bool+    } deriving (Eq, Show)+-- | repositories are identified by their name+type RepositoryName = Text++instance FromJSON Repository where+  parseJSON (Object o) =+   Repository <$> o .: "name"+              <*> o .: "description"+              <*> o .: "private"+  parseJSON _ = mzero+
+ test/Spec.hs view
@@ -0,0 +1,7 @@+import Test.Hspec++main :: IO ()+main = hspec $ do+  describe "organiztions" $ do+    it "Get a list of organizations" $ do+        pendingWith "Not implemented"