@@ -1,343 +1,26 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
31module Deps.Website
4− ( getElmJson
5− , getDocs
6− , getNewPackages
7− , getAllPackages
8− , download
9− , githubCommit
10− , githubDownload
11− , Sha
12− , register
2+ ( domain
3+ , route
4+ , metadata
135 )
146 where
157
168
17−import Prelude hiding (zip)
18−import qualified Codec.Archive.Zip as Zip
19−import Control.Monad (void)
20−import qualified Data.Binary as Binary
21−import qualified Data.Binary.Get as Binary
22−import qualified Data.ByteString.Char8 as BS
23−import qualified Data.ByteString.Lazy as LBS
24−import qualified Data.Digest.Pure.SHA as SHA
25−import qualified Data.Map as Map
26−import qualified Data.Utf8 as Utf8
27−import qualified Network.HTTP.Client as Client
28−import qualified Network.HTTP.Client.MultipartFormData as Multi
29−import qualified Network.HTTP.Types as Http
30−import qualified System.Directory as Dir
31−import System.FilePath ((</>), splitFileName)
32−
339import qualified Elm.Package as Pkg
3410import qualified Elm.Version as V
35−import qualified Json.Decode as D
36−
37−import qualified Reporting.Exit.Http as E
38−import qualified Reporting.Progress as Progress
39−import qualified Reporting.Task as Task
40−import qualified Reporting.Task.Http as Http
41−import qualified Stuff.Paths as Path
42−
43−
44−
45−-- GET PACKAGE INFO
46−
47−
48−getElmJson :: Pkg.Name -> V.Version -> Task.Task BS.ByteString
49−getElmJson name version =
50− Http.run $ fetchByteString $
51− "packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/elm.json"
52−
53−
54−getDocs :: Pkg.Name -> V.Version -> Task.Task BS.ByteString
55−getDocs name version =
56− Http.run $ fetchByteString $
57− "packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/docs.json"
58−
59−
60−
61−-- NEW PACKAGES
62−
63−
64−getNewPackages :: Int -> Task.Task [(Pkg.Name, V.Version)]
65−getNewPackages index =
66− Http.run $ fetchJson (D.list newPkgDecoder) ("all-packages/since/" ++ show index)
67−
68−
69−newPkgDecoder :: D.Decoder E.BadJson ( Pkg.Name, V.Version )
70−newPkgDecoder =
71− do str <- D.string
72− case Utf8.split 0x40 {-@-} str of
73− [key, value] ->
74− case Pkg.fromString key of
75− Right pkg ->
76− case V.fromString value of
77− Just vsn ->
78− return (pkg, vsn)
79−
80− Nothing ->
81− D.failure (E.BadNewPkg str)
82−
83− Left _ ->
84− D.failure (E.BadNewPkg str)
85−
86− _ ->
87− D.failure (E.BadNewPkg str)
88−
89−
90−
91−-- ALL PACKAGES
92−
93−
94−getAllPackages :: Task.Task (Map.Map Pkg.Name [V.Version])
95−getAllPackages =
96− Http.run $ fetchJson allPkgsDecoder "all-packages"
97−
98−
99−allPkgsDecoder :: D.Decoder E.BadJson (Map.Map Pkg.Name [V.Version])
100−allPkgsDecoder =
101− let
102− checkKeys pairs pkgs =
103− case pairs of
104− [] ->
105− return pkgs
106−
107− (key, versions) : rest ->
108− case Pkg.fromString key of
109− Right pkg ->
110− checkKeys rest (Map.insert pkg versions pkgs)
111−
112− Left badName ->
113− D.failure (E.BadAllPkg key badName)
114− in
115− do pairs <- D.pairs (D.list (D.mapError E.BadAllVsn V.decoder))
116− checkKeys pairs Map.empty
117−
118−
119−
120−-- HELPERS
121−
122−
123−fetchByteString :: String -> Http.Fetch BS.ByteString
124−fetchByteString path =
125− Http.package path [] $ \request manager ->
126− do response <- Client.httpLbs request manager
127− return $ Right $ LBS.toStrict $ Client.responseBody response
128−
129−
130−fetchJson :: D.Decoder e a -> String -> Http.Fetch a
131−fetchJson decoder path =
132− Http.package path [] $ \request manager ->
133− do response <- Client.httpLbs request manager
134− let bytes = LBS.toStrict (Client.responseBody response)
135− case D.fromByteString decoder bytes of
136− Right value ->
137− return $ Right value
138−
139− Left jsonProblem ->
140− return $ Left $ E.BadJson path (error "TODO give real HTTP problem" jsonProblem)
141−
142−
143−
144−-- DOWNLOAD
145−
146−
147−download :: [(Pkg.Name, V.Version)] -> Task.Task ()
148−download packages =
149− case packages of
150− [] ->
151− Task.report Progress.DownloadSkip
152−
153− _ ->
154− do cache <- Task.getPackageCacheDir
155−
156− let start = Progress.DownloadStart packages
157− let toEnd = Progress.DownloadEnd
158−
159− void $ Http.run $ Http.report start toEnd $
160− Http.parallel $ map (downloadHelp cache) packages
161−
162−
163−downloadHelp :: FilePath -> (Pkg.Name, V.Version) -> Http.Fetch ()
164−downloadHelp cache (name, version) =
165− let
166− endpointUrl =
167− "packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/endpoint.json"
168− in
169− Http.andThen (fetchJson endpointDecoder endpointUrl) $ \(endpoint, hash) ->
170− let
171− start = Progress.DownloadPkgStart name version
172− toEnd = Progress.DownloadPkgEnd name version
173− in
174− Http.report start toEnd $
175− Http.anything endpoint $ \request manager ->
176− Client.withResponse request manager (downloadArchive cache name version hash)
177−
178−
179−endpointDecoder :: D.Decoder e (String, String)
180−endpointDecoder =
181− (,)
182− <$> (Utf8.toChars <$> D.field "url" D.string)
183− <*> (Utf8.toChars <$> D.field "hash" D.string)
184−
185−
186−
187−-- DOWNLOAD ZIP ARCHIVE
188−
189−
190−downloadArchive :: FilePath -> Pkg.Name -> V.Version -> String -> Client.Response Client.BodyReader -> IO (Either E.Exit ())
191−downloadArchive cache name version expectedHash response =
192− do result <- readArchive (Client.responseBody response) initialArchiveState
193− case result of
194− Left msg ->
195− return (Left msg)
196−
197− Right (sha, archive) ->
198− if expectedHash == SHA.showDigest sha then
199− Right <$> writeArchive archive (cache </> Pkg.toFilePath name) (V.toChars version)
200− else
201− return $ Left $ E.BadZipSha expectedHash (SHA.showDigest sha)
202−
203−
204−
205−-- READ ARCHIVE
206−
207−
208−data ArchiveState =
209− AS
210− { _len :: !Int
211− , _sha :: !(Binary.Decoder SHA.SHA1State)
212− , _zip :: !(Binary.Decoder Zip.Archive)
213− }
214−
215−
216−initialArchiveState :: ArchiveState
217−initialArchiveState =
218− AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
219−
220−
221−type Sha = SHA.Digest SHA.SHA1State
222−
223−
224−readArchive :: Client.BodyReader -> ArchiveState -> IO (Either E.Exit (Sha, Zip.Archive))
225−readArchive body (AS len sha zip) =
226− case zip of
227− Binary.Fail _ _ _ ->
228− return $ Left E.BadZipData
229−
230− Binary.Partial k ->
231− do chunk <- Client.brRead body
232− readArchive body $ AS
233− { _len = len + BS.length chunk
234− , _sha = Binary.pushChunk sha chunk
235− , _zip = k (if BS.null chunk then Nothing else Just chunk)
236− }
237−
238− Binary.Done _ _ archive ->
239− return $ Right ( SHA.completeSha1Incremental sha len, archive )
240−
241−
242−
243−-- WRITE ARCHIVE
244−
245−
246−writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
247−writeArchive archive destination newRoot =
248− do Dir.createDirectoryIfMissing True destination
249− let opts = [Zip.OptDestination destination]
250− mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)
251−
252−
253−replaceRoot :: String -> Zip.Entry -> Zip.Entry
254−replaceRoot root entry =
255− let
256− rootless =
257− dropWhile (/='/') (Zip.eRelativePath entry)
258− in
259− entry { Zip.eRelativePath = root ++ rootless }
260−
261−
262−
263−-- FIND TAGGED COMMIT ON GITHUB
264−
265−
266−githubCommit :: Pkg.Name -> V.Version -> Task.Task String
267−githubCommit name version =
268− let
269− endpoint =
270− "https://api.github.com/repos/" ++ Pkg.toUrl name ++ "/git/refs/tags/" ++ V.toChars version
271−
272− headers =
273− [ ( Http.hUserAgent, "elm-cli" )
274− , ( Http.hAccept, "application/json" )
275− ]
276−
277− decoder =
278− D.field "object" (D.field "sha" D.string)
279− in
280− Http.run $ Http.anything endpoint $ \request manager ->
281− do response <- Client.httpLbs (request { Client.requestHeaders = headers }) manager
282− let bytes = LBS.toStrict (Client.responseBody response)
283− case D.fromByteString decoder bytes of
284− Right value ->
285− return $ Right (Utf8.toChars value)
286−
287− Left jsonProblem ->
288− return $ Left $ E.BadJson "github.json" jsonProblem
289−
290−
291−
292−-- DOWNLOAD FROM GITHUB
293−
294−
295−githubDownload :: Pkg.Name -> V.Version -> FilePath -> Task.Task Sha
296−githubDownload name version dir =
297− let
298− endpoint =
299− "https://github.com/" ++ Pkg.toUrl name ++ "/zipball/" ++ V.toChars version ++ "/"
300− in
301− Http.run $ Http.anything endpoint $ \request manager ->
302− Client.withResponse request manager (githubDownloadHelp dir)
303−
304−
305−githubDownloadHelp :: FilePath -> Client.Response Client.BodyReader -> IO (Either E.Exit Sha)
306−githubDownloadHelp targetDir response =
307− do result <- readArchive (Client.responseBody response) initialArchiveState
308− case result of
309− Left msg ->
310− return (Left msg)
311−
312− Right (sha, archive) ->
313− do let (dir, root) = splitFileName targetDir
314− writeArchive archive dir root
315− return $ Right sha
11+import qualified Http
31612
31713
14+domain :: String
15+domain =
16+ "https://package.elm-lang.org"
31817
319−-- REGISTER PACKAGES
32018
19+route :: String -> [(String,String)] -> String
20+route path params =
21+ Http.toUrl (domain ++ path) params
32122
322−register :: Pkg.Name -> V.Version -> String -> Sha -> Task.Task ()
323−register name version commitHash digest =
324− let
325− params =
326− [ ("name", Pkg.toChars name)
327− , ("version", V.toChars version)
328− , ("commit-hash", commitHash)
329− ]
33023
331− files =
332− [ Multi.partFileSource "elm.json" "elm.json"
333− , Multi.partFileSource "docs.json" Path.docs
334− , Multi.partFileSource "README.md" "README.md"
335− , Multi.partFileRequestBody "github-hash" "github-hash" $
336− Client.RequestBodyBS (BS.pack (SHA.showDigest digest))
337− ]
338− in
339− Http.run $ Http.package "register" params $ \rawRequest manager ->
340− do requestWithBody <- Multi.formDataBody files rawRequest
341− let request = requestWithBody { Client.responseTimeout = Client.responseTimeoutNone }
342− void $ Client.httpLbs request manager
343− return $ Right ()
24+metadata :: Pkg.Name -> V.Version -> String -> String
25+metadata name version file =
26+ domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file