diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,11 @@ -# Revision history for stack-all +# Release history for stack-all + +## 0.3 (2021-06-26) +- use hackage.stackage.org/snapshots.json: + - to determine the latest LTS major version + - to resolve major LTS version to latest minor snapshot and also print it +- cache snapshots.json locally in ~/.cache/stack-all/ for a few hours +- new --make-lts command to generate a stack-ltsXX.yaml file from newer one ## 0.2.2 (2021-06-07) - create a stack.yaml file if only an .cabal file is found diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ `stack-all` by default runs `stack build` over recent Stackage LTS major versions and Nightly -(current default is nightly, lts-17, lts-16, lts-14,... , lts-11) +(current default is nightly, lts-18, lts-17, lts-16, lts-14,... , lts-11) corresponding to latest major ghc minor versions, using the stack's `--resolver` option. @@ -20,14 +20,14 @@ ### Overriding stack.yaml `stack-all` can use `stack-ltsXX.yaml` files to override the default `stack.yaml` file for particular lts major versions. Note that a `stack-ltsXX.yaml` file -will also be used for earlier lts major versions until +will also be used for older lts major versions until another `stack-ltsYY.yaml` file is found. For example if you have `stack-lts14.yaml` and `stack-lts12.yaml` files in your project, then `stack.yaml` will be used as normal to build nightly, lts-17 and lts-16, but `stack-lts14.yaml` will be used for building lts-14 and lts-13, -and `stack-lts12.yaml` will be used for lts-12, lts-11 (and earlier). +and `stack-lts12.yaml` will be used for lts-12, lts-11 (and older). Since `stack-all` overrides the resolver with `--resolver lts-XX` the exact minor lts version specified in the `stack*.yaml` files doesn't actually matter: `stack-all` always uses the latest minor release of diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} import Control.Monad.Extra import Data.Either @@ -6,8 +6,6 @@ import Data.List.Extra import Data.Maybe import Data.Tuple (swap) -import Text.Read (readMaybe) -import qualified Data.Text.IO as T import SimpleCmd import SimpleCmdArgs import System.Directory @@ -15,60 +13,18 @@ import System.FilePath import System.IO import System.Process +import qualified Data.Text.IO as T +import MajorVer import Paths_stack_all (version) - --- FIXME allow specific snapshots? --- FIXME lts latest -data Snapshot = LTS Int | Nightly - deriving (Eq, Ord) - --- readCompactSnap "lts16" -readCompactSnap :: String -> Maybe Snapshot -readCompactSnap "nightly" = Just Nightly -readCompactSnap snap = - if "lts" `isPrefixOf` snap then - case readMaybe (dropPrefix "lts" snap) of - Just major -> Just (LTS major) - Nothing -> error' $ "couldn't parse compact " ++ snap ++ " (expected ltsXX)" - else Nothing - -eitherReadSnap :: String -> Either String Snapshot -eitherReadSnap cs = - case maybeReadSnap cs of - Just s -> Right s - _ -> Left cs - -maybeReadSnap :: String -> Maybe Snapshot -maybeReadSnap "nightly" = Just Nightly -maybeReadSnap snap = - if "lts" `isPrefixOf` snap then - case readMaybe (dropPrefix "lts-" snap) <|> readMaybe (dropPrefix "lts" snap) of - Just major -> Just (LTS major) - Nothing -> Nothing - else Nothing - --- readSnap "lts-16" -readSnap :: String -> Snapshot -readSnap "nightly" = Nightly -readSnap snap = - case maybeReadSnap snap of - Just s -> s - Nothing -> - error' $ "couldn't parse " ++ snap ++ " (expected lts-XX or ltsXX)" - -showSnap :: Snapshot -> String -showSnap Nightly = "nightly" -showSnap (LTS ver) = "lts-" ++ show ver +import Snapshots -defaultOldest :: Snapshot +defaultOldest :: MajorVer defaultOldest = LTS 11 -allSnaps :: [Snapshot] -allSnaps = [Nightly, LTS 17, LTS 16, LTS 14, LTS 13, LTS 12, LTS 11, - LTS 10, LTS 9, LTS 8, LTS 6, LTS 5, LTS 4, LTS 2, LTS 1] +data VersionLimit = DefaultLimit | Oldest MajorVer | AllVersions -data VersionLimit = DefaultLimit | Oldest Snapshot | AllVersions +data Command = CreateConfig | MakeStackLTS | DefaultRun main :: IO () main = do @@ -76,25 +32,32 @@ simpleCmdArgs' (Just version) "Build over Stackage versions" "stack-all builds projects easily across different Stackage versions" $ run <$> - switchWith 'c' "create-config" "Create a project .stack-all file" <*> + (flagWith' CreateConfig 'c' "create-config" "Create a project .stack-all file" <|> + flagWith DefaultRun MakeStackLTS 's' "make-lts" "Create a stack-ltsXX.yaml file") <*> switchWith 'd' "debug" "Verbose stack build output on error" <*> - optional (readSnap <$> strOptionWith 'n' "newest" "lts-MAJOR" "Newest LTS release to build from") <*> - (Oldest . readSnap <$> strOptionWith 'o' "oldest" "lts-MAJOR" "Oldest compatible LTS release" <|> + optional (readMajor <$> strOptionWith 'n' "newest" "MAJOR" "Newest LTS release to build from") <*> + (Oldest . readMajor <$> strOptionWith 'o' "oldest" "MAJOR" "Oldest compatible LTS release" <|> flagWith DefaultLimit AllVersions 'a' "all-lts" "Try to build back to LTS 1 even") <*> - many (strArg "SNAPSHOT... [COMMAND...]") + many (strArg "MAJORVER... [COMMAND...]") -run :: Bool -> Bool -> Maybe Snapshot -> VersionLimit -> [String] -> IO () -run createconfig debug mnewest verlimit verscmd = do +run :: Command -> Bool -> Maybe MajorVer -> VersionLimit -> [String] -> IO () +run command debug mnewest verlimit verscmd = do findStackProjectDir Nothing - if createconfig then - case verlimit of - Oldest oldest -> createStackAll oldest - _ -> error' "creating .stack-all requires --oldest LTS" - else do - (versions, cs) <- getVersionsCmd - configs <- mapMaybe readStackConf <$> listDirectory "." - let newestFilter = maybe id (filter . (>=)) mnewest - mapM_ (stackBuild configs debug cs) (newestFilter versions) + case command of + CreateConfig -> + case verlimit of + Oldest oldest -> createStackAll oldest + _ -> error' "creating .stack-all requires --oldest LTS" + MakeStackLTS -> do + (versions, _) <- getVersionsCmd + if null versions + then error' "--make-lts needs an LTS major version" + else makeStackLTS versions + DefaultRun -> do + (versions, cargs) <- getVersionsCmd + configs <- mapMaybe readStackConf <$> listDirectory "." + let newestFilter = maybe id (filter . (>=)) mnewest + mapM_ (stackBuild configs debug cargs) (newestFilter versions) where findStackProjectDir :: Maybe FilePath -> IO () findStackProjectDir mcwd = do @@ -109,22 +72,21 @@ else do putStrLn "stack.yaml not found" whenJust mcwd setCurrentDirectory - haveCabalFile <- fileWithExtension_ "." ".cabal" + haveCabalFile <- doesFileExistWithExtension "." ".cabal" if haveCabalFile then do + -- FIXME take suggested extra-deps into stack.yaml + -- FIXME stack init content too verbose unlessM (cmdBool "stack" ["init"]) $ - writeFile "stack.yaml" "resolver: lts-16.31\n" + -- FIXME determine latest stable snapshot automatically + writeFile "stack.yaml" "resolver: lts-17.15\n" else error' "no package/project found" - readStackConf :: FilePath -> Maybe Snapshot - readStackConf "stack-lts.yaml" = error' "unversioned stack-lts.yaml is unsupported" - readStackConf f = - stripPrefix "stack-" f >>= stripSuffix ".yaml" >>= readCompactSnap - - getVersionsCmd :: IO ([Snapshot],[String]) + getVersionsCmd :: IO ([MajorVer],[String]) getVersionsCmd = do - let partitionSnaps = swap . partitionEithers . map eitherReadSnap - (verlist,cmds) = partitionSnaps verscmd + let partitionMajors = swap . partitionEithers . map eitherReadMajor + (verlist,cmds) = partitionMajors verscmd + allMajors <- getMajorVers versions <- if null verlist then case verlimit of @@ -133,33 +95,39 @@ return $ case mnewest of Just newest -> if newest < oldest - then filter (newest >=) allSnaps - else filter (\ s -> s >= oldest && newest >= s) allSnaps - Nothing -> filter (>= oldest) allSnaps - AllVersions -> return allSnaps - Oldest ver -> return $ filter (>= ver) allSnaps + then filter (newest >=) allMajors + else filter (\ s -> s >= oldest && newest >= s) allMajors + Nothing -> filter (>= oldest) allMajors + AllVersions -> return allMajors + Oldest ver -> return $ filter (>= ver) allMajors else return verlist return (versions,if null cmds then ["build"] else cmds) +readStackConf :: FilePath -> Maybe MajorVer +readStackConf "stack-lts.yaml" = error' "unversioned stack-lts.yaml is unsupported" +readStackConf f = + stripPrefix "stack-" f >>= stripSuffix ".yaml" >>= readCompactMajor + stackAllFile :: FilePath stackAllFile = ".stack-all" -createStackAll :: Snapshot -> IO () -createStackAll snap = do +createStackAll :: MajorVer -> IO () +createStackAll ver = do exists <- doesFileExist stackAllFile if exists then error' $ stackAllFile ++ " already exists" else do + allMajors <- getMajorVers let older = - let molder = listToMaybe $ dropWhile (>= snap) allSnaps - in maybe "" (\s -> showSnap s ++ " too old") molder + let molder = listToMaybe $ dropWhile (>= ver) allMajors + in maybe "" (\s -> showMajor s ++ " too old") molder writeFile stackAllFile $ - "[versions]\n# " ++ older ++ "\noldest = " ++ showSnap snap ++ "\n" + "[versions]\n# " ++ older ++ "\noldest = " ++ showMajor ver ++ "\n" -readOldestLTS :: IO (Maybe Snapshot) +readOldestLTS :: IO (Maybe MajorVer) readOldestLTS = do haveConfig <- doesFileExist stackAllFile if haveConfig then - Just . readSnap <$> readIniConfig stackAllFile rcParser id + Just . readMajor <$> readIniConfig stackAllFile rcParser id else return Nothing where rcParser :: IniParser String @@ -172,31 +140,50 @@ ini <- T.readFile inifile return $ either error fn $ parseIniFile ini iniparser -stackBuild :: [Snapshot] -> Bool -> [String] -> Snapshot -> IO () -stackBuild configs debug command snap = do +makeStackLTS :: [MajorVer] -> IO () +makeStackLTS vers = do + configs <- mapMaybe readStackConf <$> listDirectory "." + forM_ vers $ \ ver -> do + if ver `elem` configs + then error' $ showConfig ver ++ " already exists!" + else do + let mcurrentconfig = + listToMaybe $ sort (filter (ver <=) configs) + case mcurrentconfig of + Nothing -> copyFile "stack.yaml" (showConfig ver) + Just conf -> copyFile (showConfig conf) (showConfig ver) + whenJustM (latestSnapshot ver) $ \latest -> + cmd_ "sed" ["-i", "-e", "s/\\(resolver:\\) .*/\\1 " ++ latest ++ "/", showConfig ver] + +showConfig :: MajorVer -> FilePath +showConfig sn = "stack-" ++ compactMajor sn <.> "yaml" + where + compactMajor :: MajorVer -> String + compactMajor Nightly = "nightly" + compactMajor (LTS ver) = "lts" ++ show ver + +stackBuild :: [MajorVer] -> Bool -> [String] -> MajorVer -> IO () +stackBuild configs debug command ver = do let config = - case sort (filter (snap <=) configs) of + case sort (filter (ver <=) configs) of [] -> [] (cfg:_) -> ["--stack-yaml", showConfig cfg] - opts = ["-v" | debug] ++ ["--resolver", showSnap snap] ++ - config - if debug - then debugBuild $ opts ++ command - else do - ok <- cmdBool "stack" $ opts ++ command - unless ok $ do - putStr "\nsnapshot-pkg-db: " - cmd_ "stack" $ "--silent" : opts ++ ["path", "--snapshot-pkg-db"] - error' $ "failed for " ++ showSnap snap - putStrLn "" + latest <- latestSnapshot ver + case latest of + Nothing -> error' $ "no snapshot not found for " ++ showMajor ver + Just minor -> do + let opts = ["-v" | debug] ++ ["--resolver", minor] ++ config + putStrLn $ "# " ++ minor + if debug + then debugBuild $ opts ++ command + else do + ok <- cmdBool "stack" $ opts ++ command + unless ok $ do + putStr "\nsnapshot-pkg-db: " + cmd_ "stack" $ "--silent" : opts ++ ["path", "--snapshot-pkg-db"] + error' $ "failed for " ++ showMajor ver + putStrLn "" where - showConfig :: Snapshot -> FilePath - showConfig sn = "stack-" ++ compactSnap sn <.> "yaml" - where - compactSnap :: Snapshot -> String - compactSnap Nightly = "nightly" - compactSnap (LTS ver) = "lts" ++ show ver - debugBuild :: [String] -> IO () debugBuild args = do putStr $ "stack " ++ unwords args @@ -206,7 +193,7 @@ unless (ret == ExitSuccess) $ do -- stack verbose includes info line with all stackages (> 500kbytes) mapM_ putStrLn $ filter ((<10000) . length) . lines $ err - error' $ showSnap snap ++ " build failed" + error' $ showMajor ver ++ " build failed" -- taken from cabal-rpm FileUtils: @@ -215,7 +202,7 @@ -> String -- file extension -> IO [FilePath] filesWithExtension dir ext = - filter (\ f -> takeExtension f == ext) <$> getDirectoryContents dir + filter (ext `isExtensionOf`) <$> listDirectory dir -- looks in dir for a unique file with given extension fileWithExtension :: FilePath -- directory @@ -229,6 +216,12 @@ _ -> putStrLn ("More than one " ++ ext ++ " file found!") >> return Nothing -- looks in current dir for a unique file with given extension -fileWithExtension_ :: FilePath -> String -> IO Bool -fileWithExtension_ dir ext = +doesFileExistWithExtension :: FilePath -> String -> IO Bool +doesFileExistWithExtension dir ext = isJust <$> fileWithExtension dir ext + +#if !MIN_VERSION_filepath(1,4,2) +isExtensionOf :: String -> FilePath -> Bool +isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions +isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions +#endif diff --git a/src/MajorVer.hs b/src/MajorVer.hs new file mode 100644 --- /dev/null +++ b/src/MajorVer.hs @@ -0,0 +1,57 @@ +module MajorVer ( + MajorVer(..), + eitherReadMajor, + maybeReadMajor, + readCompactMajor, + readMajor, + showMajor + ) +where + +import Control.Applicative +import Data.List.Extra +import SimpleCmd (error') +import Text.Read (readMaybe) + +-- FIXME allow specific snapshots? +-- FIXME support "lts"? +data MajorVer = LTS Int | Nightly + deriving (Eq, Ord) + +maybeReadMajor :: String -> Maybe MajorVer +maybeReadMajor "nightly" = Just Nightly +maybeReadMajor ver = + if "lts" `isPrefixOf` ver then + case readMaybe (dropPrefix "lts-" ver) <|> readMaybe (dropPrefix "lts" ver) of + Just major -> Just (LTS major) + Nothing -> Nothing + else Nothing + +-- readMajor "lts-16" +readMajor :: String -> MajorVer +readMajor "nightly" = Nightly +readMajor ver = + case maybeReadMajor ver of + Just s -> s + Nothing -> + error' $ "couldn't parse " ++ ver ++ " (expected lts-XX or ltsXX)" + +-- readCompactMajor "lts16" +readCompactMajor :: String -> Maybe MajorVer +readCompactMajor "nightly" = Just Nightly +readCompactMajor ver = + if "lts" `isPrefixOf` ver then + case readMaybe (dropPrefix "lts" ver) of + Just major -> Just (LTS major) + Nothing -> error' $ "couldn't parse compact " ++ ver ++ " (expected ltsXX)" + else Nothing + +eitherReadMajor :: String -> Either String MajorVer +eitherReadMajor cs = + case maybeReadMajor cs of + Just s -> Right s + _ -> Left cs + +showMajor :: MajorVer -> String +showMajor Nightly = "nightly" +showMajor (LTS ver) = "lts-" ++ show ver diff --git a/src/Snapshots.hs b/src/Snapshots.hs new file mode 100644 --- /dev/null +++ b/src/Snapshots.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Snapshots ( + getMajorVers, + latestSnapshot + ) +where + +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List.Extra +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Network.HTTP.Query +import SimpleCmd (error') +import System.Directory +import System.Environment.XDG.BaseDir +import System.FilePath + +import MajorVer + +excludedMajors :: [MajorVer] +excludedMajors = [LTS 15, LTS 7, LTS 3, LTS 0] + +getMajorVers :: IO [MajorVer] +getMajorVers = do + obj <- getSnapshots + return $ reverse . sort $ map (readMajor . T.unpack) (H.keys obj \\ ["lts"]) \\ excludedMajors + +latestSnapshot :: MajorVer -> IO (Maybe String) +latestSnapshot ver = do + lookupKey (T.pack (showMajor ver)) <$> getSnapshots + +-- FIXME handle network failure +getSnapshots :: IO Object +getSnapshots = do + file <- getUserCacheFile "stack-all" "snapshots.json" + exists <- doesFileExist file + unless exists $ do + putStrLn $ "Creating " ++ file ++ " ..." + createDirectoryIfMissing True (takeDirectory file) + recent <- do + if exists then do + ts <- getModificationTime file + t <- getCurrentTime + -- < 3 hours + return $ diffUTCTime t ts < 10000 + else return False + if recent + then do + eobj <- eitherDecode <$> B.readFile file + case eobj of + Left err -> error' err + Right obj -> return obj + else do + obj <- webAPIQuery "http://haddock.stackage.org/snapshots.json" [] + B.writeFile file $ encode obj + return obj diff --git a/stack-all.cabal b/stack-all.cabal --- a/stack-all.cabal +++ b/stack-all.cabal @@ -1,5 +1,5 @@ name: stack-all -version: 0.2.2 +version: 0.3 synopsis: CLI tool for building across Stackage major versions description: Build your Haskell project over Stackage major LTS versions. @@ -23,17 +23,26 @@ location: https://github.com/juhp/stack-all.git executable stack-all - main-is: src/Main.hs + main-is: Main.hs other-modules: Paths_stack_all + MajorVer + Snapshots + hs-source-dirs: src build-depends: base < 5, + aeson, + bytestring, config-ini, directory >= 1.2.5, extra >= 1.6.15, filepath, + http-query, process, simple-cmd >= 0.1.4, simple-cmd-args, - text + text, + time, + unordered-containers, + xdg-basedir default-language: Haskell2010 ghc-options: -Wall if impl(ghc >= 8.0)