Commit 3f41c6bb authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Use a custom ADT instead of a Bool.

parent 3e8c46be
...@@ -35,7 +35,7 @@ module Distribution.Client.Setup ...@@ -35,7 +35,7 @@ module Distribution.Client.Setup
, getCommand, unpackCommand, GetFlags(..) , getCommand, unpackCommand, GetFlags(..)
, checkCommand , checkCommand
, formatCommand , formatCommand
, uploadCommand, UploadFlags(..) , uploadCommand, UploadFlags(..), IsCandidate(..)
, reportCommand, ReportFlags(..) , reportCommand, ReportFlags(..)
, runCommand , runCommand
, initCommand, IT.InitFlags(..) , initCommand, IT.InitFlags(..)
...@@ -1426,8 +1426,12 @@ instance Semigroup InstallFlags where ...@@ -1426,8 +1426,12 @@ instance Semigroup InstallFlags where
-- * Upload flags -- * Upload flags
-- ------------------------------------------------------------ -- ------------------------------------------------------------
-- | Is this a candidate package or a package to be published?
data IsCandidate = IsCandidate | IsPublished
deriving Eq
data UploadFlags = UploadFlags { data UploadFlags = UploadFlags {
uploadCandidate :: Flag Bool, uploadCandidate :: Flag IsCandidate,
uploadDoc :: Flag Bool, uploadDoc :: Flag Bool,
uploadUsername :: Flag Username, uploadUsername :: Flag Username,
uploadPassword :: Flag Password, uploadPassword :: Flag Password,
...@@ -1437,7 +1441,7 @@ data UploadFlags = UploadFlags { ...@@ -1437,7 +1441,7 @@ data UploadFlags = UploadFlags {
defaultUploadFlags :: UploadFlags defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags { defaultUploadFlags = UploadFlags {
uploadCandidate = toFlag True, uploadCandidate = toFlag IsCandidate,
uploadDoc = toFlag False, uploadDoc = toFlag False,
uploadUsername = mempty, uploadUsername = mempty,
uploadPassword = mempty, uploadPassword = mempty,
...@@ -1463,7 +1467,7 @@ uploadCommand = CommandUI { ...@@ -1463,7 +1467,7 @@ uploadCommand = CommandUI {
,option [] ["publish"] ,option [] ["publish"]
"Publish the package instead of uploading it as a candidate." "Publish the package instead of uploading it as a candidate."
uploadCandidate (\v flags -> flags { uploadCandidate = v }) uploadCandidate (\v flags -> flags { uploadCandidate = v })
falseArg (noArg (Flag IsPublished))
,option ['d'] ["documentation"] ,option ['d'] ["documentation"]
("Upload documentation instead of a source package. " ("Upload documentation instead of a source package. "
......
...@@ -5,7 +5,7 @@ import Distribution.Client.Types ( Username(..), Password(..) ...@@ -5,7 +5,7 @@ import Distribution.Client.Types ( Username(..), Password(..)
import Distribution.Client.HttpUtils import Distribution.Client.HttpUtils
( HttpTransport(..), remoteRepoTryUpgradeToHttps ) ( HttpTransport(..), remoteRepoTryUpgradeToHttps )
import Distribution.Client.Setup import Distribution.Client.Setup
( RepoContext(..) ) ( IsCandidate(..), RepoContext(..) )
import Distribution.Simple.Utils (notice, warn, info, die) import Distribution.Simple.Utils (notice, warn, info, die)
import Distribution.Verbosity (Verbosity) import Distribution.Verbosity (Verbosity)
...@@ -42,9 +42,9 @@ stripExtensions exts path = foldM f path (reverse exts) ...@@ -42,9 +42,9 @@ stripExtensions exts path = foldM f path (reverse exts)
| otherwise = Nothing | otherwise = Nothing
upload :: Verbosity -> RepoContext upload :: Verbosity -> RepoContext
-> Maybe Username -> Maybe Password -> Bool -> [FilePath] -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]
-> IO () -> IO ()
upload verbosity repoCtxt mUsername mPassword candidate paths = do upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
let repos = repoContextRepos repoCtxt let repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt transport <- repoContextGetTransport repoCtxt
targetRepo <- targetRepo <-
...@@ -55,15 +55,17 @@ upload verbosity repoCtxt mUsername mPassword candidate paths = do ...@@ -55,15 +55,17 @@ upload verbosity repoCtxt mUsername mPassword candidate paths = do
rootIfEmpty x = if null x then "/" else x rootIfEmpty x = if null x then "/" else x
uploadURI = targetRepoURI { uploadURI = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</> uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>
if candidate case isCandidate of
then "packages/candidates" IsCandidate -> "packages/candidates"
else "upload" IsPublished -> "upload"
} }
packageURI pkgid = targetRepoURI { packageURI pkgid = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI) uriPath = rootIfEmpty (uriPath targetRepoURI)
FilePath.Posix.</> concat FilePath.Posix.</> concat
[ "package/", pkgid [ "package/", pkgid
, if candidate then "/candidate" else "" , case isCandidate of
IsCandidate -> "/candidate"
IsPublished -> ""
] ]
} }
Username username <- maybe promptUsername return mUsername Username username <- maybe promptUsername return mUsername
...@@ -73,15 +75,15 @@ upload verbosity repoCtxt mUsername mPassword candidate paths = do ...@@ -73,15 +75,15 @@ upload verbosity repoCtxt mUsername mPassword candidate paths = do
notice verbosity $ "Uploading " ++ path ++ "... " notice verbosity $ "Uploading " ++ path ++ "... "
case fmap takeFileName (stripExtensions ["tar", "gz"] path) of case fmap takeFileName (stripExtensions ["tar", "gz"] path) of
Just pkgid -> handlePackage transport verbosity uploadURI Just pkgid -> handlePackage transport verbosity uploadURI
(packageURI pkgid) auth candidate path (packageURI pkgid) auth isCandidate path
-- This case shouldn't really happen, since we check in Main that we -- This case shouldn't really happen, since we check in Main that we
-- only pass tar.gz files to upload. -- only pass tar.gz files to upload.
Nothing -> die $ "Not a tar.gz file: " ++ path Nothing -> die $ "Not a tar.gz file: " ++ path
uploadDoc :: Verbosity -> RepoContext uploadDoc :: Verbosity -> RepoContext
-> Maybe Username -> Maybe Password -> Bool -> FilePath -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath
-> IO () -> IO ()
uploadDoc verbosity repoCtxt mUsername mPassword candidate path = do uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do
let repos = repoContextRepos repoCtxt let repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt transport <- repoContextGetTransport repoCtxt
targetRepo <- targetRepo <-
...@@ -94,7 +96,9 @@ uploadDoc verbosity repoCtxt mUsername mPassword candidate path = do ...@@ -94,7 +96,9 @@ uploadDoc verbosity repoCtxt mUsername mPassword candidate path = do
uriPath = rootIfEmpty (uriPath targetRepoURI) uriPath = rootIfEmpty (uriPath targetRepoURI)
FilePath.Posix.</> concat FilePath.Posix.</> concat
[ "package/", pkgid [ "package/", pkgid
, if candidate then "/candidate" else "" , case isCandidate of
IsCandidate -> "/candidate"
IsPublished -> ""
, "/docs" , "/docs"
] ]
} }
...@@ -171,12 +175,12 @@ report verbosity repoCtxt mUsername mPassword = do ...@@ -171,12 +175,12 @@ report verbosity repoCtxt mUsername mPassword = do
return () return ()
handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth
-> Bool -> FilePath -> IO () -> IsCandidate -> FilePath -> IO ()
handlePackage transport verbosity uri packageUri auth candidate path = handlePackage transport verbosity uri packageUri auth isCandidate path =
do resp <- postHttpFile transport verbosity uri path auth do resp <- postHttpFile transport verbosity uri path auth
case resp of case resp of
(code,warnings) | code `elem` [200, 204] -> (code,warnings) | code `elem` [200, 204] ->
notice verbosity $ okMessage ++ notice verbosity $ okMessage isCandidate ++
if null warnings then "" else "\n" ++ formatWarnings (trim warnings) if null warnings then "" else "\n" ++ formatWarnings (trim warnings)
(code,err) -> do (code,err) -> do
notice verbosity $ "Error uploading " ++ path ++ ": " notice verbosity $ "Error uploading " ++ path ++ ": "
...@@ -184,13 +188,13 @@ handlePackage transport verbosity uri packageUri auth candidate path = ...@@ -184,13 +188,13 @@ handlePackage transport verbosity uri packageUri auth candidate path =
++ err ++ err
exitFailure exitFailure
where where
okMessage okMessage IsCandidate =
| candidate = "Package successfully uploaded as candidate. "
"Package successfully uploaded as candidate. " ++ "You can now preview the result at '" ++ show packageUri
++ "You can now preview the result at '" ++ show packageUri ++ "'. To publish the candidate, use 'cabal upload --publish'."
++ "'. To publish the candidate, use 'cabal upload --publish'." okMessage IsPublished =
| otherwise = "Package successfully published. You can now view it at '" "Package successfully published. You can now view it at '"
++ show packageUri ++ "'." ++ show packageUri ++ "'."
formatWarnings :: String -> String formatWarnings :: String -> String
formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment