Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
f18e9bdd
Commit
f18e9bdd
authored
Dec 17, 2007
by
Duncan Coutts
Browse files
Initial integration of upload feature
It still uses it's own config file, but now uses the same command line stuff
parent
530091ec
Changes
4
Hide whitespace changes
Inline
Side-by-side
cabal-install/Hackage/Setup.hs
View file @
f18e9bdd
...
...
@@ -17,6 +17,7 @@ module Hackage.Setup
,
updateCommand
,
infoCommand
,
fetchCommand
,
uploadCommand
,
UploadFlags
(
..
)
,
parsePackageArgs
,
updateConfig
...
...
@@ -48,6 +49,7 @@ import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..))
import
Hackage.Utils
(
readPToMaybe
,
parseDependencyOrPackageId
)
import
Control.Monad
(
MonadPlus
(
mplus
))
import
Data.Monoid
(
Monoid
(
..
))
-- | This function updates the configuration with the cabal configure flags.
updateConfig
::
Cabal
.
ConfigFlags
->
ConfigFlags
->
ConfigFlags
...
...
@@ -146,6 +148,78 @@ infoCommand = CommandUI {
commandOptions
=
\
_
->
[
optionVerbose
id
const
]
}
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------
type
Username
=
String
type
Password
=
String
data
UploadFlags
=
UploadFlags
{
uploadCheck
::
Flag
Bool
,
uploadUsername
::
Flag
Username
,
uploadPassword
::
Flag
Password
,
uploadVerbosity
::
Flag
Verbosity
}
deriving
(
Show
)
defaultUploadFlags
::
UploadFlags
defaultUploadFlags
=
UploadFlags
{
uploadCheck
=
toFlag
False
,
uploadUsername
=
mempty
,
uploadPassword
=
mempty
,
uploadVerbosity
=
toFlag
normal
}
uploadCommand
::
CommandUI
UploadFlags
uploadCommand
=
CommandUI
{
commandName
=
"upload"
,
commandSynopsis
=
"Uploads source packages to Hackage"
,
commandDescription
=
Just
$
\
_
->
"You can store your Hackage login in "
++
"FIXME: configFile"
++
"
\n
using the format (
\"
username
\"
,
\"
password
\"
).
\n
"
,
commandUsage
=
\
pname
->
"Usage: "
++
pname
++
" upload [FLAGS] [TARFILES]
\n\n
"
++
"Flags for upload:"
,
commandDefaultFlags
=
defaultUploadFlags
,
commandOptions
=
\
_
->
[
optionVerbose
uploadVerbosity
(
\
v
flags
->
flags
{
uploadVerbosity
=
v
})
,
option
[
'c'
]
[
"check"
]
"Do not upload, just do QA checks."
uploadCheck
(
\
v
flags
->
flags
{
uploadCheck
=
v
})
(
noArg
(
toFlag
True
)
(
fromFlagOrDefault
False
))
,
option
[
'u'
]
[
"username"
]
"Hackage username."
uploadUsername
(
\
v
flags
->
flags
{
uploadUsername
=
v
})
(
reqArg
"USERNAME"
toFlag
flagToList
)
,
option
[
'p'
]
[
"password"
]
"Hackage password."
uploadPassword
(
\
v
flags
->
flags
{
uploadPassword
=
v
})
(
reqArg
"PASSWORD"
toFlag
flagToList
)
]
}
instance
Monoid
UploadFlags
where
mempty
=
UploadFlags
{
uploadCheck
=
mempty
,
uploadUsername
=
mempty
,
uploadPassword
=
mempty
,
uploadVerbosity
=
mempty
}
mappend
a
b
=
UploadFlags
{
uploadCheck
=
combine
uploadCheck
,
uploadUsername
=
combine
uploadUsername
,
uploadPassword
=
combine
uploadPassword
,
uploadVerbosity
=
combine
uploadVerbosity
}
where
combine
field
=
field
a
`
mappend
`
field
b
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
optionVerbose
::
(
flags
->
Flag
Verbosity
)
->
(
Flag
Verbosity
->
flags
->
flags
)
->
Option
flags
...
...
cabal-install/Hackage/Upload.hs
View file @
f18e9bdd
-- This is a quick hack for uploading packages to Hackage.
-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload
import
Network.Browser
import
Network.HTTP
import
System.FilePath
((
</>
))
import
Control.Monad
import
Data.Char
import
Data.Maybe
import
Network.URI
import
Numeric
import
System.Console.GetOpt
import
System.Directory
import
System.Environment
import
System.Exit
import
System.IO
import
System.Random
module
Hackage.Upload
(
upload
)
where
import
Hackage.Setup
(
UploadFlags
(
..
))
import
Distribution.Simple.Utils
(
debug
,
notice
)
import
Distribution.Simple.Setup
(
toFlag
,
fromFlag
,
flagToMaybe
)
import
Network.Browser
(
BrowserAction
,
browse
,
request
,
Authority
(
..
),
addAuthority
,
setOutHandler
,
setErrHandler
)
import
Network.HTTP
(
Header
(
..
),
HeaderName
(
..
),
Request
(
..
),
RequestMethod
(
..
),
Response
(
..
))
import
Network.URI
(
URI
,
parseURI
)
import
Control.Monad
(
MonadPlus
(
mplus
))
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
uploadURI
::
URI
uploadURI
=
fromJust
$
parseURI
"http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"
Just
uploadURI
=
parseURI
"http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"
checkURI
::
URI
checkURI
=
fromJust
$
parseURI
"http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"
Just
checkURI
=
parseURI
"http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"
main
::
IO
()
main
=
do
args
<-
getArgs
(
opts
,
paths
)
<-
parseOptions
args
opts'
<-
if
needsAuth
opts
then
getAuth
opts
else
return
opts
mapM_
(
handlePackage
opts'
)
paths
upload
::
UploadFlags
->
[
FilePath
]
->
IO
()
upload
flags
paths
=
do
flags'
<-
if
needsAuth
flags
then
getAuth
flags
else
return
flags
mapM_
(
handlePackage
flags'
)
paths
handlePackage
::
Option
s
->
FilePath
->
IO
()
handlePackage
opt
s
path
=
do
(
uri
,
auth
)
<-
if
optCheck
opts
then
do
output
1
opts
$
"Checking "
++
path
++
"... "
handlePackage
::
UploadFlag
s
->
FilePath
->
IO
()
handlePackage
flag
s
path
=
do
(
uri
,
auth
)
<-
if
fromFlag
(
uploadCheck
flags
)
then
do
notice
verbosity
$
"Checking "
++
path
++
"... "
return
(
checkURI
,
return
()
)
else
do
output
1
opts
$
"Uploading "
++
path
++
"... "
else
do
notice
verbosity
$
"Uploading "
++
path
++
"... "
return
(
uploadURI
,
setAuth
uploadURI
(
from
Just
(
opt
Username
opt
s
))
(
from
Just
(
opt
Password
opt
s
)))
(
from
Flag
(
upload
Username
flag
s
))
(
from
Flag
(
upload
Password
flag
s
)))
req
<-
mkRequest
uri
path
debug
opts
$
"
\n
"
++
show
req
debug
verbosity
$
"
\n
"
++
show
req
(
_
,
resp
)
<-
browse
(
setErrHandler
ignoreMsg
>>
setOutHandler
ignoreMsg
>>
auth
>>
request
req
)
debug
opts
$
show
resp
debug
verbosity
$
show
resp
case
rspCode
resp
of
(
2
,
0
,
0
)
->
do
outputLn
1
opts
"OK"
(
x
,
y
,
z
)
->
do
outputLn
1
opts
"ERROR"
outputLn
0
opts
$
"ERROR: "
++
path
++
": "
++
map
intToDigit
[
x
,
y
,
z
]
++
" "
++
rspReason
resp
outputLn
3
opts
$
rspBody
resp
(
2
,
0
,
0
)
->
do
notice
verbosity
"OK"
(
x
,
y
,
z
)
->
do
notice
verbosity
$
"ERROR: "
++
path
++
": "
++
map
intToDigit
[
x
,
y
,
z
]
++
" "
++
rspReason
resp
debug
verbosity
$
rspBody
resp
where
verbosity
=
fromFlag
(
uploadVerbosity
flags
)
needsAuth
::
Option
s
->
Bool
needsAuth
=
not
.
opt
Check
needsAuth
::
UploadFlag
s
->
Bool
needsAuth
=
not
.
fromFlag
.
upload
Check
setAuth
::
URI
->
Username
->
Password
->
BrowserAction
()
setAuth
uri
user
pwd
=
...
...
@@ -70,17 +74,17 @@ setAuth uri user pwd =
auPassword
=
pwd
,
auSite
=
uri
}
getAuth
::
Options
->
IO
Option
s
getAuth
opt
s
=
getAuth
::
UploadFlags
->
IO
UploadFlag
s
getAuth
flag
s
=
do
(
mu
,
mp
)
<-
readAuthFile
u
<-
case
opt
Username
opts
`
mplus
`
mu
of
u
<-
case
flagToMaybe
(
upload
Username
flags
)
`
mplus
`
mu
of
Just
u
->
return
u
Nothing
->
promptUsername
p
<-
case
opt
Password
opts
`
mplus
`
mp
of
p
<-
case
flagToMaybe
(
upload
Password
flags
)
`
mplus
`
mp
of
Just
p
->
return
p
Nothing
->
promptPassword
return
$
opts
{
opt
Username
=
Just
u
,
opt
Password
=
Just
p
}
return
$
flags
{
upload
Username
=
toFlag
u
,
upload
Password
=
toFlag
p
}
promptUsername
::
IO
Username
promptUsername
=
...
...
@@ -151,66 +155,3 @@ printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ con
crlf
::
String
crlf
=
"
\r\n
"
-- * Command-line options
data
Options
=
Options
{
optUsername
::
Maybe
Username
,
optPassword
::
Maybe
Password
,
optCheck
::
Bool
,
optVerbosity
::
Int
}
deriving
(
Show
)
defaultOptions
::
Options
defaultOptions
=
Options
{
optUsername
=
Nothing
,
optPassword
=
Nothing
,
optCheck
=
False
,
optVerbosity
=
1
}
optDescr
::
[
OptDescr
(
Options
->
Options
)]
optDescr
=
[
Option
[
'c'
]
[
"check"
]
(
NoArg
(
\
o
->
o
{
optCheck
=
True
}))
"Don't upload, just check."
,
Option
[
'u'
]
[
"username"
]
(
ReqArg
(
\
u
o
->
o
{
optUsername
=
Just
u
})
"USERNAME"
)
"Hackage username."
,
Option
[
'p'
]
[
"password"
]
(
ReqArg
(
\
u
o
->
o
{
optPassword
=
Just
u
})
"PASSWORD"
)
"Hackage password."
,
Option
"v"
[
"verbose"
]
(
OptArg
(
\
u
o
->
o
{
optVerbosity
=
maybe
3
read
u
})
"N"
)
"Control verbosity (N is 0--5, normal verbosity level is 1, -v alone is equivalent to -v3)"
,
Option
[
'q'
]
[
"quiet"
]
(
NoArg
(
\
o
->
o
{
optVerbosity
=
0
}))
"Only essential output. Same as -v 0."
]
parseOptions
::
[
String
]
->
IO
(
Options
,
[
FilePath
])
parseOptions
args
=
do
let
(
fs
,
files
,
nonopts
,
errs
)
=
getOpt'
RequireOrder
optDescr
args
when
(
not
(
null
errs
))
$
die
errs
case
nonopts
of
[]
->
return
$
(
foldl
(
flip
(
$
))
defaultOptions
fs
,
files
)
[
"--help"
]
->
usage
_
->
die
(
map
((
"unrecognized option "
++
)
.
show
)
nonopts
)
die
::
[
String
]
->
IO
a
die
errs
=
do
mapM_
(
\
e
->
hPutStrLn
stderr
$
"cabal-upload: "
++
e
)
$
errs
hPutStrLn
stderr
"Try `cabal-upload --help' for more information."
exitFailure
usage
::
IO
a
usage
=
do
aFile
<-
authFile
let
hdr
=
unlines
[
"cabal-upload uploads Cabal source packages to Hackage."
,
""
,
"You can store your Hackage login in "
++
aFile
,
"using the format (
\"
username
\"
,
\"
password
\"
)."
,
""
,
"Usage: cabal-upload [OPTION ...] [FILE ...]"
]
putStrLn
(
usageInfo
hdr
optDescr
)
exitWith
ExitSuccess
-- * Logging
debug
=
outputLn
5
output
::
Int
->
Options
->
String
->
IO
()
output
n
opts
s
=
when
(
optVerbosity
opts
>=
n
)
$
do
hPutStr
stderr
s
hFlush
stderr
outputLn
::
Int
->
Options
->
String
->
IO
()
outputLn
n
opts
s
=
output
n
opts
(
s
++
"
\n
"
)
cabal-install/Main.hs
View file @
f18e9bdd
...
...
@@ -29,6 +29,7 @@ import Hackage.Info (info)
import
Hackage.Update
(
update
)
import
Hackage.Fetch
(
fetch
)
--import Hackage.Clean (clean)
import
Hackage.Upload
(
upload
)
import
Distribution.Verbosity
(
Verbosity
,
normal
)
import
Distribution.Version
(
showVersion
)
...
...
@@ -77,6 +78,7 @@ mainWorker args =
,
listCommand
`
commandAddAction
`
listAction
,
updateCommand
`
commandAddAction
`
updateAction
,
fetchCommand
`
commandAddAction
`
fetchAction
,
uploadCommand
`
commandAddAction
`
uploadAction
,
wrapperAction
(
Cabal
.
configureCommand
defaultProgramConfiguration
)
,
wrapperAction
(
Cabal
.
buildCommand
defaultProgramConfiguration
)
...
...
@@ -168,3 +170,12 @@ fetchAction flags extraArgs = do
case
parsePackageArgs
extraArgs
of
Left
err
->
putStrLn
err
>>
exitWith
(
ExitFailure
1
)
Right
pkgs
->
fetch
config
comp
conf
pkgs
uploadAction
::
UploadFlags
->
[
String
]
->
IO
()
uploadAction
flags
extraArgs
=
do
-- configFile <- defaultConfigFile --FIXME
-- config0 <- loadConfig configFile
-- let config = config0 { configVerbose = fromFlag $ uploadVerbosity flags }
-- FIXME: check that the .tar.gz files exist and report friendly error message if not
let
tarfiles
=
extraArgs
upload
flags
tarfiles
cabal-install/cabal-install.cabal
View file @
f18e9bdd
...
...
@@ -39,6 +39,7 @@ Executable cabal
Hackage.Tar
Hackage.Types
Hackage.Update
Hackage.Upload
Hackage.Utils
build-depends: Cabal >= 1.3.2, filepath >= 1.0, network,
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment