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

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

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

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

import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (parseBuildReport)
import qualified Distribution.Client.BuildReports.Upload as BuildReport

import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName))
import Network.HTTP (Header(..), HeaderName(..))

import System.IO        (hFlush, stdout)
import System.IO.Echo   (withoutInputEcho)
import System.FilePath  ((</>), takeExtension, takeFileName, dropExtension)
import qualified System.FilePath.Posix as FilePath.Posix ((</>))
import System.Directory

type Auth = Maybe (String, String)

-- > 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 = 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 (forall a. [a] -> [a]
reverse [String]
exts)
 where
  f :: String -> String -> Maybe String
f String
p String
e
    | String -> String
takeExtension String
p forall a. Eq a => a -> a -> Bool
== Char
'.'forall a. a -> [a] -> [a]
:String
e = forall a. a -> Maybe a
Just (String -> String
dropExtension String
p)
    | Bool
otherwise = forall a. Maybe a
Nothing

upload :: Verbosity -> RepoContext
       -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]
       -> IO ()
upload :: Verbosity
-> RepoContext
-> Maybe Username
-> Maybe Password
-> IsCandidate
-> [String]
-> IO ()
upload Verbosity
verbosity RepoContext
repoCtxt 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 <- forall a b. (a -> b) -> [a] -> [b]
map Repo -> Maybe RemoteRepo
maybeRepoRemote [Repo]
repos ] of
        [] -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Cannot upload. No remote repositories are configured."
        (RemoteRepo
r:[RemoteRepo]
rs) -> Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps Verbosity
verbosity HttpTransport
transport (forall a. NonEmpty a -> a
last (RemoteRepo
rforall a. a -> [a] -> NonEmpty a
:|[RemoteRepo]
rs))
    let targetRepoURI :: URI
        targetRepoURI :: URI
targetRepoURI = RemoteRepo -> URI
remoteRepoURI RemoteRepo
targetRepo
        domain :: String
        domain :: String
domain = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Hackage" URIAuth -> String
uriRegName forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority URI
targetRepoURI
        rootIfEmpty :: String -> String
rootIfEmpty String
x = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then String
"/" else String
x
        uploadURI :: URI
        uploadURI :: URI
uploadURI = URI
targetRepoURI {
            uriPath :: String
uriPath = String -> String
rootIfEmpty (URI -> String
uriPath URI
targetRepoURI) String -> String -> String
FilePath.Posix.</>
              case IsCandidate
isCandidate of
                IsCandidate
IsCandidate -> String
"packages/candidates"
                IsCandidate
IsPublished -> String
"upload"
        }
        packageURI :: String -> URI
packageURI String
pkgid = URI
targetRepoURI {
            uriPath :: String
uriPath = String -> String
rootIfEmpty (URI -> String
uriPath URI
targetRepoURI)
                      String -> String -> String
FilePath.Posix.</> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ String
"package/", String
pkgid
              , case IsCandidate
isCandidate of
                  IsCandidate
IsCandidate -> String
"/candidate"
                  IsCandidate
IsPublished -> String
""
              ]
        }
    Username String
username <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Username
promptUsername String
domain) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Username
mUsername
    Password String
password <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Password
promptPassword String
domain) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Password
mPassword
    let auth :: Maybe (String, String)
auth = forall a. a -> Maybe a
Just (String
username,String
password)
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
paths forall a b. (a -> b) -> a -> b
$ \String
path -> do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Uploading " forall a. [a] -> [a] -> [a]
++ String
path forall a. [a] -> [a] -> [a]
++ String
"... "
      case 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 (String, String)
-> IsCandidate
-> String
-> IO ()
handlePackage HttpTransport
transport Verbosity
verbosity URI
uploadURI
                                    (String -> URI
packageURI String
pkgid) Maybe (String, String)
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 -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Not a tar.gz file: " forall a. [a] -> [a] -> [a]
++ String
path

uploadDoc :: Verbosity -> RepoContext
          -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath
          -> IO ()
uploadDoc :: Verbosity
-> RepoContext
-> Maybe Username
-> Maybe Password
-> IsCandidate
-> String
-> IO ()
uploadDoc Verbosity
verbosity RepoContext
repoCtxt 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 <- forall a b. (a -> b) -> [a] -> [b]
map Repo -> Maybe RemoteRepo
maybeRepoRemote [Repo]
repos ] of
        [] -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Cannot upload. No remote repositories are configured."
        (RemoteRepo
r:[RemoteRepo]
rs) -> Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps Verbosity
verbosity HttpTransport
transport (forall a. NonEmpty a -> a
last (RemoteRepo
rforall a. a -> [a] -> NonEmpty a
:|[RemoteRepo]
rs))
    let targetRepoURI :: URI
targetRepoURI = RemoteRepo -> URI
remoteRepoURI RemoteRepo
targetRepo
        domain :: String
domain = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Hackage" URIAuth -> String
uriRegName forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
uriAuthority URI
targetRepoURI
        rootIfEmpty :: String -> String
rootIfEmpty String
x = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then String
"/" else String
x
        uploadURI :: URI
uploadURI = URI
targetRepoURI {
            uriPath :: String
uriPath = String -> String
rootIfEmpty (URI -> String
uriPath URI
targetRepoURI)
                      String -> String -> String
FilePath.Posix.</> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ String
"package/", String
pkgid
              , case IsCandidate
isCandidate of
                IsCandidate
IsCandidate -> String
"/candidate"
                IsCandidate
IsPublished -> String
""
              , String
"/docs"
              ]
        }
        packageUri :: URI
packageUri = URI
targetRepoURI {
            uriPath :: String
uriPath = String -> String
rootIfEmpty (URI -> String
uriPath URI
targetRepoURI)
                      String -> String -> String
FilePath.Posix.</> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ String
"package/", String
pkgid
              , case IsCandidate
isCandidate of
                  IsCandidate
IsCandidate -> String
"/candidate"
                  IsCandidate
IsPublished -> String
""
              ]
        }
        (String
reverseSuffix, String
reversePkgid) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'-')
                                        (forall a. [a] -> [a]
reverse (String -> String
takeFileName String
path))
        pkgid :: String
pkgid = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
Unsafe.tail String
reversePkgid
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. [a] -> [a]
reverse String
reverseSuffix forall a. Eq a => a -> a -> Bool
/= String
"docs.tar.gz"
          Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
reversePkgid Bool -> Bool -> Bool
|| forall a. [a] -> a
Unsafe.head String
reversePkgid forall a. Eq a => a -> a -> Bool
/= Char
'-') forall a b. (a -> b) -> a -> b
$
      forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Expected a file name matching the pattern <pkgid>-docs.tar.gz"
    Username String
username <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Username
promptUsername String
domain) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Username
mUsername
    Password String
password <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Password
promptPassword String
domain) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Password
mPassword

    let auth :: Maybe (String, String)
auth = forall a. a -> Maybe a
Just (String
username,String
password)
        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 forall a b. (a -> b) -> a -> b
$ String
"Uploading documentation " forall a. [a] -> [a] -> [a]
++ String
path forall a. [a] -> [a] -> [a]
++ String
"... "
    (HttpCode, String)
resp <- HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe (String, String)
-> [Header]
-> IO (HttpCode, String)
putHttpFile HttpTransport
transport Verbosity
verbosity URI
uploadURI String
path Maybe (String, String)
auth [Header]
headers
    case (HttpCode, String)
resp of
      -- Hackage responds with 204 No Content when docs are uploaded
      -- successfully.
      (HttpCode
code,String
_) | HttpCode
code forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HttpCode
200,HttpCode
204] -> do
        Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> String
okMessage URI
packageUri
      (HttpCode
code,String
err)  -> do
        Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Error uploading documentation "
                        forall a. [a] -> [a] -> [a]
++ String
path forall a. [a] -> [a] -> [a]
++ String
": "
                        forall a. [a] -> [a] -> [a]
++ String
"http code " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String
show HttpCode
code forall a. [a] -> [a] -> [a]
++ String
"\n"
                        forall a. [a] -> [a] -> [a]
++ String
err
        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. "
        forall a. [a] -> [a] -> [a]
++ String
"You can now preview the result at '" forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String
show a
packageUri
        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 '"
        forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String
show a
packageUri forall a. [a] -> [a] -> [a]
++ String
"'."


promptUsername :: String -> IO Username
promptUsername :: String -> IO Username
promptUsername String
domain = do
  String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
domain forall a. [a] -> [a] -> [a]
++ String
" username: "
  Handle -> IO ()
hFlush Handle
stdout
  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 forall a b. (a -> b) -> a -> b
$ String
domain 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 <- forall a. IO a -> IO a
withoutInputEcho forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Password
Password IO String
getLine
  String -> IO ()
putStrLn String
""
  forall (m :: * -> *) a. Monad m => a -> m a
return Password
passwd

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

      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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
srcExists forall a b. (a -> b) -> a -> b
$ do
        [String]
contents <- String -> IO [String]
getDirectoryContents String
srcDir
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. (a -> Bool) -> [a] -> [a]
filter (\String
c -> String -> String
takeExtension String
c forall a. Eq a => a -> a -> Bool
==String
".log") [String]
contents) 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) = 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 forall a b. (a -> b) -> a -> b
$ String
"Errors: " forall a. [a] -> [a] -> [a]
++ String
errs -- FIXME
               Right BuildReport
report' ->
                 do Verbosity -> String -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Uploading report for "
                      forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (BuildReport -> PackageIdentifier
BuildReport.package BuildReport
report')
                    Verbosity
-> RepoContext
-> (String, String)
-> URI
-> [(BuildReport, Maybe String)]
-> IO ()
BuildReport.uploadReports Verbosity
verbosity RepoContext
repoCtxt (String, String)
auth
                      (RemoteRepo -> URI
remoteRepoURI RemoteRepo
remoteRepo) [(BuildReport
report', forall a. a -> Maybe a
Just String
buildLog)]
                    forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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