Commit b8e9e939 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Get the saved hackage username and password from the config file

rather than from the old ~/.cabal-upload/auth file.
Now uses ~/.cabal/config with:
hackage-username:
hackage-password:
parent e4cb2f24
......@@ -44,6 +44,7 @@ import Distribution.Simple.Configure (getInstalledPackages)
import qualified Distribution.Simple.Configure as Configure (configCompiler)
import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, toPathTemplate)
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
import Distribution.Simple.Setup (toFlag, fromFlagOrDefault)
import Distribution.Version (showVersion)
import Distribution.Verbosity (Verbosity, normal)
......@@ -143,6 +144,8 @@ defaultConfigFlags =
, configRepos = [Repo "hackage.haskell.org" "http://hackage.haskell.org/packages/archive"]
, configVerbose = normal
, configUserInstall = True
, configUploadUsername = mempty
, configUploadPassword = mempty
}
--
......@@ -197,7 +200,17 @@ configWriteFieldDescrs =
(text . show) (readS_to_P reads)
configCacheDir (\d cfg -> cfg { configCacheDir = d })
, boolField "user-install" configUserInstall (\u cfg -> cfg { configUserInstall = u })
]
, simpleField "hackage-username"
(text . show . fromFlagOrDefault "")
(fmap emptyToNothing $ readS_to_P reads)
configUploadUsername (\d cfg -> cfg { configUploadUsername = d })
, simpleField "hackage-password"
(text . show . fromFlagOrDefault "")
(fmap emptyToNothing $ readS_to_P reads)
configUploadPassword (\d cfg -> cfg { configUploadPassword = d })
]
where emptyToNothing "" = mempty
emptyToNothing f = toFlag f
installDirDescrs :: [FieldDescr (InstallDirs (Maybe PathTemplate))]
installDirDescrs =
......
......@@ -45,7 +45,8 @@ import Distribution.Simple.Setup (Flag, toFlag, fromFlagOrDefault,
flagToMaybe, flagToList)
import Distribution.Verbosity (Verbosity, normal, flagToVerbosity, showForCabal)
import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..))
import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..),
Username, Password)
import Hackage.Utils (readPToMaybe, parseDependencyOrPackageId)
import Control.Monad (MonadPlus(mplus))
......@@ -152,9 +153,6 @@ infoCommand = CommandUI {
-- * Upload flags
-- ------------------------------------------------------------
type Username = String
type Password = String
data UploadFlags = UploadFlags {
uploadCheck :: Flag Bool,
uploadUsername :: Flag Username,
......
......@@ -14,6 +14,7 @@ module Hackage.Types where
import Distribution.Simple.Compiler (CompilerFlavor)
import Distribution.Simple.InstallDirs (InstallDirs, PathTemplate)
import Distribution.Simple.Setup (Flag)
import Distribution.Package (PackageIdentifier)
import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.Version (Dependency)
......@@ -37,10 +38,15 @@ data ConfigFlags = ConfigFlags {
configCacheDir :: FilePath,
configRepos :: [Repo], -- ^Available Hackage servers.
configVerbose :: Verbosity,
configUserInstall :: Bool -- ^--user-install flag
configUserInstall :: Bool, -- ^--user-install flag
configUploadUsername :: Flag Username,
configUploadPassword :: Flag Password
}
deriving (Show)
type Username = String
type Password = String
data Repo = Repo {
repoName :: String,
repoURL :: String
......
......@@ -4,6 +4,7 @@
module Hackage.Upload (upload) where
import Hackage.Setup (UploadFlags(..))
import Hackage.Types (ConfigFlags(..))
import Distribution.Simple.Utils (debug, notice)
import Distribution.Simple.Setup (toFlag, fromFlag, flagToMaybe)
......@@ -14,13 +15,11 @@ import Network.HTTP (Header(..), HeaderName(..), Request(..),
RequestMethod(..), Response(..))
import Network.URI (URI, parseURI)
import Control.Monad (MonadPlus(mplus))
import Data.Monoid (Monoid(mappend))
import Data.Char (intToDigit)
import Numeric (showHex)
import System.Directory (doesFileExist, getAppUserDataDirectory)
import System.IO (hFlush, stdout)
import System.Random (randomRIO)
import System.FilePath ((</>))
type Username = String
type Password = String
......@@ -34,9 +33,9 @@ Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/che
upload :: UploadFlags -> [FilePath] -> IO ()
upload flags paths = do
flags' <- if needsAuth flags then getAuth flags else return flags
upload :: ConfigFlags -> UploadFlags -> [FilePath] -> IO ()
upload cfg flags paths = do
flags' <- if needsAuth flags then getAuth cfg flags else return flags
mapM_ (handlePackage flags') paths
handlePackage :: UploadFlags -> FilePath -> IO ()
......@@ -74,13 +73,14 @@ setAuth uri user pwd =
auPassword = pwd,
auSite = uri }
getAuth :: UploadFlags -> IO UploadFlags
getAuth flags =
do (mu, mp) <- readAuthFile
u <- case flagToMaybe (uploadUsername flags) `mplus` mu of
getAuth :: ConfigFlags -> UploadFlags -> IO UploadFlags
getAuth cfg flags =
do u <- case flagToMaybe $ configUploadUsername cfg
`mappend` uploadUsername flags of
Just u -> return u
Nothing -> promptUsername
p <- case flagToMaybe (uploadPassword flags) `mplus` mp of
p <- case flagToMaybe $ configUploadPassword cfg
`mappend` uploadPassword flags of
Just p -> return p
Nothing -> promptPassword
return $ flags { uploadUsername = toFlag u,
......@@ -98,19 +98,6 @@ promptPassword =
hFlush stdout
getLine
authFile :: IO FilePath
authFile = do dir <- getAppUserDataDirectory "cabal-upload"
return $ dir </> "auth"
readAuthFile :: IO (Maybe Username, Maybe Password)
readAuthFile =
do file <- authFile
e <- doesFileExist file
if e then do s <- readFile file
let (u,p) = read s
return (Just u, Just p)
else return (Nothing, Nothing)
ignoreMsg :: String -> IO ()
ignoreMsg _ = return ()
......
......@@ -172,9 +172,8 @@ fetchAction flags extraArgs = do
uploadAction :: UploadFlags -> [String] -> IO ()
uploadAction flags extraArgs = do
-- configFile <- defaultConfigFile --FIXME
-- config0 <- loadConfig configFile
-- let config = config0 { configVerbose = fromFlag $ uploadVerbosity flags }
configFile <- defaultConfigFile --FIXME
config <- loadConfig configFile
-- FIXME: check that the .tar.gz files exist and report friendly error message if not
let tarfiles = extraArgs
upload flags tarfiles
upload config flags tarfiles
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