{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- | Provide ability to upload tarballs to Hackage.
module Stack.Upload
    ( -- * Upload
      upload
    , uploadBytes
    , uploadRevision
      -- * Credentials
    , HackageCreds
    , loadCreds
    , writeFilePrivate
    ) 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.Types.Config
import           System.Directory                      (createDirectoryIfMissing,
                                                        removeFile, renameFile)
import           System.Environment                    (lookupEnv)
import           System.FilePath                       ((</>), takeFileName, takeDirectory)
import           System.IO                             (putStrLn, putStr, print) -- TODO remove putStrLn, use logInfo
import           System.PosixCompat.Files              (setFileMode)

-- | Username and password to log into Hackage.
--
-- Since 0.1.0.0
data HackageCreds = HackageCreds
    { HackageCreds -> Text
hcUsername :: !Text
    , HackageCreds -> Text
hcPassword :: !Text
    , HackageCreds -> FilePath
hcCredsFile :: !FilePath
    }
    deriving Int -> HackageCreds -> ShowS
[HackageCreds] -> ShowS
HackageCreds -> FilePath
(Int -> HackageCreds -> ShowS)
-> (HackageCreds -> FilePath)
-> ([HackageCreds] -> ShowS)
-> Show HackageCreds
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

instance ToJSON HackageCreds where
    toJSON :: HackageCreds -> Value
toJSON (HackageCreds Text
u Text
p FilePath
_) = [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 (FilePath -> HackageCreds)
parseJSON = FilePath
-> (Object -> Parser (FilePath -> HackageCreds))
-> Value
-> Parser (FilePath -> HackageCreds)
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"HackageCreds" ((Object -> Parser (FilePath -> HackageCreds))
 -> Value -> Parser (FilePath -> HackageCreds))
-> (Object -> Parser (FilePath -> HackageCreds))
-> Value
-> Parser (FilePath -> HackageCreds)
forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> Text -> FilePath -> HackageCreds
HackageCreds
        (Text -> Text -> FilePath -> HackageCreds)
-> Parser Text -> Parser (Text -> FilePath -> 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 -> FilePath -> HackageCreds)
-> Parser Text -> Parser (FilePath -> 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 = FilePath -> IO (Maybe FilePath)
lookupEnv (Text -> FilePath
T.unpack Text
varName) IO (Maybe FilePath) -> (Maybe FilePath -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Text -> (FilePath -> IO Text) -> Maybe FilePath -> 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) -> (FilePath -> Text) -> FilePath -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack)

-- | Load Hackage credentials, either from a save file or the command
-- line.
--
-- Since 0.1.0.0
loadCreds :: Config -> IO HackageCreds
loadCreds :: Config -> IO HackageCreds
loadCreds Config
config = do
  FilePath
fp <- Config -> IO FilePath
credsFile Config
config
  Either IOException ByteString
elbs <- 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
$ FilePath -> IO ByteString
L.readFile FilePath
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, FilePath -> HackageCreds))
-> Maybe (ByteString, FilePath -> HackageCreds)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
lbs -> (ByteString
lbs, ) ((FilePath -> HackageCreds)
 -> (ByteString, FilePath -> HackageCreds))
-> Maybe (FilePath -> HackageCreds)
-> Maybe (ByteString, FilePath -> HackageCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (FilePath -> HackageCreds)
forall a. FromJSON a => ByteString -> Maybe a
decode' ByteString
lbs of
    Maybe (ByteString, FilePath -> HackageCreds)
Nothing -> FilePath -> IO HackageCreds
fromPrompt FilePath
fp
    Just (ByteString
lbs, FilePath -> HackageCreds
mkCreds) -> do
      -- Ensure privacy, for cleaning up old versions of Stack that
      -- didn't do this
      FilePath -> Builder -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate FilePath
fp (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
lbs

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configSaveHackageCreds Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        FilePath -> IO ()
putStrLn FilePath
"WARNING: You've set save-hackage-creds to false"
        FilePath -> IO ()
putStrLn FilePath
"However, credentials were found at:"
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"  " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fp
      HackageCreds -> IO HackageCreds
forall (m :: * -> *) a. Monad m => a -> m a
return (HackageCreds -> IO HackageCreds)
-> HackageCreds -> IO HackageCreds
forall a b. (a -> b) -> a -> b
$ FilePath -> HackageCreds
mkCreds FilePath
fp
  where
    fromPrompt :: FilePath -> IO HackageCreds
fromPrompt FilePath
fp = do
      Text
username <- 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 <- 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 -> FilePath -> HackageCreds
HackageCreds
            { hcUsername :: Text
hcUsername = Text
username
            , hcPassword :: Text
hcPassword = Text
password
            , hcCredsFile :: FilePath
hcCredsFile = FilePath
fp
            }

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configSaveHackageCreds Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
shouldSave <- Text -> IO Bool
forall (m :: * -> *). MonadIO m => Text -> m Bool
promptBool (Text -> IO Bool) -> Text -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
          FilePath
"Save hackage credentials to file at " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fp FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" [y/n]? "
        FilePath -> IO ()
putStrLn FilePath
"NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldSave (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          FilePath -> Builder -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate FilePath
fp (Builder -> IO ()) -> Builder -> IO ()
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
          FilePath -> IO ()
putStrLn FilePath
"Saved!"
          Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout

      HackageCreds -> IO HackageCreds
forall (m :: * -> *) a. Monad m => a -> m a
return HackageCreds
hc

-- | Write contents to a file which is always private.
--
-- For history of this function, see:
--
-- * https://github.com/commercialhaskell/stack/issues/2159#issuecomment-477948928
--
-- * https://github.com/commercialhaskell/stack/pull/4665
writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate :: FilePath -> Builder -> m ()
writeFilePrivate FilePath
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
$ FilePath -> FilePath -> (FilePath -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> FilePath -> (FilePath -> Handle -> m a) -> m a
withTempFile (ShowS
takeDirectory FilePath
fp) (ShowS
takeFileName FilePath
fp) ((FilePath -> Handle -> IO ()) -> IO ())
-> (FilePath -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fpTmp Handle
h -> do
  -- Temp file is created such that only current user can read and write it.
  -- See docs for openTempFile: https://www.stackage.org/haddock/lts-13.14/base-4.12.0.0/System-IO.html#v:openTempFile

  -- Write to the file and close the handle.
  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

  -- Make sure the destination file, if present, is writeable
  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
$ FilePath -> FileMode -> IO ()
setFileMode FilePath
fp FileMode
0o600

  -- And atomically move
  FilePath -> FilePath -> IO ()
renameFile FilePath
fpTmp FilePath
fp

credsFile :: Config -> IO FilePath
credsFile :: Config -> IO FilePath
credsFile Config
config = do
    let dir :: FilePath
dir = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
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) FilePath -> ShowS
</> FilePath
"upload"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
    FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FilePath
"credentials.json"

applyCreds :: HackageCreds -> Request -> IO Request
applyCreds :: HackageCreds -> Request -> IO Request
applyCreds HackageCreds
creds Request
req0 = do
  Manager
manager <- IO Manager
getGlobalManager
  Either SomeException Request
ereq <- 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
          FilePath -> IO ()
putStrLn FilePath
"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' -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ DigestAuthException -> FilePath
displayDigestAuthException DigestAuthException
e'
              Maybe DigestAuthException
Nothing -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e
          Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req0
      Right Request
req -> Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req

-- | Upload a single tarball with the given @Uploader@.  Instead of
-- sending a file like 'upload', this sends a lazy bytestring.
--
-- Since 0.1.2.1
uploadBytes :: String -- ^ Hackage base URL
            -> HackageCreds
            -> String -- ^ tar file name
            -> L.ByteString -- ^ tar file contents
            -> IO ()
uploadBytes :: FilePath -> HackageCreds -> FilePath -> ByteString -> IO ()
uploadBytes FilePath
baseUrl HackageCreds
creds FilePath
tarName ByteString
bytes = do
    let req1 :: Request
req1 = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader HeaderName
"Accept" [ByteString
"text/plain"]
               (FilePath -> Request
forall a. IsString a => FilePath -> a
fromString (FilePath -> Request) -> FilePath -> Request
forall a b. (a -> b) -> a -> b
$ FilePath
baseUrl FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"packages/")
        formData :: [PartM IO]
formData = [Text -> FilePath -> RequestBody -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> FilePath -> RequestBody -> PartM m
partFileRequestBody Text
"package" FilePath
tarName (ByteString -> RequestBody
RequestBodyLBS ByteString
bytes)]
    Request
req2 <- [PartM IO] -> Request -> IO Request
forall (m :: * -> *).
MonadIO m =>
[PartM IO] -> Request -> m Request
formDataBody [PartM IO]
formData Request
req1
    Request
req3 <- HackageCreds -> Request -> IO Request
applyCreds HackageCreds
creds Request
req2
    FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Uploading " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
tarName FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"... "
    Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
    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 ((Response (ConduitM () ByteString IO ()) -> IO ()) -> IO ())
-> (Response (ConduitM () ByteString IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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 -> FilePath -> IO ()
putStrLn FilePath
"done!"
            Int
401 -> do
                FilePath -> IO ()
putStrLn FilePath
"authentication failure"
                (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (IO () -> IOException -> IO ()
forall a b. a -> b -> a
const (IO () -> IOException -> IO ()) -> IO () -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (FilePath -> IO ()
removeFile (HackageCreds -> FilePath
hcCredsFile HackageCreds
creds))
                FilePath -> IO ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Authentication failure uploading to server"
            Int
403 -> do
                FilePath -> IO ()
putStrLn FilePath
"forbidden upload"
                FilePath -> IO ()
putStrLn FilePath
"Usually means: you've already uploaded this package/version combination"
                FilePath -> IO ()
putStrLn FilePath
"Ignoring error and continuing, full message from Hackage below:\n"
                Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
            Int
503 -> do
                FilePath -> IO ()
putStrLn FilePath
"service unavailable"
                FilePath -> IO ()
putStrLn FilePath
"This error some times gets sent even though the upload succeeded"
                FilePath -> IO ()
putStrLn FilePath
"Check on Hackage to see if your pacakge is present"
                Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
            Int
code -> do
                FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"unhandled status code: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
code
                Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
                FilePath -> IO ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Upload failed on " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
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 a single tarball with the given @Uploader@.
--
-- Since 0.1.0.0
upload :: String -- ^ Hackage base URL
       -> HackageCreds
       -> FilePath
       -> IO ()
upload :: FilePath -> HackageCreds -> FilePath -> IO ()
upload FilePath
baseUrl HackageCreds
creds FilePath
fp = FilePath -> HackageCreds -> FilePath -> ByteString -> IO ()
uploadBytes FilePath
baseUrl HackageCreds
creds (ShowS
takeFileName FilePath
fp) (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
L.readFile FilePath
fp

uploadRevision :: String -- ^ Hackage base URL
               -> HackageCreds
               -> PackageIdentifier
               -> L.ByteString
               -> IO ()
uploadRevision :: FilePath
-> HackageCreds -> PackageIdentifier -> ByteString -> IO ()
uploadRevision FilePath
baseUrl HackageCreds
creds ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) ByteString
cabalFile = do
  Request
req0 <- FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest (FilePath -> IO Request) -> FilePath -> IO Request
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
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 <- [PartM IO] -> Request -> IO 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 <- HackageCreds -> Request -> IO Request
applyCreds HackageCreds
creds Request
req1
  IO (Response ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Response ()) -> IO ()) -> IO (Response ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> IO (Response ())
forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody Request
req2