From 982bcfa2ad233e41e82b4d1319e280623b14a99c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 26 Dec 2014 13:43:44 +0200 Subject: [PATCH 1/6] WIP new upload --- ChangeLog.md | 4 + Stackage/PerformBuild.hs | 10 --- Stackage/Prelude.hs | 13 +++ Stackage/ServerBundle.hs | 173 +++++++++++++++++++++++++++++++++++++-- Stackage/Upload.hs | 129 +++++++++++++---------------- stackage.cabal | 3 +- 6 files changed, 243 insertions(+), 89 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 2a524e11..37704fa8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.4.0 + +* Upload bundle V2 stuff + ## 0.3.1 * Added `justCheck` and `stackage check` command line. diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index 31602d55..5299f34e 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -412,16 +412,6 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = renameOrCopy :: FilePath -> FilePath -> IO () renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest -copyDir :: FilePath -> FilePath -> IO () -copyDir src dest = - runResourceT $ sourceDirectoryDeep False src $$ mapM_C go - where - src' = src "" - go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do - let dest' = dest suffix - liftIO $ createTree $ parent dest' - sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) - copyBuiltInHaddocks :: FilePath -> IO () copyBuiltInHaddocks docdir = do mghc <- findExecutable "ghc" diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs index ab2187fc..28fff061 100644 --- a/Stackage/Prelude.hs +++ b/Stackage/Prelude.hs @@ -20,6 +20,9 @@ import Distribution.Version as X (Version (..), VersionRange) import Distribution.Version as X (withinRange) import qualified Distribution.Version as C +import Filesystem (createTree) +import Filesystem.Path (parent) +import qualified Filesystem.Path as F unPackageName :: PackageName -> Text unPackageName (PackageName str) = pack str @@ -101,3 +104,13 @@ topologicalSort toFinal toDeps = data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) deriving (Show, Typeable) instance (Show key, Typeable key) => Exception (TopologicalSortException key) + +copyDir :: FilePath -> FilePath -> IO () +copyDir src dest = + runResourceT $ sourceDirectoryDeep False src $$ mapM_C go + where + src' = src "" + go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do + let dest' = dest suffix + liftIO $ createTree $ parent dest' + sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs index 6cdf5cb4..5aedb090 100644 --- a/Stackage/ServerBundle.hs +++ b/Stackage/ServerBundle.hs @@ -7,21 +7,31 @@ module Stackage.ServerBundle , epochTime , bpAllPackages , docsListing + , createBundleV2 + , CreateBundleV2 (..) + , SnapshotType (..) + , writeIndexStyle + , DocMap + , PackageDocs (..) ) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import qualified Data.Map as M +import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject) +import System.IO.Temp (withTempDirectory) import qualified Data.Yaml as Y -import Filesystem (isFile) +import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath) import Foreign.C.Types (CTime (CTime)) import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.Prelude +import System.IO.Temp (withTempDirectory) import qualified System.PosixCompat.Time as PC import qualified Text.XML as X import Text.XML.Cursor +import System.PosixCompat.Files (createSymbolicLink) -- | Get current time epochTime :: IO Tar.EpochTime @@ -73,13 +83,30 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write map (\(PackageName name) -> name) (M.keys $ siCorePackages bpSystemInfo) +-- | Package name is key +type DocMap = Map Text PackageDocs +data PackageDocs = PackageDocs + { pdVersion :: Text + , pdModules :: Map Text [Text] + -- ^ module name, path + } +instance ToJSON PackageDocs where + toJSON PackageDocs {..} = object + [ "version" .= pdVersion + , "modules" .= pdModules + ] +instance FromJSON PackageDocs where + parseJSON = withObject "PackageDocs" $ \o -> PackageDocs + <$> o .: "version" + <*> o .: "modules" + docsListing :: BuildPlan -> FilePath -- ^ docs directory - -> IO ByteString + -> IO DocMap docsListing bp docsDir = - fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp + fmap fold $ mapM go $ mapToList $ bpAllPackages bp where - go :: (PackageName, Version) -> IO (Map Text Y.Value) + go :: (PackageName, Version) -> IO DocMap go (package, version) = do -- handleAny (const $ return mempty) $ do let dirname = fpFromText (concat [ display package @@ -107,8 +134,138 @@ docsListing bp docsDir = return $ if e then asMap $ singletonMap name [fpToText dirname, href] else mempty - return $ singletonMap (display package) $ Y.object - [ "version" Y..= display version - , "modules" Y..= m - ] + return $ singletonMap (display package) $ PackageDocs + { pdVersion = display version + , pdModules = m + } else return mempty + +data SnapshotType = STNightly + | STLTS !Int !Int -- ^ major, minor + deriving (Show, Read, Eq, Ord) + +instance ToJSON SnapshotType where + toJSON STNightly = object + [ "type" .= asText "nightly" + ] + toJSON (STLTS major minor) = object + [ "type" .= asText "lts" + , "major" .= major + , "minor" .= minor + ] +instance FromJSON SnapshotType where + parseJSON = withObject "SnapshotType" $ \o -> do + t <- o .: "type" + case asText t of + "nightly" -> return STNightly + "lts" -> STLTS + <$> o .: "major" + <*> o .: "minor" + _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t + +data CreateBundleV2 = CreateBundleV2 + { cb2Plan :: BuildPlan + , cb2Type :: SnapshotType + , cb2DocsDir :: FilePath + , cb2Dest :: FilePath + } + +-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc +-- map. +createBundleV2 :: CreateBundleV2 -> IO () +createBundleV2 CreateBundleV2 {..} = do + docsDir <- canonicalizePath cb2DocsDir + docMap <- docsListing cb2Plan cb2DocsDir + + Y.encodeFile (fpToString $ docsDir "build-plan.yaml") cb2Plan + Y.encodeFile (fpToString $ docsDir "build-type.yaml") cb2Type + Y.encodeFile (fpToString $ docsDir "docs-map.yaml") docMap + void $ writeIndexStyle Nothing cb2DocsDir + + currentDir <- getWorkingDirectory + files <- listDirectory docsDir + + let args = "cfJ" + : fpToString (currentDir cb2Dest) + : "--dereference" + : map (fpToString . filename) files + cp = (proc "tar" args) { cwd = Just $ fpToString docsDir } + withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () + +writeIndexStyle :: Maybe Text -- ^ snapshot id + -> FilePath -- ^ docs dir + -> IO [String] +writeIndexStyle msnapid dir = do + dirs <- fmap sort + $ runResourceT + $ sourceDirectory dir + $$ filterMC (liftIO . isDirectory) + =$ mapC (fpToString . filename) + =$ sinkList + writeFile (dir "index.html") $ mkIndex + (unpack <$> msnapid) + dirs + writeFile (dir "style.css") styleCss + return dirs + +mkIndex :: Maybe String -> [String] -> String +mkIndex msnapid dirs = concat + [ "\nHaddocks index" + , "" + , "" + , "" + , "" + , "
" + , "
" + , "

Haddock documentation index

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

Return to snapshot

" + ] + , "
    " + , concatMap toLI dirs + , "
" + ] + where + toLI name = concat + [ "
  • " + , name + , "
    • " + ] + +styleCss :: String +styleCss = concat + [ "@media (min-width: 530px) {" + , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }" + , "}" + , "@media (min-width: 760px) {" + , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }" + , "}" + , "ul {" + , " margin-left: 0;" + , " padding-left: 0;" + , " list-style-type: none;" + , "}" + , "body {" + , " background: #f0f0f0;" + , " font-family: 'Lato', sans-serif;" + , " text-shadow: 1px 1px 1px #ffffff;" + , " font-size: 20px;" + , " line-height: 30px;" + , " padding-bottom: 5em;" + , "}" + , "h1 {" + , " font-weight: normal;" + , " color: #06537d;" + , " font-size: 45px;" + , "}" + , ".return a {" + , " color: #06537d;" + , " font-style: italic;" + , "}" + , ".return {" + , " margin-bottom: 1em;" + , "}"] diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs index bb1c8246..bea1c289 100644 --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -13,17 +13,23 @@ module Stackage.Upload , uploadHackageDistro , UploadDocMap (..) , uploadDocMap + , uploadBundleV2 + , UploadBundleV2 (..) ) where import Control.Monad.Writer.Strict (execWriter, tell) import Data.Default.Class (Default (..)) +import Data.Function (fix) import Filesystem (isDirectory, isFile) import Network.HTTP.Client +import qualified Network.HTTP.Client.Conduit as HCC import Network.HTTP.Client.MultipartFormData import Stackage.BuildPlan (BuildPlan) import Stackage.Prelude -import Stackage.ServerBundle (bpAllPackages, docsListing) +import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle) import System.IO.Temp (withSystemTempFile) +import qualified System.IO as IO +import qualified Data.Yaml as Y newtype StackageServer = StackageServer { unStackageServer :: Text } deriving (Show, Eq, Ord, Hashable, IsString) @@ -106,17 +112,7 @@ uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do where uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do hClose h - dirs <- fmap sort - $ runResourceT - $ sourceDirectory fp0 - $$ filterMC (liftIO . isDirectory) - =$ mapC (fpToString . filename) - =$ sinkList - writeFile (fp0 "index.html") $ mkIndex - (unpack $ unSnapshotIdent ident) - dirs - writeFile (fp0 "style.css") styleCss - -- FIXME write index.html, style.css + dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0 let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs) { cwd = Just $ fpToString fp0 } @@ -187,7 +183,7 @@ 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 docmap) req1 + req2 <- formDataBody (formData $ Y.encode docmap) req1 let req3 = req2 { method = "PUT" , requestHeaders = @@ -205,61 +201,54 @@ uploadDocMap UploadDocMap {..} man = do , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap ] -mkIndex :: String -> [String] -> String -mkIndex snapid dirs = concat - [ "\nHaddocks index" - , "" - , "" - , "" - , "" - , "
    " - , "
    " - , "

    Haddock documentation index

    " - , "

    Return to snapshot

      " - , concatMap toLI dirs - , "
    " - ] - where - toLI name = concat - [ "
  • " - , name - , "
    • " - ] +data UploadBundleV2 = UploadBundleV2 + { ub2Server :: StackageServer + , ub2AuthToken :: Text + , ub2Bundle :: FilePath + } -styleCss :: String -styleCss = concat - [ "@media (min-width: 530px) {" - , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }" - , "}" - , "@media (min-width: 760px) {" - , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }" - , "}" - , "ul {" - , " margin-left: 0;" - , " padding-left: 0;" - , " list-style-type: none;" - , "}" - , "body {" - , " background: #f0f0f0;" - , " font-family: 'Lato', sans-serif;" - , " text-shadow: 1px 1px 1px #ffffff;" - , " font-size: 20px;" - , " line-height: 30px;" - , " padding-bottom: 5em;" - , "}" - , "h1 {" - , " font-weight: normal;" - , " color: #06537d;" - , " font-size: 45px;" - , "}" - , ".return a {" - , " color: #06537d;" - , " font-style: italic;" - , "}" - , ".return {" - , " margin-bottom: 1em;" - , "}"] +uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text +uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do + size <- IO.hFileSize h + req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2" + let req2 = req1 + { method = "PUT" + , requestHeaders = + [ ("Authorization", encodeUtf8 ub2AuthToken) + , ("Accept", "application/json") + , ("Content-Type", "application/x-tar") + ] + , requestBody = HCC.requestBodySource (fromIntegral size) + $ sourceHandle h $= printProgress size + } + sink = decodeUtf8C =$ fix (\loop -> do + mx <- peekC + case mx of + Nothing -> error $ "uploadBundleV2: premature end of stream" + Just _ -> do + l <- lineC $ takeCE 4096 =$ foldC + let (cmd, msg') = break (== ':') l + msg = dropWhile (== ' ') $ dropWhile (== ':') msg' + case cmd of + "CONT" -> do + putStrLn msg + loop + "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg + "SUCCESS" -> return msg + _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd + ) + withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink + where + printProgress total = + loop 0 0 + where + loop sent lastPercent = + await >>= maybe (putStrLn "Upload complete") go + where + go bs = do + yield bs + let sent' = sent + fromIntegral (length bs) + percent = sent' * 100 `div` total + when (percent /= lastPercent) + $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%" + loop sent' percent diff --git a/stackage.cabal b/stackage.cabal index 842cdbd7..d9e2a06d 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -1,5 +1,5 @@ name: stackage -version: 0.3.1 +version: 0.4.0 synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage. description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -52,6 +52,7 @@ library , yaml , unix-compat , http-client + , http-conduit , http-client-tls , temporary , data-default-class From 7dfde3ba49fb60209ccef21e1d03ba633b5fee3f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 15 Mar 2015 18:51:55 +0200 Subject: [PATCH 2/6] Generate v2 bundle during complete build --- Stackage/CompleteBuild.hs | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 80693dad..c3b26144 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -57,6 +57,8 @@ data Settings = Settings , setArgs :: Text -> UploadBundle -> UploadBundle , postBuild :: IO () , distroName :: Text -- ^ distro name on Hackage + , snapshotType :: SnapshotType + , bundleDest :: FilePath } nightlyPlanFile :: Text -- ^ day @@ -81,6 +83,8 @@ nightlySettings day plan' = Settings , plan = plan' , postBuild = return () , distroName = "Stackage" + , snapshotType = STNightly + , bundleDest = fpFromText $ "stackage-nightly-" ++ tshow day ++ ".bundle" } where slug' = "nightly-" ++ day @@ -142,6 +146,10 @@ getSettings man (LTS bumpType) = do putStrLn "Pushing to Git repository" git ["push"] , distroName = "LTSHaskell" + , snapshotType = + case new of + LTSVer x y -> STLTS x y + , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle" } data LTSVer = LTSVer !Int !Int @@ -231,7 +239,16 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do checkBuildPlan plan putStrLn "Performing build" - performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn + let 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 + } when (bfDoUpload buildFlags) $ finallyUpload settings man From fb1d2607bc6fc0b906e657b21f92117f116d2d0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 15 Mar 2015 19:15:57 +0200 Subject: [PATCH 3/6] Get rid of superfluous quotes --- Stackage/CompleteBuild.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index c3b26144..b5f41759 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -84,7 +84,7 @@ nightlySettings day plan' = Settings , postBuild = return () , distroName = "Stackage" , snapshotType = STNightly - , bundleDest = fpFromText $ "stackage-nightly-" ++ tshow day ++ ".bundle" + , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle" } where slug' = "nightly-" ++ day From 43639bd6c5cd8a5d1eedec378c1ac305d0f4fd46 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 16 Mar 2015 12:33:29 +0200 Subject: [PATCH 4/6] Remove some expected failures c/o @chrisdone --- build-constraints.yaml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/build-constraints.yaml b/build-constraints.yaml index 4036dc18..527574db 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -966,9 +966,6 @@ expected-test-failures: # https://github.com/BioHaskell/octree/issues/4 - Octree - # https://github.com/goldfirere/th-desugar/issues/12 - - th-desugar - # https://github.com/jmillikin/haskell-filesystem/issues/3 - system-filepath @@ -1077,9 +1074,6 @@ expected-haddock-failures: # https://github.com/acw/bytestring-progress/issues/4 - bytestring-progress - # https://github.com/ekmett/gl/issues/4 - - gl - # https://github.com/leventov/yarr/issues/5 - yarr From 923d655e0900dfc642a7a4b588f52339e6a42e4e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 16 Mar 2015 17:17:45 +0200 Subject: [PATCH 5/6] Provide options for v2 uploads --- ChangeLog.md | 2 +- Stackage/CompleteBuild.hs | 87 +++++++++++++++++++++++---------------- Stackage/Upload.hs | 3 ++ app/stackage.hs | 36 +++++++++++++++- stackage.cabal | 5 ++- 5 files changed, 93 insertions(+), 40 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 3d7dd179..2aa9aea0 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,4 @@ -## Unreleased +## 0.6.0 * Upload bundle V2 stuff diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index b5f41759..5f4735e6 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -8,6 +8,7 @@ module Stackage.CompleteBuild , completeBuild , justCheck , justUploadNightly + , getStackageAuthToken ) where import Control.Concurrent (threadDelay) @@ -39,6 +40,7 @@ data BuildFlags = BuildFlags , bfEnableExecDyn :: !Bool , bfVerbose :: !Bool , bfSkipCheck :: !Bool + , bfUploadV2 :: !Bool } deriving (Show) data BuildType = Nightly | LTS BumpType @@ -251,7 +253,7 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do } when (bfDoUpload buildFlags) $ - finallyUpload settings man + finallyUpload (bfUploadV2 buildFlags) settings man justUploadNightly :: Text -- ^ nightly date @@ -259,41 +261,63 @@ justUploadNightly justUploadNightly day = do plan <- decodeFileEither (fpToString $ nightlyPlanFile day) >>= either throwM return - withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan + withManager tlsManagerSettings $ finallyUpload False $ nightlySettings day plan + +getStackageAuthToken :: IO Text +getStackageAuthToken = do + mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" + case mtoken of + Nothing -> decodeUtf8 <$> readFile "/auth-token" + Just token -> return $ pack token -- | The final part of the complete build process: uploading a bundle, -- docs and a distro to hackage. -finallyUpload :: Settings -> Manager -> IO () -finallyUpload settings@Settings{..} man = do +finallyUpload :: Bool -- ^ use v2 upload + -> Settings -> Manager -> IO () +finallyUpload useV2 settings@Settings{..} man = do putStrLn "Uploading bundle to Stackage Server" - mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" - token <- - case mtoken of - Nothing -> decodeUtf8 <$> readFile "/auth-token" - Just token -> return $ pack token + token <- getStackageAuthToken - now <- epochTime - let ghcVer = display $ siGhcVersion $ bpSystemInfo plan - (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def - { ubContents = serverBundle now (title ghcVer) slug plan - , ubAuthToken = token - } - putStrLn $ "New ident: " ++ unSnapshotIdent ident - forM_ mloc $ \loc -> - putStrLn $ "Track progress at: " ++ loc + if useV2 + then do + res <- flip uploadBundleV2 man UploadBundleV2 + { ub2Server = def + , ub2AuthToken = token + , ub2Bundle = bundleDest + } + putStrLn $ "New snapshot available at: " ++ res + else do + now <- epochTime + let ghcVer = display $ siGhcVersion $ bpSystemInfo plan + (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def + { ubContents = serverBundle now (title ghcVer) slug plan + , ubAuthToken = token + } + putStrLn $ "New ident: " ++ unSnapshotIdent ident + forM_ mloc $ \loc -> + putStrLn $ "Track progress at: " ++ loc + + putStrLn "Uploading docs to Stackage Server" + res1 <- tryAny $ uploadDocs UploadDocs + { udServer = def + , udAuthToken = token + , udDocs = pbDocDir pb + , udSnapshot = ident + } man + putStrLn $ "Doc upload response: " ++ tshow res1 + + putStrLn "Uploading doc map" + tryAny (uploadDocMap UploadDocMap + { udmServer = def + , udmAuthToken = token + , udmSnapshot = ident + , udmDocDir = pbDocDir pb + , udmPlan = plan + } man) >>= print postBuild `catchAny` print - putStrLn "Uploading docs to Stackage Server" - res1 <- uploadDocs UploadDocs - { udServer = def - , udAuthToken = token - , udDocs = pbDocDir pb - , udSnapshot = ident - } man - putStrLn $ "Doc upload response: " ++ tshow res1 - ecreds <- tryIO $ readFile "/hackage-creds" case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of [username, password] -> do @@ -301,14 +325,5 @@ finallyUpload settings@Settings{..} man = do res2 <- uploadHackageDistroNamed distroName plan username password man putStrLn $ "Distro upload response: " ++ tshow res2 _ -> putStrLn "No creds found, skipping Hackage distro upload" - - putStrLn "Uploading doc map" - uploadDocMap UploadDocMap - { udmServer = def - , udmAuthToken = token - , udmSnapshot = ident - , udmDocDir = pbDocDir pb - , udmPlan = plan - } man >>= print where pb = getPerformBuild (error "finallyUpload.buildFlags") settings diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs index 3282bf91..28cdf730 100644 --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -16,6 +16,8 @@ module Stackage.Upload , uploadDocMap , uploadBundleV2 , UploadBundleV2 (..) + , def + , unStackageServer ) where import Control.Monad.Writer.Strict (execWriter, tell) @@ -224,6 +226,7 @@ data UploadBundleV2 = UploadBundleV2 uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do size <- IO.hFileSize h + putStrLn $ "Bundle size: " ++ tshow size req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2" let req2 = req1 { method = "PUT" diff --git a/app/stackage.hs b/app/stackage.hs index 1b9583c7..c53c4ee4 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -10,7 +10,11 @@ import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) import Paths_stackage (version) import Stackage.CompleteBuild +import Stackage.Upload import Stackage.InstallBuild +import Network.HTTP.Client (withManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Data.Text as T main :: IO () main = @@ -62,7 +66,13 @@ main = installBuild installFlags "install" - "Install a snapshot from an existing build plan"] + "Install a snapshot from an existing build plan" + , cmnd + uploadv2 + uploadv2Flags + "upload2" + "Upload a pre-existing v2 bundle" + ] cmnd exec parse name desc = command name $ @@ -98,7 +108,10 @@ main = help "Output verbose detail about the build steps") <*> switch (long "skip-check" <> - help "Skip the check phase, and pass --allow-newer to cabal configure") + help "Skip the check phase, and pass --allow-newer to cabal configure") <*> + switch + (long "upload-v2" <> + help "Use the V2 upload code") nightlyUploadFlags = fromString <$> strArgument (metavar "DATE" <> @@ -161,3 +174,22 @@ main = switch (long "skip-check" <> help "Skip the check phase, and pass --allow-newer to cabal configure") + + uploadv2 (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 + + uploadv2Flags = (,) + <$> (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") diff --git a/stackage.cabal b/stackage.cabal index df327327..7efbd149 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -1,5 +1,5 @@ name: stackage -version: 0.5.2 +version: 0.6.0 synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage. description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -75,6 +75,9 @@ executable stackage , stackage , optparse-applicative >= 0.11 , system-filepath + , http-client + , http-client-tls + , text ghc-options: -rtsopts -threaded -with-rtsopts=-N test-suite spec From ca22965695076fbc053c74d0d7df1fc5e349dcf1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Mar 2015 10:37:27 +0200 Subject: [PATCH 6/6] Upper bound for #476 --- build-constraints.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/build-constraints.yaml b/build-constraints.yaml index 527574db..bed49edf 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -784,6 +784,9 @@ packages: # https://github.com/fpco/stackage/issues/467 - lens < 4.8 + # https://github.com/fpco/stackage/issues/476 + - vector-space < 0.10 + # Package flags are applied to individual packages, and override the values of # global-flags package-flags: