{-# 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
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 => Config -> RIO m HackageAuth
loadAuth :: forall m. HasLogFunc m => Config -> RIO m HackageAuth
loadAuth Config
config = do
Maybe HackageKey
maybeHackageKey <- forall m. RIO m (Maybe HackageKey)
maybeGetHackageKey
case Maybe HackageKey
maybeHackageKey of
Just HackageKey
key -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"HACKAGE_KEY found in env, using that for credentials."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HackageKey -> HackageAuth
HAKey HackageKey
key
Maybe HackageKey
Nothing -> HackageCreds -> HackageAuth
HACreds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config
loadUserAndPassword :: HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword :: forall m. HasLogFunc m => Config -> RIO m HackageCreds
loadUserAndPassword Config
config = do
FilePath
fp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> IO FilePath
credsFile Config
config
Either IOException ByteString
elbs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
L.readFile FilePath
fp
case forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either IOException ByteString
elbs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
lbs -> (ByteString
lbs, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => ByteString -> Maybe a
decode' ByteString
lbs of
Maybe (ByteString, FilePath -> HackageCreds)
Nothing -> forall m. HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt FilePath
fp
Just (ByteString
lbs, FilePath -> HackageCreds
mkCreds) -> do
forall (m :: * -> *). MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate FilePath
fp forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
lbs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configSaveHackageCreds Config
config) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"WARNING: You've set save-hackage-creds to false"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"However, credentials were found at:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
" " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
fp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> HackageCreds
mkCreds FilePath
fp
where
fromPrompt :: HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt :: forall m. HasLogFunc m => FilePath -> RIO m HackageCreds
fromPrompt FilePath
fp = do
Text
username <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO Text -> IO Text
withEnvVariable Text
"HACKAGE_USERNAME" (forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Hackage username: ")
Text
password <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO Text -> IO Text
withEnvVariable Text
"HACKAGE_PASSWORD" (forall (m :: * -> *). MonadIO m => Text -> m Text
promptPassword Text
"Hackage password: ")
let hc :: HackageCreds
hc = HackageCreds
{ hcUsername :: Text
hcUsername = Text
username
, hcPassword :: Text
hcPassword = Text
password
, hcCredsFile :: FilePath
hcCredsFile = FilePath
fp
}
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configSaveHackageCreds Config
config) forall a b. (a -> b) -> a -> b
$ do
Bool
shouldSave <- forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$
FilePath
"Save hackage credentials to file at " forall a. [a] -> [a] -> [a]
++ FilePath
fp forall a. [a] -> [a] -> [a]
++ FilePath
" [y/n]? "
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldSave forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate FilePath
fp forall a b. (a -> b) -> a -> b
$ forall tag. Encoding' tag -> Builder
fromEncoding forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
toEncoding HackageCreds
hc
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Saved!"
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
forall (m :: * -> *) a. Monad m => a -> m a
return HackageCreds
hc
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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FilePath
"credentials.json"
addAPIKey :: HackageKey -> Request -> Request
addAPIKey :: HackageKey -> Request -> Request
addAPIKey (HackageKey Text
key) Request
req =
HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Authorization" [forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ FilePath
"X-ApiKey" forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
key] Request
req
applyAuth :: HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth :: forall m. HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
haAuth Request
req0 = do
case HackageAuth
haAuth of
HAKey HackageKey
key -> forall (m :: * -> *) a. Monad m => a -> m a
return (HackageKey -> Request -> Request
addAPIKey HackageKey
key Request
req0)
HACreds HackageCreds
creds -> forall m. HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0
applyCreds :: HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds :: forall m. HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds HackageCreds
creds Request
req0 = do
Manager
manager <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
getGlobalManager
Either SomeException Request
ereq <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadThrow n) =>
ByteString -> ByteString -> Request -> Manager -> m (n Request)
applyDigestAuth
(Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ HackageCreds -> Text
hcUsername HackageCreds
creds)
(Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ HackageCreds -> Text
hcPassword HackageCreds
creds)
Request
req0
Manager
manager
case Either SomeException Request
ereq of
Left SomeException
e -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"WARNING: No HTTP digest prompt found, this will probably fail"
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just DigestAuthException
e' -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ DigestAuthException -> FilePath
displayDigestAuthException DigestAuthException
e'
Maybe DigestAuthException
Nothing -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException SomeException
e
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req0
Right Request
req -> forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
uploadBytes :: HasLogFunc m
=> String
-> HackageAuth
-> String
-> UploadVariant
-> L.ByteString
-> RIO m ()
uploadBytes :: forall m.
HasLogFunc m =>
FilePath
-> HackageAuth
-> FilePath
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes FilePath
baseUrl HackageAuth
auth FilePath
tarName UploadVariant
uploadVariant ByteString
bytes = do
let req1 :: Request
req1 = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Accept" [ByteString
"text/plain"]
(forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ FilePath
baseUrl
forall a. Semigroup a => a -> a -> a
<> FilePath
"packages/"
forall a. Semigroup a => a -> a -> a
<> case UploadVariant
uploadVariant of
UploadVariant
Publishing -> FilePath
""
UploadVariant
Candidate -> FilePath
"candidates/"
)
formData :: [PartM IO]
formData = [forall (m :: * -> *).
Applicative m =>
Text -> FilePath -> RequestBody -> PartM m
partFileRequestBody Text
"package" FilePath
tarName (ByteString -> RequestBody
RequestBodyLBS ByteString
bytes)]
Request
req2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[PartM IO] -> Request -> m Request
formDataBody [PartM IO]
formData Request
req1
Request
req3 <- forall m. HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req2
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Uploading " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
tarName forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"... "
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO m a -> IO a
runInIO -> forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req3 (forall a. RIO m a -> IO a
runInIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m.
HasLogFunc m =>
Response (ConduitM () ByteString IO ()) -> RIO m ()
inner)
where
inner :: HasLogFunc m => Response (ConduitM () S.ByteString IO ()) -> RIO m ()
inner :: forall m.
HasLogFunc m =>
Response (ConduitM () ByteString IO ()) -> RIO m ()
inner Response (ConduitM () ByteString IO ())
res =
case forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
Int
200 -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"done!"
Int
401 -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"authentication failure"
case HackageAuth
auth of
HACreds HackageCreds
creds -> forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile (HackageCreds -> FilePath
hcCredsFile HackageCreds
creds))
HackageAuth
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Authentication failure uploading to server"
Int
403 -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"forbidden upload"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Usually means: you've already uploaded this package/version combination"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Ignoring error and continuing, full message from Hackage below:\n"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
Int
503 -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"service unavailable"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"This error some times gets sent even though the upload succeeded"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Check on Hackage to see if your package is present"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
Int
code -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"unhandled status code: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString (forall a. Show a => a -> FilePath
show Int
code)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall a b. (a -> b) -> a -> b
$ FilePath
"Upload failed on " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
tarName
printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
printBody :: Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
CB.sinkHandle Handle
stdout
upload :: HasLogFunc m
=> String
-> HackageAuth
-> FilePath
-> UploadVariant
-> RIO m ()
upload :: forall m.
HasLogFunc m =>
FilePath -> HackageAuth -> FilePath -> UploadVariant -> RIO m ()
upload FilePath
baseUrl HackageAuth
auth FilePath
fp UploadVariant
uploadVariant =
forall m.
HasLogFunc m =>
FilePath
-> HackageAuth
-> FilePath
-> UploadVariant
-> ByteString
-> RIO m ()
uploadBytes FilePath
baseUrl HackageAuth
auth (ShowS
takeFileName FilePath
fp) UploadVariant
uploadVariant forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
L.readFile FilePath
fp)
uploadRevision :: HasLogFunc m
=> String
-> HackageAuth
-> PackageIdentifier
-> L.ByteString
-> RIO m ()
uploadRevision :: forall m.
HasLogFunc m =>
FilePath
-> HackageAuth -> PackageIdentifier -> ByteString -> RIO m ()
uploadRevision FilePath
baseUrl HackageAuth
auth ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) ByteString
cabalFile = do
Request
req0 <- forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath
baseUrl
, FilePath
"package/"
, PackageIdentifier -> FilePath
packageIdentifierString PackageIdentifier
ident
, FilePath
"/"
, PackageName -> FilePath
packageNameString PackageName
name
, FilePath
".cabal/edit"
]
Request
req1 <- forall (m :: * -> *).
MonadIO m =>
[PartM IO] -> Request -> m Request
formDataBody
[ forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
partLBS Text
"cabalfile" ByteString
cabalFile
, forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
partBS Text
"publish" ByteString
"on"
]
Request
req0
Request
req2 <- forall m. HasLogFunc m => HackageAuth -> Request -> RIO m Request
applyAuth HackageAuth
auth Request
req1
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody Request
req2