upload-nightly

ChangeLog.md

@@ -1,6 +1,7 @@
-## 0.4.0.1
+## 0.4.1
 
-* Print "Still Alive" while checking, to avoid Travis timeouts.
+* Print "Still Alive" while checking, to avoid Travis timeouts
+* Include `stackage upload-nightly` command
 
 ## 0.4.0
 

Stackage/CompleteBuild.hs

@@ -7,6 +7,7 @@ module Stackage.CompleteBuild
     , BuildFlags (..)
     , completeBuild
     , justCheck
+    , justUploadNightly
     ) where
 
 import Control.Concurrent        (threadDelay)
@@ -53,28 +54,38 @@ data Settings = Settings
     , postBuild :: IO ()
     }
 
+nightlyPlanFile :: Text -- ^ day
+                -> FilePath
+nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"
+
+nightlySettings :: Text -- ^ day
+                -> BuildPlan
+                -> Settings
+nightlySettings day plan' = Settings
+    { planFile = nightlyPlanFile day
+    , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
+    , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
+    , title = \ghcVer -> concat
+        [ "Stackage Nightly "
+        , day
+        , ", GHC "
+        , ghcVer
+        ]
+    , slug = slug'
+    , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
+    , plan = plan'
+    , postBuild = return ()
+    }
+  where
+    slug' = "nightly-" ++ day
+
 getSettings :: Manager -> BuildType -> IO Settings
 getSettings man Nightly = do
     day <- tshow . utctDay <$> getCurrentTime
-    let slug' = "nightly-" ++ day
     bc <- defaultBuildConstraints man
     pkgs <- getLatestAllowedPlans bc
     plan' <- newBuildPlan pkgs bc
-    return Settings
+    return $ nightlySettings day plan'
-        { planFile = fpFromText ("nightly-" ++ day) <.> "yaml"
-        , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
-        , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
-        , title = \ghcVer -> concat
-            [ "Stackage Nightly "
-            , day
-            , ", GHC "
-            , ghcVer
-            ]
-        , slug = slug'
-        , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
-        , plan = plan'
-        , postBuild = return ()
-        }
 getSettings man (LTS bumpType) = do
     Option mlts <- fmap (fmap getMax) $ runResourceT
         $ sourceDirectory "."
@@ -178,6 +189,19 @@ justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do
 
     putStrLn "Plan seems valid!"
 
+getPerformBuild :: BuildFlags -> Settings -> PerformBuild
+getPerformBuild buildFlags Settings {..} = PerformBuild
+    { pbPlan = plan
+    , pbInstallDest = buildDir
+    , pbLogDir = logDir
+    , pbLog = hPut stdout
+    , pbJobs = 8
+    , pbGlobalInstall = False
+    , pbEnableTests = bfEnableTests buildFlags
+    , pbEnableLibProfiling = bfEnableLibProfile buildFlags
+    , pbVerbose = bfVerbose buildFlags
+    }
+
 -- | Make a complete plan, build, test and upload bundle, docs and
 -- distro.
 completeBuild :: BuildType -> BuildFlags -> IO ()
@@ -194,26 +218,23 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
     checkBuildPlan plan
 
     putStrLn "Performing build"
-    let pb = PerformBuild
+    performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn
-            { pbPlan = plan
-            , pbInstallDest = buildDir
-            , pbLogDir = logDir
-            , pbLog = hPut stdout
-            , pbJobs = 8
-            , pbGlobalInstall = False
-            , pbEnableTests = bfEnableTests buildFlags
-            , pbEnableLibProfiling = bfEnableLibProfile buildFlags
-            , pbVerbose = bfVerbose buildFlags
-            }
-    performBuild pb >>= mapM_ putStrLn
 
     when (bfDoUpload buildFlags) $
-        finallyUpload settings man pb
+        finallyUpload settings man
+
+justUploadNightly
+    :: Text -- ^ nightly date
+    -> IO ()
+justUploadNightly day = do
+    plan <- decodeFileEither (fpToString $ nightlyPlanFile day)
+        >>= either throwM return
+    withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan
 
 -- | The final part of the complete build process: uploading a bundle,
 -- docs and a distro to hackage.
-finallyUpload :: Settings -> Manager -> PerformBuild -> IO ()
+finallyUpload :: Settings -> Manager -> IO ()
-finallyUpload Settings{..} man pb = do
+finallyUpload settings@Settings{..} man = do
     putStrLn "Uploading bundle to Stackage Server"
     token <- readFile "/auth-token"
     now <- epochTime
@@ -253,3 +274,5 @@ finallyUpload Settings{..} man pb = do
         , udmDocDir = pbDocDir pb
         , udmPlan = plan
         } man >>= print
+  where
+    pb = getPerformBuild (error "finallyUpload.buildFlags") settings

app/stackage.hs

@@ -4,6 +4,7 @@ module Main where
 
 import Control.Monad
 import Data.Monoid
+import Data.String (fromString)
 import Data.Version
 import Options.Applicative
 import Paths_stackage (version)
@@ -45,6 +46,11 @@ main =
                   (fmap (LTS Minor, ) buildFlags)
                   "lts-minor"
                   "Build, test and upload the LTS (minor) snapshot"
+            , cmnd
+                  justUploadNightly
+                  nightlyUploadFlags
+                  "upload-nightly"
+                  "Upload an already-built nightly snapshot"
             , cmnd
                   (const justCheck)
                   (pure ())
@@ -73,3 +79,7 @@ main =
         switch
             (long "verbose" <> short 'v' <>
              help "Output verbose detail about the build steps")
+
+    nightlyUploadFlags = fromString <$> strArgument
+        (metavar "DATE" <>
+         help "Date, in YYYY-MM-DD format")

stackage.cabal

@@ -1,5 +1,5 @@
 name:                stackage
-version:             0.4.0.1
+version:             0.4.1
 synopsis:            "Stable Hackage," tools for creating a vetted set of packages from Hackage.
 description:         Please see <http://www.stackage.org/package/stackage> for a description and documentation.
 homepage:            https://github.com/fpco/stackage