{-# 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           Conduit ( mapOutput, sinkList )
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.Prelude
import           Stack.Types.Config
import           System.Directory
                   ( createDirectoryIfMissing, removeFile, renameFile )
import           System.Environment ( lookupEnv )
import           System.FilePath ( (</>), takeFileName, takeDirectory )
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [UploadPrettyException] -> ShowS
$cshowList :: [UploadPrettyException] -> ShowS
show :: UploadPrettyException -> FilePath
$cshow :: UploadPrettyException -> FilePath
showsPrec :: Int -> UploadPrettyException -> ShowS
$cshowsPrec :: Int -> UploadPrettyException -> ShowS
Show, Typeable)

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

instance Exception UploadPrettyException

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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (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 => 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure Request
req0
      Right Request
req -> 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 :: 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
                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 (f :: * -> *) a. Applicative f => a -> f a
pure ()) (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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException UploadPrettyException
AuthenticationFailure
            Int
403 -> do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Error: [S-2804]"
                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
"Error: [S-4444]"
                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
                let resBody :: ConduitT () FilePath IO ()
resBody = forall (m :: * -> *) o1 o2 i r.
Monad m =>
(o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r
mapOutput forall a. Show a => a -> FilePath
show (forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res)
                [FilePath]
resBody' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitT () FilePath IO ()
resBody forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (Int -> [FilePath] -> FilePath -> UploadPrettyException
ArchiveUploadFailure Int
code [FilePath]
resBody' 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