hackage-mirror (empty) → 0.1.0.0
raw patch · 6 files changed
+559/−0 lines, 6 filesdep +awsdep +basedep +bytestringsetup-changed
Dependencies added: aws, base, bytestring, cereal, conduit, conduit-extra, cryptohash, data-default, directory, exceptions, fast-logger, filepath, hackage-mirror, http-conduit, lifted-async, lifted-base, mmorph, monad-control, monad-logger, old-locale, optparse-applicative, resourcet, retry, shakespeare, stm, tar, template-haskell, temporary, text, thyme, transformers, unordered-containers
Files
- LICENSE +30/−0
- README.md +11/−0
- Setup.hs +2/−0
- hackage-mirror.cabal +62/−0
- main/Main.hs +60/−0
- src/Hackage/Mirror.hs +394/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, FPComplete++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of John Wiegley nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# Hackage Mirror++A tool to create an AWS S3 mirror of Hackage.++## Install++ cabal install++## Usage++ hackage-mirror --help
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-mirror.cabal view
@@ -0,0 +1,62 @@+name: hackage-mirror+version: 0.1.0.0+synopsis: Simple mirroring utility for Hackage+description: Package allows you to mirror all of hackage to your own s3 bucket.+homepage: http://fpcomplete.com+license: MIT+license-file: LICENSE+author: John Wiegley+copyright: FPComplete+maintainer: tim@fpcomplete.com+category: Distribution+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/fpco/hackage-mirror++library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules: Hackage.Mirror+ build-depends: aws >=0.11+ , base >=4.7 && <5+ , bytestring+ , cereal+ , conduit+ , conduit-extra+ , cryptohash+ , data-default+ , directory+ , exceptions+ , fast-logger+ , filepath+ , http-conduit+ , lifted-async+ , lifted-base+ , mmorph+ , monad-control+ , monad-logger+ , old-locale+ , resourcet+ , retry+ , shakespeare+ , stm+ , tar+ , template-haskell+ , temporary+ , text+ , thyme+ , transformers >=0.4+ , unordered-containers++executable hackage-mirror+ default-language: Haskell2010+ hs-source-dirs: main+ main-is: Main.hs+ build-depends: base >=4.7 && <5+ , hackage-mirror+ , monad-logger+ , optparse-applicative
+ main/Main.hs view
@@ -0,0 +1,60 @@+{-|+Module : Main+Description : Create your own a mirror of Hackage (CLI)+Copyright : (c) FPComplete.com, 2015+License : MIT+Maintainer : John Wiegley <johnw@fpcomplete.com>+Stability : experimental+Portability : POSIX++This module is command line interface to the Hackage.Mirror library.+-}++import Control.Applicative ( Applicative((<*>)), (<$>) )+import Hackage.Mirror ( Options(..), mirrorHackage )+import Options.Applicative+ ( helper,+ execParser,+ value,+ switch,+ strOption,+ progDesc,+ long,+ info,+ help,+ header,+ fullDesc,+ (<>) )+import Control.Monad.Logger+ (filterLogger, LogLevel(LevelDebug), runStdoutLoggingT)++main :: IO ()+main =+ do opts <- execParser optsParser+ runStdoutLoggingT+ (filterLogger (logFilter opts)+ (mirrorHackage opts))+ where optsParser =+ info (helper <*> options)+ (fullDesc <>+ progDesc "Mirror the necessary parts of Hackage" <>+ header "hackage-mirror - mirror only the minimum")+ options =+ Options <$>+ switch (long "verbose" <>+ help "Display verbose output") <*>+ switch (long "rebuild" <>+ help "Don't mirror; used for rebuilding") <*>+ strOption (long "from" <>+ value "http://hackage.haskell.org" <>+ help "Base URL to mirror from") <*>+ strOption (long "to" <>+ help "Base URL of server mirror to") <*>+ strOption (long "access" <>+ value "" <>+ help "S3 access key") <*>+ strOption (long "secret" <>+ value "" <>+ help "S3 secret key")+ logFilter opts _ LevelDebug = verbose opts+ logFilter _ _ _ = True
+ src/Hackage/Mirror.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++{-|+Module : Hackage.Mirror+Description : Create your own a mirror of Hackage+Copyright : (c) FPComplete.com, 2015+License : MIT+Maintainer : Tim Dysinger <tim@fpcomplete.com>+Stability : experimental+Portability : POSIX++This module will help you create a mirror of Hackage on your own+server or S3 bucket. An S3 bucket can be a cost effective way of+serving a hackage mirror.+-}++module Hackage.Mirror (Options(..), mirrorHackage)+ where++import qualified Aws as Aws+ ( Transaction,+ TimeInfo(Timestamp),+ ServiceConfiguration,+ ResponseMetadata,+ Response(responseResult),+ NormalQuery,+ DefaultServiceConfiguration(defServiceConfig),+ Credentials(Credentials, accessKeyID, iamToken, secretAccessKey,+ v4SigningKeys),+ LogLevel(..),+ Configuration(Configuration),+ readResponseIO,+ readResponse,+ aws )+import qualified Aws.S3 as Aws+ ( S3Configuration,+ Bucket,+ GetObjectResponse(gorResponse),+ putObject,+ getObject )+import qualified Codec.Archive.Tar as Tar+ ( Entry(entryContent),+ EntryContent(NormalFile),+ Entries(Done, Fail, Next),+ write,+ entryPath,+ read )+import qualified Codec.Archive.Tar.Entry as Tar+ ( Entry(entryTime) )+import Control.Concurrent.Async.Lifted ( concurrently )+import Control.Concurrent.STM+ ( modifyTVar, writeTVar, readTVarIO, newTVarIO, atomically )+import Control.Exception.Lifted ( SomeException, try, finally )+import Control.Monad ( void, when, unless, mfilter )+import Control.Monad.Catch ( MonadMask )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Logger+ ( MonadLogger, logWarn, logInfo, logError, logDebug )+import Control.Monad.Morph ( MonadTrans(lift), MFunctor(hoist) )+import Control.Monad.Trans.Control+ ( MonadBaseControl(liftBaseWith), control )+import Control.Monad.Trans.Resource+ ( ResourceT,+ MonadResource(..),+ MonadThrow,+ transResourceT,+ monadThrow )+import Control.Retry ( retrying, (<>) )+import qualified Crypto.Hash.SHA512 as SHA512 ( hashlazy )+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as BL+ ( ByteString, null, fromChunks )+import Data.Conduit ( Source, yield, unwrapResumable, ($=), ($$) )+import qualified Data.Conduit.Binary as CB+ ( sourceLbs, sourceFile, sinkLbs, sinkFile )+import qualified Data.Conduit.Lazy as CL+ ( MonadActive, lazyConsume )+import qualified Data.Conduit.List as CL ( mapMaybeM )+import Data.Conduit.Zlib as CZ+ ( WindowBits(WindowBits), ungzip, compress )+import Data.Default ( def )+import qualified Data.HashMap.Strict as M+ ( insert, fromList, lookup, toList, empty )+import Data.IORef ( newIORef )+import Data.List ( isPrefixOf )+import Data.Serialize ( encode, decodeLazy )+import qualified Data.Text as T ( unpack, pack, isInfixOf )+import qualified Data.Text.Encoding as T ( encodeUtf8 )+import Network.HTTP.Conduit+ ( Response(responseBody),+ RequestBody(RequestBodyLBS),+ Manager,+ withManager,+ http,+ parseUrl )+import System.Directory ( doesFileExist, createDirectoryIfMissing )+import System.FilePath+ ( splitDirectories, addExtension, takeDirectory, (</>) )+import System.IO ( hClose )+import System.IO.Temp ( withSystemTempFile )+import Text.Shakespeare.Text ( st )++-- | Options to pass to mirrorHackage+data Options =+ Options {verbose :: Bool -- ^ Verbose Output?+ ,rebuild :: Bool -- ^ Rebuild Mirror?+ ,mirrorFrom :: String -- ^ Hackage Source URL eg: https://hackage.haskell.org+ ,mirrorTo :: String -- ^ Mirror Destination URL eg: s3://my-hackage-mirror-bucket+ ,s3AccessKey :: String -- ^ Amazon ACCESS_KEY_ID for S3+ ,s3SecretKey :: String -- ^ Amazon SECRET_ACCESS_KEY for S3+ }++data Package =+ Package {packageName :: !String+ ,packageVersion :: !String+ ,packageCabal :: !BL.ByteString+ ,packageIdentifier :: !ByteString+ ,packageTarEntry :: !Tar.Entry}++data PathKind+ = UrlPath+ | S3Path+ | FilePath++packageFullName :: Package -> String+packageFullName Package {..} = packageName <> "-" <> packageVersion++pathKind :: String -> PathKind+pathKind url+ | "http://" `isPrefixOf` url || "https://" `isPrefixOf` url = UrlPath+ | "s3://" `isPrefixOf` url = S3Path+ | otherwise = FilePath++indexPackages :: (MonadLogger m, MonadThrow m, MonadBaseControl IO m,+ CL.MonadActive m)+ => Source m ByteString -> Source m Package+indexPackages src = do+ lbs <- lift $ CL.lazyConsume src+ sinkEntries $ Tar.read (BL.fromChunks lbs)+ where+ sinkEntries (Tar.Next ent entries)+ | Tar.NormalFile cabal _ <- Tar.entryContent ent = do+ case splitDirectories (Tar.entryPath ent) of+ [name, vers, _] ->+ yield $ Package name vers cabal+ (T.encodeUtf8 (T.pack (name <> vers))) ent+ ["preferred-versions"] -> return ()+ _ -> $(logError) $ "Failed to parse package name: "+ <> T.pack (Tar.entryPath ent)+ sinkEntries entries+ | otherwise = sinkEntries entries+ sinkEntries Tar.Done = return ()+ sinkEntries (Tar.Fail e) =+ monadThrow $ userError $ "Failed to read tar file: " ++ show e++downloadFromPath :: MonadResource m => String -> String -> Source m ByteString+downloadFromPath path file = do+ let p = path </> file+ exists <- liftIO $ doesFileExist p+ when exists $ CB.sourceFile p++downloadFromUrl :: (MonadResource m, MonadBaseControl IO m,+ MonadThrow m)+ => Manager -> String -> String -> Source m ByteString+downloadFromUrl mgr path file = do+ req <- lift $ parseUrl (path </> file)+ resp <- lift $ http req mgr+ (src, _fin) <- lift $ unwrapResumable (responseBody resp)+ -- jww (2013-11-20): What to do with fin?+ src++withS3 :: MonadResource m+ => Aws.Bucket -> String -> (Aws.Bucket -> String -> m a) -> m a+withS3 url file f = case splitDirectories (T.unpack url) of+ ["s3:", bucket] -> f (T.pack bucket) file+ ["s3:", bucket, prefix] -> f (T.pack bucket) $ prefix </> file+ _ -> monadThrow $ userError $ "Failed to parse S3 path: " ++ T.unpack url++awsRetry :: (MonadIO m, Aws.Transaction r a)+ => Aws.Configuration+ -> Aws.ServiceConfiguration r Aws.NormalQuery+ -> Manager+ -> r+ -> ResourceT m (Aws.Response (Aws.ResponseMetadata a) a)+awsRetry cfg svcfg mgr r =+ transResourceT liftIO $+ retrying def (const $ return . isLeft . Aws.responseResult) $ Aws.aws cfg svcfg mgr r+ where+ isLeft Left{} = True+ isLeft Right{} = False++downloadFromS3 :: MonadResource m+ => Aws.Configuration+ -> Aws.S3Configuration Aws.NormalQuery+ -> Manager+ -> Aws.Bucket+ -> String+ -> Source m ByteString+downloadFromS3 cfg svccfg mgr bucket file = withS3 bucket file go where+ go bucket' (T.pack -> file') = do+ res <- liftResourceT $+ awsRetry cfg svccfg mgr $ Aws.getObject bucket' file'+ case Aws.readResponse res of+ Left (_ :: SomeException) -> return ()+ Right gor -> do+ -- jww (2013-11-20): What to do with fin?+ (src, _fin) <- liftResourceT $ unwrapResumable $+ responseBody (Aws.gorResponse gor)+ hoist liftResourceT src++download :: (MonadResource m, MonadBaseControl IO m, MonadThrow m)+ => Aws.Configuration+ -> Aws.S3Configuration Aws.NormalQuery+ -> Manager+ -> String -- ^ The server path, like /tmp/foo+ -> String -- ^ The file's path within the server path+ -> Source m ByteString+download _ _ mgr path@(pathKind -> UrlPath) =+ downloadFromUrl mgr path+download cfg svccfg mgr path@(pathKind -> S3Path) =+ downloadFromS3 cfg svccfg mgr (T.pack path)+download _ _ _ path = downloadFromPath path++uploadToPath :: MonadResource m+ => String -> String -> Source m ByteString -> m ()+uploadToPath path file src = do+ let p = path </> file+ liftIO $ createDirectoryIfMissing True (takeDirectory p)+ src $$ CB.sinkFile p++uploadToS3 :: (MonadResource m, m ~ ResourceT IO)+ => Aws.Configuration+ -> Aws.S3Configuration Aws.NormalQuery+ -> Manager+ -> Aws.Bucket+ -> String+ -> Source m ByteString+ -> m ()+uploadToS3 cfg svccfg mgr bucket file src = withS3 bucket file go where+ go bucket' (T.pack -> file') = do+ lbs <- src $$ CB.sinkLbs+ res <- awsRetry cfg svccfg mgr $+ Aws.putObject bucket' file' (RequestBodyLBS lbs)+ -- Reading the response triggers an exception if one occurred during+ -- the upload.+ void $ Aws.readResponseIO res++upload :: (MonadResource m, m ~ ResourceT IO)+ => Aws.Configuration+ -> Aws.S3Configuration Aws.NormalQuery+ -> Manager+ -> String+ -> String+ -> Source m ByteString+ -> m ()+upload cfg svccfg mgr path@(pathKind -> S3Path) =+ uploadToS3 cfg svccfg mgr (T.pack path)+upload _ _ _ path = uploadToPath path++-- | Mirror Hackage using the supplied Options.+mirrorHackage :: (MonadMask m,MonadIO m,MonadLogger m,CL.MonadActive m,MonadBaseControl IO m) => Options -> m ()+mirrorHackage Options {..} = do+ ref <- liftIO (newIORef [])+ cfg <- mkCfg ref+ withManager $ \mgr -> do+ sums <- getChecksums cfg mgr+ putChecksums cfg mgr "00-checksums.bak" sums+ newSums <- liftIO $ newTVarIO sums+ changed <- liftIO $ newTVarIO False+ void $ go cfg mgr sums newSums changed `finally` do+ ch <- liftIO $ readTVarIO changed+ when ch $ do+ sums' <- liftIO $ readTVarIO newSums+ putChecksums cfg mgr "00-checksums.dat" sums'+ where+ go cfg mgr sums newSums changed = do+ ents <- CL.lazyConsume $+ getEntries cfg mgr $= processEntries cfg mgr sums newSums changed++ -- Use a temp file as a "backing store" to accumulate the new tarball.+ -- Only when it is complete and we've reached the end normally do we+ -- copy the file onto the server. The checksum file is saved in all+ -- cases so that we know what we mirrored in this session; the index+ -- file, meanwhile, is always valid (albeit temporarily out-of-date if+ -- we abort due to an exception).+ withTemp "index" $ \temp -> do+ CB.sourceLbs (Tar.write ents)+ $= CZ.compress 7 (WindowBits 31) -- gzip compression+ $$ CB.sinkFile temp++ -- Writing the tarball is what causes the changed bit to be+ -- calculated, so we write it first to a temp file and then only+ -- upload it if necessary.+ ch <- liftIO $ readTVarIO changed+ when ch $ void $ do+ _ <- push cfg mgr "00-index.tar.gz" $ CB.sourceFile temp+ $(logInfo) [st|Uploaded 00-index.tar.gz|]++ processEntries cfg mgr sums newSums changed =+ CL.mapMaybeM $ \pkg@(Package {..}) -> do+ let sha = SHA512.hashlazy packageCabal+ et = Tar.entryTime packageTarEntry+ new = case M.lookup packageIdentifier sums of+ Nothing -> True+ Just (et', _sha') -> et /= et'+ valid <- if new+ then mirror cfg mgr pkg sha newSums changed+ else return True+ return $ mfilter (const valid) (Just packageTarEntry)++ mirror cfg mgr pkg sha newSums changed = do+ let fname = packageFullName pkg+ dir = "package" </> fname+ upath = addExtension dir ".tar.gz"+ dpath = dir </> addExtension fname ".tar.gz"+ cabal = dir </> addExtension (packageName pkg) ".cabal"+ (el, er) <-+ if rebuild+ then return (Right (), Right ())+ else do+ res <- concurrently+ (push cfg mgr upath $ download cfg svccfg mgr from dpath)+ (push cfg mgr cabal $ CB.sourceLbs (packageCabal pkg))+ $(logInfo) [st|Mirrored #{fname}|]+ return res+ case (el, er) of+ (Right (), Right ()) -> liftIO $ atomically $ do+ writeTVar changed True+ modifyTVar newSums $+ M.insert (packageIdentifier pkg)+ (Tar.entryTime (packageTarEntry pkg), sha)+ return True+ _ -> return False++ push cfg mgr file src = do+ eres <- try $ liftResourceT $ upload cfg svccfg mgr to file src+ case eres of+ Right () -> return ()+ Left e -> do+ let msg = T.pack (show (e :: SomeException))+ unless ("No tarball exists for this package version"+ `T.isInfixOf` msg) $+ $(logError) $ "FAILED " <> T.pack file <> ": " <> msg+ return eres++ getChecksums cfg mgr = do+ sums <- download cfg svccfg mgr to "00-checksums.dat" $$ CB.sinkLbs+ $(logInfo) [st|Downloaded checksums.dat from #{to}|]+ return $ if BL.null sums+ then M.empty+ else case decodeLazy sums of+ Left _ -> M.empty+ Right res -> M.fromList res++ putChecksums cfg mgr file sums = do+ void $ push cfg mgr file $ yield (encode (M.toList sums))+ $(logInfo) [st|Uploaded #{file}|]++ getEntries cfg mgr = do+ $(logInfo) [st|Downloading index.tar.gz from #{from}|]+ indexPackages $+ download cfg svccfg mgr from "00-index.tar.gz" $= CZ.ungzip++ withTemp :: MonadBaseControl IO m => String -> (FilePath -> m ()) -> m ()+ withTemp prefix f = control $ \run ->+ withSystemTempFile prefix $ \temp h -> hClose h >> run (f temp)++ mkCfg ref =+ liftBaseWith $ \run -> do+ return $ Aws.Configuration Aws.Timestamp Aws.Credentials+ { accessKeyID = T.encodeUtf8 (T.pack s3AccessKey)+ , secretAccessKey = T.encodeUtf8 (T.pack s3SecretKey)+ , v4SigningKeys = ref+ , iamToken = Nothing+ }+ (logger' run)+ where+ logger' run ll text = do _stm <- run (log' ll text)+ return ()+ log' Aws.Warning = $logWarn+ log' Aws.Error = $logError+ log' _ = $logDebug++ svccfg = Aws.defServiceConfig++ from = mirrorFrom+ to = mirrorTo