{-# LANGUAGE PatternGuards, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, FlexibleInstances, CPP #-}
module Main where
import Network.HTTP
import Network.Browser
import Network.URI (URI(..), URIAuth(..))
import Distribution.Client (validateHackageURI, validatePackageIds, PkgIndexInfo(..))
import Distribution.Client.UploadLog as UploadLog (read, Entry(..))
import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, Signal(..))
import Distribution.Server.Util.Parse (packUTF8, unpackUTF8)
import Distribution.Server.Users.Types (UserId(..), UserName(UserName))
import Distribution.Server.Util.Index as PackageIndex (read)
import Distribution.Server.Util.Merge
import Distribution.Package
import Distribution.Version
import Distribution.Text
import Distribution.Verbosity
import Distribution.Simple.Utils hiding (warn)
import Data.List
import Data.Maybe
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Reader
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
import qualified Distribution.Server.Util.GZip as GZip
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Data.Set as Set
import Data.Set (Set)
import Data.IORef
import Control.Exception
import Data.Time
import Data.Time.Clock.POSIX
import System.Locale
import System.Environment
import System.IO
import System.Exit
import System.FilePath
import System.Directory
import System.Console.GetOpt
import qualified System.FilePath.Posix as Posix
#if __GLASGOW_HASKELL__ >= 706
import System.IO.Error
#else
import System.IO.Error hiding (catch)
import Prelude hiding (catch)
#endif
import Paths_hackage_server (version)
data MirrorOpts = MirrorOpts {
srcURI :: URI,
dstURI :: URI,
stateDir :: FilePath,
selectedPkgs :: [PackageId],
continuous :: Maybe Int, -- if so, interval in minutes
mo_keepGoing :: Bool
}
data MirrorEnv = MirrorEnv {
me_srcCacheDir :: FilePath,
me_dstCacheDir :: FilePath,
me_missingPkgsFile :: FilePath,
me_unmirrorablePkgsFile :: FilePath
}
deriving Show
data MirrorState = MirrorState {
ms_missingPkgs :: Set PackageId,
ms_unmirrorablePkgs :: Set PackageId
}
deriving (Eq, Show)
main :: IO ()
main = toplevelHandler $ do
rethrowSignalsAsExceptions [SIGABRT, SIGINT, SIGQUIT, SIGTERM]
hSetBuffering stdout LineBuffering
args <- getArgs
(verbosity, opts) <- validateOpts args
(env, st) <- mirrorInit verbosity opts
case continuous opts of
Nothing -> mirrorOneShot verbosity opts env st
Just interval -> cron verbosity interval
(mirrorIteration verbosity opts env) st
mirrorInit :: Verbosity -> MirrorOpts -> IO (MirrorEnv, MirrorState)
mirrorInit verbosity opts = do
let srcName = mkCacheFileName (srcURI opts)
dstName = mkCacheFileName (dstURI opts)
srcCacheDir = stateDir opts </> srcName
dstCacheDir = stateDir opts </> dstName
when (srcCacheDir == dstCacheDir) $
die "source and destination cache files clash"
when (continuous opts == Just 0) $
warn verbosity "A sync interval of zero is a seriously bad idea!"
when (isOldHackageURI (srcURI opts)
&& maybe False (<30) (continuous opts)) $
die $ "Please don't hit the central hackage.haskell.org "
++ "more frequently than every 30 minutes."
createDirectoryIfMissing False (stateDir opts)
createDirectoryIfMissing False srcCacheDir
createDirectoryIfMissing False dstCacheDir
let missingPkgsFile = stateDir opts
</> "missing-" ++ srcName
-- being unmirrorable is a function of the combination of the source and
-- destination, so the cache file uses both names.
unmirrorablePkgsFile = stateDir opts
</> "unmirrorable-" ++ srcName ++ "-" ++ dstName
missingPkgs <- readPkgProblemFile missingPkgsFile
unmirrorablePkgs <- readPkgProblemFile unmirrorablePkgsFile
return (MirrorEnv srcCacheDir dstCacheDir
missingPkgsFile unmirrorablePkgsFile
,MirrorState missingPkgs unmirrorablePkgs)
where
mkCacheFileName :: URI -> FilePath
mkCacheFileName URI { uriAuthority = Just auth }
= makeValid (uriRegName auth ++ uriPort auth)
mkCacheFileName uri = error $ "unexpected URI " ++ show uri
readPkgProblemFile :: FilePath -> IO (Set PackageId)
readPkgProblemFile file = do
exists <- doesFileExist file
if exists
then evaluate . Set.fromList
. catMaybes . map simpleParse . lines
=<< readFile file
else return Set.empty
writePkgProblemFile :: FilePath -> Set PackageId -> IO ()
writePkgProblemFile file =
writeFile file . unlines . map display . Set.toList
---------------------------
-- Main mirroring logic
---------------------------
mirrorOneShot :: Verbosity -> MirrorOpts -> MirrorEnv -> MirrorState -> IO ()
mirrorOneShot verbosity opts env st = do
(merr, _) <- mirrorOnce verbosity opts env st
case merr of
Nothing -> return ()
Just theError -> fail (formatMirrorError theError)
mirrorIteration :: Verbosity -> MirrorOpts -> MirrorEnv
-> MirrorState -> IO MirrorState
mirrorIteration verbosity opts env st = do
(merr, st') <- mirrorOnce verbosity opts { mo_keepGoing = True } env st
when (st' /= st) $
savePackagesState env st'
case merr of
Nothing -> return ()
Just Interrupted -> throw UserInterrupt
Just theError -> do
warn verbosity (formatMirrorError theError)
notice verbosity "Abandoning this mirroring attempt."
return st'
savePackagesState :: MirrorEnv -> MirrorState -> IO ()
savePackagesState (MirrorEnv _ _ missingPkgsFile unmirrorablePkgsFile)
(MirrorState missingPkgs unmirrorablePkgs) = do
writePkgProblemFile missingPkgsFile missingPkgs
writePkgProblemFile unmirrorablePkgsFile unmirrorablePkgs
mirrorOnce :: Verbosity -> MirrorOpts -> MirrorEnv
-> MirrorState -> IO (Maybe MirrorError, MirrorState)
mirrorOnce verbosity opts
(MirrorEnv srcCacheDir dstCacheDir missingPkgsFile unmirrorablePkgsFile)
st@(MirrorState missingPkgs unmirrorablePkgs) =
mirrorSession (mo_keepGoing opts) $ do
srcIndex <- downloadIndex (srcURI opts) srcCacheDir
dstIndex <- downloadIndex (dstURI opts) dstCacheDir
let pkgsMissingFromDest = diffIndex srcIndex dstIndex
pkgsToMirror
| null (selectedPkgs opts) = pkgsMissingFromDest
| otherwise = subsetIndex (selectedPkgs opts)
pkgsMissingFromDest
pkgsToMirror' = filter (\(PkgIndexInfo pkg _ _ _) ->
pkg `Set.notMember` missingPkgs
&& pkg `Set.notMember` unmirrorablePkgs )
pkgsToMirror
mirrorCount = length pkgsToMirror'
ignoreCount = length pkgsToMirror - mirrorCount
liftIO $ notice verbosity $
show mirrorCount ++ " packages to mirror."
++ if ignoreCount == 0 then ""
else " Ignoring " ++ show ignoreCount
++ " package(s) that cannot be mirrored\n(for details see "
++ missingPkgsFile ++ " and " ++ unmirrorablePkgsFile ++ ")"
mirrorPackages verbosity opts pkgsToMirror'
where
mirrorSession :: Bool
-> MirrorSession a -> IO (Maybe MirrorError, MirrorState)
mirrorSession keepGoing action =
liftM (\(eerr, st') -> (either Just (const Nothing) eerr,
fromErrorState st')) $
runMirrorSession verbosity keepGoing (toErrorState st) $ do
browserAction $ do
setUserAgent ("hackage-mirror/" ++ display version)
setErrHandler (warn verbosity)
setOutHandler (debug verbosity)
setAllowBasicAuth True
setCheckForProxy True
action
diffIndex :: [PkgIndexInfo] -> [PkgIndexInfo] -> [PkgIndexInfo]
diffIndex as bs =
[ pkg | OnlyInLeft pkg <- mergeBy (comparing mirrorPkgId)
(sortBy (comparing mirrorPkgId) as)
(sortBy (comparing mirrorPkgId) bs) ]
where
mirrorPkgId (PkgIndexInfo pkgid _ _ _) = pkgid
subsetIndex :: [PackageId] -> [PkgIndexInfo] -> [PkgIndexInfo]
subsetIndex pkgids =
filter (\(PkgIndexInfo pkgid' _ _ _) -> anyMatchPackage pkgid')
where
anyMatchPackage :: PackageId -> Bool
anyMatchPackage pkgid' =
any (\pkgid -> matchPackage pkgid pkgid') pkgids
matchPackage :: PackageId -> PackageId -> Bool
matchPackage (PackageIdentifier name (Version [] _))
(PackageIdentifier name' _ ) = name == name'
matchPackage pkgid pkgid' = pkgid == pkgid'
mirrorPackages :: Verbosity -> MirrorOpts -> [PkgIndexInfo] -> MirrorSession ()
mirrorPackages verbosity opts pkgsToMirror = do
let credentials = extractCredentials (dstURI opts)
browserAction $ setAuthorityGen (provideAuthInfo credentials)
mapM_ mirrorPackage pkgsToMirror
where
provideAuthInfo :: Maybe (String, String) -> URI -> String -> IO (Maybe (String, String))
provideAuthInfo credentials = \uri _realm -> do
if hostName uri == hostName (dstURI opts) then return credentials
else return Nothing
hostName = fmap uriRegName . uriAuthority
extractCredentials uri
| Just authority <- uriAuthority uri
, (username, ':':passwd0) <- break (==':') (uriUserInfo authority)
, let passwd = takeWhile (/='@') passwd0
, not (null username)
, not (null passwd)
= Just (username, passwd)
extractCredentials _ = Nothing
mirrorPackage pkginfo@(PkgIndexInfo pkgid _ _ _) = do
let srcPackage = if isOldHackageURI (srcURI opts)
then "packages" </> "archive"
</> display (packageName pkgid)
</> display (packageVersion pkgid)
else "package" </> display pkgid
srcBase = srcURI opts <//> srcPackage
dstBase = dstURI opts
<//> "package"
</> display pkgid
srcTgz = srcBase <//> display pkgid <.> "tar.gz"
srcCab = srcBase <//> display (packageName pkgid) <.> "cabal"
locTgz = stateDir opts </> display pkgid <.> "tar.gz"
locCab = stateDir opts </> display pkgid <.> "cabal"
liftIO $ notice verbosity $ "mirroring " ++ display pkgid
rsp <- browserActions [
downloadFile' srcCab locCab
, downloadFile' srcTgz locTgz
]
case rsp of
Just theError ->
notifyResponse (GetPackageFailed theError pkgid)
Nothing -> do
notifyResponse GetPackageOk
putPackage dstBase pkginfo locCab locTgz
putPackage :: URI -> PkgIndexInfo -> FilePath -> FilePath -> MirrorSession ()
putPackage baseURI (PkgIndexInfo pkgid mtime muname _muid) locCab locTgz = do
cab <- liftIO $ BS.readFile locCab
tgz <- liftIO $ BS.readFile locTgz
rsp <- browserActions [
requestPUT cabURI "text/plain" cab
, requestPUT tgzURI "application/x-gzip" tgz
, maybe (return Nothing) putPackageUploadTime mtime
, maybe (return Nothing) putPackageUploader muname
]
case rsp of
Just theError ->
notifyResponse (PutPackageFailed theError pkgid)
Nothing -> do
notifyResponse PutPackageOk
liftIO $ removeFile locCab
liftIO $ removeFile locTgz
-- TODO: think about in what situations we delete the file
-- and if we should actually cache it if we don't sucessfully upload.
-- TODO: perhaps we shouldn't report failure for the whole package if
-- we fail to set the upload time/uploader
where
cabURI = baseURI <//> display (packageName pkgid) <.> "cabal"
tgzURI = baseURI <//> display pkgid <.> "tar.gz"
putPackageUploadTime time = do
let timeStr = formatTime defaultTimeLocale "%c" time
requestPUT (baseURI <//> "upload-time") "text/plain" (packUTF8 timeStr)
putPackageUploader uname = do
let nameStr = display uname
requestPUT (baseURI <//> "uploader") "text/plain" (packUTF8 nameStr)
-----------------------------
-- Error handling strategy
-----------------------------
-- There's two general classes of errors we have to consider:
-- - systematic errors that apply to all packages
-- - errors that only apply to individual packages
--
-- For the first class we want to fail and not continue mirroring.
--
-- For the second class we want to keep going and try mirroring other packages.
-- In addition we want to remember the packages involved persistently so that
-- we don't keep trying again and again to mirror packages that simply cannot
-- be mirrored.
--
-- We want the mirroring to be robust. So we don't want to have temporary or
-- individual package errors make us fail overall.
--
-- To add further complication, it can be hard to distinguish a systematic
-- error from an individual per-package error. Our strategy may have to be
-- complex and based on counting various events to make best guesses.
--
-- Since we expect our error handling stategy we try to separate it from the
-- main mirroring logic.
--
-- We make a new monad to hold the plumbing for our strategy. We make it to
-- be a state monad so that we can accumulating info about non-fatal errors in
-- individual packages. We make it an error monad to deal with fatal errors.
--
-- We layer state and error on top of the HTTP Browser monad. The layering
-- order of the state vs error is such that errors do not roll back the changed
-- state. This is because we want (at least the option) to keep the info about
-- individual packages when we encounter a systematic error.
--
newtype MirrorSession a
= MirrorSession {
unMirror :: ErrorT MirrorError
(ReaderT (Verbosity, Bool, IORef ErrorState)
(BrowserAction (HandleStream ByteString)))
a
}
deriving (Functor, Monad, MonadIO,
MonadError MirrorError)
instance MonadReader (Verbosity, Bool) MirrorSession where
ask = MirrorSession (fmap (\(x,y,_) -> (x,y)) ask)
local f m = MirrorSession (local f' (unMirror m))
where
f' (x,y,z) = (x',y',z) where (x',y') = f (x,y)
instance MonadState ErrorState MirrorSession where
get = MirrorSession (ask >>= \(_,_,stRef) -> liftIO (readIORef stRef))
put x = MirrorSession (ask >>= \(_,_,stRef) -> liftIO (writeIORef stRef x))
browserAction :: BrowserAction (HandleStream ByteString) a -> MirrorSession a
browserAction = MirrorSession . lift . lift
browserActions :: [BrowserAction (HandleStream ByteString) (Maybe ErrorResponse)] -> MirrorSession (Maybe ErrorResponse)
browserActions = foldr1 maybeThen . map browserAction
where
-- Bind for the strange not-quite-monad where errors are returned as
-- (Just err) and success is returned as Nothing
maybeThen :: Monad m => m (Maybe err) -> m (Maybe err) -> m (Maybe err)
maybeThen p q = do
res <- p
case res of
Just theError -> return (Just theError)
Nothing -> q
runMirrorSession :: Verbosity -> Bool -> ErrorState -> MirrorSession a
-> IO (Either MirrorError a, ErrorState)
runMirrorSession verbosity keepGoing st (MirrorSession m) = do
stRef <- newIORef st
result <- browse (runReaderT (runErrorT m) (verbosity, keepGoing, stRef))
`catch` (return . Left . MirrorIOError)
`catch` \ae -> case ae of
UserInterrupt -> return (Left Interrupted)
_ -> throw ae
st' <- readIORef stRef
return (result, st')
-- So that's the plumbing. The actual policy/strategy is implemented by an
-- action in the monad where we inform it of the interesting events, which is
-- basically all the gets and puts, the packages and their http response codes.
-- This policy action behaves like a state machine action, updating the monad
-- state and if it decides it has to fail hard, by making use of error monad.
data MirrorError = MirrorGeneralError String
| MirrorIOError IOError
| GetEntityError Entity ErrorResponse
| ParseEntityError Entity URI String
| PutPackageError PackageId ErrorResponse
| Interrupted
deriving Show
data Entity = EntityIndex | EntityLog | EntityPackage PackageId
deriving Show
instance Error MirrorError where
strMsg = MirrorGeneralError
formatMirrorError :: MirrorError -> String
formatMirrorError (MirrorGeneralError msg) = msg
formatMirrorError (MirrorIOError ioe) = formatIOError ioe
formatMirrorError (GetEntityError entity rsp) =
"Failed to download " ++ formatEntity entity
++ ",\n " ++ formatErrorResponse rsp
formatMirrorError (ParseEntityError entity uri theError) =
"Error parsing " ++ formatEntity entity
++ " at " ++ show uri ++ ": " ++ theError
formatMirrorError (PutPackageError pkgid rsp) =
"Failed to upload package " ++ display pkgid
++ ",\n " ++ formatErrorResponse rsp
formatMirrorError Interrupted = error "formatMirrorError: Interrupted"
formatEntity :: Entity -> String
formatEntity EntityIndex = "the package index"
formatEntity EntityLog = "the package upload log"
formatEntity (EntityPackage pkgid) = "package " ++ display pkgid
data ErrorState = ErrorState {
es_missing :: Set PackageId,
es_unmirrorable :: Set PackageId
}
deriving Show
toErrorState :: MirrorState -> ErrorState
toErrorState (MirrorState missing unmirrorable) =
ErrorState missing unmirrorable
fromErrorState :: ErrorState -> MirrorState
fromErrorState (ErrorState missing unmirrorable) =
MirrorState missing unmirrorable
data MirrorEvent = GetIndexOk
| GetPackageOk | GetPackageFailed ErrorResponse PackageId
| PutPackageOk | PutPackageFailed ErrorResponse PackageId
notifyResponse :: MirrorEvent -> MirrorSession ()
notifyResponse e = do
st <- get
(verbosity, keepGoing) <- ask
st' <- handleEvent verbosity keepGoing st
put st'
where
handleEvent _ False st = case e of
GetIndexOk -> return st
GetPackageOk -> return st
PutPackageOk -> return st
GetPackageFailed rsp pkgid ->
throwError (GetEntityError (EntityPackage pkgid) rsp)
PutPackageFailed rsp pkgid ->
throwError (PutPackageError pkgid rsp)
handleEvent verbosity True st = case e of
GetIndexOk -> return st
GetPackageOk -> return st
PutPackageOk -> return st
GetPackageFailed rsp@(ErrorResponse _ code _ _) pkgid
| code == (4,0,4) -> do
liftIO $ warn verbosity $
formatMirrorError (GetEntityError (EntityPackage pkgid) rsp)
return st {
es_missing = Set.insert pkgid (es_missing st)
}
| otherwise -> throwError (GetEntityError (EntityPackage pkgid) rsp)
PutPackageFailed rsp@(ErrorResponse _ code _ _) pkgid
| code == (4,0,0) || code == (4,0,4) -> do
liftIO $ warn verbosity $
formatMirrorError (PutPackageError pkgid rsp)
return st {
es_unmirrorable = Set.insert pkgid (es_unmirrorable st)
}
| otherwise -> throwError (PutPackageError pkgid rsp)
----------------------------------------------------
-- Fetching info from source and destination servers
----------------------------------------------------
downloadIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo]
downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri
| otherwise = downloadNewIndex uri
where
isOldHackageURI :: URI -> Bool
isOldHackageURI uri
| Just auth <- uriAuthority uri = uriRegName auth == "hackage.haskell.org"
| otherwise = False
downloadOldIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo]
downloadOldIndex uri cacheDir = do
rsp1 <- browserAction $ downloadFile indexURI indexFile
case rsp1 of
Nothing -> notifyResponse GetIndexOk
Just theError -> throwError (GetEntityError EntityIndex theError)
rsp2 <- browserAction $ downloadFile logURI logFile
case rsp2 of
Nothing -> notifyResponse GetIndexOk
Just theError -> throwError (GetEntityError EntityLog theError)
res1 <- liftIO $
withFile indexFile ReadMode $ \hnd ->
evaluate . PackageIndex.read (\pkgid _ -> pkgid)
. GZip.decompressNamed indexFile
=<< BS.hGetContents hnd
pkgids <- case res1 of
Left theError -> throwError (ParseEntityError EntityIndex uri theError)
Right pkgs -> return pkgs
res2 <- liftIO $
withFile logFile ReadMode $ \hnd ->
evaluate . UploadLog.read =<< hGetContents hnd
theLog <- case res2 of
Left theError -> throwError (ParseEntityError EntityLog uri theError)
Right theLog -> return theLog
return (mergeLogInfo pkgids theLog)
where
indexURI = uri <//> "packages" </> "archive" </> "00-index.tar.gz"
indexFile = cacheDir </> "00-index.tar.gz"
logURI = uri <//> "packages" </> "archive" </> "log"
logFile = cacheDir </> "log"
mergeLogInfo pkgids theLog =
catMaybes
. map selectDetails
$ mergeBy (\pkgid entry -> compare pkgid (entryPkgId entry))
(sort pkgids)
( map (maximumBy (comparing entryTime))
. groupBy (equating entryPkgId)
. sortBy (comparing entryPkgId)
$ theLog )
selectDetails (OnlyInRight _) = Nothing
selectDetails (OnlyInLeft pkgid) =
Just $ PkgIndexInfo pkgid Nothing Nothing Nothing
selectDetails (InBoth pkgid (UploadLog.Entry time uname _)) =
Just $ PkgIndexInfo pkgid (Just time) (Just uname) Nothing
entryPkgId (Entry _ _ pkgid) = pkgid
entryTime (Entry time _ _) = time
downloadNewIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo]
downloadNewIndex uri cacheDir = do
rsp <- browserAction $ downloadFile indexURI indexFile
case rsp of
Just theError -> throwError (GetEntityError EntityIndex theError)
Nothing -> do
notifyResponse GetIndexOk
res <- liftIO $ withFile indexFile ReadMode $ \hnd ->
evaluate . PackageIndex.read selectDetails
. GZip.decompressNamed indexFile
=<< BS.hGetContents hnd
case res of
Left theError -> throwError (ParseEntityError EntityIndex uri theError)
Right pkgs -> return pkgs
where
indexURI = uri <//> "packages/00-index.tar.gz"
indexFile = cacheDir </> "00-index.tar.gz"
selectDetails :: PackageId -> Tar.Entry -> PkgIndexInfo
selectDetails pkgid entry =
PkgIndexInfo
pkgid
(Just time)
(if null username then Nothing else Just (UserName username))
(if userid == 0 then Nothing else Just (UserId userid))
where
time = epochTimeToUTC (Tar.entryTime entry)
username = Tar.ownerName (Tar.entryOwnership entry)
userid = Tar.ownerId (Tar.entryOwnership entry)
epochTimeToUTC :: Tar.EpochTime -> UTCTime
epochTimeToUTC = posixSecondsToUTCTime . realToFrac
-------------------------
-- HTTP utilities
-------------------------
infixr 5 <//>
(<//>) :: URI -> FilePath -> URI
uri <//> path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri)
Posix.</> path }
type HttpSession a = BrowserAction (HandleStream ByteString) a
downloadFile :: URI -> FilePath -> HttpSession (Maybe ErrorResponse)
downloadFile uri file = do
out $ "downloading " ++ show uri ++ " to " ++ file
let etagFile = file <.> "etag"
metag <- liftIO $ catchJustDoesNotExistError
(Just <$> readFile etagFile)
(\_ -> return Nothing)
case metag of
Just etag -> do
let headers = [mkHeader HdrIfNoneMatch (quote etag)]
(_, rsp) <- request (Request uri GET headers BS.empty)
case rspCode rsp of
(3,0,4) -> do out $ file ++ " unchanged with ETag " ++ etag
return Nothing
(2,0,0) -> do liftIO $ writeDowloadedFileAndEtag rsp
return Nothing
_ -> return (Just (mkErrorResponse uri rsp))
Nothing -> do
(_, rsp) <- request (Request uri GET [] BS.empty)
case rspCode rsp of
(2,0,0) -> do liftIO $ writeDowloadedFileAndEtag rsp
return Nothing
_ -> return (Just (mkErrorResponse uri rsp))
where
writeDowloadedFileAndEtag rsp = do
BS.writeFile file (rspBody rsp)
setETag file (unquote <$> findHeader HdrETag rsp)
getETag :: FilePath -> IO (Maybe String)
getETag file =
catchJustDoesNotExistError
(Just <$> readFile (file </> ".etag"))
(\_ -> return Nothing)
setETag :: FilePath -> Maybe String -> IO ()
setETag file Nothing = catchJustDoesNotExistError
(removeFile (file <.> "etag"))
(\_ -> return ())
setETag file (Just etag) = writeFile (file <.> "etag") etag
catchJustDoesNotExistError :: IO a -> (IOError -> IO a) -> IO a
catchJustDoesNotExistError =
catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)
quote :: String -> String
quote s = '"' : s ++ ['"']
unquote :: String -> String
unquote ('"':s) = go s
where
go [] = []
go ('"':[]) = []
go (c:cs) = c : go cs
unquote s = s
downloadFile' :: URI -> FilePath -> HttpSession (Maybe ErrorResponse)
downloadFile' uri file = do
out $ "downloading " ++ show uri ++ " to " ++ file
rsp <- requestGET uri
case rsp of
Left theError -> return (Just theError)
Right content -> do liftIO $ BS.writeFile file content
--TODO: check we wrote the expected length.
return Nothing
requestGET :: URI -> HttpSession (Either ErrorResponse ByteString)
requestGET uri = do
(_, rsp) <- request (Request uri GET headers BS.empty)
case rspCode rsp of
(2,0,0) -> return (Right (rspBody rsp))
_ -> return (Left (mkErrorResponse uri rsp))
where
headers = []
requestPUT :: URI -> String -> ByteString -> HttpSession (Maybe ErrorResponse)
requestPUT uri mimetype body = do
(_, rsp) <- request (Request uri PUT headers body)
case rspCode rsp of
(2,_,_) -> return Nothing
_ -> return (Just (mkErrorResponse uri rsp))
where
headers = [ Header HdrContentLength (show (BS.length body))
, Header HdrContentType mimetype ]
data ErrorResponse = ErrorResponse URI ResponseCode String (Maybe String)
deriving Show
mkErrorResponse :: URI -> Response ByteString -> ErrorResponse
mkErrorResponse uri rsp =
ErrorResponse uri (rspCode rsp) (rspReason rsp) mBody
where
mBody = case lookupHeader HdrContentType (rspHeaders rsp) of
Just mimetype | "text/plain" `isPrefixOf` mimetype
-> Just (unpackUTF8 (rspBody rsp))
_ -> Nothing
formatErrorResponse :: ErrorResponse -> String
formatErrorResponse (ErrorResponse uri (a,b,c) reason mBody) =
"HTTP error code " ++ show a ++ show b ++ show c
++ ", " ++ reason ++ "\n " ++ show uri
++ maybe "" (('\n':) . unlines . map (" "++) . lines . wrapText) mBody
-------------------------
-- Command line handling
-------------------------
data MirrorFlags = MirrorFlags {
flagCacheDir :: Maybe FilePath,
flagContinuous:: Bool,
flagInterval :: Maybe String,
flagKeepGoing :: Bool,
flagVerbosity :: Verbosity,
flagHelp :: Bool
}
defaultMirrorFlags :: MirrorFlags
defaultMirrorFlags = MirrorFlags
Nothing False Nothing False normal False
mirrorFlagDescrs :: [OptDescr (MirrorFlags -> MirrorFlags)]
mirrorFlagDescrs =
[ Option ['h'] ["help"]
(NoArg (\opts -> opts { flagHelp = True }))
"Show this help text"
, Option ['v'] []
(NoArg (\opts -> opts { flagVerbosity = moreVerbose (flagVerbosity opts) }))
"Verbose mode (can be listed multiple times e.g. -vv)"
, Option [] ["cache-dir"]
(ReqArg (\dir opts -> opts { flagCacheDir = Just dir }) "DIR")
"Where to put downloaded files (default ./mirror-cache/)"
, Option [] ["continuous"]
(NoArg (\opts -> opts { flagContinuous = True }))
"Mirror continuously rather than just once."
, Option [] ["interval"]
(ReqArg (\int opts -> opts { flagInterval = Just int }) "MIN")
"Set the mirroring interval in minutes (default 30)"
, Option [] ["keep-going"]
(NoArg (\opts -> opts { flagKeepGoing = True }))
"Don't fail on mirroring errors, keep going."
]
validateOpts :: [String] -> IO (Verbosity, MirrorOpts)
validateOpts args = do
let (flags0, args', errs) = getOpt Permute mirrorFlagDescrs args
flags = accum flags0 defaultMirrorFlags
when (flagHelp flags) printUsage
when (not (null errs)) (printErrors errs)
case args' of
(configFile:pkgstrs) -> do
mFromTo <- readConfigFile configFile
case mFromTo of
Left theError -> die theError
Right (fromURI, toURI) -> case (mpkgs, minterval) of
(Left theError, _) -> die theError
(_, Left theError) -> die theError
(Right pkgs, Right interval) ->
return $ (,) (flagVerbosity flags) MirrorOpts {
srcURI = fromURI,
dstURI = toURI,
stateDir = fromMaybe "mirror-cache" (flagCacheDir flags),
selectedPkgs = pkgs,
continuous = if flagContinuous flags
then Just interval
else Nothing,
mo_keepGoing = flagKeepGoing flags
}
where
mpkgs = validatePackageIds pkgstrs
minterval = validateInterval (flagInterval flags)
_ -> die $ "Expected path to a config file.\n"
++ "See hackage-mirror --help for details and an example."
where
printUsage = do
putStrLn $ usageInfo usageHeader mirrorFlagDescrs ++ helpExampleStr
exitSuccess
usageHeader = helpDescrStr
++ "Usage: hackage-mirror configFile [packages] [options]\n\n"
++ "configFile should be a path to a file containing two lines:\n\n"
++ " fromURL\n"
++ " toURL\n\n"
++ "Options:"
printErrors errs = die $ concat errs ++ "Try --help."
accum flags = foldr (flip (.)) id flags
validateInterval Nothing = return 30 --default 30 min
validateInterval (Just str) = do
int <- case reads str of
[(int,"")] -> return int
[(int,"m")] -> return int
[(int,"h")] -> return (int * 60)
_ -> Left ("expected a number of minutes, not '" ++ str ++ "'")
if int < 0
then Left "a negative mirroring interval is meaningless"
else return int
readConfigFile :: FilePath -> IO (Either String (URI, URI))
readConfigFile configFile = runErrorT $ do
config <- ErrorT $ tryIO $ readFile configFile
[fr, to] <- case lines config of
[fr, to] -> return [fr, to]
_ -> fail "Invalid config file format"
frURI <- ErrorT . return $ validateHackageURI fr
toURI <- ErrorT . return $ validateHackageURI to
return (frURI, toURI)
where
tryIO :: IO a -> IO (Either String a)
tryIO io = catch (Right `liftM` io) (\e -> return . Left $ show (e :: IOException))
helpDescrStr :: String
helpDescrStr = unlines
[ "The hackage-mirror client copies packages from one hackage server to another."
, "By default it copies over all packages that exist on the source but not on"
, "the destination server. You can also select just specific packages to mirror."
, "It is also possible to run the mirror in a continuous mode, giving you"
, "nearly-live mirroring.\n"
]
helpExampleStr :: String
helpExampleStr = unlines
[ "\nExample:"
, " Suppose we have:"
, " - source server: hackage.haskell.org"
, " - dest server: localhost:8080"
, " Uploading packages almost always requires authentication, so suppose we have"
, " a user account for our mirror client with username 'foo' and password 'bar'."
, " We include the authentication details into the destination URL:"
, " http://foo:bar@localhost:8080/"
, " To test that it is working without actually syncing a Gb of data from"
, " hackage.haskell.org, we will specify to mirror only the 'zlib' package."
, " So overall we run:"
, " hackage-mirror ./mirror.cfg zlib"
, " where ./mirror.cfg contains"
, " http://hackage.haskell.org/"
, " http://foo:bar@localhost:8080/"
, " This will synchronise all versions of the 'zlib' package and then exit."
]
toplevelHandler :: IO a -> IO a
toplevelHandler =
handle $ \ioe -> do
hFlush stdout
pname <- getProgName
hPutStrLn stderr (pname ++ ": " ++ formatIOError ioe)
exitWith (ExitFailure 1)
formatIOError :: IOError -> String
formatIOError ioe
| isUserError ioe = file ++ location ++ detail
| otherwise = show ioe
where
file = case ioeGetFileName ioe of
Nothing -> ""
Just path -> path ++ ": "
location = case ioeGetLocation ioe of
"" -> ""
loc -> loc ++ ": "
detail = ioeGetErrorString ioe
warn :: Verbosity -> String -> IO ()
warn verbosity msg =
when (verbosity >= normal) $
putStrLn ("Warning: " ++ msg)