{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Stack.Upload
(
upload
, uploadBytes
, uploadRevision
, HackageCreds
, HackageAuth (..)
, HackageKey (..)
, loadAuth
, writeFilePrivate
, 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 )
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
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)
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 => Config -> RIO m HackageAuth
loadAuth :: forall m. HasLogFunc 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
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"HACKAGE_KEY found in env, 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. HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config
loadUserAndPassword :: HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword :: forall m. HasLogFunc 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. HasLogFunc m => [Char] -> RIO m HackageCreds
fromPrompt [Char]
fp
Just (ByteString
lbs, [Char] -> HackageCreds
mkCreds) -> 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
$ 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
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"WARNING: You've set save-hackage-creds to false"
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"However, credentials were found at:"
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO m ()) -> Utf8Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
" " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
fp
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 :: HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt :: forall m. HasLogFunc 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]? "
Utf8Builder -> RIO m ()
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"
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
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"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
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
takeDirectory [Char]
fp) (ShowS
takeFileName [Char]
fp) (([Char] -> Handle -> IO ()) -> IO ())
-> ([Char] -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
fpTmp Handle
h -> do
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
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
[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
</> [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
</> [Char]
"credentials.json"
addAPIKey :: HackageKey -> Request -> Request
addAPIKey :: HackageKey -> Request -> Request
addAPIKey (HackageKey Text
key) Request
req =
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] 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 -> 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 => 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 <- 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 <- 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
Utf8Builder -> RIO m ()
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 SomeException -> Maybe DigestAuthException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just DigestAuthException
e' -> Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO m ()) -> Utf8Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder) -> [Char] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ DigestAuthException -> [Char]
displayDigestAuthException DigestAuthException
e'
Maybe DigestAuthException
Nothing -> Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO m ()) -> Utf8Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString ([Char] -> Utf8Builder) -> [Char] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ 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
uploadBytes :: HasLogFunc m
=> String
-> HackageAuth
-> String
-> UploadVariant
-> L.ByteString
-> RIO m ()
uploadBytes :: forall m.
HasLogFunc m =>
[Char]
-> HackageAuth -> [Char] -> UploadVariant -> ByteString -> RIO m ()
uploadBytes [Char]
baseUrl HackageAuth
auth [Char]
tarName UploadVariant
uploadVariant ByteString
bytes = do
let req1 :: Request
req1 = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Accept" [ByteString
"text/plain"]
([Char] -> Request
forall a. IsString a => [Char] -> a
fromString ([Char] -> Request) -> [Char] -> Request
forall a b. (a -> b) -> a -> b
$ [Char]
baseUrl
[Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"packages/"
[Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> case UploadVariant
uploadVariant of
UploadVariant
Publishing -> [Char]
""
UploadVariant
Candidate -> [Char]
"candidates/"
)
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
Request
req3 <- HackageAuth -> Request -> RIO m Request
forall m. HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req2
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO m ()) -> Utf8Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Uploading " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
tarName Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"... "
Handle -> RIO m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
((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
req3 (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.
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 Response (ConduitM () ByteString IO ()) -> Int
forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
Int
200 -> Utf8Builder -> RIO m ()
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 -> (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 ()
PrettyException -> RIO m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PrettyException -> RIO m ()) -> PrettyException -> RIO m ()
forall a b. (a -> b) -> a -> b
$ UploadPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException UploadPrettyException
AuthenticationFailure
Int
403 -> do
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Error: [S-2804]"
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"forbidden upload"
Utf8Builder -> RIO m ()
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"
Utf8Builder -> RIO m ()
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"
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
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Error: [S-4444]"
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"service unavailable"
Utf8Builder -> RIO m ()
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"
Utf8Builder -> RIO m ()
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"
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
PrettyException -> RIO m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PrettyException -> RIO m ()) -> PrettyException -> RIO m ()
forall a b. (a -> b) -> a -> b
$ UploadPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (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 :: HasLogFunc m
=> String
-> HackageAuth
-> FilePath
-> UploadVariant
-> RIO m ()
upload :: forall m.
HasLogFunc m =>
[Char] -> HackageAuth -> [Char] -> UploadVariant -> RIO m ()
upload [Char]
baseUrl HackageAuth
auth [Char]
fp UploadVariant
uploadVariant =
[Char]
-> HackageAuth -> [Char] -> UploadVariant -> ByteString -> RIO m ()
forall m.
HasLogFunc m =>
[Char]
-> HackageAuth -> [Char] -> UploadVariant -> ByteString -> RIO m ()
uploadBytes [Char]
baseUrl HackageAuth
auth (ShowS
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
=> String
-> HackageAuth
-> PackageIdentifier
-> L.ByteString
-> RIO m ()
uploadRevision :: forall m.
HasLogFunc 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 => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req1
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