git.iko.soy/elk
on 7dbdaae help sign in
elk/builder/src/Deps/Cache.hs
260 lines 6.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Deps.Cache
4 ( optionalUpdate
5 , mandatoryUpdate
6 , PackageRegistry
7 , getPackageRegistry
8 , getVersions
9 , getElmJson
10 , getDocs
11 )
12 where
15import Prelude hiding (all)
16import Control.Monad (liftM2)
17import Control.Monad.Except (catchError, liftIO)
18import Data.Binary (Binary, get, put)
19import qualified Data.ByteString as BS
20import Data.Function (on)
21import qualified Data.List as List
22import qualified Data.Map as Map
23import Data.Map (Map)
24import qualified Data.Text as Text
25import System.FilePath ((</>))
27import qualified Elm.Docs as Docs
28import qualified Elm.Package as Pkg
30import qualified Deps.Website as Website
31import qualified Elm.Project.Json as Project
32import qualified File.IO as IO
33import qualified Json.Decode as Decode
34import qualified Reporting.Doc as D
35import qualified Reporting.Exit as Exit
36import qualified Reporting.Exit.Assets as E
37import qualified Reporting.Progress as Progress
38import qualified Reporting.Suggest as Suggest
39import qualified Reporting.Task as Task
43-- PACKAGE REGISTRY
46data PackageRegistry =
47 PackageRegistry Int (Map Pkg.Name [Pkg.Version])
50getPackageRegistry :: Task.Task PackageRegistry
51getPackageRegistry =
52 do path <- getRegistryPath
53 exists <- IO.exists path
54 if exists
55 then IO.readBinary path
56 else rebuild
59getRegistryPath :: Task.Task FilePath
60getRegistryPath =
61 do dir <- Task.getPackageCacheDir
62 return (dir </> "versions.dat")
66-- REBUILD
69rebuild :: Task.Task PackageRegistry
70rebuild =
71 do path <- getRegistryPath
72 packages <- Website.getAllPackages
73 let size = Map.foldr ((+) . length) 0 packages
74 let registry = PackageRegistry size packages
75 IO.writeBinary path registry
76 return registry
80-- UPDATE
83optionalUpdate :: Task.Task PackageRegistry
84optionalUpdate =
85 update False
88mandatoryUpdate :: Task.Task PackageRegistry
89mandatoryUpdate =
90 update True
93update :: Bool -> Task.Task PackageRegistry
94update isMandatory =
95 do path <- getRegistryPath
96 exists <- IO.exists path
97 if not exists
98 then rebuild
99 else
100 do registry <- IO.readBinary path
101 if isMandatory
102 then attemptUpdate registry
103 else attemptUpdate registry `catchError` recoverUpdate registry
106recoverUpdate :: PackageRegistry -> a -> Task.Task PackageRegistry
107recoverUpdate registry _ =
108 do Task.report Progress.UnableToLoadLatestPackages
109 return registry
112attemptUpdate :: PackageRegistry -> Task.Task PackageRegistry
113attemptUpdate oldRegistry@(PackageRegistry size packages) =
114 do news <- Website.getNewPackages size
115 case news of
116 [] ->
117 return oldRegistry
119 _:_ ->
120 let
121 newSize = size + length news
122 newPkgs = List.foldl' addNew packages news
123 newRegistry = PackageRegistry newSize newPkgs
124 in
125 do path <- getRegistryPath
126 IO.writeBinary path newRegistry
127 return newRegistry
130addNew :: Map Pkg.Name [Pkg.Version] -> (Pkg.Name, Pkg.Version) -> Map Pkg.Name [Pkg.Version]
131addNew packages (name, version) =
132 Map.insertWith (++) name [version] packages
136-- GET VERSIONS
139getVersions :: Pkg.Name -> PackageRegistry -> Either [Pkg.Name] [Pkg.Version]
140getVersions name (PackageRegistry _ pkgs) =
141 case Map.lookup name pkgs of
142 Just vsns ->
143 Right vsns
145 Nothing ->
146 Left (nearbyNames name (Map.keys pkgs))
149nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
150nearbyNames (Pkg.Name author1 project1) possibleNames =
151 let
152 authorDist = authorDistance (Text.unpack author1)
153 projectDist = projectDistance (Text.unpack project1)
155 addDistance name@(Pkg.Name author2 project2) =
156 ( authorDist author2 + projectDist project2, name )
157 in
158 map snd $ take 4 $
159 List.sortBy (compare `on` fst) $
160 map addDistance possibleNames
163authorDistance :: String -> Text.Text -> Int
164authorDistance bad possibility =
165 abs (Suggest.distance bad (Text.unpack possibility))
168projectDistance :: String -> Text.Text -> Int
169projectDistance bad possibility =
170 if possibility == "elm-lang" || possibility == "elm-explorations" then
171 0
172 else
173 abs (Suggest.distance bad (Text.unpack possibility))
177-- PACKAGE INFO
180getElmJson :: Pkg.Name -> Pkg.Version -> Task.Task Project.PkgInfo
181getElmJson name version =
182 do dir <- Task.getPackageCacheDirFor name version
183 let elmJson = dir </> "elm.json"
185 exists <- IO.exists elmJson
187 json <-
188 if exists
189 then liftIO (BS.readFile elmJson)
190 else
191 do bits <- Website.getElmJson name version
192 liftIO (BS.writeFile elmJson bits)
193 return bits
195 case Decode.parse "project" E.badContentToDocs Project.pkgDecoder json of
196 Right pkgInfo ->
197 return pkgInfo
199 Left _ ->
200 do IO.remove elmJson
201 Task.throw $ Exit.Assets $ E.CorruptElmJson name version
205-- DOCS
208getDocs :: Pkg.Name -> Pkg.Version -> Task.Task Docs.Documentation
209getDocs name version =
210 do dir <- Task.getPackageCacheDirFor name version
211 let docsJson = dir </> "docs.json"
213 exists <- IO.exists docsJson
215 json <-
216 if exists
217 then liftIO (BS.readFile docsJson)
218 else
219 do bits <- Website.getDocs name version
220 liftIO (BS.writeFile docsJson bits)
221 return bits
223 case Decode.parse "docs" errorToDocs (Docs.toDict <$> Decode.list Docs.decoder) json of
224 Right pkgInfo ->
225 return pkgInfo
227 Left _ ->
228 do IO.remove docsJson
229 Task.throw $ Exit.Assets $ E.CorruptDocumentation name version
232errorToDocs :: Docs.Error -> [D.Doc]
233errorToDocs err =
234 let
235 details =
236 case err of
237 Docs.BadAssociativity txt ->
238 ["Binary","operators","cannot","have",D.red (D.fromString (show txt)),"as","their","associativity."]
240 Docs.BadName ->
241 ["It","is","not","a","valid","module","name."]
243 Docs.BadType ->
244 ["It","is","not","a","valid","Elm","type."]
245 in
246 details
247 ++
248 ["This","should","not","happen","in","general,","so","please","report","this","at"
249 ,"<https://github.com/elm-lang/package.elm-lang.org/issues>"
250 ,"if","you","think","it","is","on","the","Elm","side!"
251 ]
255-- BINARY
258instance Binary PackageRegistry where
259 get = liftM2 PackageRegistry get get
260 put (PackageRegistry a b) = put a >> put b