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 :: [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
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
(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
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)
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)
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
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