{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | Provide ability to upload tarballs to Hackage.

module Stack.Upload
    ( -- * Upload

      upload
    , uploadBytes
    , uploadRevision
      -- * Credentials

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

    , maybeGetHackageKey
    ) where

import           Stack.Prelude
import           Data.Aeson                            (FromJSON (..),
                                                        ToJSON (..),
                                                        decode', toEncoding, fromEncoding,
                                                        object, 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,
                                                        withResponse,
                                                        httpNoBody,
                                                        getGlobalManager,
                                                        getResponseStatusCode,
                                                        getResponseBody,
                                                        setRequestHeader,
                                                        parseRequest,
                                                        formDataBody, partFileRequestBody,
                                                        partBS, partLBS,
                                                        applyDigestAuth,
                                                        displayDigestAuthException)
import           Stack.Options.UploadParser
import           Stack.Types.Config
import           System.Directory                      (createDirectoryIfMissing,
                                                        removeFile, renameFile)
import           System.Environment                    (lookupEnv)
import           System.FilePath                       ((</>), takeFileName, takeDirectory)
import           System.PosixCompat.Files              (setFileMode)


newtype HackageKey = HackageKey Text
    deriving (HackageKey -> HackageKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HackageKey -> HackageKey -> Bool
$c/= :: HackageKey -> HackageKey -> Bool
== :: HackageKey -> HackageKey -> Bool
$c== :: HackageKey -> HackageKey -> Bool
Eq, Int -> HackageKey -> ShowS
[HackageKey] -> ShowS
HackageKey -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [HackageKey] -> ShowS
$cshowList :: [HackageKey] -> ShowS
show :: HackageKey -> FilePath
$cshow :: HackageKey -> FilePath
showsPrec :: Int -> HackageKey -> ShowS
$cshowsPrec :: Int -> 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 -> FilePath
hcCredsFile :: !FilePath
    }
    deriving (HackageCreds -> HackageCreds -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HackageCreds -> HackageCreds -> Bool
$c/= :: HackageCreds -> HackageCreds -> Bool
== :: HackageCreds -> HackageCreds -> Bool
$c== :: HackageCreds -> HackageCreds -> Bool
Eq, Int -> HackageCreds -> ShowS
[HackageCreds] -> ShowS
HackageCreds -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [HackageCreds] -> ShowS
$cshowList :: [HackageCreds] -> ShowS
show :: HackageCreds -> FilePath
$cshow :: HackageCreds -> FilePath
showsPrec :: Int -> HackageCreds -> ShowS
$cshowsPrec :: Int -> HackageCreds -> ShowS
Show)

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

instance ToJSON HackageCreds where
    toJSON :: HackageCreds -> Value
toJSON (HackageCreds Text
u Text
p FilePath
_) = [Pair] -> Value
object
        [ Key
"username" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
u
        , Key
"password" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
p
        ]
instance FromJSON (FilePath -> HackageCreds) where
    parseJSON :: Value -> Parser (FilePath -> HackageCreds)
parseJSON = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"HackageCreds" forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> Text -> FilePath -> HackageCreds
HackageCreds
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"username"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o 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 = FilePath -> IO (Maybe FilePath)
lookupEnv (Text -> FilePath
T.unpack Text
varName) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
fromPrompt (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack)

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

loadAuth :: HasLogFunc m => Config -> RIO m HackageAuth
loadAuth :: forall m. HasLogFunc m => Config -> RIO m HackageAuth
loadAuth Config
config = do
  Maybe HackageKey
maybeHackageKey <- forall m. RIO m (Maybe HackageKey)
maybeGetHackageKey
  case Maybe HackageKey
maybeHackageKey of
    Just HackageKey
key -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"HACKAGE_KEY found in env, using that for credentials."
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HackageKey -> HackageAuth
HAKey HackageKey
key
    Maybe HackageKey
Nothing -> HackageCreds -> HackageAuth
HACreds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. HasLogFunc 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 :: HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword :: forall m. HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config = do
  FilePath
fp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> IO FilePath
credsFile Config
config
  Either IOException ByteString
elbs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
L.readFile FilePath
fp
  case forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either IOException ByteString
elbs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
lbs -> (ByteString
lbs, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => ByteString -> Maybe a
decode' ByteString
lbs of
    Maybe (ByteString, FilePath -> HackageCreds)
Nothing -> forall m. HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt FilePath
fp
    Just (ByteString
lbs, FilePath -> HackageCreds
mkCreds) -> do
      -- Ensure privacy, for cleaning up old versions of Stack that

      -- didn't do this

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

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configSaveHackageCreds Config
config) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"WARNING: You've set save-hackage-creds to false"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"However, credentials were found at:"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"  " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
fp
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> HackageCreds
mkCreds FilePath
fp
  where
    fromPrompt :: HasLogFunc m => FilePath -> RIO m HackageCreds
    fromPrompt :: forall m. HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt FilePath
fp = do
      Text
username <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO Text -> IO Text
withEnvVariable Text
"HACKAGE_USERNAME" (forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Hackage username: ")
      Text
password <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO Text -> IO Text
withEnvVariable Text
"HACKAGE_PASSWORD" (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 :: FilePath
hcCredsFile = FilePath
fp
            }

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configSaveHackageCreds Config
config) forall a b. (a -> b) -> a -> b
$ do
        Bool
shouldSave <- forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$
          FilePath
"Save hackage credentials to file at " forall a. [a] -> [a] -> [a]
++ FilePath
fp forall a. [a] -> [a] -> [a]
++ FilePath
" [y/n]? "
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldSave forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *). MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate FilePath
fp forall a b. (a -> b) -> a -> b
$ forall tag. Encoding' tag -> Builder
fromEncoding forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
toEncoding HackageCreds
hc
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Saved!"
          forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout

      forall (m :: * -> *) a. Monad m => a -> m a
return 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 => FilePath -> Builder -> m ()
writeFilePrivate FilePath
fp Builder
builder = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> FilePath -> (FilePath -> Handle -> m a) -> m a
withTempFile (ShowS
takeDirectory FilePath
fp) (ShowS
takeFileName FilePath
fp) forall a b. (a -> b) -> a -> b
$ \FilePath
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.

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

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

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

  -- And atomically move

  FilePath -> FilePath -> IO ()
renameFile FilePath
fpTmp FilePath
fp

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

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

applyAuth :: HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth :: forall m. HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
haAuth Request
req0 = do
    case HackageAuth
haAuth of
        HAKey HackageKey
key -> forall (m :: * -> *) a. Monad m => a -> m a
return (HackageKey -> Request -> Request
addAPIKey HackageKey
key Request
req0)
        HACreds HackageCreds
creds -> forall m. HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0

applyCreds :: HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds :: forall m. HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0 = do
  Manager
manager <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
getGlobalManager
  Either SomeException Request
ereq <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadThrow n) =>
ByteString -> ByteString -> Request -> Manager -> m (n Request)
applyDigestAuth
    (Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ HackageCreds -> Text
hcUsername HackageCreds
creds)
    (Text -> ByteString
encodeUtf8 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
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"WARNING: No HTTP digest prompt found, this will probably fail"
          case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
              Just DigestAuthException
e' -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ DigestAuthException -> FilePath
displayDigestAuthException DigestAuthException
e'
              Maybe DigestAuthException
Nothing -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException SomeException
e
          forall (m :: * -> *) a. Monad m => a -> m a
return Request
req0
      Right Request
req -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: HasLogFunc m
            => String -- ^ Hackage base URL

            -> HackageAuth
            -> String -- ^ tar file name

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

            -> RIO m ()
uploadBytes :: forall m.
HasLogFunc m =>
FilePath
-> HackageAuth
-> FilePath
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes FilePath
baseUrl HackageAuth
auth FilePath
tarName UploadVariant
uploadVariant ByteString
bytes = do
    let req1 :: Request
req1 = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Accept" [ByteString
"text/plain"]
               (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ FilePath
baseUrl
                          forall a. Semigroup a => a -> a -> a
<> FilePath
"packages/"
                          forall a. Semigroup a => a -> a -> a
<> case UploadVariant
uploadVariant of
                               UploadVariant
Publishing -> FilePath
""
                               UploadVariant
Candidate -> FilePath
"candidates/"
               )
        formData :: [PartM IO]
formData = [forall (m :: * -> *).
Applicative m =>
Text -> FilePath -> RequestBody -> PartM m
partFileRequestBody Text
"package" FilePath
tarName (ByteString -> RequestBody
RequestBodyLBS ByteString
bytes)]
    Request
req2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[PartM IO] -> Request -> m Request
formDataBody [PartM IO]
formData Request
req1
    Request
req3 <- forall m. HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req2
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Uploading " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
tarName forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"... "
    forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO m a -> IO a
runInIO -> forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req3 (forall a. RIO m a -> IO a
runInIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m.
HasLogFunc m =>
Response (ConduitM () ByteString IO ()) -> RIO m ()
inner)
 where
    inner :: HasLogFunc m => Response (ConduitM () S.ByteString IO ()) -> RIO m ()
    inner :: forall m.
HasLogFunc m =>
Response (ConduitM () ByteString IO ()) -> RIO m ()
inner Response (ConduitM () ByteString IO ())
res =
        case forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
            Int
200 -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"done!"
            Int
401 -> do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"authentication failure"
                case HackageAuth
auth of
                  HACreds HackageCreds
creds -> forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile (HackageCreds -> FilePath
hcCredsFile HackageCreds
creds))
                  HackageAuth
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Authentication failure uploading to server"
            Int
403 -> do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"forbidden upload"
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Usually means: you've already uploaded this package/version combination"
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Ignoring error and continuing, full message from Hackage below:\n"
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
            Int
503 -> do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"service unavailable"
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"This error some times gets sent even though the upload succeeded"
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Check on Hackage to see if your package is present"
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
            Int
code -> do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"unhandled status code: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString (forall a. Show a => a -> FilePath
show Int
code)
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
                forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall a b. (a -> b) -> a -> b
$ FilePath
"Upload failed on " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
tarName

printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
printBody :: Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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
       => String -- ^ Hackage base URL

       -> HackageAuth
       -> FilePath
       -> UploadVariant
       -> RIO m ()
upload :: forall m.
HasLogFunc m =>
FilePath -> HackageAuth -> FilePath -> UploadVariant -> RIO m ()
upload FilePath
baseUrl HackageAuth
auth FilePath
fp UploadVariant
uploadVariant =
  forall m.
HasLogFunc m =>
FilePath
-> HackageAuth
-> FilePath
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes FilePath
baseUrl HackageAuth
auth (ShowS
takeFileName FilePath
fp) UploadVariant
uploadVariant forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
L.readFile FilePath
fp)

uploadRevision :: HasLogFunc m
               => String -- ^ Hackage base URL

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