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