module Distribution.Client.Upload (upload, uploadDoc, report) where

import Distribution.Client.Compat.Prelude
import qualified Prelude as Unsafe (read)

import Distribution.Client.HttpUtils
  ( HttpTransport (..)
  , remoteRepoTryUpgradeToHttps
  )
import Distribution.Client.Setup
  ( IsCandidate (..)
  , RepoContext (..)
  )
import Distribution.Client.Types.Credentials
  ( Auth
  , Password (..)
  , Token (..)
  , Username (..)
  )
import Distribution.Client.Types.Repo (RemoteRepo (..), Repo, maybeRepoRemote)
import Distribution.Client.Types.RepoName (unRepoName)

import Distribution.Client.Config
import Distribution.Simple.Utils (dieWithException, info, notice, toUTF8BS, warn)
import Distribution.Utils.String (trim)

import Distribution.Client.BuildReports.Anonymous (parseBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import qualified Distribution.Client.BuildReports.Upload as BuildReport
import Distribution.Client.Errors
import Network.HTTP (Header (..), HeaderName (..))
import Network.URI (URI (uriAuthority, uriPath), URIAuth (uriRegName))
import System.Directory
import System.FilePath (dropExtension, takeExtension, takeFileName, (</>))
import qualified System.FilePath.Posix as FilePath.Posix ((</>))
import System.IO (hFlush, stdout)
import System.IO.Echo (withoutInputEcho)

-- > stripExtensions ["tar", "gz"] "foo.tar.gz"
-- Just "foo"
-- > stripExtensions ["tar", "gz"] "foo.gz.tar"
-- Nothing
stripExtensions :: [String] -> FilePath -> Maybe String
stripExtensions :: [String] -> String -> Maybe String
stripExtensions [String]
exts String
path = (String -> String -> Maybe String)
-> String -> [String] -> Maybe String
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM String -> String -> Maybe String
f String
path ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
exts)
  where
    f :: String -> String -> Maybe String
f String
p String
e
      | String -> String
takeExtension String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
e = String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
dropExtension String
p)
      | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

upload
  :: Verbosity
  -> RepoContext
  -> Maybe Token
  -> Maybe Username
  -> Maybe Password
  -> IsCandidate
  -> [FilePath]
  -> IO ()
upload :: Verbosity
-> RepoContext
-> Maybe Token
-> Maybe Username
-> Maybe Password
-> IsCandidate
-> [String]
-> IO ()
upload Verbosity
verbosity RepoContext
repoCtxt Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword IsCandidate
isCandidate [String]
paths = do
  let repos :: [Repo]
      repos :: [Repo]
repos = RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt
  HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
  RemoteRepo
targetRepo <-
    case [RemoteRepo
remoteRepo | Just RemoteRepo
remoteRepo <- (Repo -> Maybe RemoteRepo) -> [Repo] -> [Maybe RemoteRepo]
forall a b. (a -> b) -> [a] -> [b]
map Repo -> Maybe RemoteRepo
maybeRepoRemote [Repo]
repos] of
      [] -> Verbosity -> CabalInstallException -> IO RemoteRepo
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
NoRemoteRepositories
      (RemoteRepo
r : [RemoteRepo]
rs) -> Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps Verbosity
verbosity HttpTransport
transport (NonEmpty RemoteRepo -> RemoteRepo
forall a. NonEmpty a -> a
last (RemoteRepo
r RemoteRepo -> [RemoteRepo] -> NonEmpty RemoteRepo
forall a. a -> [a] -> NonEmpty a
:| [RemoteRepo]
rs))
  let targetRepoURI :: URI
      targetRepoURI :: URI
targetRepoURI = RemoteRepo -> URI
remoteRepoURI RemoteRepo
targetRepo
      domain :: String
      domain :: String
domain = String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Hackage" URIAuth -> String
uriRegName (Maybe URIAuth -> String) -> Maybe URIAuth -> String
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority URI
targetRepoURI
      rootIfEmpty :: String -> String
rootIfEmpty String
x = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then String
"/" else String
x
      uploadURI :: URI
      uploadURI :: URI
uploadURI =
        URI
targetRepoURI
          { uriPath =
              rootIfEmpty (uriPath targetRepoURI)
                FilePath.Posix.</> case isCandidate of
                  IsCandidate
IsCandidate -> String
"packages/candidates"
                  IsCandidate
IsPublished -> String
"upload"
          }
      packageURI :: String -> URI
packageURI String
pkgid =
        URI
targetRepoURI
          { uriPath =
              rootIfEmpty (uriPath targetRepoURI)
                FilePath.Posix.</> concat
                  [ "package/"
                  , pkgid
                  , case isCandidate of
                      IsCandidate
IsCandidate -> String
"/candidate"
                      IsCandidate
IsPublished -> String
""
                  ]
          }
  Maybe Auth
auth <- Auth -> Maybe Auth
forall a. a -> Maybe a
Just (Auth -> Maybe Auth) -> IO Auth -> IO (Maybe Auth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Maybe Token -> Maybe Username -> Maybe Password -> IO Auth
createAuth String
domain Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword
  [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
paths ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
path -> do
    Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Uploading " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"... "
    case (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
takeFileName ([String] -> String -> Maybe String
stripExtensions [String
"tar", String
"gz"] String
path) of
      Just String
pkgid ->
        HttpTransport
-> Verbosity
-> URI
-> URI
-> Maybe Auth
-> IsCandidate
-> String
-> IO ()
handlePackage
          HttpTransport
transport
          Verbosity
verbosity
          URI
uploadURI
          (String -> URI
packageURI String
pkgid)
          Maybe Auth
auth
          IsCandidate
isCandidate
          String
path
      -- This case shouldn't really happen, since we check in Main that we
      -- only pass tar.gz files to upload.
      Maybe String
Nothing -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
NotATarDotGzFile String
path

uploadDoc
  :: Verbosity
  -> RepoContext
  -> Maybe Token
  -> Maybe Username
  -> Maybe Password
  -> IsCandidate
  -> FilePath
  -> IO ()
uploadDoc :: Verbosity
-> RepoContext
-> Maybe Token
-> Maybe Username
-> Maybe Password
-> IsCandidate
-> String
-> IO ()
uploadDoc Verbosity
verbosity RepoContext
repoCtxt Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword IsCandidate
isCandidate String
path = do
  let repos :: [Repo]
repos = RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt
  HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
  RemoteRepo
targetRepo <-
    case [RemoteRepo
remoteRepo | Just RemoteRepo
remoteRepo <- (Repo -> Maybe RemoteRepo) -> [Repo] -> [Maybe RemoteRepo]
forall a b. (a -> b) -> [a] -> [b]
map Repo -> Maybe RemoteRepo
maybeRepoRemote [Repo]
repos] of
      [] -> Verbosity -> CabalInstallException -> IO RemoteRepo
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
NoRemoteRepositories
      (RemoteRepo
r : [RemoteRepo]
rs) -> Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps Verbosity
verbosity HttpTransport
transport (NonEmpty RemoteRepo -> RemoteRepo
forall a. NonEmpty a -> a
last (RemoteRepo
r RemoteRepo -> [RemoteRepo] -> NonEmpty RemoteRepo
forall a. a -> [a] -> NonEmpty a
:| [RemoteRepo]
rs))
  let targetRepoURI :: URI
targetRepoURI = RemoteRepo -> URI
remoteRepoURI RemoteRepo
targetRepo
      domain :: String
domain = String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Hackage" URIAuth -> String
uriRegName (Maybe URIAuth -> String) -> Maybe URIAuth -> String
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority URI
targetRepoURI
      rootIfEmpty :: String -> String
rootIfEmpty String
x = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then String
"/" else String
x
      uploadURI :: URI
uploadURI =
        URI
targetRepoURI
          { uriPath =
              rootIfEmpty (uriPath targetRepoURI)
                FilePath.Posix.</> concat
                  [ "package/"
                  , pkgid
                  , case isCandidate of
                      IsCandidate
IsCandidate -> String
"/candidate"
                      IsCandidate
IsPublished -> String
""
                  , "/docs"
                  ]
          }
      packageUri :: URI
packageUri =
        URI
targetRepoURI
          { uriPath =
              rootIfEmpty (uriPath targetRepoURI)
                FilePath.Posix.</> concat
                  [ "package/"
                  , pkgid
                  , case isCandidate of
                      IsCandidate
IsCandidate -> String
"/candidate"
                      IsCandidate
IsPublished -> String
""
                  ]
          }
      (String
reverseSuffix, String
reversePkgid) =
        (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break
          (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
          (String -> String
forall a. [a] -> [a]
reverse (String -> String
takeFileName String
path))
      pkgid :: String
pkgid = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ HttpCode -> String -> String
forall a. HttpCode -> [a] -> [a]
drop HttpCode
1 String
reversePkgid
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    ( String -> String
forall a. [a] -> [a]
reverse String
reverseSuffix String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"docs.tar.gz"
        Bool -> Bool -> Bool
|| ( case String
reversePkgid of
              [] -> Bool
True
              (Char
c : String
_) -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-'
           )
    )
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
ExpectedMatchingFileName

  Maybe Auth
auth <- Auth -> Maybe Auth
forall a. a -> Maybe a
Just (Auth -> Maybe Auth) -> IO Auth -> IO (Maybe Auth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Maybe Token -> Maybe Username -> Maybe Password -> IO Auth
createAuth String
domain Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword

  let headers :: [Header]
headers =
        [ HeaderName -> String -> Header
Header HeaderName
HdrContentType String
"application/x-tar"
        , HeaderName -> String -> Header
Header HeaderName
HdrContentEncoding String
"gzip"
        ]
  Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Uploading documentation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"... "
  (HttpCode, String)
resp <- HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String)
putHttpFile HttpTransport
transport Verbosity
verbosity URI
uploadURI String
path Maybe Auth
auth [Header]
headers
  case (HttpCode, String)
resp of
    -- Hackage responds with 204 No Content when docs are uploaded
    -- successfully.
    (HttpCode
code, String
_) | HttpCode
code HttpCode -> [HttpCode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HttpCode
200, HttpCode
204] -> do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> String
forall {a}. Show a => a -> String
okMessage URI
packageUri
    (HttpCode
code, String
err) -> do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Error uploading documentation "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"http code "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpCode -> String
forall {a}. Show a => a -> String
show HttpCode
code
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
      IO ()
forall a. IO a
exitFailure
  where
    okMessage :: a -> String
okMessage a
packageUri = case IsCandidate
isCandidate of
      IsCandidate
IsCandidate ->
        String
"Documentation successfully uploaded for package candidate. "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"You can now preview the result at '"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
packageUri
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. To upload non-candidate documentation, use 'cabal upload --publish'."
      IsCandidate
IsPublished ->
        String
"Package documentation successfully published. You can now view it at '"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
packageUri
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."

promptUsername :: String -> IO Username
promptUsername :: String -> IO Username
promptUsername String
domain = do
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
domain String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" username: "
  Handle -> IO ()
hFlush Handle
stdout
  (String -> Username) -> IO String -> IO Username
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Username
Username IO String
getLine

promptPassword :: String -> IO Password
promptPassword :: String -> IO Password
promptPassword String
domain = do
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
domain String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" password: "
  Handle -> IO ()
hFlush Handle
stdout
  -- save/restore the terminal echoing status (no echoing for entering the password)
  Password
passwd <- IO Password -> IO Password
forall a. IO a -> IO a
withoutInputEcho (IO Password -> IO Password) -> IO Password -> IO Password
forall a b. (a -> b) -> a -> b
$ (String -> Password) -> IO String -> IO Password
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Password
Password IO String
getLine
  String -> IO ()
putStrLn String
""
  Password -> IO Password
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Password
passwd

report :: Verbosity -> RepoContext -> Maybe Token -> Maybe Username -> Maybe Password -> IO ()
report :: Verbosity
-> RepoContext
-> Maybe Token
-> Maybe Username
-> Maybe Password
-> IO ()
report Verbosity
verbosity RepoContext
repoCtxt Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword = do
  let repos :: [Repo]
      repos :: [Repo]
repos = RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt
      remoteRepos :: [RemoteRepo]
      remoteRepos :: [RemoteRepo]
remoteRepos = (Repo -> Maybe RemoteRepo) -> [Repo] -> [RemoteRepo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Repo -> Maybe RemoteRepo
maybeRepoRemote [Repo]
repos
  [RemoteRepo] -> (RemoteRepo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [RemoteRepo]
remoteRepos ((RemoteRepo -> IO ()) -> IO ()) -> (RemoteRepo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RemoteRepo
remoteRepo -> do
    let domain :: String
domain = String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Hackage" URIAuth -> String
uriRegName (Maybe URIAuth -> String) -> Maybe URIAuth -> String
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority (RemoteRepo -> URI
remoteRepoURI RemoteRepo
remoteRepo)
    Auth
auth <- String
-> Maybe Token -> Maybe Username -> Maybe Password -> IO Auth
createAuth String
domain Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword

    String
reportsDir <- IO String
defaultReportsDir
    let srcDir :: FilePath
        srcDir :: String
srcDir = String
reportsDir String -> String -> String
</> RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remoteRepo)
    -- We don't want to bomb out just because we haven't built any packages
    -- from this repo yet.
    Bool
srcExists <- String -> IO Bool
doesDirectoryExist String
srcDir
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
srcExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [String]
contents <- String -> IO [String]
getDirectoryContents String
srcDir
      [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
c -> String -> String
takeExtension String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".log") [String]
contents) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
logFile ->
        do
          String
inp <- String -> IO String
readFile (String
srcDir String -> String -> String
</> String
logFile)
          let (String
reportStr, String
buildLog) = String -> (String, String)
forall a. Read a => String -> a
Unsafe.read String
inp :: (String, String) -- TODO: eradicateNoParse
          case ByteString -> Either String BuildReport
parseBuildReport (String -> ByteString
toUTF8BS String
reportStr) of
            Left String
errs -> Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Errors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errs -- FIXME
            Right BuildReport
report' ->
              do
                Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                  String
"Uploading report for "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (BuildReport -> PackageIdentifier
BuildReport.package BuildReport
report')
                Verbosity
-> RepoContext
-> Auth
-> URI
-> [(BuildReport, Maybe String)]
-> IO ()
BuildReport.uploadReports
                  Verbosity
verbosity
                  RepoContext
repoCtxt
                  Auth
auth
                  (RemoteRepo -> URI
remoteRepoURI RemoteRepo
remoteRepo)
                  [(BuildReport
report', String -> Maybe String
forall a. a -> Maybe a
Just String
buildLog)]
                () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handlePackage
  :: HttpTransport
  -> Verbosity
  -> URI
  -> URI
  -> Maybe Auth
  -> IsCandidate
  -> FilePath
  -> IO ()
handlePackage :: HttpTransport
-> Verbosity
-> URI
-> URI
-> Maybe Auth
-> IsCandidate
-> String
-> IO ()
handlePackage HttpTransport
transport Verbosity
verbosity URI
uri URI
packageUri Maybe Auth
auth IsCandidate
isCandidate String
path =
  do
    (HttpCode, String)
resp <- HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> IO (HttpCode, String)
postHttpFile HttpTransport
transport Verbosity
verbosity URI
uri String
path Maybe Auth
auth
    case (HttpCode, String)
resp of
      (HttpCode
code, String
warnings)
        | HttpCode
code HttpCode -> [HttpCode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HttpCode
200, HttpCode
204] ->
            Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              IsCandidate -> String
okMessage IsCandidate
isCandidate
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
warnings then String
"" else String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
formatWarnings (String -> String
trim String
warnings)
      (HttpCode
code, String
err) -> do
        Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Error uploading "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"http code "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpCode -> String
forall {a}. Show a => a -> String
show HttpCode
code
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
        IO ()
forall a. IO a
exitFailure
  where
    okMessage :: IsCandidate -> String
    okMessage :: IsCandidate -> String
okMessage IsCandidate
IsCandidate =
      String
"Package successfully uploaded as candidate. "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"You can now preview the result at '"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall {a}. Show a => a -> String
show URI
packageUri
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. To publish the candidate, use 'cabal upload --publish'."
    okMessage IsCandidate
IsPublished =
      String
"Package successfully published. You can now view it at '"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall {a}. Show a => a -> String
show URI
packageUri
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."

formatWarnings :: String -> String
formatWarnings :: String -> String
formatWarnings String
x = String
"Warnings:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
x

createAuth
  :: String
  -> Maybe Token
  -> Maybe Username
  -> Maybe Password
  -> IO Auth
createAuth :: String
-> Maybe Token -> Maybe Username -> Maybe Password -> IO Auth
createAuth String
domain Maybe Token
mToken Maybe Username
mUsername Maybe Password
mPassword = case Maybe Token
mToken of
  Just Token
token -> Auth -> IO Auth
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Auth -> IO Auth) -> Auth -> IO Auth
forall a b. (a -> b) -> a -> b
$ String -> Auth
forall a b. b -> Either a b
Right (String -> Auth) -> String -> Auth
forall a b. (a -> b) -> a -> b
$ Token -> String
unToken Token
token
  -- Use username and password if no token is provided
  Maybe Token
Nothing -> do
    Username String
username <- IO Username
-> (Username -> IO Username) -> Maybe Username -> IO Username
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Username
promptUsername String
domain) Username -> IO Username
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Username
mUsername
    Password String
password <- IO Password
-> (Password -> IO Password) -> Maybe Password -> IO Password
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Password
promptPassword String
domain) Password -> IO Password
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Password
mPassword
    Auth -> IO Auth
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Auth -> IO Auth) -> Auth -> IO Auth
forall a b. (a -> b) -> a -> b
$ (String, String) -> Auth
forall a b. a -> Either a b
Left (String
username, String
password)