diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.8.0 + +* Restructured commands to work on server/Docker setup + ## 0.7.4 * `-j`/`--jobs` option for build flags diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -1,24 +1,35 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Stackage.CompleteBuild ( BuildType (..) , BumpType (..) , BuildFlags (..) - , completeBuild - , justCheck + , checkPlan , getStackageAuthToken + , createPlan + , fetch + , makeBundle + , upload + , hackageDistro + , uploadGithub ) where +import System.Directory (getAppUserDataDirectory) +import Filesystem (isDirectory, createTree, isFile, rename) +import Filesystem.Path (parent) import Control.Concurrent (threadDelay, getNumCapabilities) import Control.Concurrent.Async (withAsync) import Data.Default.Class (def) import Data.Semigroup (Max (..), Option (..)) import Data.Text.Read (decimal) import Data.Time -import Data.Yaml (decodeFileEither, encodeFile) +import Data.Yaml (decodeFileEither, encodeFile, decodeEither') import Network.HTTP.Client +import Network.HTTP.Client.Conduit (bodyReaderSource) import Network.HTTP.Client.TLS (tlsManagerSettings) import Stackage.BuildConstraints import Stackage.BuildPlan @@ -30,6 +41,9 @@ import Stackage.Upload import System.Environment (lookupEnv) import System.IO (BufferMode (LineBuffering), hSetBuffering) +import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift) +import Data.Function (fix) +import Control.Concurrent.Async (Concurrently (..)) -- | Flags passed in from the command line. data BuildFlags = BuildFlags @@ -46,6 +60,9 @@ , bfGitPush :: !Bool -- ^ push to Git (when doing an LTS build) , bfJobs :: !(Maybe Int) + , bfPlanFile :: !(Maybe FilePath) + , bfPreBuild :: !Bool + , bfLoadPlan :: !Bool } deriving (Show) data BuildType = Nightly | LTS BumpType Text @@ -61,7 +78,6 @@ , logDir :: FilePath , title :: Text -> Text -- ^ GHC version -> title , slug :: Text - , setArgs :: Text -> UploadBundle -> UploadBundle , postBuild :: IO () , distroName :: Text -- ^ distro name on Hackage , snapshotType :: SnapshotType @@ -77,7 +93,7 @@ -> BuildPlan -> Settings nightlySettings day bf plan' = Settings - { planFile = nightlyPlanFile day + { planFile = fromMaybe (nightlyPlanFile day) (bfPlanFile bf) , buildDir = fpFromText $ "builds/nightly" , logDir = fpFromText $ "logs/stackage-nightly-" ++ day , title = \ghcVer -> concat @@ -87,7 +103,6 @@ , ghcVer ] , slug = slug' - , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } , plan = plan' , postBuild = return () , distroName = "Stackage" @@ -124,14 +139,17 @@ deriving (Show, Typeable) instance Exception ParseGoalFailure -getSettings :: Manager -> BuildFlags -> BuildType -> IO Settings -getSettings man bf Nightly = do +getSettings :: Manager -> BuildFlags -> BuildType -> Maybe FilePath -> IO Settings +getSettings man bf Nightly mplanFile = do day <- tshow . utctDay <$> getCurrentTime - bc <- defaultBuildConstraints man - pkgs <- getLatestAllowedPlans bc - plan' <- newBuildPlan pkgs bc + plan' <- case mplanFile of + Nothing -> do + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + newBuildPlan pkgs bc + Just file -> decodeFileEither (fpToString file) >>= either throwIO return return $ nightlySettings day bf plan' -getSettings man bf (LTS bumpType goal) = do +getSettings man bf (LTS bumpType goal) Nothing = do matchesGoal <- parseGoal bumpType goal Option mlts <- fmap (fmap getMax) $ runResourceT $ sourceDirectory "." @@ -162,7 +180,7 @@ let newfile = renderLTSVer new return Settings - { planFile = newfile + { planFile = fromMaybe newfile (bfPlanFile bf) , buildDir = fpFromText $ "builds/lts" , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new , title = \ghcVer -> concat @@ -172,7 +190,6 @@ , ghcVer ] , slug = "lts-" ++ tshow new - , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new } , plan = plan' , postBuild = do let git args = withCheckedProcess @@ -213,6 +230,39 @@ Right (minor, "") <- Just $ decimal z return $ LTSVer major minor +createPlan :: Target + -> FilePath + -> IO () +createPlan target dest = withManager tlsManagerSettings $ \man -> do + putStrLn $ "Creating plan for: " ++ tshow target + bc <- + case target of + TargetMinor x y -> do + let url = concat + [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-" + , show x + , "." + , show (y - 1) + , ".yaml" + ] + putStrLn $ "Downloading old plan from " ++ pack url + req <- parseUrl url + res <- httpLbs req man + oldplan <- either throwM return + $ decodeEither' (toStrict $ responseBody res) + return $ updateBuildConstraints oldplan + _ -> defaultBuildConstraints man + + plan <- planFromConstraints bc + + putStrLn $ "Writing build plan to " ++ fpToText dest + encodeFile (fpToString dest) plan + +planFromConstraints bc = do + putStrLn "Creating build plan" + plans <- getLatestAllowedPlans bc + newBuildPlan plans bc + renderLTSVer :: LTSVer -> FilePath renderLTSVer lts = fpFromText $ concat [ "lts-" @@ -233,18 +283,24 @@ -- | Generate and check a new build plan, but do not execute it. -- -- Since 0.3.1 -justCheck :: IO () -justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do - putStrLn "Loading build constraints" - bc <- defaultBuildConstraints man +checkPlan :: Maybe FilePath -> IO () +checkPlan mfp = stillAlive $ withManager tlsManagerSettings $ \man -> do + plan <- + case mfp of + Nothing -> do + putStrLn "Loading default build constraints" + bc <- defaultBuildConstraints man - putStrLn "Creating build plan" - plans <- getLatestAllowedPlans bc - plan <- newBuildPlan plans bc + plan <- planFromConstraints bc - putStrLn $ "Writing build plan to check-plan.yaml" - encodeFile "check-plan.yaml" plan + putStrLn $ "Writing build plan to check-plan.yaml" + encodeFile "check-plan.yaml" plan + return plan + Just fp -> do + putStrLn $ "Loading plan from " ++ fpToText fp + decodeFileEither (fpToString fp) >>= either throwM return + putStrLn "Checking plan" checkBuildPlan plan @@ -269,44 +325,60 @@ , pbBuildHoogle = bfBuildHoogle buildFlags } +{- FIXME remove -- | Make a complete plan, build, test and upload bundle, docs and -- distro. completeBuild :: BuildType -> BuildFlags -> IO () completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do hSetBuffering stdout LineBuffering - putStrLn $ "Loading settings for: " ++ tshow buildType - settings@Settings {..} <- getSettings man buildFlags buildType + settings@Settings {..} <- if bfLoadPlan buildFlags + then + case bfPlanFile buildFlags of + Nothing -> error "When loading plan, plan file must be specified" + Just file -> do + putStrLn $ "Loading build plan from: " ++ fpToText file + getSettings man buildFlags buildType $ Just file + else do + putStrLn $ "Loading settings for: " ++ tshow buildType + settings@Settings {..} <- getSettings man buildFlags buildType Nothing - putStrLn $ "Writing build plan to: " ++ fpToText planFile - encodeFile (fpToString planFile) plan + putStrLn $ "Writing build plan to: " ++ fpToText planFile + encodeFile (fpToString planFile) plan - if bfSkipCheck buildFlags - then putStrLn "Skipping build plan check" - else do - putStrLn "Checking build plan" - checkBuildPlan plan + if bfSkipCheck buildFlags + then putStrLn "Skipping build plan check" + else do + putStrLn "Checking build plan" + checkBuildPlan plan - putStrLn "Performing build" + return settings + pb <- getPerformBuild buildFlags settings - performBuild pb >>= mapM_ putStrLn - putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest - createBundleV2 CreateBundleV2 - { cb2Plan = plan - , cb2Type = snapshotType - , cb2DocsDir = pbDocDir pb - , cb2Dest = bundleDest - } + if bfPreBuild buildFlags + then prefetchPackages pb + else do + putStrLn "Performing build" + performBuild pb >>= mapM_ putStrLn - postBuild `catchAny` print + putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest + createBundleV2 CreateBundleV2 + { cb2Plan = plan + , cb2Type = snapshotType + , cb2DocsDir = pbDocDir pb + , cb2Dest = bundleDest + } - when (bfDoUpload buildFlags) $ - finallyUpload - buildFlags - settings - man + postBuild `catchAny` print + when (bfDoUpload buildFlags) $ + finallyUpload + buildFlags + settings + man +-} + getStackageAuthToken :: IO Text getStackageAuthToken = do mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" @@ -314,6 +386,7 @@ Nothing -> decodeUtf8 <$> readFile "/auth-token" Just token -> return $ pack token +{- FIXME remove -- | The final part of the complete build process: uploading a bundle, -- docs and a distro to hackage. finallyUpload :: BuildFlags @@ -333,10 +406,228 @@ } putStrLn $ "New snapshot available at: " ++ res +-} + +hackageDistro + :: FilePath -- ^ plan file + -> Target + -> IO () +hackageDistro planFile target = withManager tlsManagerSettings $ \man -> do + plan <- decodeFileEither (fpToString planFile) >>= either throwM return ecreds <- tryIO $ readFile "/hackage-creds" case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of [username, password] -> do - putStrLn "Uploading as Hackage distro" - res2 <- uploadHackageDistroNamed distroName plan username password man + putStrLn $ "Uploading as Hackage distro: " ++ distroName + res2 <- uploadHackageDistro distroName plan username password man putStrLn $ "Distro upload response: " ++ tshow res2 - _ -> putStrLn "No creds found, skipping Hackage distro upload" + _ -> error "No Hackage creds found at /hackage-creds" + where + distroName = + case target of + TargetNightly -> "Stackage" + TargetMajor _ -> "LTSHaskell" + TargetMinor _ _ -> "LTSHaskell" + +uploadGithub + :: FilePath -- ^ plan file + -> Target + -> IO () +uploadGithub planFile target = do + let repoUrl = + case target of + TargetNightly -> "git@github.com:fpco/stackage-nightly" + _ -> "git@github.com:fpco/lts-haskell" + + root <- fpFromString <$> getAppUserDataDirectory "stackage-curator" + + now <- getCurrentTime + + let repoDir = + case target of + TargetNightly -> root "stackage-nightly" + _ -> root "lts-haskell" + + destFP = + case target of + TargetNightly -> repoDir (fpFromString $ concat + [ "nightly-" + , show $ utctDay now + , ".yaml" + ]) + TargetMajor x -> repoDir (fpFromString $ concat + [ "lts-" + , show x + , ".0.yaml" + ]) + TargetMinor x y -> repoDir (fpFromString $ concat + [ "lts-" + , show x + , "." + , show y + , ".yaml" + ]) + + runIn wdir cmd args = do + putStrLn $ concat + [ fpToText wdir + , ": " + , tshow (cmd:args) + ] + withCheckedProcess + (proc cmd args) + { cwd = Just $ fpToString wdir + } $ \ClosedStream Inherited Inherited -> return () + + git = runIn repoDir "git" + + exists <- isDirectory repoDir + if exists + then do + git ["fetch"] + git ["checkout", "origin/master"] + else do + createTree $ parent repoDir + runIn "." "git" ["clone", repoUrl, fpToString repoDir] + + runResourceT $ sourceFile planFile $$ (sinkFile destFP :: Sink ByteString (ResourceT IO) ()) + git ["add", fpToString destFP] + git ["commit", "-m", "Checking in " ++ fpToString (filename destFP)] + git ["push", "origin", "HEAD:master"] + +upload + :: FilePath -- ^ bundle file + -> StackageServer -- ^ server URL + -> IO () +upload bundleFile server = withManager tlsManagerSettings $ \man -> do + putStrLn "Uploading bundle to Stackage Server" + + token <- getStackageAuthToken + + res <- flip uploadBundleV2 man UploadBundleV2 + { ub2Server = server + , ub2AuthToken = token + , ub2Bundle = bundleFile + } + putStrLn $ "New snapshot available at: " ++ res + +makeBundle + :: FilePath -- ^ plan file + -> FilePath -- ^ bundle file + -> Target + -> Maybe Int -- ^ jobs + -> Bool -- ^ skip tests? + -> Bool -- ^ skip haddock? + -> Bool -- ^ skip hoogle? + -> Bool -- ^ enable library profiling? + -> Bool -- ^ enable executable dynamic? + -> Bool -- ^ verbose? + -> Bool -- ^ allow-newer? + -> IO () +makeBundle + planFile bundleFile target mjobs skipTests skipHaddocks skipHoogle + enableLibraryProfiling enableExecutableDynamic verbose allowNewer + = do + plan <- decodeFileEither (fpToString planFile) >>= either throwM return + jobs <- maybe getNumCapabilities return mjobs + let pb = PerformBuild + { pbPlan = plan + , pbInstallDest = + case target of + TargetNightly -> "builds/nightly" + TargetMajor x -> fpFromText $ "builds/lts-" ++ tshow x + TargetMinor x _ -> fpFromText $ "builds/lts-" ++ tshow x + , pbLog = hPut stdout + , pbLogDir = + case target of + TargetNightly -> "logs/nightly" + TargetMajor x -> fpFromText $ "logs/lts-" ++ tshow x + TargetMinor x _ -> fpFromText $ "logs/lts-" ++ tshow x + , pbJobs = jobs + , pbGlobalInstall = False + , pbEnableTests = not skipTests + , pbEnableHaddock = not skipHaddocks + , pbEnableLibProfiling = enableLibraryProfiling + , pbEnableExecDyn = enableExecutableDynamic + , pbVerbose = verbose + , pbAllowNewer = allowNewer + , pbBuildHoogle = not skipHoogle + } + + putStrLn "Performing build" + performBuild pb >>= mapM_ putStrLn + + putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleFile + createBundleV2 CreateBundleV2 + { cb2Plan = plan + , cb2Type = + case target of + TargetNightly -> STNightly + TargetMajor x -> STLTS x 0 + TargetMinor x y -> STLTS x y + , cb2DocsDir = pbDocDir pb + , cb2Dest = bundleFile + } + +fetch :: FilePath -> IO () +fetch planFile = withManager tlsManagerSettings $ \man -> do + -- First make sure to fetch all of the dependencies... just in case Hackage + -- has an outage. Don't feel like wasting hours of CPU time. + putStrLn "Pre-fetching all packages" + + plan <- decodeFileEither (fpToString planFile) >>= either throwM return + + cabalDir <- fpFromString <$> getAppUserDataDirectory "cabal" + parMapM_ 8 (download man cabalDir) $ mapToList $ bpPackages plan + where + download man cabalDir (display -> name, display . ppVersion -> version) = do + unlessM (isFile fp) $ do + hPut stdout $ encodeUtf8 $ concat + [ "Downloading " + , name + , "-" + , version + , "\n" + ] + createTree $ parent fp + req <- parseUrl url + withResponse req man $ \res -> do + let tmp = fp <.> "tmp" + runResourceT $ bodyReaderSource (responseBody res) $$ sinkFile tmp + rename tmp fp + where + url = unpack $ concat + [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" + , name + , "-" + , version + , ".tar.gz" + ] + fp = cabalDir + "packages" + "hackage.haskell.org" + fpFromText name + fpFromText version + fpFromText (concat [name, "-", version, ".tar.gz"]) + +parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono) + => Int + -> (Element mono -> m ()) + -> mono + -> m () +parMapM_ (max 1 -> 1) f xs = mapM_ f xs +parMapM_ cnt f xs0 = do + var <- liftBase $ newTVarIO $ toList xs0 + run <- askRunBase + let worker :: IO () + worker = run $ fix $ \loop -> join $ atomically $ do + xs <- readTVar var + case xs of + [] -> return $ return () + x:xs' -> do + writeTVar var xs' + return $ do + f x + loop + workers 1 = Concurrently worker + workers i = Concurrently worker *> workers (i - 1) + liftBase $ runConcurrently $ workers cnt diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -32,6 +32,7 @@ import System.IO (IOMode (WriteMode), openBinaryFile) import System.IO.Temp (withSystemTempDirectory) +import Data.Yaml (decodeFileEither) data BuildException = BuildException (Map PackageName BuildFailure) [Text] deriving Typeable @@ -154,22 +155,6 @@ performBuild' :: PerformBuild -> IO [Text] performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do - -- First make sure to fetch all of the dependencies... just in case Hackage - -- has an outage. Don't feel like wasting hours of CPU time. - pbLog $ encodeUtf8 "Pre-fetching all packages\n" - let toDownload = flip map (mapToList $ bpPackages pbPlan) - $ \(name, plan) -> unpack $ concat - [ display name - , "-" - , display $ ppVersion plan - ] - withCheckedProcess - (proc "cabal" - $ "fetch" - : "--no-dependencies" - : toDownload) - $ \ClosedStream Inherited Inherited -> return () - let removeTree' fp = whenM (isDirectory fp) (removeTree fp) removeTree' pbLogDir diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs --- a/Stackage/Prelude.hs +++ b/Stackage/Prelude.hs @@ -69,3 +69,8 @@ let dest' = dest suffix liftIO $ createTree $ parent dest' sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) + +data Target = TargetNightly + | TargetMajor Int + | TargetMinor Int Int + deriving Show diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs --- a/Stackage/ServerBundle.hs +++ b/Stackage/ServerBundle.hs @@ -174,13 +174,13 @@ [ "\nHaddocks index" , "" , "" - , "" + , "" , "" , "
" , "
" , "

Haddock documentation index

" , flip foldMap msnapid $ \snapid -> concat - [ "

Return to snapshot

" ] diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -5,15 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Stackage.Upload - ( UploadBundle (..) - , SnapshotIdent (..) - , uploadBundle - , UploadDocs (..) - , uploadDocs - , uploadHackageDistro - , uploadHackageDistroNamed - , UploadDocMap (..) - , uploadDocMap + ( uploadHackageDistro , uploadBundleV2 , UploadBundleV2 (..) , def @@ -38,129 +30,18 @@ newtype StackageServer = StackageServer { unStackageServer :: Text } deriving (Show, Eq, Ord, Hashable, IsString) instance Default StackageServer where - def = "http://www.stackage.org" - -data UploadBundle = UploadBundle - { ubServer :: StackageServer - , ubContents :: LByteString - , ubAlias :: Maybe Text - , ubNightly :: Maybe Text -- ^ should be GHC version - , ubLTS :: Maybe Text -- ^ e.g. 2.3 - , ubAuthToken :: Text - } -instance Default UploadBundle where - def = UploadBundle - { ubServer = def - , ubContents = mempty - , ubAlias = Nothing - , ubNightly = Nothing - , ubLTS = Nothing - , ubAuthToken = "no-auth-token-provided" - } - -newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text } - deriving (Show, Eq, Ord, Hashable, IsString) - -uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text) -uploadBundle UploadBundle {..} man = do - req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload" - req2 <- formDataBody formData req1 - let req3 = req2 - { method = "PUT" - , requestHeaders = - [ ("Authorization", encodeUtf8 ubAuthToken) - , ("Accept", "application/json") - ] ++ requestHeaders req2 - , redirectCount = 0 - , checkStatus = \_ _ _ -> Nothing - , responseTimeout = Just 300000000 - } - res <- httpLbs req3 man - case lookup "x-stackage-ident" $ responseHeaders res of - Just snapid -> return - ( SnapshotIdent $ decodeUtf8 snapid - , decodeUtf8 <$> lookup "location" (responseHeaders res) - ) - Nothing -> error $ "An error occurred: " ++ show res - where - params = mapMaybe (\(x, y) -> (x, ) <$> y) - [ ("alias", ubAlias) - , ("nightly", ubNightly) - , ("lts", ubLTS) - ] - formData = ($ []) $ execWriter $ do - forM_ params $ \(key, value) -> - tell' $ partBS key $ encodeUtf8 value - tell' $ partFileRequestBody "stackage" "stackage" - $ RequestBodyLBS ubContents - - tell' x = tell (x:) - -data UploadDocs = UploadDocs - { udServer :: StackageServer - , udDocs :: FilePath -- ^ may be a directory or a tarball - , udAuthToken :: Text - , udSnapshot :: SnapshotIdent - } - -uploadDocs :: UploadDocs -> Manager -> IO (Response LByteString) -uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do - fe <- isFile fp0 - if fe - then uploadDocsFile $ fpToString fp0 - else do - de <- isDirectory fp0 - if de - then uploadDocsDir - else error $ "Path not found: " ++ fpToString fp0 - where - uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do - hClose h - dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0 - let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs) - { cwd = Just $ fpToString fp0 - } - withCheckedProcess cp $ \Inherited Inherited Inherited -> return () - uploadDocsFile fp - uploadDocsFile fp = do - req1 <- parseUrl $ unpack $ concat - [ host - , "/upload-haddock/" - , unSnapshotIdent ident - ] - let formData = - [ partFileSource "tarball" fp - ] - req2 <- formDataBody formData req1 - let req3 = req2 - { method = "PUT" - , requestHeaders = - [ ("Authorization", encodeUtf8 token) - , ("Accept", "application/json") - ] ++ requestHeaders req2 - , redirectCount = 0 - , checkStatus = \_ _ _ -> Nothing - , responseTimeout = Just 300000000 - } - httpLbs req3 man - -uploadHackageDistro :: BuildPlan - -> ByteString -- ^ Hackage username - -> ByteString -- ^ Hackage password - -> Manager - -> IO (Response LByteString) -uploadHackageDistro = uploadHackageDistroNamed "Stackage" + def = "https://www.stackage.org" -uploadHackageDistroNamed +uploadHackageDistro :: Text -- ^ distro name -> BuildPlan -> ByteString -- ^ Hackage username -> ByteString -- ^ Hackage password -> Manager -> IO (Response LByteString) -uploadHackageDistroNamed name bp username password manager = do +uploadHackageDistro name bp username password manager = do req1 <- parseUrl $ concat - [ "http://hackage.haskell.org/distro/" + [ "https://hackage.haskell.org/distro/" , unpack name , "/packages.csv" ] @@ -184,39 +65,9 @@ (toBuilder $ display name) ++ "\",\"" ++ (toBuilder $ display version) ++ - "\",\"http://www.stackage.org/package/" ++ + "\",\"https://www.stackage.org/package/" ++ (toBuilder $ display name) ++ "\"" - -data UploadDocMap = UploadDocMap - { udmServer :: StackageServer - , udmAuthToken :: Text - , udmSnapshot :: SnapshotIdent - , udmDocDir :: FilePath - , udmPlan :: BuildPlan - } - -uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString) -uploadDocMap UploadDocMap {..} man = do - docmap <- docsListing udmPlan udmDocDir - req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map" - req2 <- formDataBody (formData $ Y.encode docmap) req1 - let req3 = req2 - { method = "PUT" - , requestHeaders = - [ ("Authorization", encodeUtf8 udmAuthToken) - , ("Accept", "application/json") - ] ++ requestHeaders req2 - , redirectCount = 0 - , checkStatus = \_ _ _ -> Nothing - , responseTimeout = Just 300000000 - } - httpLbs req3 man - where - formData docmap = - [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot) - , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap - ] data UploadBundleV2 = UploadBundleV2 { ub2Server :: StackageServer diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -1,45 +1,80 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} module Main where +import qualified Prelude import Control.Monad -import Data.Monoid import Data.String (fromString) import Data.Version +import Data.Text (pack, stripPrefix) +import Data.Text.Read (decimal) import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) import Paths_stackage_curator (version) +import Stackage.CLI import Stackage.CompleteBuild import Stackage.DiffPlans import Stackage.Upload +import Stackage.Update import Stackage.InstallBuild +import Stackage.Prelude hiding ((<>)) import Stackage.Stats import Network.HTTP.Client (withManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import qualified Data.Text as T +import System.IO (hSetBuffering, stdout, BufferMode (LineBuffering)) main :: IO () -main = - join $ - execParser $ - info - (helpOption <*> versionOption <*> summaryOption <*> config) - (header "Stackage" <> - fullDesc) +main = do + hSetBuffering stdout LineBuffering + join $ fmap snd $ simpleOptions + $(simpleVersion version) + "Stackage curation tool" + "Build package sets for Stackage Nightly and LTS Haskell" + (pure ()) + commands where - helpOption = - abortOption ShowHelpText $ - long "help" <> - help "Show this help text" - versionOption = - infoOption - ("stackage-curator version " ++ showVersion version) - (long "version" <> - help "Show stackage version") - summaryOption = - infoOption - "Build package sets for Stackage Nightly and LTS Haskell" - (long "summary") + commands = do + addCommand "update" "Update the package index" id + (pure $ stackageUpdate defaultStackageUpdateSettings) + addCommand "create-plan" "Generate a new plan file (possibly based on a previous LTS)" id + (createPlan <$> target <*> planFile) + addCommand "check" "Verify that a plan is valid" id + (checkPlan <$> (fmap Just planFile <|> pure Nothing)) + addCommand "fetch" "Fetch all tarballs needed by a plan" id + (fetch <$> planFile) + addCommand "make-bundle" "Run a complete build and generate an upload bundle" id + makeBundle' + addCommand "upload" "Upload a bundle to Stackage Server" id + (upload <$> bundleFile <*> stackageServer) + addCommand "hackage-distro" "Update the Hackage distro list" id + (hackageDistro <$> planFile <*> target) + addCommand "upload-github" "Upload a plan to the relevant Github repo" id + (uploadGithub <$> planFile <*> target) + addCommand "install" "Install a snapshot from an existing build plan" id + (installBuild <$> installFlags) + addCommand "stats" "Print statistics on a build plan" id + (printStats <$> planFile) + addCommand "diff" "Show the high-level differences between two build plans" id + (diffPlans <$> planFileArg <*> planFileArg) + + makeBundle' = makeBundle + <$> planFile + <*> bundleFile + <*> target + <*> jobs + <*> skipTests + <*> skipHaddock + <*> skipHoogle + <*> enableLibraryProfiling + <*> enableExecutableDynamic + <*> verbose + <*> allowNewer + + + {- config = subparser $ mconcat @@ -67,7 +102,6 @@ installBuild installFlags "install" - "Install a snapshot from an existing build plan" , cmnd upload uploadFlags @@ -96,12 +130,12 @@ fmap not (switch - (long "skip-tests" <> + (long "skip-tests" ++ help "Skip build and running the test suites")) <*> fmap not (switch - (long "skip-haddock" <> + (long "skip-haddock" ++ help "Skip generating haddock documentation")) <*> fmap not @@ -112,12 +146,6 @@ (long "enable-library-profiling" <> help "Enable profiling when building") <*> switch - (long "enable-executable-dynamic" <> - help "Enable dynamic executables when building") <*> - switch - (long "verbose" <> short 'v' <> - help "Output verbose detail about the build steps") <*> - switch (long "skip-check" <> help "Skip the check phase, and pass --allow-newer to cabal configure") <*> (fmap fromString (strOption @@ -136,12 +164,18 @@ (fmap not (switch (long "skip-git-push" <> help "Do not perform a git push after completion (for LTS builds only)"))) <*> - (fmap Just (option - auto - (long "jobs" <> short 'j' <> - metavar "NUMBER" <> - help "Number of threads")) <|> pure Nothing) + (fmap (Just . fromString) (strOption + (long "plan-file" <> metavar "FILENAME")) + <|> pure Nothing) <*> + (switch + (long "pre-build" <> + help "Only perform operations up until the actual build")) <*> + (switch + (long "load-plan" <> + help "Load plan from file")) + -} + installFlags :: Parser InstallFlags installFlags = InstallFlags <$> (fmap @@ -205,37 +239,94 @@ (long "skip-hoogle" <> help "Skip generating Hoogle input files")) - upload (path, url) = withManager tlsManagerSettings $ \man -> do - token <- getStackageAuthToken - res <- flip uploadBundleV2 man UploadBundleV2 - { ub2AuthToken = token - , ub2Server = fromString url - , ub2Bundle = decodeString path - } - putStrLn $ "New URL: " ++ T.unpack res + jobs = + (fmap Just (option + auto + (long "jobs" ++ short 'j' ++ + metavar "NUMBER" ++ + help "Number of threads")) <|> pure Nothing) - uploadFlags = (,) - <$> (strArgument - (metavar "BUNDLE-PATH" <> - help "Bundle path")) - <*> strOption - (long "server-url" <> - metavar "SERVER-URL" <> - showDefault <> value (T.unpack $ unStackageServer def) <> - help "Server to upload bundle to") + skipTests = + switch + (long "skip-tests" ++ + help "Skip build and running the test suites") - lts bumpType = (\x y -> (y, x)) -- get the order of arguments correct - <$> buildFlags - <*> (LTS bumpType <$> (T.pack <$> argument str - ( metavar "TARGET-VERSION" - <> help "Used to run old LTS minor bumps, and rerun broken builds" - <> value "" - ) ) ) + skipHaddock = + switch + (long "skip-haddock" ++ + help "Skip generating haddock documentation") - printStatsFlags = yamlArg + skipHoogle = + switch + (long "skip-hoogle" ++ + help "Skip generating Hoogle input files") - diffPlansFlags = (,) <$> yamlArg <*> yamlArg + enableLibraryProfiling = + switch + (long "enable-library-profiling" ++ + help "Enable profiling when building") - yamlArg = fmap decodeString $ strArgument - $ metavar "YAML-FILE" - <> help "YAML file containing a build plan" + enableExecutableDynamic = + switch + (long "enable-executable-dynamic" ++ + help "Enable dynamic executables when building") + + verbose = + switch + (long "verbose" ++ short 'v' ++ + help "Output verbose detail about the build steps") + + allowNewer = + switch + (long "allow-newer" ++ + help "Pass --allow-newer to cabal configure (useful when skipping checks)") + + target :: Parser Target + target = option readTarget + ( metavar "TARGET" + ++ long "target" + ++ help "Build target: nightly, lts-X.Y" + ) + + readTarget :: ReadM Target + readTarget = do + s <- str + let onErr = fail $ "Invalid target: " ++ s + case s of + "nightly" -> return TargetNightly + 'l':'t':'s':'-':t1 -> maybe onErr return $ do + Right (i, t2) <- Just $ decimal $ T.pack t1 + if T.null t2 + then return $ TargetMajor i + else do + t3 <- T.stripPrefix (T.pack ".") t2 + Right (j, t4) <- Just $ decimal t3 + guard $ T.null t4 + if j == 0 + then return $ TargetMajor i + else return $ TargetMinor i j + _ -> onErr + + planFile = fmap decodeString $ strOption + ( metavar "YAML-FILE" + ++ long "plan-file" + ++ help "YAML file containing a build plan" + ) + + planFileArg = fmap decodeString $ strArgument + ( metavar "YAML-FILE" + ++ help "YAML file containing a build plan" + ) + + bundleFile = fmap decodeString $ strOption + ( metavar "BUNDLE-FILE" + ++ long "bundle-file" + ++ help "Path to bundle file" + ) + + stackageServer = + (fmap fromString (strOption + (long "server-url" ++ + metavar "SERVER-URL" ++ + showDefault ++ value (T.unpack $ unStackageServer def) ++ + help "Server to upload bundle to"))) diff --git a/stackage-curator.cabal b/stackage-curator.cabal --- a/stackage-curator.cabal +++ b/stackage-curator.cabal @@ -1,5 +1,5 @@ name: stackage-curator -version: 0.7.4 +version: 0.8.0 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -16,6 +16,7 @@ library default-language: Haskell2010 + other-extensions: TemplateHaskell exposed-modules: Stackage.Prelude Stackage.BuildConstraints Stackage.CorePackages @@ -35,7 +36,7 @@ Stackage.CompleteBuild build-depends: base >= 4 && < 5 , containers - , Cabal >= 1.14 && < 1.20 + , Cabal >= 1.14 , tar >= 0.3 , zlib , bytestring @@ -69,14 +70,19 @@ , xml-conduit , conduit , stackage-types + , monad-unlift executable stackage-curator default-language: Haskell2010 hs-source-dirs: app main-is: stackage.hs + other-extensions: TemplateHaskell build-depends: base , stackage-curator , optparse-applicative >= 0.11 + , optparse-simple + , stackage-update + , stackage-cli , system-filepath , http-client , http-client-tls