{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}

-- | Types and functions related to Stack's @upload@ command.

module Stack.Upload
  ( -- * Upload

    UploadOpts (..)
  , SDistOpts (..)
  , UploadContent (..)
  , UploadVariant (..)
  , uploadCmd
  , upload
  , uploadBytes
  , uploadRevision
    -- * Credentials

  , HackageCreds
  , HackageAuth (..)
  , HackageKey (..)
  , loadAuth
  , writeFilePrivate
    -- * Internal

  , maybeGetHackageKey
  ) where

import           Conduit ( mapOutput, sinkList )
import           Data.Aeson
                   ( FromJSON (..), ToJSON (..), (.:), (.=), decode'
                   , fromEncoding, object, toEncoding, withObject
                   )
import           Data.ByteString.Builder ( lazyByteString )
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T
import           Network.HTTP.StackClient
                   ( Request, RequestBody (RequestBodyLBS), Response
                   , applyDigestAuth, displayDigestAuthException, formDataBody
                   , getGlobalManager, getResponseBody, getResponseStatusCode
                   , httpNoBody, method, methodPost, methodPut, parseRequest
                   , partBS, partFileRequestBody, partLBS, setRequestHeader
                   , setRequestHeaders, withResponse
                   )
import           Path ( (</>), addExtension, parseRelFile )
import           Path.IO ( resolveDir', resolveFile' )
import qualified Path.IO as Path
import           Stack.Constants ( isStackUploadDisabled )
import           Stack.Constants.Config ( distDirFromDir )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SDist
                   ( SDistOpts (..), checkSDistTarball, checkSDistTarball'
                   , getSDistTarball, readLocalPackage
                   )
import           Stack.Types.Config ( Config (..), configL, stackRootL )
import           Stack.Types.EnvConfig ( HasEnvConfig )
import           Stack.Types.Package ( LocalPackage (..), packageIdentifier )
import           Stack.Types.PvpBounds (PvpBounds)
import           Stack.Types.Runner ( Runner )
import           System.Directory
                   ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
                   , removeFile, renameFile
                   )
import           System.Environment ( lookupEnv )
import qualified System.FilePath as FP
import           System.PosixCompat.Files ( setFileMode )

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Upload" module.

data UploadPrettyException
  = AuthenticationFailure
  | ArchiveUploadFailure Int [String] String
  deriving (Int -> UploadPrettyException -> ShowS
[UploadPrettyException] -> ShowS
UploadPrettyException -> [Char]
(Int -> UploadPrettyException -> ShowS)
-> (UploadPrettyException -> [Char])
-> ([UploadPrettyException] -> ShowS)
-> Show UploadPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UploadPrettyException -> ShowS
showsPrec :: Int -> UploadPrettyException -> ShowS
$cshow :: UploadPrettyException -> [Char]
show :: UploadPrettyException -> [Char]
$cshowList :: [UploadPrettyException] -> ShowS
showList :: [UploadPrettyException] -> ShowS
Show, Typeable)

instance Pretty UploadPrettyException where
  pretty :: UploadPrettyException -> StyleDoc
pretty UploadPrettyException
AuthenticationFailure =
       StyleDoc
"[S-2256]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"authentification failure"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"Authentication failure uploading to server"
  pretty (ArchiveUploadFailure Int
code [[Char]]
res [Char]
tarName) =
       StyleDoc
"[S-6108]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"unhandled status code:" StyleDoc -> StyleDoc -> StyleDoc
<+> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
code)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"Upload failed on" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
tarName)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
vsep (([Char] -> StyleDoc) -> [[Char]] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> StyleDoc
string [[Char]]
res)

instance Exception UploadPrettyException

-- | Type representing forms of content for upload to Hackage.

data UploadContent
  = SDist
  | DocArchive

-- | Type representing variants for uploading to Hackage.

data UploadVariant
  = Publishing
    -- ^ Publish the package/a published package.

  | Candidate
    -- ^ Create a package candidate/a package candidate.


-- | Type representing command line options for the @stack upload@ command.

data UploadOpts = UploadOpts
  { UploadOpts -> [[Char]]
uoItemsToWorkWith :: ![String]
  , UploadOpts -> Bool
uoDocumentation :: !Bool
  , UploadOpts -> Maybe PvpBounds
uoPvpBounds :: !(Maybe PvpBounds)
  , UploadOpts -> Bool
uoCheck :: !Bool
  , UploadOpts -> Bool
uoBuildPackage :: !Bool
  , UploadOpts -> Maybe [Char]
uoTarPath :: !(Maybe FilePath)
  , UploadOpts -> UploadVariant
uoUploadVariant :: !UploadVariant
  }

-- | Function underlying the @stack upload@ command. Upload to Hackage.

uploadCmd :: UploadOpts -> RIO Runner ()
uploadCmd :: UploadOpts -> RIO Runner ()
uploadCmd (UploadOpts [] Bool
uoDocumentation Maybe PvpBounds
_ Bool
_ Bool
_ Maybe [Char]
_ UploadVariant
_) = do
  let subject :: [Char]
subject = if Bool
uoDocumentation
        then [Char]
"documentation for the current package,"
        else [Char]
"the current package,"
  [StyleDoc] -> RIO Runner ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
    [ [Char] -> StyleDoc
flow [Char]
"An item must be specified. To upload"
    , [Char] -> StyleDoc
flow [Char]
subject
    , [Char] -> StyleDoc
flow [Char]
"please run"
    , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upload ."
    , [Char] -> StyleDoc
flow [Char]
"(with the period at the end)"
    ]
  IO () -> RIO Runner ()
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
uploadCmd (UploadOpts {Bool
[[Char]]
Maybe [Char]
Maybe PvpBounds
UploadVariant
uoItemsToWorkWith :: UploadOpts -> [[Char]]
uoDocumentation :: UploadOpts -> Bool
uoPvpBounds :: UploadOpts -> Maybe PvpBounds
uoCheck :: UploadOpts -> Bool
uoBuildPackage :: UploadOpts -> Bool
uoTarPath :: UploadOpts -> Maybe [Char]
uoUploadVariant :: UploadOpts -> UploadVariant
uoItemsToWorkWith :: [[Char]]
uoDocumentation :: Bool
uoPvpBounds :: Maybe PvpBounds
uoCheck :: Bool
uoBuildPackage :: Bool
uoTarPath :: Maybe [Char]
uoUploadVariant :: UploadVariant
..}) = ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ RIO EnvConfig () -> RIO Config ()
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
  Config
config <- Getting Config EnvConfig Config -> RIO EnvConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL
  let hackageUrl :: [Char]
hackageUrl = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Config -> Text
configHackageBaseUrl Config
config
  if Bool
uoDocumentation
    then do
      ([[Char]]
dirs, [[Char]]
invalid) <-
        IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]])
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]]))
-> IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ ([Char] -> IO Bool) -> [[Char]] -> IO ([[Char]], [[Char]])
forall {f :: * -> *} {a}.
Monad f =>
(a -> f Bool) -> [a] -> f ([a], [a])
partitionM [Char] -> IO Bool
doesDirectoryExist [[Char]]
uoItemsToWorkWith
      Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
invalid) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ do
        let invalidList :: StyleDoc
invalidList =
              [StyleDoc] -> StyleDoc
bulletedList ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ([Char] -> StyleDoc) -> [[Char]] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString) [[Char]]
invalid
        StyleDoc -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO EnvConfig ()) -> StyleDoc -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> StyleDoc
flow [Char]
"For documentation upload, Stack expects a list of relative \
               \paths to package directories. Stack can't find:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
invalidList
        RIO EnvConfig ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
      ([([Char], Path Abs File)]
failed, [([Char], Path Abs File)]
items) <- [Either ([Char], Path Abs File) ([Char], Path Abs File)]
-> ([([Char], Path Abs File)], [([Char], Path Abs File)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ([Char], Path Abs File) ([Char], Path Abs File)]
 -> ([([Char], Path Abs File)], [([Char], Path Abs File)]))
-> RIO
     EnvConfig [Either ([Char], Path Abs File) ([Char], Path Abs File)]
-> RIO
     EnvConfig ([([Char], Path Abs File)], [([Char], Path Abs File)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
-> ([Char]
    -> RIO
         EnvConfig (Either ([Char], Path Abs File) ([Char], Path Abs File)))
-> RIO
     EnvConfig [Either ([Char], Path Abs File) ([Char], Path Abs File)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
dirs [Char]
-> RIO
     EnvConfig (Either ([Char], Path Abs File) ([Char], Path Abs File))
forall env.
HasEnvConfig env =>
[Char]
-> RIO env (Either ([Char], Path Abs File) ([Char], Path Abs File))
checkDocsTarball
      Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([([Char], Path Abs File)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], Path Abs File)]
failed) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ do
        let invalidItem :: ([Char], a) -> StyleDoc
invalidItem ([Char]
pkgIdName, a
tarGzFile) = [StyleDoc] -> StyleDoc
fillSep
              [ a -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty a
tarGzFile
              , StyleDoc
"for"
              , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
pkgIdName) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
              ]
            invalidList :: StyleDoc
invalidList = [StyleDoc] -> StyleDoc
bulletedList ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ (([Char], Path Abs File) -> StyleDoc)
-> [([Char], Path Abs File)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Path Abs File) -> StyleDoc
forall {a}. Pretty a => ([Char], a) -> StyleDoc
invalidItem [([Char], Path Abs File)]
failed
        StyleDoc -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO EnvConfig ()) -> StyleDoc -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> StyleDoc
flow [Char]
"Stack can't find:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
invalidList
        RIO EnvConfig ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
      Memoized HackageAuth
getCreds <- RIO EnvConfig HackageAuth -> RIO EnvConfig (Memoized HackageAuth)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeRef (RIO EnvConfig HackageAuth -> RIO EnvConfig (Memoized HackageAuth))
-> RIO EnvConfig HackageAuth
-> RIO EnvConfig (Memoized HackageAuth)
forall a b. (a -> b) -> a -> b
$ Config -> RIO EnvConfig HackageAuth
forall m. (HasLogFunc m, HasTerm m) => Config -> RIO m HackageAuth
loadAuth Config
config
      [([Char], Path Abs File)]
-> (([Char], Path Abs File) -> RIO EnvConfig ())
-> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([Char], Path Abs File)]
items ((([Char], Path Abs File) -> RIO EnvConfig ()) -> RIO EnvConfig ())
-> (([Char], Path Abs File) -> RIO EnvConfig ())
-> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ \([Char]
pkgIdName, Path Abs File
tarGzFile) -> do
        HackageAuth
creds <- Memoized HackageAuth -> RIO EnvConfig HackageAuth
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized HackageAuth
getCreds
        [Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> RIO EnvConfig ()
forall m.
(HasLogFunc m, HasTerm m) =>
[Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> RIO m ()
upload
          [Char]
hackageUrl
          HackageAuth
creds
          UploadContent
DocArchive
          ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
pkgIdName)
          (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
tarGzFile)
          UploadVariant
uoUploadVariant
    else do
      ([[Char]]
files, [[Char]]
nonFiles) <- IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]])
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]]))
-> IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ ([Char] -> IO Bool) -> [[Char]] -> IO ([[Char]], [[Char]])
forall {f :: * -> *} {a}.
Monad f =>
(a -> f Bool) -> [a] -> f ([a], [a])
partitionM [Char] -> IO Bool
doesFileExist [[Char]]
uoItemsToWorkWith
      ([[Char]]
dirs, [[Char]]
invalid) <- IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]])
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]]))
-> IO ([[Char]], [[Char]]) -> RIO EnvConfig ([[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ ([Char] -> IO Bool) -> [[Char]] -> IO ([[Char]], [[Char]])
forall {f :: * -> *} {a}.
Monad f =>
(a -> f Bool) -> [a] -> f ([a], [a])
partitionM [Char] -> IO Bool
doesDirectoryExist [[Char]]
nonFiles
      Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
invalid) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ do
        let invalidList :: StyleDoc
invalidList = [StyleDoc] -> StyleDoc
bulletedList ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ([Char] -> StyleDoc) -> [[Char]] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString) [[Char]]
invalid
        StyleDoc -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO EnvConfig ()) -> StyleDoc -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$
             [Char] -> StyleDoc
flow [Char]
"For package upload, Stack expects a list of relative paths \
                  \to tosdist tarballs or package directories. Stack can't \
                  \find:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
invalidList
        RIO EnvConfig ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
      let sdistOpts :: SDistOpts
sdistOpts = [[Char]]
-> Maybe PvpBounds -> Bool -> Bool -> Maybe [Char] -> SDistOpts
SDistOpts
            [[Char]]
uoItemsToWorkWith
            Maybe PvpBounds
uoPvpBounds
            Bool
uoCheck
            Bool
uoBuildPackage
            Maybe [Char]
uoTarPath
      Memoized HackageAuth
getCreds <- RIO EnvConfig HackageAuth -> RIO EnvConfig (Memoized HackageAuth)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeRef (RIO EnvConfig HackageAuth -> RIO EnvConfig (Memoized HackageAuth))
-> RIO EnvConfig HackageAuth
-> RIO EnvConfig (Memoized HackageAuth)
forall a b. (a -> b) -> a -> b
$ Config -> RIO EnvConfig HackageAuth
forall m. (HasLogFunc m, HasTerm m) => Config -> RIO m HackageAuth
loadAuth Config
config
      ([Char] -> RIO EnvConfig ()) -> [[Char]] -> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs File)
resolveFile' ([Char] -> RIO EnvConfig (Path Abs File))
-> (Path Abs File -> RIO EnvConfig ())
-> [Char]
-> RIO EnvConfig ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> SDistOpts -> Path Abs File -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
sdistOpts) [[Char]]
files
      [[Char]] -> ([Char] -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files (([Char] -> RIO EnvConfig ()) -> RIO EnvConfig ())
-> ([Char] -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
        Path Abs File
tarFile <- [Char] -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs File)
resolveFile' [Char]
file
        HackageAuth
creds <- Memoized HackageAuth -> RIO EnvConfig HackageAuth
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized HackageAuth
getCreds
        [Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> RIO EnvConfig ()
forall m.
(HasLogFunc m, HasTerm m) =>
[Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> RIO m ()
upload
          [Char]
hackageUrl
          HackageAuth
creds
          UploadContent
SDist
          Maybe [Char]
forall a. Maybe a
Nothing
          (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
tarFile)
          UploadVariant
uoUploadVariant
      [[Char]] -> ([Char] -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
dirs (([Char] -> RIO EnvConfig ()) -> RIO EnvConfig ())
-> ([Char] -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
        Path Abs Dir
pkgDir <- [Char] -> RIO EnvConfig (Path Abs Dir)
forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs Dir)
resolveDir' [Char]
dir
        ([Char]
tarName, ByteString
tarBytes, Maybe (PackageIdentifier, ByteString)
mcabalRevision) <- Maybe PvpBounds
-> Path Abs Dir
-> RIO
     EnvConfig
     ([Char], ByteString, Maybe (PackageIdentifier, ByteString))
forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
     env ([Char], ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball Maybe PvpBounds
uoPvpBounds Path Abs Dir
pkgDir
        SDistOpts -> [Char] -> ByteString -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
SDistOpts -> [Char] -> ByteString -> RIO env ()
checkSDistTarball' SDistOpts
sdistOpts [Char]
tarName ByteString
tarBytes
        HackageAuth
creds <- Memoized HackageAuth -> RIO EnvConfig HackageAuth
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized HackageAuth
getCreds
        [Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> ByteString
-> RIO EnvConfig ()
forall m.
HasTerm m =>
[Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes
          [Char]
hackageUrl
          HackageAuth
creds
          UploadContent
SDist
          Maybe [Char]
forall a. Maybe a
Nothing
          [Char]
tarName
          UploadVariant
uoUploadVariant
          ByteString
tarBytes
        Maybe (PackageIdentifier, ByteString)
-> ((PackageIdentifier, ByteString) -> RIO EnvConfig ())
-> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (PackageIdentifier, ByteString)
mcabalRevision (((PackageIdentifier, ByteString) -> RIO EnvConfig ())
 -> RIO EnvConfig ())
-> ((PackageIdentifier, ByteString) -> RIO EnvConfig ())
-> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ (PackageIdentifier -> ByteString -> RIO EnvConfig ())
-> (PackageIdentifier, ByteString) -> RIO EnvConfig ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((PackageIdentifier -> ByteString -> RIO EnvConfig ())
 -> (PackageIdentifier, ByteString) -> RIO EnvConfig ())
-> (PackageIdentifier -> ByteString -> RIO EnvConfig ())
-> (PackageIdentifier, ByteString)
-> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ [Char]
-> HackageAuth
-> PackageIdentifier
-> ByteString
-> RIO EnvConfig ()
forall m.
(HasLogFunc m, HasTerm m) =>
[Char]
-> HackageAuth -> PackageIdentifier -> ByteString -> RIO m ()
uploadRevision [Char]
hackageUrl HackageAuth
creds
   where
    checkDocsTarball ::
         HasEnvConfig env
      => FilePath
      -> RIO env (Either (String, Path Abs File) (String, Path Abs File))
    checkDocsTarball :: forall env.
HasEnvConfig env =>
[Char]
-> RIO env (Either ([Char], Path Abs File) ([Char], Path Abs File))
checkDocsTarball [Char]
dir = do
      Path Abs Dir
pkgDir <- [Char] -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs Dir)
resolveDir' [Char]
dir
      Path Abs Dir
distDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
      LocalPackage
lp <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir
      let pkgId :: PackageIdentifier
pkgId = Package -> PackageIdentifier
packageIdentifier (LocalPackage -> Package
lpPackage LocalPackage
lp)
          pkgIdName :: [Char]
pkgIdName = PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
pkgId
          name :: [Char]
name = [Char]
pkgIdName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"-docs"
          tarGzFileName :: Path Rel File
tarGzFileName = Path Rel File -> Maybe (Path Rel File) -> Path Rel File
forall a. a -> Maybe a -> a
fromMaybe
            ([Char] -> Path Rel File
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible")
            ( do Path Rel File
nameRelFile <- [Char] -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
name
                 [Char] -> Path Rel File -> Maybe (Path Rel File)
forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
".gz" (Path Rel File -> Maybe (Path Rel File))
-> Maybe (Path Rel File) -> Maybe (Path Rel File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Path Rel File -> Maybe (Path Rel File)
forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
".tar" Path Rel File
nameRelFile
            )
          tarGzFile :: Path Abs File
tarGzFile = Path Abs Dir
distDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
Path.</> Path Rel File
tarGzFileName
      Bool
isFile <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
Path.doesFileExist Path Abs File
tarGzFile
      Either ([Char], Path Abs File) ([Char], Path Abs File)
-> RIO env (Either ([Char], Path Abs File) ([Char], Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ([Char], Path Abs File) ([Char], Path Abs File)
 -> RIO
      env (Either ([Char], Path Abs File) ([Char], Path Abs File)))
-> Either ([Char], Path Abs File) ([Char], Path Abs File)
-> RIO env (Either ([Char], Path Abs File) ([Char], Path Abs File))
forall a b. (a -> b) -> a -> b
$ (if Bool
isFile then ([Char], Path Abs File)
-> Either ([Char], Path Abs File) ([Char], Path Abs File)
forall a b. b -> Either a b
Right else ([Char], Path Abs File)
-> Either ([Char], Path Abs File) ([Char], Path Abs File)
forall a b. a -> Either a b
Left) ([Char]
pkgIdName, Path Abs File
tarGzFile)
    partitionM :: (a -> f Bool) -> [a] -> f ([a], [a])
partitionM a -> f Bool
_ [] = ([a], [a]) -> f ([a], [a])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
    partitionM a -> f Bool
f (a
x:[a]
xs) = do
      Bool
r <- a -> f Bool
f a
x
      ([a]
as, [a]
bs) <- (a -> f Bool) -> [a] -> f ([a], [a])
partitionM a -> f Bool
f [a]
xs
      ([a], [a]) -> f ([a], [a])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([a], [a]) -> f ([a], [a])) -> ([a], [a]) -> f ([a], [a])
forall a b. (a -> b) -> a -> b
$ if Bool
r then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as, [a]
bs) else ([a]
as, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs)

newtype HackageKey = HackageKey Text
  deriving (HackageKey -> HackageKey -> Bool
(HackageKey -> HackageKey -> Bool)
-> (HackageKey -> HackageKey -> Bool) -> Eq HackageKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HackageKey -> HackageKey -> Bool
== :: HackageKey -> HackageKey -> Bool
$c/= :: HackageKey -> HackageKey -> Bool
/= :: HackageKey -> HackageKey -> Bool
Eq, Int -> HackageKey -> ShowS
[HackageKey] -> ShowS
HackageKey -> [Char]
(Int -> HackageKey -> ShowS)
-> (HackageKey -> [Char])
-> ([HackageKey] -> ShowS)
-> Show HackageKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HackageKey -> ShowS
showsPrec :: Int -> HackageKey -> ShowS
$cshow :: HackageKey -> [Char]
show :: HackageKey -> [Char]
$cshowList :: [HackageKey] -> ShowS
showList :: [HackageKey] -> ShowS
Show)

-- | Username and password to log into Hackage.

--

-- Since 0.1.0.0

data HackageCreds = HackageCreds
  { HackageCreds -> Text
hcUsername :: !Text
  , HackageCreds -> Text
hcPassword :: !Text
  , HackageCreds -> [Char]
hcCredsFile :: !FilePath
  }
  deriving (HackageCreds -> HackageCreds -> Bool
(HackageCreds -> HackageCreds -> Bool)
-> (HackageCreds -> HackageCreds -> Bool) -> Eq HackageCreds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HackageCreds -> HackageCreds -> Bool
== :: HackageCreds -> HackageCreds -> Bool
$c/= :: HackageCreds -> HackageCreds -> Bool
/= :: HackageCreds -> HackageCreds -> Bool
Eq, Int -> HackageCreds -> ShowS
[HackageCreds] -> ShowS
HackageCreds -> [Char]
(Int -> HackageCreds -> ShowS)
-> (HackageCreds -> [Char])
-> ([HackageCreds] -> ShowS)
-> Show HackageCreds
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HackageCreds -> ShowS
showsPrec :: Int -> HackageCreds -> ShowS
$cshow :: HackageCreds -> [Char]
show :: HackageCreds -> [Char]
$cshowList :: [HackageCreds] -> ShowS
showList :: [HackageCreds] -> ShowS
Show)

data HackageAuth
  = HAKey HackageKey
  | HACreds HackageCreds
  deriving (HackageAuth -> HackageAuth -> Bool
(HackageAuth -> HackageAuth -> Bool)
-> (HackageAuth -> HackageAuth -> Bool) -> Eq HackageAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HackageAuth -> HackageAuth -> Bool
== :: HackageAuth -> HackageAuth -> Bool
$c/= :: HackageAuth -> HackageAuth -> Bool
/= :: HackageAuth -> HackageAuth -> Bool
Eq, Int -> HackageAuth -> ShowS
[HackageAuth] -> ShowS
HackageAuth -> [Char]
(Int -> HackageAuth -> ShowS)
-> (HackageAuth -> [Char])
-> ([HackageAuth] -> ShowS)
-> Show HackageAuth
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HackageAuth -> ShowS
showsPrec :: Int -> HackageAuth -> ShowS
$cshow :: HackageAuth -> [Char]
show :: HackageAuth -> [Char]
$cshowList :: [HackageAuth] -> ShowS
showList :: [HackageAuth] -> ShowS
Show)

instance ToJSON HackageCreds where
  toJSON :: HackageCreds -> Value
toJSON (HackageCreds Text
u Text
p [Char]
_) = [Pair] -> Value
object
    [ Key
"username" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
u
    , Key
"password" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
p
    ]

instance FromJSON (FilePath -> HackageCreds) where
  parseJSON :: Value -> Parser ([Char] -> HackageCreds)
parseJSON = [Char]
-> (Object -> Parser ([Char] -> HackageCreds))
-> Value
-> Parser ([Char] -> HackageCreds)
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"HackageCreds" ((Object -> Parser ([Char] -> HackageCreds))
 -> Value -> Parser ([Char] -> HackageCreds))
-> (Object -> Parser ([Char] -> HackageCreds))
-> Value
-> Parser ([Char] -> HackageCreds)
forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> Text -> [Char] -> HackageCreds
HackageCreds
    (Text -> Text -> [Char] -> HackageCreds)
-> Parser Text -> Parser (Text -> [Char] -> HackageCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"username"
    Parser (Text -> [Char] -> HackageCreds)
-> Parser Text -> Parser ([Char] -> HackageCreds)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"password"

withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable Text
varName IO Text
fromPrompt =
  [Char] -> IO (Maybe [Char])
lookupEnv (Text -> [Char]
T.unpack Text
varName) IO (Maybe [Char]) -> (Maybe [Char] -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Text -> ([Char] -> IO Text) -> Maybe [Char] -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
fromPrompt (Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> ([Char] -> Text) -> [Char] -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack)

maybeGetHackageKey :: RIO m (Maybe HackageKey)
maybeGetHackageKey :: forall m. RIO m (Maybe HackageKey)
maybeGetHackageKey =
  IO (Maybe HackageKey) -> RIO m (Maybe HackageKey)
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe HackageKey) -> RIO m (Maybe HackageKey))
-> IO (Maybe HackageKey) -> RIO m (Maybe HackageKey)
forall a b. (a -> b) -> a -> b
$ ([Char] -> HackageKey) -> Maybe [Char] -> Maybe HackageKey
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> HackageKey
HackageKey (Text -> HackageKey) -> ([Char] -> Text) -> [Char] -> HackageKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) (Maybe [Char] -> Maybe HackageKey)
-> IO (Maybe [Char]) -> IO (Maybe HackageKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HACKAGE_KEY"

loadAuth :: (HasLogFunc m, HasTerm m) => Config -> RIO m HackageAuth
loadAuth :: forall m. (HasLogFunc m, HasTerm m) => Config -> RIO m HackageAuth
loadAuth Config
config = do
  Maybe HackageKey
maybeHackageKey <- RIO m (Maybe HackageKey)
forall m. RIO m (Maybe HackageKey)
maybeGetHackageKey
  case Maybe HackageKey
maybeHackageKey of
    Just HackageKey
key -> do
      [Char] -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyInfoS
        [Char]
"HACKAGE_KEY environment variable found, using that for credentials."
      HackageAuth -> RIO m HackageAuth
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageAuth -> RIO m HackageAuth)
-> HackageAuth -> RIO m HackageAuth
forall a b. (a -> b) -> a -> b
$ HackageKey -> HackageAuth
HAKey HackageKey
key
    Maybe HackageKey
Nothing -> HackageCreds -> HackageAuth
HACreds (HackageCreds -> HackageAuth)
-> RIO m HackageCreds -> RIO m HackageAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> RIO m HackageCreds
forall m. HasTerm m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config

-- | Load Hackage credentials, either from a save file or the command

-- line.

--

-- Since 0.1.0.0

loadUserAndPassword :: HasTerm m => Config -> RIO m HackageCreds
loadUserAndPassword :: forall m. HasTerm m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config = do
  [Char]
fp <- IO [Char] -> RIO m [Char]
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> RIO m [Char]) -> IO [Char] -> RIO m [Char]
forall a b. (a -> b) -> a -> b
$ Config -> IO [Char]
credsFile Config
config
  Either IOException ByteString
elbs <- IO (Either IOException ByteString)
-> RIO m (Either IOException ByteString)
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ByteString)
 -> RIO m (Either IOException ByteString))
-> IO (Either IOException ByteString)
-> RIO m (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO (Either IOException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
L.readFile [Char]
fp
  case (IOException -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either IOException ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> IOException -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just Either IOException ByteString
elbs Maybe ByteString
-> (ByteString -> Maybe (ByteString, [Char] -> HackageCreds))
-> Maybe (ByteString, [Char] -> HackageCreds)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
lbs -> (ByteString
lbs, ) (([Char] -> HackageCreds) -> (ByteString, [Char] -> HackageCreds))
-> Maybe ([Char] -> HackageCreds)
-> Maybe (ByteString, [Char] -> HackageCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe ([Char] -> HackageCreds)
forall a. FromJSON a => ByteString -> Maybe a
decode' ByteString
lbs of
    Maybe (ByteString, [Char] -> HackageCreds)
Nothing -> [Char] -> RIO m HackageCreds
forall m. HasTerm m => [Char] -> RIO m HackageCreds
fromPrompt [Char]
fp
    Just (ByteString
lbs, [Char] -> HackageCreds
mkCreds) -> do
      -- Ensure privacy, for cleaning up old versions of Stack that

      -- didn't do this

      [Char] -> Builder -> RIO m ()
forall (m :: * -> *). MonadIO m => [Char] -> Builder -> m ()
writeFilePrivate [Char]
fp (Builder -> RIO m ()) -> Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
lbs

      Bool -> RIO m () -> RIO m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configSaveHackageCreds Config
config) (RIO m () -> RIO m ()) -> RIO m () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ do
        [StyleDoc] -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ [Char] -> StyleDoc
flow [Char]
"You've set save-hackage-creds to false. However, credentials \
                 \ were found at:"
          , Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
fp) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      HackageCreds -> RIO m HackageCreds
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageCreds -> RIO m HackageCreds)
-> HackageCreds -> RIO m HackageCreds
forall a b. (a -> b) -> a -> b
$ [Char] -> HackageCreds
mkCreds [Char]
fp
 where
  fromPrompt :: HasTerm m => FilePath -> RIO m HackageCreds
  fromPrompt :: forall m. HasTerm m => [Char] -> RIO m HackageCreds
fromPrompt [Char]
fp = do
    Text
username <- IO Text -> RIO m Text
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> RIO m Text) -> IO Text -> RIO m Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text -> IO Text
withEnvVariable Text
"HACKAGE_USERNAME" (Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Hackage username: ")
    Text
password <- IO Text -> RIO m Text
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> RIO m Text) -> IO Text -> RIO m Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text -> IO Text
withEnvVariable Text
"HACKAGE_PASSWORD" (Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
promptPassword Text
"Hackage password: ")
    let hc :: HackageCreds
hc = HackageCreds
          { hcUsername :: Text
hcUsername = Text
username
          , hcPassword :: Text
hcPassword = Text
password
          , hcCredsFile :: [Char]
hcCredsFile = [Char]
fp
          }

    Bool -> RIO m () -> RIO m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configSaveHackageCreds Config
config) (RIO m () -> RIO m ()) -> RIO m () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
shouldSave <- Text -> RIO m Bool
forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool (Text -> RIO m Bool) -> Text -> RIO m Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
        [Char]
"Save Hackage credentials to file at " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
fp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" [y/n]? "
      [StyleDoc] -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyNoteL
        [ [Char] -> StyleDoc
flow [Char]
"Avoid this prompt in the future by using the configuration \
               \file option"
        , Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
flow [Char]
"save-hackage-creds: false") StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      Bool -> RIO m () -> RIO m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldSave (RIO m () -> RIO m ()) -> RIO m () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> Builder -> RIO m ()
forall (m :: * -> *). MonadIO m => [Char] -> Builder -> m ()
writeFilePrivate [Char]
fp (Builder -> RIO m ()) -> Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Encoding -> Builder
forall tag. Encoding' tag -> Builder
fromEncoding (Encoding -> Builder) -> Encoding -> Builder
forall a b. (a -> b) -> a -> b
$ HackageCreds -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding HackageCreds
hc
        [Char] -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyInfoS [Char]
"Saved!"
        Handle -> RIO m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout

    HackageCreds -> RIO m HackageCreds
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageCreds
hc

-- | Write contents to a file which is always private.

--

-- For history of this function, see:

--

-- * https://github.com/commercialhaskell/stack/issues/2159#issuecomment-477948928

--

-- * https://github.com/commercialhaskell/stack/pull/4665

writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate :: forall (m :: * -> *). MonadIO m => [Char] -> Builder -> m ()
writeFilePrivate [Char]
fp Builder
builder =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> ([Char] -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFile (ShowS
FP.takeDirectory [Char]
fp) (ShowS
FP.takeFileName [Char]
fp) (([Char] -> Handle -> IO ()) -> IO ())
-> ([Char] -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
fpTmp Handle
h -> do
    -- Temp file is created such that only current user can read and write it.

    -- See docs for openTempFile:

    -- https://www.stackage.org/haddock/lts-13.14/base-4.12.0.0/System-IO.html#v:openTempFile


    -- Write to the file and close the handle.

    Handle -> Builder -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
h Builder
builder
    Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h

    -- Make sure the destination file, if present, is writeable

    IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ [Char] -> FileMode -> IO ()
setFileMode [Char]
fp FileMode
0o600

    -- And atomically move

    [Char] -> [Char] -> IO ()
renameFile [Char]
fpTmp [Char]
fp

credsFile :: Config -> IO FilePath
credsFile :: Config -> IO [Char]
credsFile Config
config = do
  let dir :: [Char]
dir = Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' Config (Path Abs Dir)
stackRootL Config
config) [Char] -> ShowS
FP.</> [Char]
"upload"
  Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
  [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> ShowS
FP.</> [Char]
"credentials.json"

addAPIKey :: HackageKey -> Request -> Request
addAPIKey :: HackageKey -> Request -> Request
addAPIKey (HackageKey Text
key) = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader
  HeaderName
"Authorization"
  [[Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"X-ApiKey" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key]

applyAuth ::
     (HasLogFunc m, HasTerm m)
  => HackageAuth
  -> Request
  -> RIO m Request
applyAuth :: forall m.
(HasLogFunc m, HasTerm m) =>
HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
haAuth Request
req0 =
  case HackageAuth
haAuth of
    HAKey HackageKey
key -> Request -> RIO m Request
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageKey -> Request -> Request
addAPIKey HackageKey
key Request
req0)
    HACreds HackageCreds
creds -> HackageCreds -> Request -> RIO m Request
forall m.
(HasLogFunc m, HasTerm m) =>
HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0

applyCreds ::
     (HasLogFunc m, HasTerm m)
  => HackageCreds
  -> Request
  -> RIO m Request
applyCreds :: forall m.
(HasLogFunc m, HasTerm m) =>
HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0 = do
  Manager
manager <- IO Manager -> RIO m Manager
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
getGlobalManager
  Either SomeException Request
ereq <- if Bool
isStackUploadDisabled
    then do
      [Char] -> Request -> RIO m ()
forall env. HasTerm env => [Char] -> Request -> RIO env ()
debugRequest [Char]
"applyCreds" Request
req0
      Either SomeException Request
-> RIO m (Either SomeException Request)
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeException -> Either SomeException Request
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Request)
-> SomeException -> Either SomeException Request
forall a b. (a -> b) -> a -> b
$ ExitCode -> SomeException
forall e. Exception e => e -> SomeException
toException ExitCode
ExitSuccess )
    else
      IO (Either SomeException Request)
-> RIO m (Either SomeException Request)
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException Request)
 -> RIO m (Either SomeException Request))
-> IO (Either SomeException Request)
-> RIO m (Either SomeException Request)
forall a b. (a -> b) -> a -> b
$ ByteString
-> ByteString
-> Request
-> Manager
-> IO (Either SomeException Request)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadThrow n) =>
ByteString -> ByteString -> Request -> Manager -> m (n Request)
applyDigestAuth
        (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ HackageCreds -> Text
hcUsername HackageCreds
creds)
        (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ HackageCreds -> Text
hcPassword HackageCreds
creds)
        Request
req0
        Manager
manager
  case Either SomeException Request
ereq of
    Left SomeException
e -> do
      StyleDoc -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO m ()) -> StyleDoc -> RIO m ()
forall a b. (a -> b) -> a -> b
$
           [Char] -> StyleDoc
flow [Char]
"No HTTP digest prompt found, this will probably fail."
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string
             ( case SomeException -> Maybe DigestAuthException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                 Just DigestAuthException
e' -> DigestAuthException -> [Char]
displayDigestAuthException DigestAuthException
e'
                 Maybe DigestAuthException
Nothing -> SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e
             )
      Request -> RIO m Request
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req0
    Right Request
req -> Request -> RIO m Request
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req

-- | Upload a single tarball with the given @Uploader@. Instead of sending a

-- file like 'upload', this sends a lazy bytestring.

--

-- Since 0.1.2.1

uploadBytes ::
     HasTerm m
  => String -- ^ Hackage base URL

  -> HackageAuth
  -> UploadContent
     -- ^ Form of the content to be uploaded.

  -> Maybe String
     -- ^ Optional package identifier name, applies only to the upload of

     -- documentation.

  -> String -- ^ tar file name

  -> UploadVariant
  -> L.ByteString -- ^ tar file contents

  -> RIO m ()
uploadBytes :: forall m.
HasTerm m =>
[Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes [Char]
baseUrl HackageAuth
auth UploadContent
contentForm Maybe [Char]
mPkgIdName [Char]
tarName UploadVariant
uploadVariant ByteString
bytes = do
  ([Char]
url, [(HeaderName, ByteString)]
headers, ByteString
uploadMethod) <- case UploadContent
contentForm of
    UploadContent
SDist -> do
      Bool -> RIO m () -> RIO m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [Char]
mPkgIdName) (RIO m () -> RIO m ()) -> RIO m () -> RIO m ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> RIO m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"uploadBytes: package identified specified"
      let variant :: [Char]
variant = case UploadVariant
uploadVariant of
            UploadVariant
Publishing -> [Char]
""
            UploadVariant
Candidate -> [Char]
"candidates/"
      ([Char], [(HeaderName, ByteString)], ByteString)
-> RIO m ([Char], [(HeaderName, ByteString)], ByteString)
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [Char]
baseUrl [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"packages/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
variant
        , [(HeaderName
"Accept", ByteString
"text/plain")]
        , ByteString
methodPost
        )
    UploadContent
DocArchive -> case Maybe [Char]
mPkgIdName of
      Maybe [Char]
Nothing -> [Char] -> RIO m ([Char], [(HeaderName, ByteString)], ByteString)
forall a. HasCallStack => [Char] -> a
error [Char]
"uploadBytes: package identified not specified"
      Just [Char]
pkgIdName -> do
        let variant :: [Char]
variant = case UploadVariant
uploadVariant of
              UploadVariant
Publishing -> [Char]
""
              UploadVariant
Candidate -> [Char]
"candidate/"
        ([Char], [(HeaderName, ByteString)], ByteString)
-> RIO m ([Char], [(HeaderName, ByteString)], ByteString)
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( [Char]
baseUrl [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"package/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
pkgIdName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
variant [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"docs"
          , [ (HeaderName
"Accept", ByteString
"application/x-tar")
            , (HeaderName
"Accept-Encoding", ByteString
"gzip")
            ]
          , ByteString
methodPut
          )
  let req1 :: Request
req1 = [(HeaderName, ByteString)] -> Request -> Request
setRequestHeaders [(HeaderName, ByteString)]
headers ([Char] -> Request
forall a. IsString a => [Char] -> a
fromString [Char]
url)
      formData :: [PartM IO]
formData = [Text -> [Char] -> RequestBody -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> [Char] -> RequestBody -> PartM m
partFileRequestBody Text
"package" [Char]
tarName (ByteString -> RequestBody
RequestBodyLBS ByteString
bytes)]
  Request
req2 <- IO Request -> RIO m Request
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> RIO m Request) -> IO Request -> RIO m Request
forall a b. (a -> b) -> a -> b
$ [PartM IO] -> Request -> IO Request
forall (m :: * -> *).
MonadIO m =>
[PartM IO] -> Request -> m Request
formDataBody [PartM IO]
formData Request
req1
  let req3 :: Request
req3 = Request
req2 { method :: ByteString
method = ByteString
uploadMethod }
  Request
req4 <- HackageAuth -> Request -> RIO m Request
forall m.
(HasLogFunc m, HasTerm m) =>
HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req3
  [StyleDoc] -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ StyleDoc
"Uploading"
    , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
tarName) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"..."
    ]
  Handle -> RIO m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  if Bool
isStackUploadDisabled
    then
      [Char] -> Request -> RIO m ()
forall env. HasTerm env => [Char] -> Request -> RIO env ()
debugRequest [Char]
"uploadBytes" Request
req4
    else
      ((forall a. RIO m a -> IO a) -> IO ()) -> RIO m ()
forall b. ((forall a. RIO m a -> IO a) -> IO b) -> RIO m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. RIO m a -> IO a) -> IO ()) -> RIO m ())
-> ((forall a. RIO m a -> IO a) -> IO ()) -> RIO m ()
forall a b. (a -> b) -> a -> b
$ \forall a. RIO m a -> IO a
runInIO -> Request
-> (Response (ConduitM () ByteString IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req4 (RIO m () -> IO ()
forall a. RIO m a -> IO a
runInIO (RIO m () -> IO ())
-> (Response (ConduitM () ByteString IO ()) -> RIO m ())
-> Response (ConduitM () ByteString IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response (ConduitM () ByteString IO ()) -> RIO m ()
forall m.
HasTerm m =>
Response (ConduitM () ByteString IO ()) -> RIO m ()
inner)
 where
  inner :: HasTerm m => Response (ConduitM () S.ByteString IO ()) -> RIO m ()
  inner :: forall m.
HasTerm m =>
Response (ConduitM () ByteString IO ()) -> RIO m ()
inner Response (ConduitM () ByteString IO ())
res =
    case Response (ConduitM () ByteString IO ()) -> Int
forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
      Int
200 -> [Char] -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyInfoS [Char]
"done!"
      Int
401 -> do
        case HackageAuth
auth of
          HACreds HackageCreds
creds ->
            (IOException -> RIO m ()) -> RIO m () -> RIO m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO
              (RIO m () -> IOException -> RIO m ()
forall a b. a -> b -> a
const (RIO m () -> IOException -> RIO m ())
-> RIO m () -> IOException -> RIO m ()
forall a b. (a -> b) -> a -> b
$ () -> RIO m ()
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (IO () -> RIO m ()
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO m ()) -> IO () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFile (HackageCreds -> [Char]
hcCredsFile HackageCreds
creds))
          HackageAuth
_ -> () -> RIO m ()
forall a. a -> RIO m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        UploadPrettyException -> RIO m ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UploadPrettyException
AuthenticationFailure
      Int
403 -> do
        StyleDoc -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO m ()) -> StyleDoc -> RIO m ()
forall a b. (a -> b) -> a -> b
$
          StyleDoc
"[S-2804]"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"forbidden upload"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"Usually means: you've already uploaded this package/version \
                  \combination. Ignoring error and continuing. The full \
                  \message from Hackage is below:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        IO () -> RIO m ()
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO m ()) -> IO () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
      Int
503 -> do
        StyleDoc -> RIO m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO m ()) -> StyleDoc -> RIO m ()
forall a b. (a -> b) -> a -> b
$
          StyleDoc
"[S-4444]"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"service unavailable"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"This error some times gets sent even though the upload \
                  \succeeded. Check on Hackage to see if your package is \
                  \present. The full message form Hackage is below:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        IO () -> RIO m ()
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO m ()) -> IO () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
      Int
code -> do
        let resBody :: ConduitT () [Char] IO ()
resBody = (ByteString -> [Char])
-> ConduitM () ByteString IO () -> ConduitT () [Char] IO ()
forall (m :: * -> *) o1 o2 i r.
Monad m =>
(o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r
mapOutput ByteString -> [Char]
forall a. Show a => a -> [Char]
show (Response (ConduitM () ByteString IO ())
-> ConduitM () ByteString IO ()
forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res)
        [[Char]]
resBody' <- IO [[Char]] -> RIO m [[Char]]
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> RIO m [[Char]]) -> IO [[Char]] -> RIO m [[Char]]
forall a b. (a -> b) -> a -> b
$ ConduitT () Void IO [[Char]] -> IO [[Char]]
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO [[Char]] -> IO [[Char]])
-> ConduitT () Void IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ ConduitT () [Char] IO ()
resBody ConduitT () [Char] IO ()
-> ConduitT [Char] Void IO [[Char]] -> ConduitT () Void IO [[Char]]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT [Char] Void IO [[Char]]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
        UploadPrettyException -> RIO m ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (Int -> [[Char]] -> [Char] -> UploadPrettyException
ArchiveUploadFailure Int
code [[Char]]
resBody' [Char]
tarName)

printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
printBody :: Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res = ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ())
-> ConduitM () ByteString IO ()
forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res ConduitM () ByteString IO ()
-> ConduitT ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Handle -> ConduitT ByteString Void IO ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
CB.sinkHandle Handle
stdout

-- | Upload a single tarball with the given @Uploader@.

--

-- Since 0.1.0.0

upload ::
     (HasLogFunc m, HasTerm m)
  => String -- ^ Hackage base URL

  -> HackageAuth
  -> UploadContent
  -> Maybe String
     -- ^ Optional package identifier name, applies only to the upload of

     -- documentation.

  -> FilePath
     -- ^ Path to archive file.

  -> UploadVariant
  -> RIO m ()
upload :: forall m.
(HasLogFunc m, HasTerm m) =>
[Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> RIO m ()
upload [Char]
baseUrl HackageAuth
auth UploadContent
contentForm Maybe [Char]
mPkgIdName [Char]
fp UploadVariant
uploadVariant =
  [Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> ByteString
-> RIO m ()
forall m.
HasTerm m =>
[Char]
-> HackageAuth
-> UploadContent
-> Maybe [Char]
-> [Char]
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes
    [Char]
baseUrl HackageAuth
auth UploadContent
contentForm Maybe [Char]
mPkgIdName (ShowS
FP.takeFileName [Char]
fp) UploadVariant
uploadVariant
      (ByteString -> RIO m ()) -> RIO m ByteString -> RIO m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> RIO m ByteString
forall a. IO a -> RIO m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ByteString
L.readFile [Char]
fp)

uploadRevision ::
     (HasLogFunc m, HasTerm m)
  => String -- ^ Hackage base URL

  -> HackageAuth
  -> PackageIdentifier
  -> L.ByteString
  -> RIO m ()
uploadRevision :: forall m.
(HasLogFunc m, HasTerm m) =>
[Char]
-> HackageAuth -> PackageIdentifier -> ByteString -> RIO m ()
uploadRevision [Char]
baseUrl HackageAuth
auth ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) ByteString
cabalFile = do
  Request
req0 <- [Char] -> RIO m Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest ([Char] -> RIO m Request) -> [Char] -> RIO m Request
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
baseUrl
    , [Char]
"package/"
    , PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident
    , [Char]
"/"
    , PackageName -> [Char]
packageNameString PackageName
name
    , [Char]
".cabal/edit"
    ]
  Request
req1 <- [PartM IO] -> Request -> RIO m Request
forall (m :: * -> *).
MonadIO m =>
[PartM IO] -> Request -> m Request
formDataBody
    [ Text -> ByteString -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
partLBS Text
"cabalfile" ByteString
cabalFile
    , Text -> ByteString -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
partBS Text
"publish" ByteString
"on"
    ]
    Request
req0
  Request
req2 <- HackageAuth -> Request -> RIO m Request
forall m.
(HasLogFunc m, HasTerm m) =>
HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req1
  if Bool
isStackUploadDisabled
    then
      [Char] -> Request -> RIO m ()
forall env. HasTerm env => [Char] -> Request -> RIO env ()
debugRequest [Char]
"uploadRevision" Request
req2
    else
      RIO m (Response ()) -> RIO m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO m (Response ()) -> RIO m ())
-> RIO m (Response ()) -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Request -> RIO m (Response ())
forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody Request
req2

debugRequest :: HasTerm env => String -> Request -> RIO env ()
debugRequest :: forall env. HasTerm env => [Char] -> Request -> RIO env ()
debugRequest [Char]
callSite Request
req = StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
     [StyleDoc] -> StyleDoc
fillSep
       [ [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
callSite StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
       , [Char] -> StyleDoc
flow [Char]
"When enabled, would apply the following request:"
       ]
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Request -> [Char]
forall a. Show a => a -> [Char]
show Request
req)