@@ -7,6 +7,7 @@
77
88module Main where
99
10+import qualified Control.Foldl as Foldl
1011import qualified Data.Aeson as Aeson
1112import Data.Aeson.Encode.Pretty
1213import Data.Foldable (fold, for_, traverse_)
@@ -15,9 +16,11 @@ import qualified Data.Map as Map
1516import Data.Maybe (fromMaybe, mapMaybe)
1617import qualified Data.Set as Set
1718import Data.Text (pack)
19+import qualified Data.Text as T
20+import Data.Text.Encoding (encodeUtf8)
1821import qualified Data.Text.Lazy as TL
1922import qualified Data.Text.Lazy.Builder as TB
20−import Data.Text.Encoding (encodeUtf8)
23+import qualified Data.Text.Read as TR
2124import Data.Traversable (for)
2225import Data.Version (showVersion)
2326import qualified Filesystem.Path.CurrentOS as Path
@@ -25,7 +28,8 @@ import GHC.Generics (Generic)
2528import qualified Options.Applicative as Opts
2629import qualified Paths_purescript as Paths
2730import qualified System.IO as IO
28−import Turtle hiding (fold)
31+import Turtle hiding (fold, s, x)
32+import qualified Turtle
2933
3034packageFile :: Path.FilePath
3135packageFile = "psc-package.json"
@@ -61,8 +65,8 @@ readPackageFile = do
6165 exit (ExitFailure 1)
6266 Just pkg -> return pkg
6367
64−encodePrettyToText :: Aeson.ToJSON json => json -> Text
65−encodePrettyToText =
68+packageConfigToJSON :: PackageConfig -> Text
69+packageConfigToJSON =
6670 TL.toStrict
6771 . TB.toLazyText
6872 . encodePrettyToTextBuilder' config
@@ -76,10 +80,18 @@ encodePrettyToText =
7680 ]
7781 }
7882
83+packageSetToJSON :: PackageSet -> Text
84+packageSetToJSON =
85+ TL.toStrict
86+ . TB.toLazyText
87+ . encodePrettyToTextBuilder' config
88+ where
89+ config = defConfig { confCompare = compare }
90+
7991writePackageFile :: PackageConfig -> IO ()
8092writePackageFile =
8193 writeTextFile packageFile
82− . encodePrettyToText
94+ . packageConfigToJSON
8395
8496data PackageInfo = PackageInfo
8597 { repo :: Text
@@ -108,6 +120,18 @@ cloneShallow from ref into =
108120 , pathToTextUnsafe into
109121 ] empty .||. exit (ExitFailure 1)
110122
123+listRemoteTags
124+ :: Text
125+ -- ^ repo
126+ -> Turtle.Shell Text
127+listRemoteTags from =
128+ inproc "git"
129+ [ "ls-remote"
130+ , "-q"
131+ , "-t"
132+ , from
133+ ] empty
134+
111135getPackageSet :: PackageConfig -> IO ()
112136getPackageSet PackageConfig{ source, set } = do
113137 let pkgDir = ".psc-package" </> fromText set </> ".set"
@@ -128,6 +152,11 @@ readPackageSet PackageConfig{ set } = do
128152 exit (ExitFailure 1)
129153 Just db -> return db
130154
155+writePackageSet :: PackageConfig -> PackageSet -> IO ()
156+writePackageSet PackageConfig{ set } =
157+ let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
158+ in writeTextFile dbFile . packageSetToJSON
159+
131160installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath
132161installOrUpdate set pkgName PackageInfo{ repo, version } = do
133162 echo ("Updating " <> pkgName)
@@ -233,6 +262,84 @@ exec exeName = do
233262 (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
234263 empty
235264
265+checkForUpdates :: Bool -> Bool -> IO ()
266+checkForUpdates applyMinorUpdates applyMajorUpdates = do
267+ pkg <- readPackageFile
268+ db <- readPackageSet pkg
269+
270+ echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")
271+ echo "Warning: this could take some time!"
272+
273+ newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do
274+ echo ("Checking package " <> name)
275+ tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list
276+ let tags = mapMaybe parseTag tagLines
277+ newVersion <- case parseVersion version of
278+ Just parts ->
279+ let applyMinor =
280+ case filter (isMinorReleaseFrom parts) tags of
281+ [] -> pure version
282+ minorReleases -> do
283+ echo ("New minor release available")
284+ case applyMinorUpdates of
285+ True -> do
286+ let latestMinorRelease = maximum minorReleases
287+ pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease))
288+ False -> pure version
289+ applyMajor =
290+ case filter (isMajorReleaseFrom parts) tags of
291+ [] -> applyMinor
292+ newReleases -> do
293+ echo ("New major release available")
294+ case applyMajorUpdates of
295+ True -> do
296+ let latestRelease = maximum newReleases
297+ pure ("v" <> T.intercalate "." (map (pack . show) latestRelease))
298+ False -> applyMinor
299+ in applyMajor
300+ _ -> do
301+ echo "Unable to parse version string"
302+ pure version
303+ pure (name, p { version = newVersion }))
304+
305+ when (applyMinorUpdates || applyMajorUpdates)
306+ (writePackageSet pkg newDb)
307+ where
308+ parseTag :: Text -> Maybe [Int]
309+ parseTag line =
310+ case T.splitOn "\t" line of
311+ [_sha, ref] ->
312+ case T.stripPrefix "refs/tags/" ref of
313+ Just tag ->
314+ case parseVersion tag of
315+ Just parts -> pure parts
316+ _ -> Nothing
317+ _ -> Nothing
318+ _ -> Nothing
319+
320+ parseVersion :: Text -> Maybe [Int]
321+ parseVersion ref =
322+ case T.stripPrefix "v" ref of
323+ Just tag ->
324+ traverse parseDecimal (T.splitOn "." tag)
325+ _ -> Nothing
326+
327+ parseDecimal :: Text -> Maybe Int
328+ parseDecimal s =
329+ case TR.decimal s of
330+ Right (n, "") -> Just n
331+ _ -> Nothing
332+
333+ isMajorReleaseFrom :: [Int] -> [Int] -> Bool
334+ isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys
335+ isMajorReleaseFrom (x : _) (y : _) = y > x
336+ isMajorReleaseFrom _ _ = False
337+
338+ isMinorReleaseFrom :: [Int] -> [Int] -> Bool
339+ isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys
340+ isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs
341+ isMinorReleaseFrom _ _ = False
342+
236343verifyPackageSet :: IO ()
237344verifyPackageSet = do
238345 pkg <- readPackageFile
@@ -292,6 +399,9 @@ main = do
292399 , Opts.command "available"
293400 (Opts.info (pure listPackages)
294401 (Opts.progDesc "List all packages available in the package set"))
402+ , Opts.command "updates"
403+ (Opts.info (checkForUpdates <$> apply <*> applyMajor)
404+ (Opts.progDesc "Check all packages in the package set for new releases"))
295405 , Opts.command "verify-set"
296406 (Opts.info (pure verifyPackageSet)
297407 (Opts.progDesc "Verify that the packages in the package set build correctly"))
@@ -300,3 +410,11 @@ main = do
300410 pkg = Opts.strArgument $
301411 Opts.metavar "PACKAGE"
302412 <> Opts.help "The name of the package to install"
413+
414+ apply = Opts.switch $
415+ Opts.long "apply"
416+ <> Opts.help "Apply all minor package updates"
417+
418+ applyMajor = Opts.switch $
419+ Opts.long "apply-breaking"
420+ <> Opts.help "Apply all major package updates"