{-# 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 Stack.Prelude
import Data.Aeson (FromJSON (..),
ToJSON (..),
decode', toEncoding, fromEncoding,
object, withObject,
(.:), (.=))
import Data.ByteString.Builder (lazyByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T
import Network.HTTP.StackClient (Request,
RequestBody(RequestBodyLBS),
Response,
withResponse,
httpNoBody,
getGlobalManager,
getResponseStatusCode,
getResponseBody,
setRequestHeader,
parseRequest,
formDataBody, partFileRequestBody,
partBS, partLBS,
applyDigestAuth,
displayDigestAuthException)
import Stack.Options.UploadParser
import Stack.Types.Config
import System.Directory (createDirectoryIfMissing,
removeFile, renameFile)
import System.Environment (lookupEnv)
import System.FilePath ((</>), takeFileName, takeDirectory)
import System.PosixCompat.Files (setFileMode)
newtype HackageKey = HackageKey Text
deriving (HackageKey -> HackageKey -> Bool
(HackageKey -> HackageKey -> Bool)
-> (HackageKey -> HackageKey -> Bool) -> Eq HackageKey
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 -> String
(Int -> HackageKey -> ShowS)
-> (HackageKey -> String)
-> ([HackageKey] -> ShowS)
-> Show HackageKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HackageKey] -> ShowS
$cshowList :: [HackageKey] -> ShowS
show :: HackageKey -> String
$cshow :: HackageKey -> String
showsPrec :: Int -> HackageKey -> ShowS
$cshowsPrec :: Int -> HackageKey -> ShowS
Show)
data HackageCreds = HackageCreds
{ HackageCreds -> Text
hcUsername :: !Text
, HackageCreds -> Text
hcPassword :: !Text
, HackageCreds -> String
hcCredsFile :: !FilePath
}
deriving (HackageCreds -> HackageCreds -> Bool
(HackageCreds -> HackageCreds -> Bool)
-> (HackageCreds -> HackageCreds -> Bool) -> Eq HackageCreds
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 -> String
(Int -> HackageCreds -> ShowS)
-> (HackageCreds -> String)
-> ([HackageCreds] -> ShowS)
-> Show HackageCreds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HackageCreds] -> ShowS
$cshowList :: [HackageCreds] -> ShowS
show :: HackageCreds -> String
$cshow :: HackageCreds -> String
showsPrec :: Int -> HackageCreds -> ShowS
$cshowsPrec :: Int -> 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
/= :: HackageAuth -> HackageAuth -> Bool
$c/= :: HackageAuth -> HackageAuth -> Bool
== :: HackageAuth -> HackageAuth -> Bool
$c== :: HackageAuth -> HackageAuth -> Bool
Eq, Int -> HackageAuth -> ShowS
[HackageAuth] -> ShowS
HackageAuth -> String
(Int -> HackageAuth -> ShowS)
-> (HackageAuth -> String)
-> ([HackageAuth] -> ShowS)
-> Show HackageAuth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HackageAuth] -> ShowS
$cshowList :: [HackageAuth] -> ShowS
show :: HackageAuth -> String
$cshow :: HackageAuth -> String
showsPrec :: Int -> HackageAuth -> ShowS
$cshowsPrec :: Int -> HackageAuth -> ShowS
Show)
instance ToJSON HackageCreds where
toJSON :: HackageCreds -> Value
toJSON (HackageCreds Text
u Text
p String
_) = [Pair] -> Value
object
[ Text
"username" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
u
, Text
"password" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
p
]
instance FromJSON (FilePath -> HackageCreds) where
parseJSON :: Value -> Parser (String -> HackageCreds)
parseJSON = String
-> (Object -> Parser (String -> HackageCreds))
-> Value
-> Parser (String -> HackageCreds)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"HackageCreds" ((Object -> Parser (String -> HackageCreds))
-> Value -> Parser (String -> HackageCreds))
-> (Object -> Parser (String -> HackageCreds))
-> Value
-> Parser (String -> HackageCreds)
forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> Text -> String -> HackageCreds
HackageCreds
(Text -> Text -> String -> HackageCreds)
-> Parser Text -> Parser (Text -> String -> HackageCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"username"
Parser (Text -> String -> HackageCreds)
-> Parser Text -> Parser (String -> HackageCreds)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"password"
withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable Text
varName IO Text
fromPrompt = String -> IO (Maybe String)
lookupEnv (Text -> String
T.unpack Text
varName) IO (Maybe String) -> (Maybe String -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Text -> (String -> IO Text) -> Maybe String -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
fromPrompt (Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (String -> Text) -> String -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
maybeGetHackageKey :: RIO m (Maybe HackageKey)
maybeGetHackageKey :: RIO m (Maybe HackageKey)
maybeGetHackageKey = IO (Maybe HackageKey) -> RIO m (Maybe HackageKey)
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
$ (String -> HackageKey) -> Maybe String -> Maybe HackageKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> HackageKey
HackageKey (Text -> HackageKey) -> (String -> Text) -> String -> HackageKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Maybe String -> Maybe HackageKey)
-> IO (Maybe String) -> IO (Maybe HackageKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"HACKAGE_KEY"
loadAuth :: HasLogFunc m => Config -> RIO m HackageAuth
loadAuth :: 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 (m :: * -> *) a. Monad m => a -> m a
return (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 :: Config -> RIO m HackageCreds
loadUserAndPassword Config
config = do
String
fp <- IO String -> RIO m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO m String) -> IO String -> RIO m String
forall a b. (a -> b) -> a -> b
$ Config -> IO String
credsFile Config
config
Either IOException ByteString
elbs <- IO (Either IOException ByteString)
-> RIO m (Either IOException ByteString)
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
$ String -> IO ByteString
L.readFile String
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, String -> HackageCreds))
-> Maybe (ByteString, String -> HackageCreds)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
lbs -> (ByteString
lbs, ) ((String -> HackageCreds) -> (ByteString, String -> HackageCreds))
-> Maybe (String -> HackageCreds)
-> Maybe (ByteString, String -> HackageCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (String -> HackageCreds)
forall a. FromJSON a => ByteString -> Maybe a
decode' ByteString
lbs of
Maybe (ByteString, String -> HackageCreds)
Nothing -> String -> RIO m HackageCreds
forall m. HasLogFunc m => String -> RIO m HackageCreds
fromPrompt String
fp
Just (ByteString
lbs, String -> HackageCreds
mkCreds) -> do
String -> Builder -> RIO m ()
forall (m :: * -> *). MonadIO m => String -> Builder -> m ()
writeFilePrivate String
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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
fp
HackageCreds -> RIO m HackageCreds
forall (m :: * -> *) a. Monad m => a -> m a
return (HackageCreds -> RIO m HackageCreds)
-> HackageCreds -> RIO m HackageCreds
forall a b. (a -> b) -> a -> b
$ String -> HackageCreds
mkCreds String
fp
where
fromPrompt :: HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt :: String -> RIO m HackageCreds
fromPrompt String
fp = do
Text
username <- IO Text -> RIO m Text
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 (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 :: Text -> Text -> String -> HackageCreds
HackageCreds
{ hcUsername :: Text
hcUsername = Text
username
, hcPassword :: Text
hcPassword = Text
password
, hcCredsFile :: String
hcCredsFile = String
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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
String
"Save hackage credentials to file at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" [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
String -> Builder -> RIO m ()
forall (m :: * -> *). MonadIO m => String -> Builder -> m ()
writeFilePrivate String
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 (m :: * -> *) a. Monad m => a -> m a
return HackageCreds
hc
writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate :: String -> Builder -> m ()
writeFilePrivate String
fp Builder
builder = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile (ShowS
takeDirectory String
fp) (ShowS
takeFileName String
fp) ((String -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
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
$ String -> FileMode -> IO ()
setFileMode String
fp FileMode
0o600
String -> String -> IO ()
renameFile String
fpTmp String
fp
credsFile :: Config -> IO FilePath
credsFile :: Config -> IO String
credsFile Config
config = do
let dir :: String
dir = Path Abs Dir -> String
forall b t. Path b t -> String
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)
stackRootL Config
config) String -> ShowS
</> String
"upload"
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
"credentials.json"
addAPIKey :: HackageKey -> Request -> Request
addAPIKey :: HackageKey -> Request -> Request
addAPIKey (HackageKey Text
key) Request
req =
HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Authorization" [String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"X-ApiKey" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
key] Request
req
applyAuth :: HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth :: HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
haAuth Request
req0 = do
case HackageAuth
haAuth of
HAKey HackageKey
key -> Request -> RIO m Request
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0 = do
Manager
manager <- IO Manager -> RIO m Manager
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 (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
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ DigestAuthException -> String
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
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
Request -> RIO m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req0
Right Request
req -> Request -> RIO m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
uploadBytes :: HasLogFunc m
=> String
-> HackageAuth
-> String
-> UploadVariant
-> L.ByteString
-> RIO m ()
uploadBytes :: String
-> HackageAuth -> String -> UploadVariant -> ByteString -> RIO m ()
uploadBytes String
baseUrl HackageAuth
auth String
tarName UploadVariant
uploadVariant ByteString
bytes = do
let req1 :: Request
req1 = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Accept" [ByteString
"text/plain"]
(String -> Request
forall a. IsString a => String -> a
fromString (String -> Request) -> String -> Request
forall a b. (a -> b) -> a -> b
$ String
baseUrl
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"packages/"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case UploadVariant
uploadVariant of
UploadVariant
Publishing -> String
""
UploadVariant
Candidate -> String
"candidates/"
)
formData :: [PartM IO]
formData = [Text -> String -> RequestBody -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> String -> RequestBody -> PartM m
partFileRequestBody Text
"package" String
tarName (ByteString -> RequestBody
RequestBodyLBS ByteString
bytes)]
Request
req2 <- IO Request -> RIO m Request
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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
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 (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 :: 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
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"authentication failure"
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 (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> RIO m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO m ()) -> IO () -> RIO m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile (HackageCreds -> String
hcCredsFile HackageCreds
creds))
HackageAuth
_ -> () -> RIO m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
String -> RIO m ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Authentication failure uploading to server"
Int
403 -> do
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 (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
"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 pacakge is present"
IO () -> RIO m ()
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
Utf8Builder -> RIO m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO m ()) -> Utf8Builder -> RIO m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"unhandled status code: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
code)
IO () -> RIO m ()
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
String -> RIO m ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> RIO m ()) -> String -> RIO m ()
forall a b. (a -> b) -> a -> b
$ String
"Upload failed on " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. IsString a => String -> a
fromString String
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 ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle -> ConduitM 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 :: String -> HackageAuth -> String -> UploadVariant -> RIO m ()
upload String
baseUrl HackageAuth
auth String
fp UploadVariant
uploadVariant =
String
-> HackageAuth -> String -> UploadVariant -> ByteString -> RIO m ()
forall m.
HasLogFunc m =>
String
-> HackageAuth -> String -> UploadVariant -> ByteString -> RIO m ()
uploadBytes String
baseUrl HackageAuth
auth (ShowS
takeFileName String
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
L.readFile String
fp)
uploadRevision :: HasLogFunc m
=> String
-> HackageAuth
-> PackageIdentifier
-> L.ByteString
-> RIO m ()
uploadRevision :: String
-> HackageAuth -> PackageIdentifier -> ByteString -> RIO m ()
uploadRevision String
baseUrl HackageAuth
auth ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) ByteString
cabalFile = do
Request
req0 <- String -> RIO m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> RIO m Request) -> String -> RIO m Request
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
baseUrl
, String
"package/"
, PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
, String
"/"
, PackageName -> String
packageNameString PackageName
name
, String
".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