git.iko.soy/elk
on be145bc help sign in
elk/builder/src/Deps/Cache.hs
248 lines 6.2 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 qualified Data.Name as Name
24import System.FilePath ((</>))
26import qualified Deps.Website as Website
27import qualified Elm.Docs as Docs
28import qualified Elm.Package as Pkg
29import qualified Elm.Project.Json as Project
30import qualified Elm.Version as V
31import qualified File.IO as IO
32import qualified Json.Decode as Decode
33import qualified Reporting.Exit as Exit
34import qualified Reporting.Exit.Assets as E
35import qualified Reporting.Progress as Progress
36import qualified Reporting.Suggest as Suggest
37import qualified Reporting.Task as Task
41-- PACKAGE REGISTRY
44data PackageRegistry =
45 PackageRegistry Int (Map.Map Pkg.Name [V.Version])
48getPackageRegistry :: Task.Task PackageRegistry
49getPackageRegistry =
50 do path <- getRegistryPath
51 exists <- liftIO $ IO.exists path
52 if exists
53 then unsafeGetRegistry path
54 else rebuild
57getRegistryPath :: Task.Task FilePath
58getRegistryPath =
59 do dir <- Task.getPackageCacheDir
60 return (dir </> "versions.dat")
63unsafeGetRegistry :: FilePath -> Task.Task PackageRegistry
64unsafeGetRegistry path =
65 do maybeRegistry <- liftIO $ IO.readBinary path
66 case maybeRegistry of
67 Just registry ->
68 return registry
70 Nothing ->
71 liftIO (putStrLn path) >>
72 Task.throw (error "TODO corrupt binary 3")
76-- REBUILD
79rebuild :: Task.Task PackageRegistry
80rebuild =
81 do path <- getRegistryPath
82 packages <- Website.getAllPackages
83 let size = Map.foldr ((+) . length) 0 packages
84 let registry = PackageRegistry size packages
85 liftIO $ IO.writeBinary path registry
86 return registry
90-- UPDATE
93optionalUpdate :: Task.Task PackageRegistry
94optionalUpdate =
95 update False
98mandatoryUpdate :: Task.Task PackageRegistry
99mandatoryUpdate =
100 update True
103update :: Bool -> Task.Task PackageRegistry
104update isMandatory =
105 do path <- getRegistryPath
106 exists <- liftIO $ IO.exists path
107 if not exists
108 then rebuild
109 else
110 do registry <- unsafeGetRegistry path
111 if isMandatory
112 then attemptUpdate registry
113 else attemptUpdate registry `catchError` recoverUpdate registry
116recoverUpdate :: PackageRegistry -> a -> Task.Task PackageRegistry
117recoverUpdate registry _ =
118 do Task.report Progress.UnableToLoadLatestPackages
119 return registry
122attemptUpdate :: PackageRegistry -> Task.Task PackageRegistry
123attemptUpdate oldRegistry@(PackageRegistry size packages) =
124 do news <- Website.getNewPackages size
125 case news of
126 [] ->
127 return oldRegistry
129 _:_ ->
130 let
131 newSize = size + length news
132 newPkgs = List.foldl' addNew packages news
133 newRegistry = PackageRegistry newSize newPkgs
134 in
135 do path <- getRegistryPath
136 liftIO $ IO.writeBinary path newRegistry
137 return newRegistry
140addNew :: Map.Map Pkg.Name [V.Version] -> (Pkg.Name, V.Version) -> Map.Map Pkg.Name [V.Version]
141addNew packages (name, version) =
142 Map.insertWith (++) name [version] packages
146-- GET VERSIONS
149getVersions :: Pkg.Name -> PackageRegistry -> Either [Pkg.Name] [V.Version]
150getVersions name (PackageRegistry _ pkgs) =
151 case Map.lookup name pkgs of
152 Just vsns ->
153 Right vsns
155 Nothing ->
156 Left (nearbyNames name (Map.keys pkgs))
159nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
160nearbyNames (Pkg.Name author1 project1) possibleNames =
161 let
162 authorDist = authorDistance (Name.toChars author1)
163 projectDist = projectDistance (Name.toChars project1)
165 addDistance name@(Pkg.Name author2 project2) =
166 ( authorDist author2 + projectDist project2, name )
167 in
168 map snd $ take 4 $
169 List.sortBy (compare `on` fst) $
170 map addDistance possibleNames
173authorDistance :: String -> Name.Name -> Int
174authorDistance bad possibility =
175 abs (Suggest.distance bad (Name.toChars possibility))
178projectDistance :: String -> Name.Name -> Int
179projectDistance bad possibility =
180 if possibility == "elm" || possibility == "elm-explorations" then
181 0
182 else
183 abs (Suggest.distance bad (Name.toChars possibility))
187-- PACKAGE INFO
190getElmJson :: Pkg.Name -> V.Version -> Task.Task Project.PkgInfo
191getElmJson name version =
192 do dir <- Task.getPackageCacheDirFor name version
193 let elmJson = dir </> "elm.json"
195 exists <- liftIO $ IO.exists elmJson
197 json <-
198 if exists
199 then liftIO (BS.readFile elmJson)
200 else
201 do bits <- Website.getElmJson name version
202 liftIO (BS.writeFile elmJson bits)
203 return bits
205 case Decode.fromByteString Project.pkgDecoder json of
206 Right pkgInfo ->
207 return pkgInfo
209 Left _ ->
210 do liftIO $ IO.remove elmJson
211 Task.throw $ Exit.Assets $ E.CorruptElmJson name version
215-- DOCS
218getDocs :: Pkg.Name -> V.Version -> Task.Task Docs.Documentation
219getDocs name version =
220 do dir <- Task.getPackageCacheDirFor name version
221 let docsJson = dir </> "docs.json"
223 exists <- liftIO $ IO.exists docsJson
225 json <-
226 if exists
227 then liftIO (BS.readFile docsJson)
228 else
229 do bits <- Website.getDocs name version
230 liftIO (BS.writeFile docsJson bits)
231 return bits
233 case Decode.fromByteString (Docs.toDict <$> Decode.list Docs.decoder) json of
234 Right pkgInfo ->
235 return pkgInfo
237 Left _ ->
238 do liftIO $ IO.remove docsJson
239 Task.throw $ Exit.Assets $ E.CorruptDocumentation name version
243-- BINARY
246instance Binary PackageRegistry where
247 get = liftM2 PackageRegistry get get
248 put (PackageRegistry a b) = put a >> put b