Merge pull request #4964 from commercialhaskell/split-out-subs

Split out subs

snapshot-lts-12.yaml

@@ -15,6 +15,10 @@ packages:
 - hedgehog-0.6.1@rev:4 # for ansi-terminal-0.9
 - optparse-simple-0.1.1.2
 - typed-process-0.2.6.0@rev:0 # for rio-0.1.10.0
+- rio-prettyprint-0.1.0.0
+- hi-file-parser-0.1.0.0
+- http-download-0.1.0.0
+- pantry-0.1.1.0
 - git: https://github.com/snoyberg/filelock.git
   commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc
 

snapshot-nightly.yaml

-resolver: nightly-2019-07-11
+resolver: nightly-2019-07-15
 name: snapshot-for-building-stack-with-ghc-8.6.5
 
 packages:
-- amazonka-1.6.1@rev:0
-- amazonka-s3-1.6.1@rev:0
-- amazonka-core-1.6.1@rev:0
-  # For amazonka-1.6.1 (check for amazonka update allowing http-client-0.6)
-  # Once fixed, remove bounds from `package.yaml` (also under `subs`)
-- http-client-0.5.14@rev:0
-- cryptonite-0.26@rev:0
 - git: https://github.com/snoyberg/filelock.git
   commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc
 

snapshot.yaml

@@ -23,6 +23,10 @@ packages:
 - ansi-wl-pprint-0.6.8.2@rev:1 # for ansi-terminal-0.9
 - hedgehog-0.6.1@rev:4 # for ansi-terminal-0.9
 - typed-process-0.2.6.0@rev:0 # for rio-0.1.10.0
+- rio-prettyprint-0.1.0.0
+- hi-file-parser-0.1.0.0
+- http-download-0.1.0.0
+- pantry-0.1.1.0
 - git: https://github.com/snoyberg/filelock.git
   commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc
 

stack-lts-12.yaml

 resolver: snapshot-lts-12.yaml
 
-packages:
-- .
-- subs/pantry
-- subs/curator
-- subs/http-download
-- subs/rio-prettyprint
-- subs/hi-file-parser
-
 docker:
   enable: false
   repo: fpco/stack-build-small:lts-12.26

stack-nightly.yaml

 resolver: snapshot-nightly.yaml
 
-packages:
-- .
-- subs/pantry
-- subs/curator
-- subs/http-download
-- subs/rio-prettyprint
-- subs/hi-file-parser
-
 docker:
   enable: false
   repo: fpco/stack-build-small:lts-13.26

stack.yaml

 resolver: snapshot.yaml
 
-packages:
-- .
-- subs/pantry
-- subs/curator
-- subs/http-download
-- subs/rio-prettyprint
-- subs/hi-file-parser
-
 docker:
   enable: false
   repo: fpco/stack-build:lts-11.22

subs/convert/.gitignore

-lts-haskell/
-stackage-nightly/
-stackage-snapshots/

subs/convert/convert-old-stackage.sh

-#!/usr/bin/env bash
-
-set -eux
-
-cd $(dirname ${BASH_SOURCE[0]})
-
-for d in lts-haskell stackage-nightly stackage-snapshots
-do
-    if [[ ! -d "$d" ]]
-    then
-        git clone https://github.com/commercialhaskell/$d
-    else
-        (cd "$d" && git pull || echo "Git pull failed, ignoring")
-    fi
-done
-
-stack build --flag pantry:convert-old-stackage pantry:convert-old-stackage --exec convert-old-stackage

subs/convert/make-global-hints.hs

-#!/usr/bin/env stack
--- stack --resolver lts-12.0 script
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-import RIO
-import qualified RIO.Map as Map
-import Conduit
-import Data.Yaml
-
-main :: IO ()
-main = runSimpleApp $ do
-  m <- runConduitRes $ allFiles .| foldMC addFile mempty
-  liftIO $ encodeFile "global-hints.yaml" m
-
-allFiles =
-  sourceDirectoryDeep True "stackage-snapshots/lts" *>
-  sourceDirectoryDeep True "stackage-snapshots/nightly"
-
-addFile m fp = do
-  GlobalHints ghc packages <- liftIO $ decodeFileThrow fp
-  evaluate $ Map.insert ghc
-    (case Map.lookup ghc m of
-      Nothing -> packages
-      Just packages' -> Map.unionWith
-        (\x y ->
-           if x == y
-             then x
-             else error $ show (ghc, fp, x, y))
-        packages
-        packages') m
-
-data GlobalHints = GlobalHints !Text !(Map Text Text)
-
-instance FromJSON GlobalHints where
-  parseJSON = withObject "GlobalHints" $ \o -> GlobalHints
-    <$> o .: "compiler"
-    <*> o .: "global-hints"

subs/curator/.gitignore

-build-constraints.yaml
-constraints.yaml
-snapshot-incomplete.yaml
-snapshot.yaml
-unpack-dir/

subs/curator/LICENSE

-Copyright (c) 2015-2019, Stack contributors
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-    * Redistributions in binary form must reproduce the above copyright
-      notice, this list of conditions and the following disclaimer in the
-      documentation and/or other materials provided with the distribution.
-    * Neither the name of Stack nor the
-      names of its contributors may be used to endorse or promote products
-      derived from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY
-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

subs/curator/README.md

-# curator
-
-Snapshot curator tool for, e.g., creating Stackage snapshots.
-
-This is the "curator 2.0", replacing
-https://github.com/fpco/stackage-curator. It relies on pantry for
-finding appropriate packages, and Stack for performing the builds. It
-is intended to be much simpler to maintain than the old
-stackage-curator tool.
-
-## Incomplete!
-
-This tool is not yet complete. Here's a (likely incomplete) list of
-things that still need to be handled to replace `stackage-curator`:
-
-* Collect the Haddocks in a way that stackage-server can handle them
-* Proper CLI, right now the `app/Main.hs` just runs through a bunch of
-  steps. We need to have individual commands like the current tool, so
-  each command can be called in an appropriately locked-down Docker
-  container.
-* Logic for uploading generated snapshots and other info to Github,
-  S3, etc.
-* Ability to roll an LTS minor version bump.
-* Ability to specify package locations from Git.
-* External, but: stackage-server needs to be updated to support the
-  new snapshot format/location
-* No support for custom configure arguments from `build-constraints.yaml`. I'd
-  like to see if we can get rid of them entirely and instead just customize the
-  Docker build image.
-
-## Basic workflow
-
-Here's a rundown of how this tool is intended to be used.
-
-We update the Hackage index to get a list of all of the most recent
-package versions. This is pantry's `updateHackageIndex` command.
-
-We start with `build-constraints.yaml`, the configuration file in
-commercialhaskell/stackage. This specifies all of the packages we want
-to include in a snapshot, along with a bunch of configuration.
-
-We parse `build-constraints.yaml` and convert it into the
-`constraints.yaml` file, which contains a more properly structures set
-of constraints. We'll continue to let users edit the
-`build-constraints.yaml` file, since it's more user-friendly. But
-`constraints.yaml` gives us more flexibility.
-
-* For LTS minor bumps, instead of generating `constraints.yaml` from
-  `build-constraints.yaml`, we'll take the `constraints.yaml` used for
-  the last LTS release in the series. Details still need to be worked
-  out on how upper bounds are added and where this file is stored.
-
-Curator team: at this point, you can edit `constraints.yaml` to make
-tweaks to the build plan. This replaces the old `CONSTRAINTS`
-environment variable.
-
-We combine the `constraints.yaml` file and the information from
-Hackage to produce `snapshot-incomplete.yaml`. This has a concrete
-list of all of the packages we intend to include in the
-snapshot. Again, this file can be manually modified if desired.
-
-* When we support Git repos, we'll also be checking those repos to
-  find the latest appropriate release. We'll need to figure out
-  exactly how that plays in with LTS upper bounds; I'm thinking we'll
-  have logic like "use commit X, or the latest if it meets version
-  range Y."
-
-The `snapshot-incomplete.yaml` file does not have all of the
-cryptographic hashes necessary for fully reproducible builds. We next
-generate `snapshot.yaml` with all of this information. This file
-should _never be manually edited_, instead edits should occur at the
-`snapshot-incomplete.yaml` and `constraints.yaml` phases.
-
-The `snapshot.yaml` file gets checked for its consistency ensuring the
-following:
-
-* All package dependencies are explicitly specified in constraints files
-
-* Dependency bounds of all snapshot packages are properly satisfied
-
-* There are no dependency cycles in the snapshot (only libraries and
-  executables are included into checked dependency tree as test suites and
-  benchmarks are allowed to create cycles)
-
-* The snapshot contains Cabal version suitable to build all packages
-
-We unpack all of the package specified by `snapshot.yaml` into a local
-directory, and generate a `stack.yaml` that gives instructions to
-build all of those packages.
-
-We build the packages, run test suites, and generate Haddocks.
-
-__TODO__ Grab artifacts and upload them to the right place.

subs/curator/app/Main.hs

-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-import Curator hiding (Snapshot)
-import Data.Yaml (encodeFile, decodeFileThrow)
-import Network.HTTP.Client (httpLbs, newManager, parseUrlThrow, responseBody)
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Network.HTTP.Download (download)
-import Options.Applicative.Simple hiding (action)
-import qualified Pantry
-import Path (toFilePath)
-import Path.IO (doesFileExist, removeFile, resolveFile', resolveDir')
-import Paths_curator (version)
-import qualified RIO.ByteString.Lazy as BL
-import RIO.List (stripPrefix)
-import qualified RIO.Map as Map
-import RIO.Process
-import qualified RIO.Text as T
-import RIO.Time
-
-options :: IO ((), RIO PantryApp ())
-options =
-    simpleOptions $(simpleVersion version)
-                  "curator - Stackage curator tool"
-                  "Special utilities for Stackage curators"
-                  (pure ())
-                  commands
-  where
-    commands = do
-      addCommand "update"
-                 "Update Pantry databse from Hackage"
-                 (const update)
-                 (pure ())
-      addCommand "check-target-available"
-                 "Check if target snapshot isn't yet on Github"
-                 checkTargetAvailable
-                 parseTarget
-      addCommand "constraints"
-                 "Generate constraints file from build-constraints.yaml"
-                 constraints
-                 parseTarget
-      addCommand "snapshot-incomplete"
-                 "Generate incomplete snapshot"
-                 (const snapshotIncomplete)
-                 (pure ())
-      addCommand "snapshot"
-                 "Complete locations in incomplete snapshot"
-                 (const snapshot)
-                 (pure ())
-      addCommand "check-snapshot"
-                 "Check snapshot consistency"
-                 (const checkSnapshot)
-                 (pure ())
-      addCommand "legacy-snapshot"
-                 "Generate a legacy-format snapshot file"
-                 (const legacySnapshot)
-                 (pure ())
-      addCommand "unpack"
-                 "Unpack snapshot packages and create a Stack project for it"
-                 (const unpackFiles)
-                 (pure ())
-      addCommand "build"
-                 "Build Stack project for a Stackage snapshot"
-                 build
-                 parseJobs
-      addCommand "upload-docs"
-                 "Upload documentation to an S3 bucket"
-                 uploadDocs'
-                 parseTarget
-      addCommand "upload-github"
-                 "Commit and push snapshot definition to Github repository"
-                 uploadGithub'
-                 parseTarget
-      addCommand "hackage-distro"
-                 "Upload list of snapshot packages on Hackage as a distro"
-                 hackageDistro
-                 parseTarget
-      addCommand "legacy-bulk"
-                 "Bulk convert all new snapshots to the legacy LTS/Nightly directories"
-                 legacyBulk
-                 parseLegacyBulkArgs
-    parseTarget =
-      option (nightly <|> lts) ( long "target"
-                              <> metavar "TARGET"
-                              <> help "Target Stackage snapshot 'lts-MM.NN' or 'nightly-YYYY-MM-DD'"
-                               )
-    nightly = maybeReader $ \s -> do
-      s' <- stripPrefix "nightly-" s
-      TargetNightly <$> parseTimeM False defaultTimeLocale "%Y-%m-%d" s'
-    lts = maybeReader $ \s -> do
-      s' <- stripPrefix "lts-" s
-      case break (== '.') s' of
-        (major, '.':minor) -> TargetLts <$> readMaybe major <*> readMaybe minor
-        _ -> Nothing
-    parseJobs = option auto ( long "jobs"
-                           <> metavar "JOBS"
-                           <> showDefault
-                           <> value 1
-                           <> help "Number of jobs to run Stackage build with"
-                              )
-    parseLegacyBulkArgs = LegacyBulkArgs
-      <$> strOption (long "stackage-snapshots" <> metavar "DIR")
-      <*> strOption (long "lts-haskell" <> metavar "DIR")
-      <*> strOption (long "stackage-nightly" <> metavar "DIR")
-
-main :: IO ()
-main = runPantryApp $ do
-  ((), runCmd) <- liftIO options
-  runCmd
-
-update :: RIO PantryApp ()
-update = do
-  void $ updateHackageIndex $ Just "Updating hackage index"
-
-constraints :: Target -> RIO PantryApp ()
-constraints target =
-  case target of
-    TargetLts x y | y > 0 -> do
-      let prev = y - 1
-          url = concat [ "https://raw.githubusercontent.com/" ++ constraintsRepo ++ "/master/lts/"
-                        , show x
-                        , "/"
-                        , show prev
-                        , ".yaml"
-                        ]
-      logInfo $ "Will reuse constraints.yaml from lts-" <> display x <> "." <> display prev
-      req <- parseUrlThrow url
-      constraintsPath <- resolveFile' constraintsFilename
-      exists <- doesFileExist constraintsPath
-      when exists $ do
-        logWarn "Local constraints file will be deleted before downloading reused constraints"
-        removeFile constraintsPath
-      downloaded <- download req constraintsPath
-      unless downloaded $
-        error $ "Could not download constraints.yaml from " <> url
-    _ -> do
-      buildConstraintsPath <- resolveFile' "build-constraints.yaml"
-      exists <- doesFileExist buildConstraintsPath
-      stackageConstraints <- if exists
-        then do
-          logInfo "Reusing already existing file build-constraints.yaml"
-          loadStackageConstraints $ toFilePath buildConstraintsPath
-        else do
-          logInfo $ "Downloading build-constraints from commercialhaskell/stackage"
-          req <- parseUrlThrow "https://raw.githubusercontent.com/commercialhaskell/stackage/master/build-constraints.yaml"
-          man <- liftIO $ newManager tlsManagerSettings
-          liftIO (httpLbs req man) >>=
-            loadStackageConstraintsBs . BL.toStrict . responseBody
-      logInfo "Writing constraints.yaml"
-      liftIO $ encodeFile constraintsFilename stackageConstraints
-
-snapshotIncomplete :: RIO PantryApp ()
-snapshotIncomplete = do
-  logInfo "Writing snapshot-incomplete.yaml"
-  decodeFileThrow constraintsFilename >>= \constraints' ->
-    makeSnapshot constraints' >>=
-    liftIO . encodeFile "snapshot-incomplete.yaml"
-
-snapshot :: RIO PantryApp ()
-snapshot = do
-  logInfo "Writing snapshot.yaml"
-  incomplete <- loadPantrySnapshotLayerFile "snapshot-incomplete.yaml"
-  complete <- completeSnapshotLayer incomplete
-  liftIO $ encodeFile snapshotFilename complete
-
-loadSnapshotYaml :: RIO PantryApp Pantry.Snapshot
-loadSnapshotYaml = do
-  abs' <- resolveFile' snapshotFilename
-  let sloc = SLFilePath $
-        ResolvedPath (RelFilePath (fromString snapshotFilename)) abs'
-  (snap, _, _) <- loadAndCompleteSnapshot sloc Map.empty Map.empty
-  pure snap
-
-checkSnapshot :: RIO PantryApp ()
-checkSnapshot = do
-  logInfo "Checking dependencies in snapshot.yaml"
-  decodeFileThrow constraintsFilename >>= \constraints' -> do
-    snapshot' <- loadSnapshotYaml
-    checkDependencyGraph constraints' snapshot'
-
-legacySnapshot :: RIO PantryApp ()
-legacySnapshot = do
-  logInfo "Generating legacy-style snapshot file in legacy-snapshot.yaml"
-  snapshot' <- loadSnapshotYaml
-  legacy <- toLegacySnapshot snapshot'
-  liftIO $ encodeFile "legacy-snapshot.yaml" legacy
-
-unpackDir :: FilePath
-unpackDir = "unpack-dir"
-
-unpackFiles :: RIO PantryApp ()
-unpackFiles = do
-  logInfo "Unpacking files"
-  snapshot' <- loadSnapshotYaml
-  constraints' <- decodeFileThrow constraintsFilename
-  dest <- resolveDir' unpackDir
-  unpackSnapshot constraints' snapshot' dest
-
-build :: Int -> RIO PantryApp ()
-build jobs = do
-  logInfo "Building"
-  withWorkingDir unpackDir $ proc
-    "stack"
-    (words $ "--terminal --system-ghc build --test --bench --test-suite-timeout=600 --no-rerun-tests --no-run-benchmarks --haddock --no-interleaved-output --jobs=" ++ show jobs)
-    runProcess_
-
-hackageDistro :: Target -> RIO PantryApp ()
-hackageDistro target = do
-  logInfo "Uploading Hackage distro for snapshot.yaml"
-  snapshot' <- loadSnapshotYaml
-  let packageVersions =
-        Map.mapMaybe (snapshotVersion . spLocation) (snapshotPackages snapshot')
-  uploadHackageDistro target packageVersions
-
-uploadDocs' :: Target -> RIO PantryApp ()
-uploadDocs' target = do
-  docsDir <- fmap (T.unpack . T.dropSuffix "\n" . decodeUtf8Lenient . BL.toStrict) $
-    withWorkingDir unpackDir $ proc "stack" (words "path --local-doc-root") readProcessStdout_
-  logInfo "Uploading docs to S3"
-  let prefix = utf8BuilderToText $
-        case target of
-          TargetNightly day ->
-            let date = formatTime defaultTimeLocale (iso8601DateFormat Nothing) day
-            in "nightly-" <> fromString date
-          TargetLts x y ->
-            "lts-" <> display x <> "." <> display y
-  uploadDocs docsDir prefix haddockBucket
-
-uploadGithub' :: Target -> RIO PantryApp ()
-uploadGithub' target = do
-  logInfo "Uploading snapshot definition to Github"
-  uploadGithub target
-
-loadPantrySnapshotLayerFile :: FilePath -> RIO PantryApp RawSnapshotLayer
-loadPantrySnapshotLayerFile fp = do
-  abs' <- resolveFile' fp
-  eres <- loadSnapshotLayer $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs')
-  case eres of
-    Left x -> error $ "should not happen: " ++ show (fp, x)
-    Right x -> pure x

subs/curator/package.yaml

-name:    curator
-version: 2.0.0.0
-
-ghc-options:
-- -optP-Wno-nonportable-include-path # workaround [Filename case on macOS · Issue #4739 · haskell/cabal](https://github.com/haskell/cabal/issues/4739)
-
-dependencies:
-- base >=4.10 && < 5
-- http-client
-- http-client-tls
-- pantry
-- path
-- path-io
-- rio
-- rio-prettyprint
-- yaml
-
-library:
-  source-dirs: src
-  exposed-modules:
-  - Curator
-  dependencies:
-  - Cabal
-  - amazonka
-  - amazonka-s3
-  - blaze-html
-  - bytestring
-  - conduit
-  - conduit-extra
-  - cryptonite
-  - cryptonite-conduit
-  - html-conduit
-  - memory
-  - mime-types
-  - mtl
-  - resourcet
-  - tar
-  - xml-conduit
-  - xml-types
-
-executables:
-  curator:
-    source-dirs: app
-    main: Main.hs
-    dependencies:
-    - curator
-    - http-download
-    - optparse-simple

subs/curator/src/Curator.hs

-module Curator
-  ( module Export
-  , Target(..)
-  ) where
-
-import Curator.Constants as Export
-import Curator.HackageDistro as Export
-import Curator.Legacy as Export
-import Curator.Repo as Export
-import Curator.StackageConstraints as Export
-import Curator.Snapshot as Export
-import Curator.Types (Target(..))
-import Curator.Unpack as Export
-import Curator.UploadDocs as Export
-import Pantry as Export
-import RIO as Export

subs/curator/src/Curator/Constants.hs

-module Curator.Constants
-    ( snapshotFilename
-    , constraintsFilename
-    , snapshotsRepo
-    , constraintsRepo
-    , haddockBucket
-    ) where
-
-import RIO (Text, fromString)
-
-snapshotFilename :: FilePath
-snapshotFilename = "snapshot.yaml" 
-
-constraintsFilename :: FilePath
-constraintsFilename = "constraints.yaml"
-
-snapshotsRepo :: String
-snapshotsRepo = "commercialhaskell/stackage-snapshots"
-
-constraintsRepo :: String
-constraintsRepo = "commercialhaskell/stackage-constraints"
-
-haddockBucket :: Text
-haddockBucket = fromString "haddock.stackage.org"

subs/curator/src/Curator/GithubPings.hs

-module Curator.GithubPings
-    ( getGithubPings
-    , applyGithubMapping
-    ) where
-
-import Curator.Types
-import Distribution.PackageDescription
-import RIO
-import RIO.List (stripPrefix)
-import qualified RIO.Map as Map
-import qualified RIO.Set as Set
-import qualified RIO.Text as T
-
-applyGithubMapping :: Constraints -> Set Text -> Set Text
-applyGithubMapping cons =
-    foldMap (\name -> fromMaybe (Set.singleton name) (Map.lookup name (consGithubUsers cons)))
-
--- | Determine accounts to be pinged on Github based on various metadata in the
--- package description.
-getGithubPings :: GenericPackageDescription -> Set Text
-getGithubPings gpd =
-        Set.fromList $
-        map T.pack $
-        goHomepage (homepage $ packageDescription gpd) ++
-        concatMap goRepo (sourceRepos $ packageDescription gpd)
-  where
-    goHomepage t = do
-        prefix <-
-            [ "http://github.com/"
-            , "https://github.com/"
-            , "git://github.com/"
-            , "git@github.com:"
-            ]
-        t' <- maybeToList $ stripPrefix prefix t
-        let t'' = takeWhile (/= '/') t'
-        guard $ not $ null t''
-        return t''
-
-    goRepo sr =
-        case (repoType sr, repoLocation sr) of
-            (Just Git, Just s) -> goHomepage s
-            _ -> []

subs/curator/src/Curator/HackageDistro.hs

-{-# LANGUAGE OverloadedStrings #-}
-module Curator.HackageDistro
-    ( uploadHackageDistro
-    ) where
-
-import Curator.Types
-import Data.ByteString.Builder (toLazyByteString)
-import Network.HTTP.Client
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Pantry
-import RIO
-import qualified RIO.List as L
-import qualified RIO.Map as Map
-import qualified RIO.Text as T
-
-uploadHackageDistro ::
-       (HasLogFunc env) => Target -> Map PackageName Version -> RIO env ()
-uploadHackageDistro target packages = do
-    man <- liftIO $ newManager tlsManagerSettings
-    ecreds <- tryIO $ readFileBinary "/hackage-creds"
-    case T.words $ decodeUtf8Lenient $ either (const mempty) id ecreds of
-        [username, password] -> do
-            logInfo $ "Uploading as Hackage distro: " <> display distroName
-            res2 <- liftIO $
-              uploadDistro distroName packages (encodeUtf8 username) (encodeUtf8 password) man
-            logInfo $ "Distro upload response: " <> displayShow res2
-        _ -> error "No Hackage creds found at /hackage-creds"
-  where
-    distroName :: Text
-    distroName =
-        case target of
-            TargetNightly _ -> "Stackage"
-            TargetLts _ _ -> "LTSHaskell"
-
-uploadDistro
-    :: Text -- ^ distro name
-    -> Map PackageName Version
-    -> ByteString -- ^ Hackage username
-    -> ByteString -- ^ Hackage password
-    -> Manager
-    -> IO (Response LByteString)
-uploadDistro name packages username password manager = do
-    req1 <- parseRequest $ concat
-        [ "https://hackage.haskell.org/distro/"
-        , T.unpack name
-        , "/packages.csv"
-        ]
-    let req2 = req1
-                { requestHeaders = [("Content-Type", "text/csv")]
-                , requestBody = RequestBodyLBS csv
-                , method = "PUT"
-                }
-    httpLbs (applyBasicAuth username password req2) manager
-  where
-    csv = toLazyByteString . getUtf8Builder
-        $ mconcat
-        $ L.intersperse "\n"
-        $ map go
-        $ Map.toList packages
-    go (name', version) =
-        "\"" <>
-        displayShow name' <>
-        "\",\"" <>
-        displayShow version <>
-        "\",\"https://www.stackage.org/package/" <>
-        displayShow name' <>
-        "\""

subs/curator/src/Curator/Legacy.hs

-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
--- | Legacy-style snapshot files
-module Curator.Legacy
-  ( LegacySnapshot
-  , toLegacySnapshot
-  , LegacyBulkArgs (..)
-  , legacyBulk
-  ) where
-
-import Conduit
-import RIO
-import RIO.Directory (doesFileExist)
-import RIO.FilePath (splitDirectories, splitExtension, (</>))
-import RIO.List (stripPrefix)
-import RIO.PrettyPrint (HasTerm)
-import RIO.Time (fromGregorian)
-import Pantry
-import Path.IO (resolveFile')
-import Curator.Types
-import Data.Yaml
-
-data LegacySnapshot = LegacySnapshot
-  { lsGhcVersion :: !Version
-  , lsCorePackages :: !(Map PackageName Version)
-  , lsPackages :: !(Map PackageName PackageInfo)
-  }
-
-data PackageInfo = PackageInfo
-  { piVersion :: !Version
-  , piCabalSha :: !SHA256
-  , piCabalSize :: !FileSize
-  , piFlags :: !(Map FlagName Bool)
-  , piHidden :: !Bool
-  }
-
-toLegacySnapshot
-  :: (HasPantryConfig env, HasTerm env)
-  => Snapshot
-  -> RIO env LegacySnapshot
-toLegacySnapshot Snapshot {..} = do
-  lsGhcVersion <-
-    case snapshotCompiler of
-      WCGhc v -> pure v
-      x -> error $ "Unexpected snapshotCompiler: " ++ show x
-  mglobalHints <- loadGlobalHints snapshotCompiler
-  lsCorePackages <-
-    case mglobalHints of
-      Nothing -> error $ "Could not load global hints for: " ++ show snapshotCompiler
-      Just x -> pure x
-  lsPackages <- traverse toPackageInfo snapshotPackages
-  pure LegacySnapshot {..}
-
-toPackageInfo
-  :: HasPantryConfig env
-  => SnapshotPackage
-  -> RIO env PackageInfo
-toPackageInfo (SnapshotPackage loc piFlags piHidden ghcOptions) = do
-  unless (null ghcOptions) $ error "ghc-options not supported"
-  (piVersion, BlobKey piCabalSha piCabalSize) <-
-    case loc of
-      PLIHackage (PackageIdentifier _name version) cabalFile _treekey ->
-        pure (version, cabalFile)
-      x -> error $ "Unsupported package location: " ++ show x
-  pure PackageInfo {..}
-
-instance ToJSON LegacySnapshot where
-  toJSON LegacySnapshot {..} = object
-    [ "system-info" .= object
-        [ "ghc-version" .= CabalString lsGhcVersion
-        , "core-packages" .= toCabalStringMap (CabalString <$> lsCorePackages)
-        ]
-    , "packages" .= toCabalStringMap lsPackages
-    ]
-
-instance ToJSON PackageInfo where
-  toJSON PackageInfo {..} = object
-    [ "version" .= CabalString piVersion
-    , "cabal-file-info" .= object
-        [ "size" .= piCabalSize
-        , "hashes" .= object
-            [ "SHA256" .= piCabalSha
-            ]
-        ]
-    , "constraints" .= object
-        [ "flags" .= toCabalStringMap piFlags
-        , "hidden" .= piHidden
-        ]
-    ]
-
-data LegacyBulkArgs = LegacyBulkArgs
-  { lbaSnapshots :: !FilePath
-  -- ^ Pantry snapshots dir
-  , lbaLts :: !FilePath
-  -- ^ Legacy LTS
-  , lbaNightly :: !FilePath
-  -- ^ Legacy nightly
-  }
-  deriving Show
-
-convert :: Convert -> RIO PantryApp ()
-convert Convert {..} = do
-  logInfo $ "Convert from " <> fromString convertFrom <> " to " <> fromString convertTo
-  abs' <- resolveFile' convertFrom
-  let sloc = SLFilePath $ ResolvedPath (RelFilePath (fromString convertFrom)) abs'
-  (snapshot, _, _) <- loadAndCompleteSnapshot sloc mempty mempty
-  legacy <- toLegacySnapshot snapshot
-  liftIO $ encodeFile convertTo legacy
-
-data Convert = Convert
-  { convertFrom :: !FilePath
-  , convertTo :: !FilePath
-  }
-  deriving Show
-
-legacyBulk :: LegacyBulkArgs -> RIO PantryApp ()
-legacyBulk LegacyBulkArgs {..} = do
-  logInfo "Bulk converting Pantry-based snapshots to legacy snapshots"
-  let toDest (TargetLts major minor) = lbaLts </> concat ["lts-", show major, ".", show minor, ".yaml"]
-      toDest (TargetNightly day) = lbaNightly </> concat ["nightly-", show day, ".yaml"]
-  runConduitRes $
-    sourceDirectoryDeep True lbaSnapshots .|
-    concatMapC (\fp -> Convert fp <$> (toDest <$> (stripDirPrefix lbaSnapshots fp >>= parseTarget))) .|
-    filterMC (fmap not . doesFileExist . convertTo) .|
-    mapM_C (lift . convert)
-
-stripDirPrefix :: FilePath -> FilePath -> Maybe [FilePath]
-stripDirPrefix prefix fp = stripPrefix (splitDirectories prefix) (splitDirectories fp)
-
-parseTarget :: [FilePath] -> Maybe Target
-parseTarget ["lts", major, minorYaml] = do
-  (minor, ".yaml") <- Just $ splitExtension minorYaml
-  TargetLts <$> readMaybe major <*> readMaybe minor
-parseTarget ["nightly", year, month, dayYaml] = do
-  (day, ".yaml") <- Just $ splitExtension dayYaml
-  TargetNightly <$> (fromGregorian
-    <$> readMaybe year
-    <*> readMaybe month
-    <*> readMaybe day)
-parseTarget _ = Nothing

subs/curator/src/Curator/Repo.hs

-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Curator.Repo
-    ( checkTargetAvailable
-    , uploadGithub
-    ) where
-
-import Conduit
-import Curator.Constants
-import Curator.Types
-import Path
-import Path.IO
-import RIO
-import RIO.Process
-import RIO.Time
-
--- | Check if the given target is already used in the Github repos
-checkTargetAvailable ::
-       ( HasLogFunc env
-       , HasProcessContext env
-       , MonadReader env m
-       , MonadIO m
-       , MonadThrow m
-       )
-    => Target
-    -> m ()
-checkTargetAvailable t = do
-    void $ checkoutConstraintsRepo t
-    void $ checkoutSnapshotsRepo t
-
--- | Upload snapshot definition to Github repository
-uploadGithub ::
-       (HasLogFunc env, HasProcessContext env)
-    => Target
-    -> RIO env ()
-uploadGithub target = do
-    upload checkoutConstraintsRepo constraintsFilename
-    upload checkoutSnapshotsRepo snapshotFilename
-  where
-    upload checkout srcFilename = do
-        (git, snapshotFile, snapshotName) <- checkout target
-
-        createDirIfMissing True $ parent snapshotFile
-        runConduitRes $ sourceFile srcFilename .| sinkFile (toFilePath snapshotFile)
-
-        void $ git ["add", toFilePath snapshotFile]
-        void $ git ["commit", "-m", "Checking in " ++ snapshotName]
-        void $ git ["push", "origin", "HEAD:master"]
-
-checkoutSnapshotsRepo ::
-       ( HasLogFunc env
-       , HasProcessContext env
-       , MonadReader env m
-       , MonadIO m
-       , MonadThrow m
-       )
-    => Target
-    -> m ([String] -> m (), Path Abs File, String)
-checkoutSnapshotsRepo t = checkoutRepo t dir url
-  where
-    url = "git@github.com:" ++ snapshotsRepo
-    dir = $(mkRelDir "stackage-snapshots")
-
-checkoutConstraintsRepo ::
-       ( HasLogFunc env
-       , HasProcessContext env
-       , MonadReader env m
-       , MonadIO m
-       , MonadThrow m
-       )
-    => Target
-    -> m ([String] -> m (), Path Abs File, String)
-checkoutConstraintsRepo t = checkoutRepo t dir url
-  where
-    url = "git@github.com:" ++ constraintsRepo
-    dir = $(mkRelDir "stackage-constraints")
-
-checkoutRepo ::
-       ( HasLogFunc env
-       , HasProcessContext env
-       , MonadReader env m
-       , MonadIO m
-       , MonadThrow m
-       )
-    => Target
-    -> Path Rel Dir
-    -> String
-    -> m ([String] -> m (), Path Abs File, String)
-checkoutRepo target dirName repoUrl = do
-    root <- fmap (</> $(mkRelDir "curator")) $ getAppUserDataDir "stackage"
-
-    let repoDir = root </> dirName
-
-        runIn wdir cmd args = do
-            let wdir' = toFilePath wdir
-            logInfo $ fromString wdir' <> ": " <> displayShow (cmd:args)
-            withWorkingDir wdir' $ proc cmd args runProcess_
-
-        git = runIn repoDir "git"
-
-    (relSnapshotPath, snapshotName) <- case target of
-        TargetNightly d -> do
-            let (year, month, day) = toGregorian d
-            year' <- parseRelDir (show year)
-            month' <- parseRelDir (show month)
-            day' <- parseRelFile (show day)
-            fname <- day' <.> "yaml"
-            pure ( $(mkRelDir "nightly") </> year' </> month' </> fname
-                 , "nightly-" <> show d
-                 )
-        TargetLts x y -> do
-            major <- parseRelDir (show x)
-            minor <- parseRelFile (show y)
-            fname <- minor <.> "yaml"
-            pure ( $(mkRelDir "lts") </> major </> fname
-                 , "lts-" <> show x <> "-" <> show y
-                 )
-
-    let destSnapshotFile = repoDir </> relSnapshotPath
-
-    exists <- doesDirExist repoDir
-    if exists
-        then do
-            git ["fetch"]
-            git ["checkout", "origin/master"]
-        else do
-            createDirIfMissing True $ parent repoDir
-            runIn $(mkRelDir ".") "git" ["clone", repoUrl, toFilePath repoDir]
-
-    whenM (liftIO $ doesFileExist destSnapshotFile)
-        $ error $ "File already exists: " ++ toFilePath destSnapshotFile
-
-    return (git, destSnapshotFile, snapshotName)