Thanks to visit codestin.com
Credit goes to github.com

Skip to content

Commit e592153

Browse files
phadejphadej
authored
Merge pull request haskell-github#307 from ryantrinkle/get-archive-link
Add "Get archive link" API
2 parents 72f238c + 8f543cd commit e592153

File tree

4 files changed

+80
-3
lines changed

4 files changed

+80
-3
lines changed

‎src/GitHub/Data/Repos.hs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module GitHub.Data.Repos where
1414
import GitHub.Data.Definitions
1515
import GitHub.Data.Id (Id)
1616
import GitHub.Data.Name (Name)
17+
import GitHub.Data.Request (IsPathPart (..))
1718
import GitHub.Data.URL (URL)
1819
import GitHub.Internal.Prelude
1920
import Prelude ()
@@ -257,3 +258,13 @@ instance FromJSON a => FromJSON (HM.HashMap Language a) where
257258
mapKey f = HM.fromList . map (first f) . HM.toList
258259
#endif
259260
#endif
261+
262+
data ArchiveFormat
263+
= ArchiveFormatTarball -- ^ ".tar.gz" format
264+
| ArchiveFormatZipball -- ^ ".zip" format
265+
deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic)
266+
267+
instance IsPathPart ArchiveFormat where
268+
toPathPart af = case af of
269+
ArchiveFormatTarball -> "tarball"
270+
ArchiveFormatZipball -> "zipball"

‎src/GitHub/Data/Request.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy as LBS
3636
import qualified Data.Text as T
3737
import qualified Network.HTTP.Types as Types
3838
import qualified Network.HTTP.Types.Method as Method
39+
import Network.URI (URI)
3940
------------------------------------------------------------------------------
4041
-- Auxillary types
4142
------------------------------------------------------------------------------
@@ -141,6 +142,7 @@ data Request (k :: RW) a where
141142
SimpleQuery :: FromJSON a => SimpleRequest k a -> Request k a
142143
StatusQuery :: StatusMap a -> SimpleRequest k () -> Request k a
143144
HeaderQuery :: FromJSON a => Types.RequestHeaders -> SimpleRequest k a -> Request k a
145+
RedirectQuery :: SimpleRequest k () -> Request k URI
144146
deriving (Typeable)
145147

146148
data SimpleRequest (k :: RW) a where
@@ -218,6 +220,8 @@ instance Show (Request k a) where
218220
. showsPrec (appPrec + 1) m
219221
. showString " "
220222
. showsPrec (appPrec + 1) req
223+
RedirectQuery req -> showString "Redirect "
224+
. showsPrec (appPrec + 1) req
221225
where
222226
appPrec = 10 :: Int
223227

@@ -249,3 +253,6 @@ instance Hashable (Request k a) where
249253
salt `hashWithSalt` (2 :: Int)
250254
`hashWithSalt` h
251255
`hashWithSalt` req
256+
hashWithSalt salt (RedirectQuery req) =
257+
salt `hashWithSalt` (3 :: Int)
258+
`hashWithSalt` req

‎src/GitHub/Endpoints/Repos/Contents.hs‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,9 @@ module GitHub.Endpoints.Repos.Contents (
1313
readmeFor,
1414
readmeFor',
1515
readmeForR,
16+
archiveFor,
17+
archiveFor',
18+
archiveForR,
1619

1720
-- ** Create
1821
createFile,
@@ -34,7 +37,9 @@ import GitHub.Internal.Prelude
3437
import GitHub.Request
3538
import Prelude ()
3639

40+
import Data.Maybe (maybeToList)
3741
import qualified Data.Text.Encoding as TE
42+
import Network.URI (URI)
3843

3944
-- | The contents of a file or directory in a repo, given the repo owner, name, and path to the file
4045
--
@@ -79,6 +84,31 @@ readmeForR :: Name Owner -> Name Repo -> Request k Content
7984
readmeForR user repo =
8085
query ["repos", toPathPart user, toPathPart repo, "readme"] []
8186

87+
-- | The archive of a repo, given the repo owner, name, and archive type
88+
--
89+
-- > archiveFor "thoughtbot" "paperclip" ArchiveFormatTarball Nothing
90+
archiveFor :: Name Owner -> Name Repo -> ArchiveFormat -> Maybe Text -> IO (Either Error URI)
91+
archiveFor = archiveFor' Nothing
92+
93+
-- | The archive of a repo, given the repo owner, name, and archive type
94+
-- With Authentication
95+
--
96+
-- > archiveFor' (Just (BasicAuth (user, password))) "thoughtbot" "paperclip" ArchiveFormatTarball Nothing
97+
archiveFor' :: Maybe Auth -> Name Owner -> Name Repo -> ArchiveFormat -> Maybe Text -> IO (Either Error URI)
98+
archiveFor' auth user repo path ref =
99+
executeRequestMaybe auth $ archiveForR user repo path ref
100+
101+
archiveForR
102+
:: Name Owner
103+
-> Name Repo
104+
-> ArchiveFormat -- ^ The type of archive to retrieve
105+
-> Maybe Text -- ^ Git commit
106+
-> Request k URI
107+
archiveForR user repo format ref =
108+
RedirectQuery $ Query path []
109+
where
110+
path = ["repos", toPathPart user, toPathPart repo, toPathPart format] <> maybeToList ref
111+
82112
-- | Create a file.
83113
createFile
84114
:: Auth

‎src/GitHub/Request.hs‎

Lines changed: 32 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,7 @@ import Control.Monad.Except (MonadError (..))
5959
import Control.Monad.Error (MonadError (..))
6060
#endif
6161

62+
import Control.Monad (when)
6263
import Control.Monad.Catch (MonadCatch (..), MonadThrow)
6364
import Control.Monad.Trans.Class (lift)
6465
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
@@ -67,13 +68,13 @@ import Data.List (find)
6768

6869
import Network.HTTP.Client
6970
(HttpException (..), Manager, RequestBody (..), Response (..),
70-
applyBasicAuth, httpLbs, method, newManager, requestBody,
71-
requestHeaders, setQueryString)
71+
applyBasicAuth, getUri, httpLbs, method, newManager, redirectCount,
72+
requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus)
7273
import Network.HTTP.Client.TLS (tlsManagerSettings)
7374
import Network.HTTP.Link.Parser (parseLinkHeaderBS)
7475
import Network.HTTP.Link.Types (Link (..), LinkParam (..), href, linkParams)
7576
import Network.HTTP.Types (Method, RequestHeaders, Status (..))
76-
import Network.URI (URI)
77+
import Network.URI (URI, parseURIReference, relativeTo)
7778

7879
#if !MIN_VERSION_http_client(0,5,0)
7980
import qualified Control.Exception as E
@@ -82,6 +83,7 @@ import Network.HTTP.Types (ResponseHeaders)
8283

8384
import qualified Data.ByteString.Lazy as LBS
8485
import qualified Data.Text as T
86+
import qualified Data.Text.Encoding as TE
8587
import qualified Data.Vector as V
8688
import qualified Network.HTTP.Client as HTTP
8789
import qualified Network.HTTP.Client.Internal as HTTP
@@ -125,6 +127,9 @@ executeRequestWithMgr mgr auth req = runExceptT $ do
125127
performHttpReq httpReq (StatusQuery sm _) = do
126128
res <- httpLbs' httpReq
127129
parseStatus sm . responseStatus $ res
130+
performHttpReq httpReq (RedirectQuery _) = do
131+
res <- httpLbs' httpReq
132+
parseRedirect (getUri httpReq) res
128133

129134
performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest k b -> ExceptT Error IO b
130135
performHttpReq' httpReq Query {} = do
@@ -172,6 +177,9 @@ executeRequestWithMgr' mgr req = runExceptT $ do
172177
performHttpReq httpReq (StatusQuery sm _) = do
173178
res <- httpLbs' httpReq
174179
parseStatus sm . responseStatus $ res
180+
performHttpReq httpReq (RedirectQuery _) = do
181+
res <- httpLbs' httpReq
182+
parseRedirect (getUri httpReq) res
175183

176184
performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest 'RO b -> ExceptT Error IO b
177185
performHttpReq' httpReq Query {} = do
@@ -222,6 +230,9 @@ makeHttpRequest auth r = case r of
222230
HeaderQuery h req -> do
223231
req' <- makeHttpSimpleRequest auth req
224232
return $ req' { requestHeaders = h <> requestHeaders req' }
233+
RedirectQuery req -> do
234+
req' <- makeHttpSimpleRequest auth req
235+
return $ setRequestIgnoreStatus $ req' { redirectCount = 0 }
225236

226237
makeHttpSimpleRequest
227238
:: MonadThrow m
@@ -328,6 +339,24 @@ parseStatus m (Status sci _) =
328339
where
329340
err = throwError $ JsonError $ "invalid status: " <> T.pack (show sci)
330341

342+
-- | Helper for handling of 'RequestRedirect'.
343+
--
344+
-- @
345+
-- parseRedirect :: 'Response' 'LBS.ByteString' -> 'Either' 'Error' a
346+
-- @
347+
parseRedirect :: MonadError Error m => URI -> Response LBS.ByteString -> m URI
348+
parseRedirect originalUri rsp = do
349+
let status = responseStatus rsp
350+
when (statusCode status /= 302) $
351+
throwError $ ParseError $ "invalid status: " <> T.pack (show status)
352+
loc <- maybe noLocation return $ lookup "Location" $ responseHeaders rsp
353+
case parseURIReference $ T.unpack $ TE.decodeUtf8 loc of
354+
Nothing -> throwError $ ParseError $
355+
"location header does not contain a URI: " <> T.pack (show loc)
356+
Just uri -> return $ uri `relativeTo` originalUri
357+
where
358+
noLocation = throwError $ ParseError "no location header in response"
359+
331360
-- | Helper for making paginated requests. Responses, @a@ are combined monoidally.
332361
--
333362
-- @

0 commit comments

Comments
 (0)