@@ -1,25 +1,28 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Deps.Get
4− ( all
5− , AllPackages
6− , Mode(..)
7− , versions
8− , info
9− , docs
3+module Deps.Cache
4+ ( update
5+ , optionalUpdate
6+ , mandatoryUpdate
7+ , PackageRegistry
8+ , getPackageRegistry
9+ , getVersions
10+ , getElmJson
11+ , getDocs
1012 )
1113 where
1214
1315
1416import Prelude hiding (all)
17+import Control.Monad (liftM2)
1518import Control.Monad.Except (catchError, liftIO)
19+import Data.Binary (Binary, get, put)
1620import qualified Data.ByteString as BS
1721import Data.Function (on)
1822import qualified Data.List as List
1923import qualified Data.Map as Map
2024import Data.Map (Map)
2125import qualified Data.Text as Text
22−import qualified System.Directory as Dir
2326import System.FilePath ((</>))
2427
2528import qualified Elm.Docs as Docs
@@ -38,53 +41,91 @@ import qualified Reporting.Task as Task
3841
3942
4043
41−-- ALL VERSIONS
44+-- PACKAGE REGISTRY
4245
4346
44−data Mode = RequireLatest | AllowOffline
47+data PackageRegistry =
48+ PackageRegistry Int (Map Pkg.Name [Pkg.Version])
4549
4650
47−newtype AllPackages = AllPackages (Map Pkg.Name [Pkg.Version])
51+getPackageRegistry :: Task.Task PackageRegistry
52+getPackageRegistry =
53+ do path <- getRegistryPath
54+ exists <- IO.exists path
55+ if exists
56+ then IO.readBinary path
57+ else rebuild
4858
4959
50−all :: Mode -> Task.Task AllPackages
51−all mode =
60+getRegistryPath :: Task.Task FilePath
61+getRegistryPath =
5262 do dir <- Task.getPackageCacheDir
53− let versionsFile = dir </> "versions.dat"
54− exists <- liftIO $ Dir.doesFileExist versionsFile
55− if exists
56− then fetchNew versionsFile mode
57− else fetchAll versionsFile
63+ return (dir </> "versions.dat")
64+
65+
66+
67+-- REBUILD
5868
5969
60−fetchAll :: FilePath -> Task.Task AllPackages
61−fetchAll versionsFile =
62− do packages <- Website.getAllPackages
70+rebuild :: Task.Task PackageRegistry
71+rebuild =
72+ do path <- getRegistryPath
73+ packages <- Website.getAllPackages
6374 let size = Map.foldr ((+) . length) 0 packages
64− IO.writeBinary versionsFile (size, packages)
65− return (AllPackages packages)
75+ let registry = PackageRegistry size packages
76+ IO.writeBinary path registry
77+ return registry
6678
6779
68−fetchNew :: FilePath -> Mode -> Task.Task AllPackages
69−fetchNew versionsFile mode =
70− do (size, packages) <- IO.readBinary versionsFile
7180
72− news <-
73− case mode of
74− RequireLatest ->
75− Website.getNewPackages size
81+-- UPDATE
7682
77− AllowOffline ->
78− Website.getNewPackages size `catchError` \_ ->
79− do Task.report Progress.UnableToLoadLatestPackages
80− return []
8183
82− if null news
83− then return (AllPackages packages)
84+optionalUpdate :: Task.Task PackageRegistry
85+optionalUpdate =
86+ update False
87+
88+
89+mandatoryUpdate :: Task.Task PackageRegistry
90+mandatoryUpdate =
91+ update True
92+
93+
94+update :: Bool -> Task.Task PackageRegistry
95+update isMandatory =
96+ do path <- getRegistryPath
97+ exists <- IO.exists path
98+ if not exists
99+ then rebuild
84100 else
85− do let newAllPkgs = List.foldl' addNew packages news
86− IO.writeBinary versionsFile (size + length news, newAllPkgs)
87− return (AllPackages newAllPkgs)
101+ do registry <- IO.readBinary path
102+ if isMandatory
103+ then attemptUpdate registry
104+ else attemptUpdate registry `catchError` recoverUpdate registry
105+
106+
107+recoverUpdate :: PackageRegistry -> a -> Task.Task PackageRegistry
108+recoverUpdate registry _ =
109+ do Task.report Progress.UnableToLoadLatestPackages
110+ return registry
111+
112+
113+attemptUpdate :: PackageRegistry -> Task.Task PackageRegistry
114+attemptUpdate oldRegistry@(PackageRegistry size packages) =
115+ do news <- Website.getNewPackages size
116+ case news of
117+ [] ->
118+ return oldRegistry
119+
120+ _:_ ->
121+ let
122+ newSize = size + length news
123+ newPkgs = List.foldl' addNew packages news
124+ newRegistry = PackageRegistry newSize newPkgs
125+ in
126+ do path <- getRegistryPath
127+ IO.writeBinary path newRegistry
128+ return newRegistry
88129
89130
90131addNew :: Map Pkg.Name [Pkg.Version] -> (Pkg.Name, Pkg.Version) -> Map Pkg.Name [Pkg.Version]
@@ -93,11 +134,11 @@ addNew packages (name, version) =
93134
94135
95136
96−-- VERSIONS
137+-- GET VERSIONS
97138
98139
99−versions :: Pkg.Name -> AllPackages -> Either [Pkg.Name] [Pkg.Version]
100−versions name (AllPackages pkgs) =
140+getVersions :: Pkg.Name -> PackageRegistry -> Either [Pkg.Name] [Pkg.Version]
141+getVersions name (PackageRegistry _ pkgs) =
101142 case Map.lookup name pkgs of
102143 Just vsns ->
103144 Right vsns
@@ -137,12 +178,12 @@ projectDistance bad possibility =
137178-- PACKAGE INFO
138179
139180
140−info :: Pkg.Name -> Pkg.Version -> Task.Task Project.PkgInfo
141−info name version =
181+getElmJson :: Pkg.Name -> Pkg.Version -> Task.Task Project.PkgInfo
182+getElmJson name version =
142183 do dir <- Task.getPackageCacheDirFor name version
143184 let elmJson = dir </> "elm.json"
144185
145− exists <- liftIO $ Dir.doesFileExist elmJson
186+ exists <- IO.exists elmJson
146187
147188 json <-
148189 if exists
@@ -165,12 +206,12 @@ info name version =
165206-- DOCS
166207
167208
168−docs :: Pkg.Name -> Pkg.Version -> Task.Task Docs.Documentation
169−docs name version =
209+getDocs :: Pkg.Name -> Pkg.Version -> Task.Task Docs.Documentation
210+getDocs name version =
170211 do dir <- Task.getPackageCacheDirFor name version
171212 let docsJson = dir </> "docs.json"
172213
173− exists <- liftIO $ Dir.doesFileExist docsJson
214+ exists <- IO.exists docsJson
174215
175216 json <-
176217 if exists
@@ -209,3 +250,12 @@ errorToDocs err =
209250 ,"<https://github.com/elm-lang/package.elm-lang.org/issues>"
210251 ,"if","you","think","it","is","on","the","Elm","side!"
211252 ]
253+
254+
255+
256+-- BINARY
257+
258+
259+instance Binary PackageRegistry where
260+ get = liftM2 PackageRegistry get get
261+ put (PackageRegistry a b) = put a >> put b