I'e added support for paged calls

Some of the calls are by nature paged, so I'e added support to githubapi.hs along the lines
indicated this morning in the lecture. There are now two calls locally for runClientM in
Guthubapi.hs: a non recursie one and a recursie one. The detail is hidden away from the client usage
in lib.hs by some typing fun. To gie you a hint, the call to a github api method in lib.hs is now a
partial function that gets completed only in runClientPagedM (which adds a page number and env) and
runClientM (which adds the env). So in Lib.hs you will see the calls being more simple, with no env
created. That's paid for in GithubAPI.hs, where the code has got a little more sophisticated.

github-get.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 07c865489e610342f1097de0a00dfaa599f00261a19e92554fe1a44e549bb397
+-- hash: 364ac76fdbbb3b33a28ea026f7b23c3f342ef896e6a1e6934e23eaea0a7c63d8
 
 name:           github-get
 version:        0.1.0.0
@@ -36,10 +36,12 @@ library
   build-depends:
       aeson
     , base >=4.7 && <5
+    , hashmap
     , http-client
     , http-client-tls
     , servant
     , servant-client
+    , split
     , text
     , utf8-string
   default-language: Haskell2010
@@ -55,10 +57,12 @@ executable github-get-exe
       aeson
     , base >=4.7 && <5
     , github-get
+    , hashmap
     , http-client
     , http-client-tls
     , servant
     , servant-client
+    , split
     , text
     , utf8-string
   default-language: Haskell2010
@@ -75,10 +79,12 @@ test-suite github-get-test
       aeson
     , base >=4.7 && <5
     , github-get
+    , hashmap
     , http-client
     , http-client-tls
     , servant
     , servant-client
+    , split
     , text
     , utf8-string
   default-language: Haskell2010

package.yaml

@@ -28,6 +28,8 @@ dependencies:
   - http-client
   - http-client-tls
   - utf8-string
+  - hashmap
+  - split
 
 library:
   source-dirs: src

src/GitHub.hs

@@ -1,20 +1,43 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators     #-}
 {-# LANGUAGE DuplicateRecordFields     #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
 
-module GitHub where 
+module GitHub where
 
-import           Control.Monad       (mzero)
-import           Data.Aeson
-import           Data.Proxy
-import           Data.Text
-import           GHC.Generics
-import           Network.HTTP.Client (defaultManagerSettings, newManager)
-import           Servant.API
-import           Servant.Client
+import Data.Aeson ( FromJSON )
+import Data.Proxy ( Proxy(..) )
+import Data.Text ( Text )
+import GHC.Generics ( Generic )
+import qualified Servant.Client               as SC
+import Servant.API
+    ( type (:<|>)(..),
+      BasicAuth,
+      BasicAuthData,
+      Capture,
+      JSON,
+      Header,
+      type (:>),
+      Get )
+import Servant.Client ( client, ClientM )
+import qualified Data.HashMap as HM
+import Data.List.Split  (splitOn)
+import Data.ByteString.UTF8 (toString)
+import           Network.HTTP.Client          (newManager)
+import           Network.HTTP.Client.TLS      (tlsManagerSettings)
+import Servant.API.ResponseHeaders
+import Servant.API.QueryParam (QueryParam)
+import Data.String (IsString)
+
+-- a type i created to wrap up paged requests
+type GetPaged a b = QueryParam "page" String :> Get a (GitHubPaged b)
 
 type Username  = Text
 type UserAgent = Text
@@ -28,7 +51,7 @@ data GitHubUser =
 
 data GitHubRepo =
   GitHubRepo { name :: Text
-             , fullname :: Maybe Text
+             , full_name :: Maybe Text
              , language :: Maybe Text
              } deriving (Generic, FromJSON, Show)
 
@@ -38,23 +61,72 @@ data RepoContributor =
                   } deriving (Generic, FromJSON, Show)
 
 type GitHubAPI = "users" :> Header  "user-agent" UserAgent
-                         :> BasicAuth "github" Int 
-                         :> Capture "username" Username  :> Get '[JSON] GitHubUser
-
+                         :> BasicAuth "github" Int
+                         :> Capture "username" Username
+                         :> Get '[JSON] GitHubUser
+
             :<|> "users" :> Header  "user-agent" UserAgent
-                         :> BasicAuth "github" Int 
-                         :> Capture "username" Username  :> "repos" :>  Get '[JSON] [GitHubRepo]
-
+                         :> BasicAuth "github" Int
+                         :> Capture "username" Username
+                         :> "repos"
+                         :> GetPaged '[JSON] [GitHubRepo]
+
             :<|> "repos" :> Header  "user-agent" UserAgent
-                         :> BasicAuth "github" Int 
-                         :> Capture "username" Username  
-                         :> Capture "repo"     Reponame  :> "contributors" :>  Get '[JSON] [RepoContributor]
+                         :> BasicAuth "github" Int
+                         :> Capture "username" Username
+                         :> Capture "repo"     Reponame
+                         :> "contributors"
+                         :> GetPaged '[JSON] [RepoContributor]
+
+            -- This call has been implemented to return link Headers so that we can gather multipage responses
+            :<|> "repositories" :> Header  "user-agent" UserAgent
+                                :> BasicAuth "github" Int
+                                :> GetPaged '[JSON] [GitHubRepo]
 
 gitHubAPI :: Proxy GitHubAPI
 gitHubAPI = Proxy
 
+
+
+type GitHubPaged a = Headers '[Header "link" Text, Header "X-Ratelimit-Remaining" Int] a
+type ClientMPaged a = Maybe String -> ClientM (GitHubPaged a)
+
 getUser ::          Maybe UserAgent -> BasicAuthData -> Username            -> ClientM GitHubUser
-getUserRepos ::     Maybe UserAgent -> BasicAuthData -> Username            -> ClientM [GitHubRepo]
-getRepoContribs ::  Maybe UserAgent -> BasicAuthData -> Username -> Reponame -> ClientM [RepoContributor]
-
-getUser :<|> getUserRepos :<|> getRepoContribs = client gitHubAPI
+getUserRepos ::     Maybe UserAgent -> BasicAuthData -> Username            -> ClientMPaged [GitHubRepo]
+getRepoContribs ::  Maybe UserAgent -> BasicAuthData -> Username -> Reponame -> ClientMPaged [RepoContributor]
+getRepositories ::  Maybe Text      -> BasicAuthData                       -> ClientMPaged [GitHubRepo]
+
+getUser :<|> getUserRepos :<|> getRepoContribs :<|> getRepositories = client gitHubAPI
+
+-- run a GitHub API call where teh result is pagnated
+runClientPagedM fn = recursiveCall "1"
+ where
+   recursiveCall page = do
+    putStrLn $ "running runClientPagedM " ++ page
+    (SC.runClientM (fn $ Just page)=<< env) >>= \case
+     Left e -> return $ Left e -- silently return error if there is one
+     Right (Headers rs hs) ->
+           -- the following is a bit of a hack but does the job extracting nextPage link, and can be used
+           -- to extract other links also, as it gets all links returned by the links header field, before
+           -- extracting the "next" link page
+       let getLnk xs = let (a:b:_) = splitOn ";" xs
+                           clean s = filter (not .( `elem` ['>','"'])) .head .tail .splitOn s
+                       in (clean "rel=" b, clean "page=" a)
+           nextPage = (HM.lookup "link" .HM.fromList $ getHeaders hs) >>= 
+                      foldr ((\(n,v) a -> case a of
+                                           Nothing -> if n == "next" then Just v else Nothing
+                                           x -> x) .getLnk) Nothing .splitOn "," .toString
+       in case nextPage of
+         Just x -> recursiveCall x >>= \case
+           Right rs' -> return .Right $ rs ++ rs'
+           e -> return e
+         Nothing -> return $ Right rs
+
+-- runa github API call ignoring pagination if any
+runClientM :: forall a. ClientM a -> IO (Either SC.ClientError a)
+runClientM fn = SC.runClientM fn =<< env
+
+env :: IO SC.ClientEnv
+env = do
+  manager <- newManager tlsManagerSettings
+  return $ SC.mkClientEnv manager (SC.BaseUrl SC.Http "api.github.com" 80 "")

src/Lib.hs

@@ -1,13 +1,8 @@
+
 {-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DeriveAnyClass       #-}
-{-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE StandaloneDeriving   #-}
-{-# LANGUAGE TemplateHaskell      #-}
-{-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DuplicateRecordFields     #-}
 
@@ -17,12 +12,10 @@ module Lib
 
 import qualified GitHub as GH
 import qualified Servant.Client               as SC
-import           Network.HTTP.Client          (newManager)
-import           Network.HTTP.Client.TLS      (tlsManagerSettings)
 import           System.Environment           (getArgs)
-import Data.Text hiding (map,intercalate, groupBy, concat)
+import Data.Text ( Text, pack, unpack )
 import Data.List (intercalate, groupBy, sortBy)
-import Data.Either
+import Data.Either ( partitionEithers )
 import           Servant.API                (BasicAuthData (..))
 import Data.ByteString.UTF8 (fromString)
 
@@ -35,30 +28,29 @@ someFunc = do
   putStrLn $ "github token for api call is " ++ token
 
   let auth = BasicAuthData (fromString user) (fromString token)
-  
+
   testGitHubCall auth $ pack rName
   putStrLn "end."
 
-
 testGitHubCall :: BasicAuthData -> Text -> IO ()
 testGitHubCall auth name = 
-  (SC.runClientM (GH.getUser (Just "haskell-app") auth name) =<< env) >>= \case
+  GH.runClientM (GH.getUser (Just "haskell-app") auth name) >>= \case
 
     Left err -> do
       putStrLn $ "heuston, we have a problem: " ++ show err
     Right res -> do
       putStrLn $ "the votes of the github jury are " ++ show res
-      
-      -- now lets get the users repositories
-      (SC.runClientM (GH.getUserRepos (Just "haskell-app") auth name) =<< env) >>= \case
+
+      -- now lets get the users repositories. Note this is now running paged cass.
+      GH.runClientPagedM (GH.getUserRepos (Just "haskell-app") auth name) >>= \case
         Left err -> do
           putStrLn $ "heuston, we have a problem (gettign repos): " ++ show err
         Right repos -> do
           putStrLn $ " repositories are:" ++
             intercalate ", " (map (\(GH.GitHubRepo n _ _ ) -> unpack n) repos)
 
           -- now lets get the full list of collaborators from repositories
-          partitionEithers <$> mapM (getContribs auth name) repos >>= \case
+          (partitionEithers <$> mapM (getContribs auth name) repos) >>= \case
 
             ([], contribs) ->
               putStrLn $ " contributors are: " ++
@@ -68,30 +60,23 @@ testGitHubCall auth name =
 
             (ers, _)-> do
               putStrLn $ "heuston, we have a problem (getting contributors): " ++ show ers
-
-
-
-  where env :: IO SC.ClientEnv
-        env = do
-          manager <- newManager tlsManagerSettings
-          return $ SC.mkClientEnv manager (SC.BaseUrl SC.Http "api.github.com" 80 "")
-
-        getContribs :: BasicAuthData -> GH.Username -> GH.GitHubRepo -> IO (Either SC.ClientError [GH.RepoContributor])
+
+  where getContribs :: BasicAuthData -> GH.Username -> GH.GitHubRepo -> IO (Either SC.ClientError [GH.RepoContributor])
         getContribs auth name (GH.GitHubRepo repo _ _) =
-          SC.runClientM (GH.getRepoContribs (Just "haskell-app") auth name repo) =<< env
+          GH.runClientPagedM (GH.getRepoContribs (Just "haskell-app") auth name repo)
 
         groupContributors :: [GH.RepoContributor] -> [GH.RepoContributor]
         groupContributors  = sortBy (\(GH.RepoContributor _ c1) (GH.RepoContributor _ c2) ->  compare c1 c2) .
                              map mapfn .
                              groupBy (\(GH.RepoContributor l1 _) (GH.RepoContributor l2 _) ->  l1 == l2)
          where mapfn :: [GH.RepoContributor] -> GH.RepoContributor
-               mapfn xs@((GH.RepoContributor l _):_) = GH.RepoContributor l . sum $ 
+               mapfn xs@((GH.RepoContributor l _):_) = GH.RepoContributor l . sum $
                                                        map (\(GH.RepoContributor _ c) -> c)  xs
-
-
-
-
 
 
 
-
+
+
+
+
+