{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Upload
(
UploadOpts (..)
, UploadVariant (..)
, uploadCmd
, upload
, uploadBytes
, uploadRevision
, HackageCreds
, HackageAuth (..)
, HackageKey (..)
, loadAuth
, writeFilePrivate
, 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, parseRequest, partBS, partFileRequestBody
, partLBS, setRequestHeader, withResponse
)
import Path.IO ( resolveDir', resolveFile' )
import Stack.Prelude
import Stack.Runners
( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import Stack.SDist
( SDistOpts (..), checkSDistTarball, checkSDistTarball'
, getSDistTarball
)
import Stack.Types.Config ( Config (..), configL, stackRootL )
import Stack.Types.Runner ( Runner )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, removeFile, renameFile
)
import System.Environment ( lookupEnv )
import System.FilePath ( (</>), takeDirectory, takeFileName )
import System.PosixCompat.Files ( setFileMode )
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
data UploadVariant
= Publishing
| Candidate
data UploadOpts = UploadOpts
{ UploadOpts -> SDistOpts
uoptsSDistOpts :: SDistOpts
, UploadOpts -> UploadVariant
uoptsUploadVariant :: UploadVariant
}
uploadCmd :: UploadOpts -> RIO Runner ()
uploadCmd :: UploadOpts -> RIO Runner ()
uploadCmd (UploadOpts (SDistOpts [] Maybe PvpBounds
_ Bool
_ Bool
_ Maybe FilePath
_) UploadVariant
_) = do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
[ FilePath -> StyleDoc
flow FilePath
"To upload the current package, please run"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upload ."
, FilePath -> StyleDoc
flow FilePath
"(with the period at the end)"
]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *) a. MonadIO m => m a
exitFailure
uploadCmd UploadOpts
uploadOpts = do
let partitionM :: (a -> f Bool) -> [a] -> f ([a], [a])
partitionM a -> f Bool
_ [] = 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
r then (a
xforall a. a -> [a] -> [a]
:[a]
as, [a]
bs) else ([a]
as, a
xforall a. a -> [a] -> [a]
:[a]
bs)
sdistOpts :: SDistOpts
sdistOpts = UploadOpts -> SDistOpts
uoptsSDistOpts UploadOpts
uploadOpts
([FilePath]
files, [FilePath]
nonFiles) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a}.
Monad f =>
(a -> f Bool) -> [a] -> f ([a], [a])
partitionM FilePath -> IO Bool
doesFileExist (SDistOpts -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
([FilePath]
dirs, [FilePath]
invalid) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a}.
Monad f =>
(a -> f Bool) -> [a] -> f ([a], [a])
partitionM FilePath -> IO Bool
doesDirectoryExist [FilePath]
nonFiles
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
invalid) forall a b. (a -> b) -> a -> b
$ do
let invalidList :: StyleDoc
invalidList = [StyleDoc] -> StyleDoc
bulletedList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) [FilePath]
invalid
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upload"
, FilePath -> StyleDoc
flow FilePath
"expects a list of sdist tarballs or package directories."
, FilePath -> StyleDoc
flow FilePath
"Can't find:"
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> StyleDoc
invalidList
]
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
files Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
dirs) forall a b. (a -> b) -> a -> b
$ do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upload"
, FilePath -> StyleDoc
flow FilePath
"expects a list of sdist tarballs or package directories, but none were specified."
]
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
let hackageUrl :: FilePath
hackageUrl = Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ Config -> Text
configHackageBaseUrl Config
config
uploadVariant :: UploadVariant
uploadVariant = UploadOpts -> UploadVariant
uoptsUploadVariant UploadOpts
uploadOpts
Memoized HackageAuth
getCreds <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeRef forall a b. (a -> b) -> a -> b
$ forall m. (HasLogFunc m, HasTerm m) => Config -> RIO m HackageAuth
loadAuth Config
config
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
sdistOpts) [FilePath]
files
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
Path Abs File
tarFile <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
file
HackageAuth
creds <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized HackageAuth
getCreds
forall m.
(HasLogFunc m, HasTerm m) =>
FilePath -> HackageAuth -> FilePath -> UploadVariant -> RIO m ()
upload FilePath
hackageUrl HackageAuth
creds (forall b t. Path b t -> FilePath
toFilePath Path Abs File
tarFile) UploadVariant
uploadVariant
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
dirs forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
Path Abs Dir
pkgDir <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' FilePath
dir
(FilePath
tarName, ByteString
tarBytes, Maybe (PackageIdentifier, ByteString)
mcabalRevision) <-
forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball (SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds SDistOpts
sdistOpts) Path Abs Dir
pkgDir
forall env.
HasEnvConfig env =>
SDistOpts -> FilePath -> ByteString -> RIO env ()
checkSDistTarball' SDistOpts
sdistOpts FilePath
tarName ByteString
tarBytes
HackageAuth
creds <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized Memoized HackageAuth
getCreds
forall m.
HasTerm m =>
FilePath
-> HackageAuth
-> FilePath
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes FilePath
hackageUrl HackageAuth
creds FilePath
tarName UploadVariant
uploadVariant ByteString
tarBytes
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (PackageIdentifier, ByteString)
mcabalRevision forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall m.
(HasLogFunc m, HasTerm m) =>
FilePath
-> HackageAuth -> PackageIdentifier -> ByteString -> RIO m ()
uploadRevision FilePath
hackageUrl HackageAuth
creds
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)
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, HasTerm m) => Config -> RIO m HackageAuth
loadAuth :: forall m. (HasLogFunc m, HasTerm 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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyInfoS
FilePath
"HACKAGE_KEY environment variable found, 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. HasTerm m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config
loadUserAndPassword :: HasTerm m => Config -> RIO m HackageCreds
loadUserAndPassword :: forall m. HasTerm 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. HasTerm m => FilePath -> RIO m HackageCreds
fromPrompt FilePath
fp
Just (ByteString
lbs, FilePath -> HackageCreds
mkCreds) -> do
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ FilePath -> StyleDoc
flow FilePath
"You've set save-hackage-creds to false. However, credentials \
\ were found at:"
, Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString FilePath
fp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> HackageCreds
mkCreds FilePath
fp
where
fromPrompt :: HasTerm m => FilePath -> RIO m HackageCreds
fromPrompt :: forall m. HasTerm 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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyNoteL
[ FilePath -> StyleDoc
flow FilePath
"Avoid this prompt in the future by using the configuration \
\file option"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (FilePath -> StyleDoc
flow FilePath
"save-hackage-creds: false") forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyInfoS FilePath
"Saved!"
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageCreds
hc
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
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
h Builder
builder
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
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
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) = 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]
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageKey -> Request -> Request
addAPIKey HackageKey
key Request
req0)
HACreds HackageCreds
creds -> 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 <- 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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"No HTTP digest prompt found, this will probably fail."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
string
( case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just DigestAuthException
e' -> DigestAuthException -> FilePath
displayDigestAuthException DigestAuthException
e'
Maybe DigestAuthException
Nothing -> 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
uploadBytes :: HasTerm m
=> String
-> HackageAuth
-> String
-> UploadVariant
-> L.ByteString
-> RIO m ()
uploadBytes :: forall m.
HasTerm 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, HasTerm m) =>
HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req2
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ StyleDoc
"Uploading"
, Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => FilePath -> a
fromString FilePath
tarName) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"..."
]
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.
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 forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
Int
200 -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyInfoS FilePath
"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 e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO UploadPrettyException
AuthenticationFailure
Int
403 -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
StyleDoc
"[S-2804]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"forbidden upload"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Usually means: you've already uploaded this package/version \
\combination. Ignoring error and continuing. The full \
\message from Hackage is below:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
StyleDoc
"[S-4444]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"service unavailable"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"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:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
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 e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (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 :: (HasLogFunc m, HasTerm m)
=> String
-> HackageAuth
-> FilePath
-> UploadVariant
-> RIO m ()
upload :: forall m.
(HasLogFunc m, HasTerm m) =>
FilePath -> HackageAuth -> FilePath -> UploadVariant -> RIO m ()
upload FilePath
baseUrl HackageAuth
auth FilePath
fp UploadVariant
uploadVariant =
forall m.
HasTerm 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, HasTerm m)
=> String
-> HackageAuth
-> PackageIdentifier
-> L.ByteString
-> RIO m ()
uploadRevision :: forall m.
(HasLogFunc m, HasTerm 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, HasTerm 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