git.iko.soy/elk
on master help sign in
Redo Deps.Verify code in Elm.Details
c338ea6Evan Czaplicki
builder/src/Deps/Verify.hsdeleted−388
compare with master
unifiedsplit
@@ -1,388 +0,0 @@
1−module Deps.Verify
2− ( verify
3− )
4− where
5−
6−
7−import Control.Concurrent (forkIO)
8−import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, putMVar, readMVar, takeMVar)
9−import Control.Monad (filterM, void)
10−import Control.Monad.Trans (liftIO)
11−import qualified Data.Map as Map
12−import qualified Data.Map.Merge.Strict as Map
13−import qualified Data.Set as Set
14−import System.Directory (doesDirectoryExist)
15−import System.FilePath ((</>))
16−
17−import qualified Deps.Cache as Cache
18−import qualified Deps.Explorer as Explorer
19−import qualified Deps.Solver as Solver
20−import qualified Deps.Website as Website
21−import qualified Elm.Compiler as Compiler
22−import qualified Elm.Compiler.Objects as Obj
23−import qualified Elm.Constraint as Con
24−import qualified Elm.Interface as I
25−import qualified Elm.ModuleName as ModuleName
26−import qualified Elm.Package as Pkg
27−import qualified Elm.PerUserCache as PerUserCache
28−import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))
29−import qualified Elm.Project.Json as Project
30−import qualified Elm.Project.Summary as Summary
31−import qualified Elm.Version as V
32−import qualified File.Args as Args
33−import qualified File.Compile as Compile
34−import qualified File.Crawl as Crawl
35−import qualified File.IO as IO
36−import qualified File.Plan as Plan
37−import qualified Generate.Artifacts as Artifacts
38−import qualified Reporting.Exit as Exit
39−import qualified Reporting.Exit.Deps as E
40−import qualified Reporting.Progress as Progress
41−import qualified Reporting.Task as Task
42−import qualified Stuff.Paths as Paths
43−
44−
45−
46−-- VERIFY
47−
48−
49−verify :: FilePath -> Project -> Task.Task Summary.Summary
50−verify root project =
51− do solution <-
52− case project of
53− Project.App info -> verifyApp info
54− Project.Pkg info -> verifyPkg info
55−
56− (RawInfo infos ifaces) <- verifyArtifacts solution
57− return (Summary.init root project infos ifaces)
58−
59−
60−throw :: E.Exit -> Task.Task a
61−throw exit =
62− Task.throw (Exit.Deps exit)
63−
64−
65−
66−-- VERIFY APP
67−
68−
69−verifyApp :: AppInfo -> Task.Task (Map.Map Pkg.Name V.Version)
70−verifyApp info =
71− if _app_elm_version info /= V.compiler then
72− throw (E.AppBadElm (_app_elm_version info))
73−
74− else
75− do oldSolution <- appToSolution info
76− let solver = Solver.solve (Map.map Con.exactly oldSolution)
77− registry <- Cache.optionalUpdate
78− maybeSolution <- Explorer.run registry (Solver.run solver)
79− case maybeSolution of
80− Nothing ->
81− throw E.BadDeps
82−
83− Just newSolution ->
84− if Map.size oldSolution == Map.size newSolution then
85− return newSolution
86− else
87− throw (E.AppMissingTrans (Map.toList (Map.difference newSolution oldSolution)))
88−
89−
90−
91−-- VERIFY PKG
92−
93−
94−verifyPkg :: PkgInfo -> Task.Task (Map.Map Pkg.Name V.Version)
95−verifyPkg info =
96− if not (Con.goodElm (_pkg_elm_version info)) then
97− throw (E.PkgBadElm (_pkg_elm_version info))
98−
99− else
100− do deps <- union noDups (_pkg_deps info) (_pkg_test_deps info)
101− let solver = Solver.solve deps
102− registry <- Cache.optionalUpdate
103− maybeSolution <- Explorer.run registry (Solver.run solver)
104− case maybeSolution of
105− Nothing ->
106− throw E.BadDeps
107−
108− Just solution ->
109− return solution
110−
111−
112−
113−-- APP TO SOLUTION
114−
115−
116−appToSolution :: Project.AppInfo -> Task.Task (Map.Map Pkg.Name V.Version)
117−appToSolution (Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
118− do a <- union allowEqualDups depsTrans testDirect
119− b <- union noDups depsDirect testTrans
120− union noDups a b
121−
122−
123−noDups :: Pkg.Name -> a -> a -> Task.Task a
124−noDups _ _ _ =
125− throw E.BadDeps
126−
127−
128−allowEqualDups :: Pkg.Name -> V.Version -> V.Version -> Task.Task V.Version
129−allowEqualDups _ v1 v2 =
130− if v1 == v2 then
131− return v1
132− else
133− throw E.BadDeps
134−
135−
136−union :: (Pkg.Name -> a -> a -> Task.Task a) -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Task.Task (Map.Map Pkg.Name a)
137−union tieBreaker deps1 deps2 =
138− Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
139−
140−
141−
142−-- VERIFY ARTIFACTS
143−
144−
145−verifyArtifacts :: Map.Map Pkg.Name V.Version -> Task.Task RawInfo
146−verifyArtifacts solution =
147− do Website.download =<< filterM noSrc (Map.toList solution)
148− verifyBuildArtifacts solution
149−
150−
151−noSrc :: (Pkg.Name, V.Version) -> Task.Task Bool
152−noSrc (name, version) =
153− do root <- Task.getPackageCacheDirFor name version
154− liftIO $ not <$> doesDirectoryExist (root </> "src")
155−
156−
157−
158−-- VERIFY BUILD ARTIFACTS
159−
160−
161−verifyBuildArtifacts :: Map.Map Pkg.Name V.Version -> Task.Task RawInfo
162−verifyBuildArtifacts solution =
163− do Task.report (Progress.BuildDepsStart (Map.size solution))
164− startMVar <- liftIO newEmptyMVar
165− ifacesMVar <- liftIO $ newMVar Map.empty
166− pkgInfoMVars <- Map.traverseWithKey (verifyBuild startMVar ifacesMVar) solution
167− liftIO $ putMVar startMVar pkgInfoMVars
168− answers <- liftIO $ traverse readMVar pkgInfoMVars
169− Task.report Progress.BuildDepsEnd
170− RawInfo
171− <$> Map.traverseMaybeWithKey toInfo answers
172− <*> liftIO (readMVar ifacesMVar)
173−
174−
175−data RawInfo =
176− RawInfo (Map.Map Pkg.Name PkgInfo) I.Interfaces
177−
178−
179−verifyBuild
180− :: MVar (Map.Map Pkg.Name (MVar Answer))
181− -> MVar I.Interfaces
182− -> Pkg.Name
183− -> V.Version
184− -> Task.Task (MVar Answer)
185−verifyBuild pkgInfoMVar ifacesMVar name version =
186− do mvar <- liftIO newEmptyMVar
187− info <- Cache.getElmJson name version
188− report <- Task.getReporter
189− runner <- Task.getSilentRunner
190−
191− liftIO $ void $ forkIO $
192− do allMVars <- readMVar pkgInfoMVar
193− let deps = Project._pkg_deps info
194− let depsMVars = Map.intersection allMVars deps
195− depAnswers <- traverse readMVar depsMVars
196−
197− answer <- ifNotBlocked depAnswers $ \infos ->
198− do ifacesBefore <- readMVar ifacesMVar
199− result <- runner (getIface name version info infos ifacesBefore)
200− case result of
201− Right ifaces ->
202− do ifacesNow <- takeMVar ifacesMVar
203− putMVar ifacesMVar (Map.union ifacesNow ifaces)
204− return (Ok info)
205−
206− Left _ ->
207− return (Err name version)
208−
209− report Progress.BuildDepsProgress
210− putMVar mvar answer
211−
212− return mvar
213−
214−
215−
216−-- ANSWERS
217−
218−
219−data Answer
220− = Ok PkgInfo
221− | Blocked
222− | Err Pkg.Name V.Version
223−
224−
225−toInfo :: Pkg.Name -> Answer -> Task.Task (Maybe PkgInfo)
226−toInfo _ answer =
227− case answer of
228− Ok info ->
229− return (Just info)
230−
231− Blocked ->
232− return Nothing
233−
234− Err name version ->
235− do elmHome <- liftIO PerUserCache.getElmHome
236− throw (E.BuildFailure elmHome name version)
237−
238−
239−ifNotBlocked :: Map.Map Pkg.Name Answer -> (Map.Map Pkg.Name PkgInfo -> IO Answer) -> IO Answer
240−ifNotBlocked answers callback =
241− case traverse isOk answers of
242− Nothing ->
243− return Blocked
244−
245− Just infos ->
246− callback infos
247−
248−
249−isOk :: Answer -> Maybe PkgInfo
250−isOk answer =
251− case answer of
252− Ok info -> Just info
253− Blocked -> Nothing
254− Err _ _ -> Nothing
255−
256−
257−
258−-- GET INTERFACE
259−
260−
261−getIface
262− :: Pkg.Name
263− -> V.Version
264− -> PkgInfo
265− -> Map.Map Pkg.Name PkgInfo
266− -> I.Interfaces
267− -> Task.Task I.Interfaces
268−getIface name version info infos depIfaces =
269− do root <- Task.getPackageCacheDirFor name version
270− let solution = Map.map _pkg_version infos
271−
272− cached <- liftIO $ isCached root solution
273−
274− if cached
275− then
276− do maybeIfaces <- liftIO $ IO.readBinary (root </> "ifaces.dat")
277− maybe (Task.throw (error "TODO corrupt binary 1")) return maybeIfaces
278− else
279− do Paths.removeStuff root
280− let summary = Summary.cheapInit root info infos depIfaces
281− args <- Args.fromSummary summary
282− graph <- Crawl.crawl summary args
283− (dirty, cachedIfaces) <- Plan.plan summary graph
284− answers <- Compile.compile (Pkg info) cachedIfaces dirty
285− results <- Artifacts.ignore answers
286− Paths.removeStuff root
287−
288− updateCache root name info solution graph results
289−
290−
291−
292−-- IS CACHED?
293−
294−
295−isCached :: FilePath -> Map.Map Pkg.Name V.Version -> IO Bool
296−isCached root solution =
297− IO.andM
298− [ IO.exists (root </> "cached.dat")
299− , IO.exists (root </> "ifaces.dat")
300− , IO.exists (root </> "objs.dat")
301− , isCachedHelp solution <$> IO.readBinary (root </> "cached.dat")
302− ]
303−
304−
305−isCachedHelp :: Map.Map Pkg.Name V.Version -> Maybe (Map.Map Pkg.Name (Set.Set V.Version)) -> Bool
306−isCachedHelp solution maybeCachedDeps =
307− case maybeCachedDeps of
308− Nothing ->
309− False
310−
311− Just cachedDeps ->
312− let
313− matches =
314− Map.intersectionWith Set.member solution cachedDeps
315− in
316− Map.size solution == Map.size matches
317− && Map.foldr (&&) True matches
318−
319−
320−
321−-- UPDATE CACHE
322−
323−
324−updateCache
325− :: FilePath
326− -> Pkg.Name
327− -> PkgInfo
328− -> Map.Map Pkg.Name V.Version
329− -> Crawl.Result
330− -> Map.Map ModuleName.Raw Compiler.Artifacts
331− -> Task.Task I.Interfaces
332−updateCache root name info solution graph results =
333− do let path = root </> "cached.dat"
334− let deps = Map.map Set.singleton solution
335− let elmi = crush name info results
336−
337− exists <- liftIO $ IO.exists path
338−
339− if exists
340− then
341− do maybeOldDeps <- liftIO $ IO.readBinary path
342− oldDeps <- maybe (error "TODO corrupt binary 2") return maybeOldDeps
343− liftIO $ IO.writeBinary path (Map.unionWith Set.union deps oldDeps)
344− else
345− liftIO $
346− do IO.writeBinary (root </> "ifaces.dat") elmi
347− IO.writeBinary path deps
348− IO.writeBinary (root </> "objs.dat") $
349− Map.foldr addGraph (objGraphFromKernels graph) results
350−
351− return elmi
352−
353−
354−
355−-- CRUSH INTERFACES
356−
357−
358−crush :: Pkg.Name -> PkgInfo -> Map.Map ModuleName.Raw Compiler.Artifacts -> I.Interfaces
359−crush pkg info results =
360− let
361− exposed =
362− Set.fromList (Project.getExposed info)
363− in
364− Map.mapKeys (ModuleName.Canonical pkg) $
365− Map.mapMaybeWithKey (crushHelp exposed) results
366−
367−
368−crushHelp :: Set.Set ModuleName.Raw -> ModuleName.Raw -> Compiler.Artifacts -> Maybe I.Interface
369−crushHelp exposed name (Compiler.Artifacts elmi _) =
370− if Set.member name exposed then
371− Just elmi
372−
373− else
374− Nothing
375−
376−
377−
378−-- OBJECT GRAPH
379−
380−
381−addGraph :: Compiler.Artifacts -> Obj.Graph -> Obj.Graph
382−addGraph (Compiler.Artifacts _ elmo) graph =
383− Obj.union elmo graph
384−
385−
386−objGraphFromKernels :: Crawl.Result -> Obj.Graph
387−objGraphFromKernels (Crawl.Graph _ _ kernels _ _) =
388− Obj.fromKernels kernels
builder/src/Elm/Details.hs+479−6
@@ -1,26 +1,34 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Elm.Details
3module Elm.Details
3 ( Details(..)
4 ( Details(..)
4 , ValidOutline(..)
5 , ValidOutline(..)
5 , Local(..)
6 , Local(..)
6 , Foreign(..)
7 , Foreign(..)
8+ , verify
7 )
9 )
8 where
10 where
9
11
10
12
11import Control.Concurrent (forkIO)
13import Control.Concurrent (forkIO)
12−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
14+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
13import Control.Monad (liftM, liftM2, liftM3, liftM4)
15import Control.Monad (liftM, liftM2, liftM3, liftM4)
14import Data.Binary (Binary, get, put, getWord8, putWord8)
16import Data.Binary (Binary, get, put, getWord8, putWord8)
17+import Data.Foldable (traverse_)
15import qualified Data.Map as Map
18import qualified Data.Map as Map
16import qualified Data.Map.Merge.Strict as Map
19import qualified Data.Map.Merge.Strict as Map
20+import qualified Data.OneOrMore as OneOrMore
17import qualified Data.Set as Set
21import qualified Data.Set as Set
18import qualified Data.Utf8 as Utf8
22import qualified Data.Utf8 as Utf8
19−import System.Directory (doesDirectoryExist)
23+import qualified System.Directory as Dir
20−import System.FilePath ((</>))
24+import System.FilePath ((</>), (<.>))
21
25
26+import qualified AST.Source as Src
27+import qualified AST.Optimized as Opt
28+import qualified Compile
22import qualified Deps.Registry as Registry
29import qualified Deps.Registry as Registry
23import qualified Deps.Solver as Solver
30import qualified Deps.Solver as Solver
31+import qualified Deps.Website as Website
24import qualified Elm.Constraint as Con
32import qualified Elm.Constraint as Con
25import qualified Elm.Interface as I
33import qualified Elm.Interface as I
26import qualified Elm.ModuleName as ModuleName
34import qualified Elm.ModuleName as ModuleName
@@ -30,8 +38,8 @@ import qualified Elm.Version as V
30import qualified File
38import qualified File
31import qualified Http
39import qualified Http
32import qualified Json.Decode as D
40import qualified Json.Decode as D
41+import qualified Parse.Module as Parse
33import qualified Reporting.Exit as Exit
42import qualified Reporting.Exit as Exit
34−import qualified Reporting.Progress as Progress
35import qualified Reporting.Task as Task
43import qualified Reporting.Task as Task
36import qualified Stuff
44import qualified Stuff
37
45
@@ -67,6 +75,466 @@ data Foreign =
67
75
68
76
69
77
78+-- VERIFY
79+
80+
81+verify :: FilePath -> Task.Task Details
82+verify root =
83+ do newTime <- Task.io $ File.getTime (root </> "elm.json")
84+ maybeDetails <- Task.io $ File.readBinary (root </> Stuff.details)
85+ case maybeDetails of
86+ Nothing ->
87+ rebuild root newTime
88+
89+ Just details@(Details oldTime _ _ _) ->
90+ if oldTime == newTime
91+ then return details
92+ else rebuild root newTime
93+
94+
95+
96+-- REBUILD
97+
98+
99+rebuild :: FilePath -> File.Time -> Task.Task Details
100+rebuild root time =
101+ do (outline, info) <- rebuildHelp root
102+ case outline of
103+ Outline.Pkg pkg -> solvePkg info time pkg
104+ Outline.App app -> solveApp info time app
105+
106+
107+data Info =
108+ Info Stuff.PackageCache Http.Manager Connection Registry.Registry
109+
110+
111+data Connection
112+ = Online
113+ | Offline
114+
115+
116+rebuildHelp :: FilePath -> Task.Task (Outline.Outline, Info)
117+rebuildHelp root =
118+ Task.eio id $
119+ do cacheMVar <- fork Stuff.getPackageCache
120+ managerMVar <- fork Http.getManager
121+ registryMVar <- fork (Registry.read =<< readMVar cacheMVar)
122+ eitherOutline <- Outline.read root
123+ cache <- readMVar cacheMVar
124+ manager <- readMVar managerMVar
125+ maybeRegistry <- readMVar registryMVar
126+ case eitherOutline of
127+ Left problem ->
128+ return $ Left $ Exit.DetailsBadOutline problem
129+
130+ Right outline ->
131+ case maybeRegistry of
132+ Nothing ->
133+ do eitherRegistry <- Registry.fetch manager cache
134+ case eitherRegistry of
135+ Right latestRegistry ->
136+ return $ Right (outline, Info cache manager Online latestRegistry)
137+
138+ Left problem ->
139+ return $ Left $ Exit.DetailsCannotGetRegistry problem
140+
141+ Just cachedRegistry ->
142+ do eitherRegistry <- Registry.update manager cache cachedRegistry
143+ case eitherRegistry of
144+ Right latestRegistry ->
145+ return $ Right (outline, Info cache manager Online latestRegistry)
146+
147+ Left _ ->
148+ return $ Right (outline, Info cache manager Offline cachedRegistry)
149+
150+
151+
152+-- SOLVE PKG
153+
154+
155+solvePkg :: Info -> File.Time -> Outline.PkgOutline -> Task.Task Details
156+solvePkg info time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
157+ if Con.goodElm elm
158+ then
159+ do solution <- solve info =<< union noDups direct testDirect
160+ foreigns <- verifyDependencies info solution direct
161+ let vsns = Map.map (\(Solver.Details v _) -> v) solution
162+ return $ Details time (ValidPkg outline vsns) Map.empty foreigns
163+ else
164+ Task.throw $ Exit.DetailsBadElmInPkg elm
165+
166+
167+
168+-- SOLVE APP
169+
170+
171+solveApp :: Info -> File.Time -> Outline.AppOutline -> Task.Task Details
172+solveApp info time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
173+ if elmVersion == V.compiler
174+ then
175+ do stated <- checkAppDeps outline
176+ actual <- solve info (Map.map Con.exactly stated)
177+ if Map.size stated == Map.size actual
178+ then
179+ do foreigns <- verifyDependencies info actual direct
180+ return $ Details time (ValidApp outline) Map.empty foreigns
181+ else
182+ Task.throw $ error "TODO solveApp"
183+ else
184+ Task.throw $ Exit.DetailsBadElmInApp elmVersion
185+
186+
187+checkAppDeps :: Outline.AppOutline -> Task.Task (Map.Map Pkg.Name V.Version)
188+checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
189+ do x <- union allowEqualDups indirect testDirect
190+ y <- union noDups direct testIndirect
191+ union noDups x y
192+
193+
194+
195+-- SOLVE
196+
197+
198+solve :: Info -> Map.Map Pkg.Name Con.Constraint -> Task.Task (Map.Map Pkg.Name Solver.Details)
199+solve (Info cache manager connection registry) constraints =
200+ Task.eio (error "TODO solve problem") $
201+ case connection of
202+ Online -> Solver.online cache manager registry constraints
203+ Offline -> Solver.offline cache registry constraints
204+
205+
206+
207+-- UNION
208+
209+
210+union :: (Ord k) => (k -> v -> v -> Task.Task v) -> Map.Map k v -> Map.Map k v -> Task.Task (Map.Map k v)
211+union tieBreaker deps1 deps2 =
212+ Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
213+
214+
215+noDups :: k -> v -> v -> Task.Task v
216+noDups _ _ _ =
217+ Task.throw Exit.DetailsHandEditedDependencies
218+
219+
220+allowEqualDups :: (Eq v) => k -> v -> v -> Task.Task v
221+allowEqualDups _ v1 v2 =
222+ if v1 == v2
223+ then return v1
224+ else Task.throw Exit.DetailsHandEditedDependencies
225+
226+
227+
228+-- FORK
229+
230+
231+fork :: IO a -> IO (MVar a)
232+fork work =
233+ do mvar <- newEmptyMVar
234+ _ <- forkIO $ putMVar mvar =<< work
235+ return mvar
236+
237+
238+
239+-- VERIFY DEPENDENCIES
240+
241+
242+verifyDependencies :: Info -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task.Task (Map.Map ModuleName.Raw Foreign)
243+verifyDependencies info solution directDeps =
244+ Task.eio (error "TODO verifyDependencies") $
245+ do mvar <- newEmptyMVar
246+ mvars <- Map.traverseWithKey (\k v -> fork (verifyDep info mvar solution k v)) solution
247+ putMVar mvar mvars
248+ results <- traverse readMVar mvars
249+ case sequence results of
250+ Left _ ->
251+ return (Left (error "TODO one of the dependencies did not build"))
252+
253+ Right artifacts ->
254+ let
255+ objs = Map.foldr gatherObjects Opt.empty artifacts
256+ ifaces = Map.foldrWithKey (gatherInterfaces directDeps) Map.empty artifacts
257+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
258+ in
259+ do File.writeBinary Stuff.objects objs
260+ File.writeBinary Stuff.interfaces ifaces
261+ return (Right foreigns)
262+
263+
264+gatherObjects :: Artifacts -> Opt.Graph -> Opt.Graph
265+gatherObjects (Artifacts _ objs) graph =
266+ Opt.union objs graph
267+
268+
269+gatherInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Canonical I.DependencyInterface
270+gatherInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
271+ Map.union dependencyInterfaces $ Map.mapKeys (ModuleName.Canonical pkg) $
272+ if Map.member pkg directDeps
273+ then ifaces
274+ else Map.map I.privatize ifaces
275+
276+
277+gatherForeigns :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name)
278+gatherForeigns pkg (Artifacts ifaces _) foreigns =
279+ let
280+ isPublic di =
281+ case di of
282+ I.Public _ -> Just (OneOrMore.one pkg)
283+ I.Private _ _ -> Nothing
284+ in
285+ Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
286+
287+
288+
289+-- VERIFY DEPENDENCY
290+
291+
292+data Artifacts =
293+ Artifacts
294+ { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
295+ , _objects :: Opt.Graph
296+ }
297+
298+
299+type Result =
300+ Either Problem Artifacts
301+
302+
303+data Problem
304+ = BadDownload Exit.PackageProblem
305+ | BadBuild
306+ | BadDependency
307+
308+
309+verifyDep :: Info -> MVar (Map.Map Pkg.Name (MVar Result)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Result
310+verifyDep (Info cache manager _ _) resultsMVar solution name details@(Solver.Details version directDeps) =
311+ let
312+ fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
313+ in
314+ do exists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
315+ if exists
316+ then
317+ do maybeCache <- File.readBinary (Stuff.package cache name version </> "artifacts.dat")
318+ case maybeCache of
319+ Nothing ->
320+ build cache resultsMVar name details (Set.singleton fingerprint)
321+
322+ Just (ArtifactCache fingerprints artifacts) ->
323+ if Set.member fingerprint fingerprints
324+ then return (Right artifacts)
325+ else build cache resultsMVar name details (Set.insert fingerprint fingerprints)
326+ else
327+ do result <- downloadPackage cache manager name version
328+ case result of
329+ Left p -> return (Left (BadDownload p))
330+ Right () -> build cache resultsMVar name details (Set.singleton fingerprint)
331+
332+
333+
334+-- ARTIFACT CACHE
335+
336+
337+data ArtifactCache =
338+ ArtifactCache
339+ { _fingerprints :: Set.Set Fingerprint
340+ , _artifacts :: Artifacts
341+ }
342+
343+
344+type Fingerprint =
345+ Map.Map Pkg.Name V.Version
346+
347+
348+
349+-- BUILD
350+
351+
352+build :: Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Result)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Result
353+build cache resultsMVar name (Solver.Details version _) fingerprints =
354+ do eitherOutline <- Outline.read (Stuff.package cache name version </> "elm.json")
355+ case eitherOutline of
356+ Left _ ->
357+ return (Left BadBuild)
358+
359+ Right (Outline.App _) ->
360+ return (Left BadBuild)
361+
362+ Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
363+ do allResults <- readMVar resultsMVar
364+ directResults <- traverse readMVar (Map.intersection allResults deps)
365+ case sequence directResults of
366+ Left _ ->
367+ return (Left BadDependency)
368+
369+ Right directArtifacts ->
370+ do mvar <- newMVar Map.empty
371+ let src = Stuff.package cache name version </> "src"
372+ let foreignDeps = gatherForeignInterfaces directArtifacts
373+ let exposedDict = Map.fromList $ map (\n -> (n,())) (Outline.flattenExposed exposed)
374+ traverse_ readMVar =<<
375+ Map.traverseWithKey (const . fork . buildModule foreignDeps mvar name src) exposedDict
376+ result <- traverse readMVar =<< readMVar mvar
377+ case Map.traverseMaybeWithKey checkStatus result of
378+ Nothing ->
379+ return (Left BadBuild)
380+
381+ Just artifactsDict ->
382+ let
383+ path = Stuff.package cache name version </> "artifacts.dat"
384+ ifaces = gatherPackageInterfaces exposedDict artifactsDict
385+ objects = Map.foldr (Opt.union . snd) Opt.empty artifactsDict
386+ artifacts = Artifacts ifaces objects
387+ in
388+ do File.writeBinary path (ArtifactCache fingerprints artifacts)
389+ return (Right artifacts)
390+
391+
392+checkStatus :: ModuleName.Raw -> Status -> Maybe (Maybe (I.Interface, Opt.Graph))
393+checkStatus _ status =
394+ case status of
395+ SFailure -> Nothing
396+ SLocal i g -> Just (Just (i,g))
397+ SForeign _ -> Just Nothing
398+
399+
400+gatherPackageInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw (I.Interface, Opt.Graph) -> Map.Map ModuleName.Raw I.DependencyInterface
401+gatherPackageInterfaces exposed artifacts =
402+ Map.merge onLeft onRight onBoth exposed artifacts
403+ where
404+ onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherPackageInterfaces")
405+ onRight = Map.mapMissing (\_ (i,_) -> I.private i)
406+ onBoth = Map.zipWithMatched (\_ () (i,_) -> I.public i)
407+
408+
409+
410+-- FOREIGN INTERFACES
411+
412+
413+data ForeignInterface
414+ = ForeignAmbiguous
415+ | ForeignSpecific I.Interface
416+
417+
418+gatherForeignInterfaces :: Map.Map Pkg.Name Artifacts -> Map.Map ModuleName.Raw ForeignInterface
419+gatherForeignInterfaces directArtifacts =
420+ Map.map (OneOrMore.destruct finalize) $
421+ Map.foldrWithKey gather Map.empty directArtifacts
422+ where
423+ finalize :: I.Interface -> [I.Interface] -> ForeignInterface
424+ finalize i is =
425+ case is of
426+ [] -> ForeignSpecific i
427+ _:_ -> ForeignAmbiguous
428+
429+ gather :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface)
430+ gather _ (Artifacts ifaces _) buckets =
431+ Map.unionWith OneOrMore.more buckets (Map.mapMaybe isPublic ifaces)
432+
433+ isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
434+ isPublic di =
435+ case di of
436+ I.Public iface -> Just (OneOrMore.one iface)
437+ I.Private _ _ -> Nothing
438+
439+
440+
441+-- BUILD MODULE
442+
443+
444+type StatusDict =
445+ Map.Map ModuleName.Raw (MVar Status)
446+
447+
448+data Status
449+ = SLocal !I.Interface !Opt.Graph
450+ | SForeign I.Interface
451+ | SFailure
452+
453+
454+buildModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO Status
455+buildModule foreignDeps mvar pkg src name =
456+ do let path = src </> ModuleName.toFilePath name <.> "elm"
457+ exists <- File.exists path
458+ case Map.lookup name foreignDeps of
459+ Just ForeignAmbiguous ->
460+ return SFailure
461+
462+ Just (ForeignSpecific iface) ->
463+ if exists
464+ then return SFailure
465+ else return (SForeign iface)
466+
467+ Nothing ->
468+ if not exists
469+ then return SFailure
470+ else
471+ do result <- Parse.fromFile pkg path
472+ case result of
473+ Right modul@(Src.Module (Just actualName) _ deps _ _ _ _ _) | name == actualName ->
474+ do statusDict <- takeMVar mvar
475+ let depsDict = Map.fromList $ map (\i -> (Src.getImport i, ())) deps
476+ let newsDict = Map.difference depsDict statusDict
477+ statusMVars <- Map.traverseWithKey (const . fork . buildModule foreignDeps mvar pkg src) newsDict
478+ putMVar mvar (Map.union statusMVars statusDict)
479+ statuses <- traverse readMVar statusMVars
480+ case traverse getInterface statuses of
481+ Nothing ->
482+ return SFailure
483+
484+ Just imports ->
485+ case Compile.compile pkg imports modul of
486+ (_, Right (Compile.Artifacts canonical annotations objects)) ->
487+ return (SLocal (I.fromModule pkg canonical annotations) objects)
488+
489+ (_, Left _) ->
490+ return SFailure
491+
492+ _ ->
493+ return SFailure
494+
495+
496+getInterface :: Status -> Maybe I.Interface
497+getInterface status =
498+ case status of
499+ SLocal iface _ -> Just iface
500+ SForeign iface -> Just iface
501+ SFailure -> Nothing
502+
503+
504+
505+-- DOWNLOAD PACKAGE
506+
507+
508+downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
509+downloadPackage cache manager name version =
510+ do eitherByteString <-
511+ Http.post manager (Website.metadata name version "endpoint.json") [] id (return . Right)
512+
513+ case eitherByteString of
514+ Left err ->
515+ return (Left (Exit.PP_BadEndpointRequest err))
516+
517+ Right byteString ->
518+ case D.fromByteString endpointDecoder byteString of
519+ Left _ ->
520+ return (Left Exit.PP_BadEndpointContent)
521+
522+ Right (endpoint, expectedHash) ->
523+ Http.fetchArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
524+ \(sha, archive) ->
525+ if expectedHash == Http.shaToChars sha
526+ then Right <$> File.writeArchive (Stuff.package cache name version) archive
527+ else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
528+
529+
530+endpointDecoder :: D.Decoder e (String, String)
531+endpointDecoder =
532+ do url <- D.field "url" D.string
533+ hash <- D.field "hash" D.string
534+ return (Utf8.toChars url, Utf8.toChars hash)
535+
536+
537+
70-- BINARY
538-- BINARY
71
539
72
540
@@ -100,5 +568,10 @@ instance Binary Foreign where
100
568
101
569
102instance Binary Artifacts where
570instance Binary Artifacts where
103− get = liftM3 Artifacts get get get
571+ get = liftM2 Artifacts get get
104− put (Artifacts a b c) = put a >> put b >> put c
572+ put (Artifacts a b) = put a >> put b
573+
574+
575+instance Binary ArtifactCache where
576+ get = liftM2 ArtifactCache get get
577+ put (ArtifactCache a b) = put a >> put b