1{-# OPTIONS_GHC -Wall #-} 2{-# LANGUAGE BangPatterns, OverloadedStrings #-} 3module Deps.Registry 4 ( Registry(..) 5 , KnownVersions(..) 6 , read 7 , fetch 8 , update 9 , latest 10 , getVersions 11 , getVersions' 12 ) 13 where 14 15 16import Prelude hiding (read) 17import Control.Monad (liftM2) 18import Data.Binary (Binary, get, put) 19import qualified Data.List as List 20import qualified Data.Map.Strict as Map 21 22import qualified Deps.Website as Website 23import qualified Elm.Package as Pkg 24import qualified Elm.Version as V 25import qualified File 26import qualified Http 27import qualified Json.Decode as D 28import qualified Parse.Primitives as P 29import qualified Reporting.Exit as Exit 30import qualified Stuff 31 32 33 34-- REGISTRY 35 36 37data Registry = 38 Registry 39 { _count :: !Int 40 , _versions :: !(Map.Map Pkg.Name KnownVersions) 41 } 42 43 44data KnownVersions = 45 KnownVersions 46 { _newest :: V.Version 47 , _previous :: ![V.Version] 48 } 49 50 51 52-- READ 53 54 55read :: Stuff.PackageCache -> IO (Maybe Registry) 56read cache = 57 File.readBinary (Stuff.registry cache) 58 59 60 61-- FETCH 62 63 64fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry) 65fetch manager cache = 66 post manager "/all-packages" allPkgsDecoder $ 67 \versions -> 68 do let size = Map.foldr' addEntry 0 versions 69 let registry = Registry size versions 70 let path = Stuff.registry cache 71 File.writeBinary path registry 72 return registry 73 74 75addEntry :: KnownVersions -> Int -> Int 76addEntry (KnownVersions _ vs) count = 77 count + 1 + length vs 78 79 80allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions) 81allPkgsDecoder = 82 let 83 keyDecoder = 84 Pkg.keyDecoder bail 85 86 versionsDecoder = 87 D.list (D.mapError (\_ -> ()) V.decoder) 88 89 toKnownVersions versions = 90 case List.sortBy (flip compare) versions of 91 v:vs -> return (KnownVersions v vs) 92 [] -> D.failure () 93 in 94 D.dict keyDecoder (toKnownVersions =<< versionsDecoder) 95 96 97 98-- UPDATE 99 100 101update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry) 102update manager cache oldRegistry@(Registry size packages) = 103 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $ 104 \news -> 105 case news of 106 [] -> 107 return oldRegistry 108 109 _:_ -> 110 let 111 newSize = size + length news 112 newPkgs = foldr addNew packages news 113 newRegistry = Registry newSize newPkgs 114 in 115 do File.writeBinary (Stuff.registry cache) newRegistry 116 return newRegistry 117 118 119addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions 120addNew (name, version) versions = 121 let 122 add maybeKnowns = 123 case maybeKnowns of 124 Just (KnownVersions v vs) -> 125 KnownVersions version (v:vs) 126 127 Nothing -> 128 KnownVersions version [] 129 in 130 Map.alter (Just . add) name versions 131 132 133 134-- NEW PACKAGE DECODER 135 136 137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version) 138newPkgDecoder = 139 D.customString newPkgParser bail 140 141 142newPkgParser :: P.Parser () (Pkg.Name, V.Version) 143newPkgParser = 144 do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser 145 P.word1 0x40 {-@-} bail 146 vsn <- P.specialize (\_ _ _ -> ()) V.parser 147 return (pkg, vsn) 148 149 150bail :: row -> col -> () 151bail _ _ = 152 () 153 154 155 156-- LATEST 157 158 159latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry) 160latest manager cache = 161 do maybeOldRegistry <- read cache 162 case maybeOldRegistry of 163 Just oldRegistry -> 164 update manager cache oldRegistry 165 166 Nothing -> 167 fetch manager cache 168 169 170 171-- GET VERSIONS 172 173 174getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions 175getVersions name (Registry _ versions) = 176 Map.lookup name versions 177 178 179getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions 180getVersions' name (Registry _ versions) = 181 case Map.lookup name versions of 182 Just kvs -> Right kvs 183 Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions) 184 185 186 187-- POST 188 189 190post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b) 191post manager path decoder callback = 192 let 193 url = Website.route path [] 194 in 195 Http.post manager url [] Exit.RP_Http $ 196 \body -> 197 case D.fromByteString decoder body of 198 Right a -> Right <$> callback a 199 Left _ -> return $ Left $ Exit.RP_Data url body 200 201 202 203-- BINARY 204 205 206instance Binary Registry where 207 get = liftM2 Registry get get 208 put (Registry a b) = put a >> put b 209 210 211instance Binary KnownVersions where 212 get = liftM2 KnownVersions get get 213 put (KnownVersions a b) = put a >> put b 214