Skip to content

Commit 4c736d7

Browse files
edskoedsko
committed
Improvements to the mirror client
* Split mirror clients into multiple modules * Generalize to multiple repo kinds, distinguishing between source and target * Basic support for mirroring to local repo * Use parsec to parse mirror config * When reading the index, only look for .cabal files * Simplify MirrorSession monad * Basic support for secure repos * Actually copy index/TUF files when mirror is done * Cache the index for the target repo * Remove support for Hackage 1 * Lower max rate on hackage to every 5 mins * Avoid updating target index if unchanged. * Add post-mirror-hook
1 parent 4b2770a commit 4c736d7

File tree

14 files changed

+1861
-867
lines changed

14 files changed

+1861
-867
lines changed

‎Distribution/Client.hs

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
module Distribution.Client
33
( -- * Command line handling
44
validateHackageURI
5+
, validateHackageURI'
56
, validatePackageIds
67
-- * Fetching info from source and destination servers
78
, PkgIndexInfo(..)
@@ -67,11 +68,14 @@ import qualified System.FilePath.Posix as Posix
6768

6869
validateHackageURI :: String -> Either String URI
6970
validateHackageURI str = case parseURI str of
70-
Nothing -> Left ("invalid URL " ++ str)
71-
Just uri
72-
| uriScheme uri /= "http:" -> Left ("only http URLs are supported " ++ str)
73-
| isNothing (uriAuthority uri) -> Left ("server name required in URL " ++ str)
74-
| otherwise -> Right uri
71+
Nothing -> Left ("invalid URL " ++ str)
72+
Just uri -> validateHackageURI' uri
73+
74+
validateHackageURI' :: URI -> Either String URI
75+
validateHackageURI' uri
76+
| uriScheme uri /= "http:" = Left $ "only http URLs are supported " ++ show uri
77+
| isNothing (uriAuthority uri) = Left $ "server name required in URL " ++ show uri
78+
| otherwise = Right uri
7579

7680
validatePackageIds :: [String] -> Either String [PackageId]
7781
validatePackageIds pkgstrs =
@@ -116,7 +120,7 @@ downloadOldIndex uri cacheDir = do
116120

117121
pkgids <- withFile indexFile ReadMode $ \hnd -> do
118122
content <- BS.hGetContents hnd
119-
case PackageIndex.read (\pkgid _ -> pkgid) (GZip.decompressNamed indexFile content) of
123+
case PackageIndex.read (\pkgid _ -> pkgid) (const True) (GZip.decompressNamed indexFile content) of
120124
Right pkgs -> return pkgs
121125
Left theError ->
122126
die $ "Error parsing index at " ++ show uri ++ ": " ++ theError
@@ -170,7 +174,7 @@ readNewIndex :: FilePath -> HttpSession [PkgIndexInfo]
170174
readNewIndex cacheDir = do
171175
liftIO $ withFile indexFile ReadMode $ \hnd -> do
172176
content <- BS.hGetContents hnd
173-
case PackageIndex.read selectDetails (GZip.decompressNamed indexFile content) of
177+
case PackageIndex.read selectDetails (const True) (GZip.decompressNamed indexFile content) of
174178
Left theError ->
175179
error ("Error parsing index at " ++ show indexFile ++ ": "
176180
++ theError)

‎Distribution/Client/Index.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,9 +38,10 @@ import Prelude hiding (read)
3838
-- belonging to a package are ignored.
3939
--
4040
read :: (PackageIdentifier -> Tar.Entry -> pkg)
41+
-> (FilePath -> Bool) -- ^ Should this file be included?
4142
-> ByteString
4243
-> Either String [pkg]
43-
read mkPackage indexFileContent = collect [] entries
44+
read mkPackage includeFile indexFileContent = collect [] entries
4445
where
4546
entries = Tar.read indexFileContent
4647
collect es' Tar.Done = Right es'
@@ -53,6 +54,7 @@ read mkPackage indexFileContent = collect [] entries
5354
| [pkgname,versionStr,_] <- splitDirectories (normalise (Tar.entryPath e))
5455
, Just version <- simpleParse versionStr
5556
, [] <- versionTags version
57+
, True <- includeFile (Tar.entryPath e)
5658
= let pkgid = PackageIdentifier (PackageName pkgname) version
5759
in Just (mkPackage pkgid e)
5860
entry _ = Nothing

‎Distribution/Client/Mirror/CmdLine.hs

Lines changed: 178 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,178 @@
1+
module Distribution.Client.Mirror.CmdLine (
2+
MirrorOpts(..)
3+
, validateOpts
4+
) where
5+
6+
-- stdlib
7+
import Control.Monad
8+
import Data.Maybe (fromMaybe)
9+
import System.Exit (exitSuccess)
10+
import System.Console.GetOpt
11+
12+
-- Cabal
13+
import Distribution.Package
14+
import Distribution.Verbosity
15+
import Distribution.Simple.Utils hiding (warn)
16+
17+
-- hackage
18+
import Distribution.Client (validatePackageIds)
19+
import Distribution.Client.Mirror.Config
20+
21+
data MirrorOpts = MirrorOpts {
22+
mirrorConfig :: MirrorConfig,
23+
stateDir :: FilePath,
24+
selectedPkgs :: [PackageId],
25+
continuous :: Maybe Int, -- if so, interval in minutes
26+
mo_keepGoing :: Bool,
27+
mirrorUploaders :: Bool
28+
}
29+
30+
data MirrorFlags = MirrorFlags {
31+
flagCacheDir :: Maybe FilePath,
32+
flagContinuous :: Bool,
33+
flagInterval :: Maybe String,
34+
flagKeepGoing :: Bool,
35+
flagMirrorUploaders :: Bool,
36+
flagVerbosity :: Verbosity,
37+
flagHelp :: Bool
38+
}
39+
40+
defaultMirrorFlags :: MirrorFlags
41+
defaultMirrorFlags = MirrorFlags
42+
{ flagCacheDir = Nothing
43+
, flagContinuous = False
44+
, flagInterval = Nothing
45+
, flagKeepGoing = False
46+
, flagMirrorUploaders = False
47+
, flagVerbosity = normal
48+
, flagHelp = False
49+
}
50+
51+
mirrorFlagDescrs :: [OptDescr (MirrorFlags -> MirrorFlags)]
52+
mirrorFlagDescrs =
53+
[ Option ['h'] ["help"]
54+
(NoArg (\opts -> opts { flagHelp = True }))
55+
"Show this help text"
56+
57+
, Option ['v'] []
58+
(NoArg (\opts -> opts { flagVerbosity = moreVerbose (flagVerbosity opts) }))
59+
"Verbose mode (can be listed multiple times e.g. -vv)"
60+
61+
, Option [] ["cache-dir"]
62+
(ReqArg (\dir opts -> opts { flagCacheDir = Just dir }) "DIR")
63+
"Where to put downloaded files (default ./mirror-cache/)"
64+
65+
, Option [] ["continuous"]
66+
(NoArg (\opts -> opts { flagContinuous = True }))
67+
"Mirror continuously rather than just once."
68+
69+
, Option [] ["interval"]
70+
(ReqArg (\int opts -> opts { flagInterval = Just int }) "MIN")
71+
"Set the mirroring interval in minutes (default 30)"
72+
73+
, Option [] ["keep-going"]
74+
(NoArg (\opts -> opts { flagKeepGoing = True }))
75+
"Don't fail on mirroring errors, keep going."
76+
77+
, Option [] ["mirror-uploaders"]
78+
(NoArg (\opts -> opts { flagMirrorUploaders = True }))
79+
"Mirror the original uploaders which requires that they are already registered on the target hackage."
80+
]
81+
82+
validateOpts :: [String] -> IO (Verbosity, MirrorOpts)
83+
validateOpts args = do
84+
let (flags0, args', errs) = getOpt Permute mirrorFlagDescrs args
85+
flags = accum flags0 defaultMirrorFlags
86+
87+
when (flagHelp flags) printUsage
88+
when (not (null errs)) (printErrors errs)
89+
90+
case args' of
91+
(configFile:pkgstrs) -> do
92+
mCfg <- readMirrorConfig configFile
93+
case mCfg of
94+
Left theError -> die theError
95+
Right config -> case (mpkgs, minterval) of
96+
(Left theError, _) -> die theError
97+
(_, Left theError) -> die theError
98+
(Right pkgs, Right interval) ->
99+
return (flagVerbosity flags, MirrorOpts {
100+
mirrorConfig = config,
101+
stateDir = fromMaybe "mirror-cache" (flagCacheDir flags),
102+
selectedPkgs = pkgs,
103+
continuous = if flagContinuous flags
104+
then Just interval
105+
else Nothing,
106+
mo_keepGoing = flagKeepGoing flags,
107+
mirrorUploaders = flagMirrorUploaders flags
108+
})
109+
where
110+
mpkgs = validatePackageIds pkgstrs
111+
minterval = validateInterval (flagInterval flags)
112+
113+
_ -> die $ "Expected path to a config file.\n"
114+
++ "See hackage-mirror --help for details and an example."
115+
116+
where
117+
printUsage = do
118+
putStrLn $ usageInfo usageHeader mirrorFlagDescrs ++ helpExampleStr
119+
exitSuccess
120+
usageHeader = helpDescrStr
121+
++ "Usage: hackage-mirror configFile [packages] [options]\n"
122+
++ "\n"
123+
++ "configFile should be a path to a file with format:\n"
124+
++ "\n"
125+
++ " source \"name-of-source-repo\"\n"
126+
++ " uri: http://example:port\n"
127+
++ " type: secure\n"
128+
++ " \n"
129+
++ " target \"name-of-target-repo\"\n"
130+
++ " uri: file:/path/to/local/repo\n"
131+
++ " type: local\n"
132+
++ " \n"
133+
++ " post-mirror-hook: \"shell command to execute\"\n"
134+
++ "\n"
135+
++ "Recognized types are hackage2, secure and local.\n"
136+
++ "The post-mirror-hook is optional.\n"
137+
++ "\n"
138+
++ "Options:"
139+
printErrors errs = die $ concat errs ++ "Try --help."
140+
141+
accum flags = foldr (flip (.)) id flags
142+
143+
validateInterval Nothing = return 30 --default 30 min
144+
validateInterval (Just str) = do
145+
int <- case reads str of
146+
[(int,"")] -> return int
147+
[(int,"m")] -> return int
148+
[(int,"h")] -> return (int * 60)
149+
_ -> Left ("expected a number of minutes, not '" ++ str ++ "'")
150+
if int < 0
151+
then Left "a negative mirroring interval is meaningless"
152+
else return int
153+
154+
helpDescrStr :: String
155+
helpDescrStr = unlines
156+
[ "The hackage-mirror client copies packages from one hackage server to another."
157+
, "By default it copies over all packages that exist on the source but not on"
158+
, "the destination server. You can also select just specific packages to mirror."
159+
, "It is also possible to run the mirror in a continuous mode, giving you"
160+
, "nearly-live mirroring.\n"
161+
]
162+
163+
helpExampleStr :: String
164+
helpExampleStr = unlines
165+
[ "\nExample:"
166+
, " Suppose we have:"
167+
, " - source server: hackage.haskell.org"
168+
, " - dest server: localhost:8080"
169+
, " Uploading packages almost always requires authentication, so suppose we have"
170+
, " a user account for our mirror client with username 'foo' and password 'bar'."
171+
, " We include the authentication details into the destination URL:"
172+
, " http://foo:bar@localhost:8080/"
173+
, " To test that it is working without actually syncing a Gb of data from"
174+
, " hackage.haskell.org, we will specify to mirror only the 'zlib' package."
175+
, " So overall we run:"
176+
, " hackage-mirror ./mirror.cfg zlib"
177+
, " This will synchronise all versions of the 'zlib' package and then exit."
178+
]

‎Distribution/Client/Mirror/Config.hs

Lines changed: 133 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,133 @@
1+
{-# OPTIONS -fno-warn-missing-signatures #-}
2+
module Distribution.Client.Mirror.Config (
3+
MirrorConfig(..)
4+
, PreRepo(..)
5+
, readMirrorConfig
6+
) where
7+
8+
-- stdlib
9+
import Control.Applicative hiding ((<|>))
10+
import Control.Monad
11+
import Data.Char (isSpace)
12+
import Network.URI (URI)
13+
import Text.Parsec
14+
import Text.Parsec.Language (haskellStyle)
15+
import Text.Parsec.String
16+
import qualified Text.Parsec.Token as P
17+
import qualified Network.URI as URI
18+
19+
-- hackage-security
20+
import qualified Hackage.Security.Client as Sec
21+
22+
{-------------------------------------------------------------------------------
23+
Configuration data types
24+
-------------------------------------------------------------------------------}
25+
26+
data MirrorConfig = MirrorConfig {
27+
mirrorSource :: PreRepo
28+
, mirrorTarget :: PreRepo
29+
, mirrorPostHook :: Maybe String
30+
}
31+
deriving Show
32+
33+
data PreRepo = PreRepo {
34+
preRepoName :: String
35+
, preRepoURI :: Maybe URI
36+
, preRepoType :: Maybe String
37+
, preRepoThreshold :: Maybe Sec.KeyThreshold
38+
, preRepoKeys :: Maybe [Sec.KeyId]
39+
}
40+
deriving Show
41+
42+
{-------------------------------------------------------------------------------
43+
Parser
44+
-------------------------------------------------------------------------------}
45+
46+
readMirrorConfig :: FilePath -> IO (Either String MirrorConfig)
47+
readMirrorConfig = liftM (either (Left . show) Right)
48+
. parseFromFile (whiteSpace *> parseMirrorConfig <* eof)
49+
50+
parseMirrorConfig :: Parser MirrorConfig
51+
parseMirrorConfig = MirrorConfig
52+
<$> parsePreRepo "source"
53+
<*> parsePreRepo "target"
54+
<*> (optionMaybe $ reserved "post-mirror-hook" *> reservedOp ":" *> parseArg)
55+
56+
parsePreRepo :: String -> Parser PreRepo
57+
parsePreRepo sourceOrTarget = do
58+
reserved sourceOrTarget
59+
repoName <- parseArg
60+
fields <- many1 parsePreRepoField
61+
62+
let emptyRepo = PreRepo {
63+
preRepoName = repoName
64+
, preRepoURI = Nothing
65+
, preRepoType = Nothing
66+
, preRepoThreshold = Nothing
67+
, preRepoKeys = Nothing
68+
}
69+
70+
return $ foldr ($) emptyRepo fields
71+
72+
parsePreRepoField :: Parser (PreRepo -> PreRepo)
73+
parsePreRepoField = choice [
74+
field "uri" parseURI $ \x r -> r {preRepoURI = Just x}
75+
, field "type" parseArg $ \x r -> r {preRepoType = Just x}
76+
, field "threshold" parseThreshold $ \x r -> r {preRepoThreshold = Just x}
77+
, field "keys" (many1 parseKeyId) $ \x r -> r {preRepoKeys = Just x}
78+
]
79+
where
80+
field :: String
81+
-> Parser a
82+
-> (a -> PreRepo -> PreRepo)
83+
-> Parser (PreRepo -> PreRepo)
84+
field nm p f = f <$> (reserved nm *> reservedOp ":" *> p)
85+
86+
{-------------------------------------------------------------------------------
87+
Auxiliary parsec definitions
88+
-------------------------------------------------------------------------------}
89+
90+
parseURI :: Parser URI
91+
parseURI = aux =<< parseArg
92+
where
93+
aux :: String -> Parser URI
94+
aux str = case URI.parseURI str of
95+
Nothing -> fail $ "Invalid URI: " ++ show str
96+
Just uri -> return uri
97+
98+
-- | Parse generic argument: either string without spaces or quoted string
99+
parseArg :: Parser String
100+
parseArg = lexeme (quoted <|> noSpaces)
101+
where
102+
noSpaces, quoted :: Parser String
103+
noSpaces = many1 (satisfy (not . isSpace))
104+
quoted = char '"' *> many1 (satisfy (/= '"')) <* char '"'
105+
106+
parseThreshold :: Parser Sec.KeyThreshold
107+
parseThreshold = (Sec.KeyThreshold . fromInteger) <$> integer
108+
109+
parseKeyId :: Parser Sec.KeyId
110+
parseKeyId = Sec.KeyId <$> parseArg
111+
112+
{-------------------------------------------------------------------------------
113+
Lexer
114+
-------------------------------------------------------------------------------}
115+
116+
lexer = P.makeTokenParser haskellStyle {
117+
P.reservedOpNames = [":"]
118+
, P.reservedNames = [ "hackage2"
119+
, "local"
120+
, "post-mirror-hook"
121+
, "root"
122+
, "source"
123+
, "target"
124+
, "type"
125+
, "url"
126+
]
127+
}
128+
129+
lexeme = P.lexeme lexer
130+
reserved = P.reserved lexer
131+
reservedOp = P.reservedOp lexer
132+
whiteSpace = P.whiteSpace lexer
133+
integer = P.integer lexer

0 commit comments

Comments
 (0)