{-# 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 u :: Text
u p :: Text
p _) = [Pair] -> Value
object
        [ "username" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
u
        , "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 "HackageCreds" ((Object -> Parser (FilePath -> HackageCreds))
 -> Value -> Parser (FilePath -> HackageCreds))
-> (Object -> Parser (FilePath -> HackageCreds))
-> Value
-> Parser (FilePath -> HackageCreds)
forall a b. (a -> b) -> a -> b
$ \o :: 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
.: "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
.: "password"

withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable varName :: Text
varName fromPrompt :: 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
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
>>= \lbs :: 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
    Nothing -> FilePath -> IO HackageCreds
fromPrompt FilePath
fp
    Just (lbs :: ByteString
lbs, mkCreds :: 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 "WARNING: You've set save-hackage-creds to false"
        FilePath -> IO ()
putStrLn "However, credentials were found at:"
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "  " 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 fp :: FilePath
fp = do
      Text
username <- Text -> IO Text -> IO Text
withEnvVariable "HACKAGE_USERNAME" (Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
prompt "Hackage username: ")
      Text
password <- Text -> IO Text -> IO Text
withEnvVariable "HACKAGE_PASSWORD" (Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
promptPassword "Hackage password: ")
      let hc :: HackageCreds
hc = $WHackageCreds :: 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
$
          "Save hackage credentials to file at " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fp FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ " [y/n]? "
        FilePath -> IO ()
putStrLn "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 "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 fp :: FilePath
fp builder :: 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
$ \fpTmp :: FilePath
fpTmp h :: 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 0o600

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

credsFile :: Config -> IO FilePath
credsFile :: Config -> IO FilePath
credsFile config :: 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
</> "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
</> "credentials.json"

applyCreds :: HackageCreds -> Request -> IO Request
applyCreds :: HackageCreds -> Request -> IO Request
applyCreds creds :: HackageCreds
creds req0 :: 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 e :: SomeException
e -> do
          FilePath -> IO ()
putStrLn "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 e' :: DigestAuthException
e' -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ DigestAuthException -> FilePath
displayDigestAuthException DigestAuthException
e'
              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 req :: 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 baseUrl :: FilePath
baseUrl creds :: HackageCreds
creds tarName :: FilePath
tarName bytes :: ByteString
bytes = do
    let req1 :: Request
req1 = HeaderName -> [ByteString] -> Request -> Request
setRequestHeader "Accept" ["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
<> "packages/")
        formData :: [PartM IO]
formData = [Text -> FilePath -> RequestBody -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> FilePath -> RequestBody -> PartM m
partFileRequestBody "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
$ "Uploading " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
tarName FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "... "
    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
$ \res :: Response (ConduitM () ByteString IO ())
res ->
        case Response (ConduitM () ByteString IO ()) -> Int
forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
            200 -> FilePath -> IO ()
putStrLn "done!"
            401 -> do
                FilePath -> IO ()
putStrLn "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 "Authentication failure uploading to server"
            403 -> do
                FilePath -> IO ()
putStrLn "forbidden upload"
                FilePath -> IO ()
putStrLn "Usually means: you've already uploaded this package/version combination"
                FilePath -> IO ()
putStrLn "Ignoring error and continuing, full message from Hackage below:\n"
                Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
            503 -> do
                FilePath -> IO ()
putStrLn "service unavailable"
                FilePath -> IO ()
putStrLn "This error some times gets sent even though the upload succeeded"
                FilePath -> IO ()
putStrLn "Check on Hackage to see if your pacakge is present"
                Response (ConduitM () ByteString IO ()) -> IO ()
printBody Response (ConduitM () ByteString IO ())
res
            code :: Int
code -> do
                FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "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
$ "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 res :: 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 baseUrl :: FilePath
baseUrl creds :: HackageCreds
creds fp :: 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 baseUrl :: FilePath
baseUrl creds :: HackageCreds
creds ident :: PackageIdentifier
ident@(PackageIdentifier name :: PackageName
name _) cabalFile :: 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
    , "package/"
    , PackageIdentifier -> FilePath
packageIdentifierString PackageIdentifier
ident
    , "/"
    , PackageName -> FilePath
packageNameString PackageName
name
    , ".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 "cabalfile" ByteString
cabalFile
    , Text -> ByteString -> PartM IO
forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
partBS "publish" "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