Commit 7cced199 authored by bjorn@bringert.net's avatar bjorn@bringert.net
Browse files

Use the ungzipped 00-index.tar as the local package info cache.

This adds a dependency on zlib, to unzip the downloaded 00-index.tar.gz.
Once unzipped, a small pure haskell tar reader is used to read
the index contents.
Servers in the server list now have names which are used 
as local cache directory names.
The --with-server command line flag has been removed since it
did not allow specifying a server name.
parent c85a6f50
......@@ -14,7 +14,8 @@ Build-type: Simple
Build-depends: base, mtl, network, regex-compat,
filepath >= 1.0,
Cabal>=1.3,
HTTP >= 3000.0 && < 3000.1
HTTP >= 3000.0 && < 3000.1,
zlib >= 0.3
data-files: serv.list
Extra-Source-Files: copyright README
......@@ -33,6 +34,7 @@ Other-Modules:
Network.Hackage.CabalInstall.List
Network.Hackage.CabalInstall.Main
Network.Hackage.CabalInstall.Setup
Network.Hackage.CabalInstall.Tar
Network.Hackage.CabalInstall.TarUtils
Network.Hackage.CabalInstall.Types
Network.Hackage.CabalInstall.Update
......
["http://hackage.haskell.org/packages/archive"]
[("hackage.haskell.org", "http://hackage.haskell.org/packages/archive")]
......@@ -12,19 +12,21 @@
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Config
( packagesDirectory
, repoCacheDir
, getDefaultConfigDir
, getLocalConfigDir
, getLocalCacheDir
, getLocalPkgListDir
, getKnownServers
, getKnownPackages
, writeKnownPackages
, selectValidConfigDir
) where
import Prelude hiding (catch)
import Control.Exception (catch, Exception(IOException))
import Control.Monad.Error (mplus, filterM) -- Using Control.Monad.Error to get the Error instance for IO.
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Maybe (mapMaybe)
import System.Directory (Permissions (..), getPermissions, createDirectoryIfMissing
,getTemporaryDirectory)
......@@ -36,10 +38,11 @@ import Distribution.Package (PackageIdentifier)
import Distribution.PackageDescription (parseDescription, ParseResult(..))
import Distribution.Version (Dependency)
import Distribution.Verbosity
import System.FilePath ((</>))
import System.FilePath ((</>), takeExtension)
import System.Directory
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen(..), PkgInfo (..))
import Network.Hackage.CabalInstall.Tar (readTarArchive)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen(..), PkgInfo (..), Repo(..))
import Paths_cabal_install (getDataDir)
......@@ -77,52 +80,44 @@ servList cfg = configConfDir cfg </> servListFile
packagesDirectory :: ConfigFlags -> FilePath
packagesDirectory cfg = configCacheDir cfg </> packagesDirectoryName
-- | Full path to the package list file
pkgList :: ConfigFlags -> FilePath
pkgList cfg = configPkgListDir cfg </> pkgListFile
-- | Full path to the local cache directory for a repository.
repoCacheDir :: ConfigFlags -> Repo -> FilePath
repoCacheDir cfg repo = packagesDirectory cfg </> repoName repo
-- |Read the list of known packages from the pkg.list file.
getKnownPackages :: ConfigFlags -> IO [PkgInfo]
getKnownPackages cfg
= fmap readKnownPackages (readFile (pkgList cfg))
`catch` (\e
= fmap concat $ mapM (readRepoIndex cfg) $ configServers cfg
readRepoIndex :: ConfigFlags -> Repo -> IO [PkgInfo]
readRepoIndex cfg repo =
do let indexFile = repoCacheDir cfg repo </> "00-index.tar"
fmap parseRepoIndex (BS.readFile indexFile)
`catch` (\e
-> do hPutStrLn stderr ("Warning: Problem opening package list '"
++ pkgList cfg
++ "'."
)
++ indexFile ++ "'.")
case e of
IOException ioe | isDoesNotExistError ioe ->
hPutStrLn stderr "File doesn't exist. Run 'cabal-install update' to create the package list."
_ -> hPutStrLn stderr ("Error: " ++ (show e))
return [])
where
-- |Write the list of known packages to the pkg.list file.
writeKnownPackages :: ConfigFlags -> [PkgInfo] -> IO ()
writeKnownPackages cfg pkgs
= do message (configOutputGen cfg) verbose $
"creating package file " ++ pkgList cfg
createDirectoryIfMissing True (configPkgListDir cfg)
writeFile (pkgList cfg) (showKnownPackages pkgs)
-- FIXME: hacky format
showKnownPackages :: [PkgInfo] -> String
showKnownPackages = show . map show
-- FIXME: hacky format
-- FIXME: report errors
readKnownPackages :: String -> [PkgInfo]
readKnownPackages = mapMaybe readDesc . read
where readDesc s = case parseDescription s of
ParseOk _ d -> Just d
ParseFailed e -> Nothing
getKnownServers :: ConfigFlags -> IO [String]
parseRepoIndex :: ByteString -> [PkgInfo]
parseRepoIndex s =
do (name, content) <- readTarArchive s
if takeExtension name == ".cabal"
then case parseDescription (BS.unpack content) of
ParseOk _ descr -> return descr
_ -> error $ "Couldn't read cabal file " ++ show name
else fail "Not a .cabal file"
getKnownServers :: ConfigFlags -> IO [Repo]
getKnownServers cfg
= fmap read (readFile (servList cfg))
= fmap readRepos (readFile (servList cfg))
`mplus` return []
readRepos :: String -> [Repo]
readRepos = map (\ (n,u) -> Repo { repoName = n, repoURL = u }) . read
-- |Confirms validity of a config directory by checking the permissions for the package-list file,
-- server-list file and downloaded packages directory.
isValidConfigDir :: FilePath -> IO Bool
......
......@@ -146,7 +146,7 @@ mkConfigFlags cfg
, configUserIns = userIns
}
knownServers <- getKnownServers config
return (config{ configServers = knownServers ++ tempServers cfg})
return (config{ configServers = knownServers})
runhaskellProgram :: Program
runhaskellProgram = simpleProgram "runhaskell"
......@@ -33,8 +33,8 @@ import Data.Version
import Text.Printf (printf)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen (..), UnresolvedDependency (..))
import Network.Hackage.CabalInstall.Config (packagesDirectory)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen (..), UnresolvedDependency (..), Repo(..))
import Network.Hackage.CabalInstall.Config (packagesDirectory, repoCacheDir)
import Network.Hackage.CabalInstall.Dependency (filterFetchables, resolveDependencies)
import Distribution.Package (PackageIdentifier(..), showPackageId)
......@@ -95,16 +95,17 @@ downloadPackage cfg pkg url
Nothing -> return path
where path = packageFile cfg pkg
-- Downloads an index file to [config-dir/packages/serv-id
downloadIndex :: ConfigFlags -> String -> IO String
downloadIndex cfg serv
= do createDirectoryIfMissing True (packagesDirectory cfg)
-- Downloads an index file to [config-dir/packages/serv-id].
downloadIndex :: ConfigFlags -> Repo -> IO FilePath
downloadIndex cfg repo
= do let url = repoURL repo ++ "/" ++ "00-index.tar.gz"
dir = repoCacheDir cfg repo
path = dir </> "00-index" <.> "tar.gz"
createDirectoryIfMissing True dir
mbError <- downloadFile path url
case mbError of
Just err -> fail $ printf "Failed to download index '%s'" (show err)
Nothing -> return path
where url = serv ++ "/" ++ "00-index.tar.gz"
path = packagesDirectory cfg </> "00-index" <.> "tar.gz"
-- |Generate the full path to the locally cached copy of
-- the tarball for a given @PackageIdentifer@.
......
......@@ -39,7 +39,6 @@ emptyTempFlags = TempFlags {
tempPkgListDir = Nothing,
tempHcPkg = Nothing,
tempPrefix = Nothing,
tempServers = [],
tempRunHc = Nothing,
tempTarPath = Nothing,
tempVerbose = normal,
......@@ -62,8 +61,6 @@ globalOptions =
, Option "g" ["ghc"] (NoArg (\t -> t { tempHcFlavor = Just GHC })) "compile with GHC"
, Option "n" ["nhc"] (NoArg (\t -> t { tempHcFlavor = Just NHC })) "compile with NHC"
, Option "" ["hugs"] (NoArg (\t -> t { tempHcFlavor = Just Hugs })) "compile with hugs"
, Option "s" ["with-server"] (ReqArg (\url t -> t { tempServers = url:tempServers t }) "URL")
"give the URL to a Hackage server"
, Option "c" ["config-dir"] (ReqArg (\path t -> t { tempConfDir = Just path }) "PATH")
("override the path to the config dir.")
, Option "" ["cache-dir"] (ReqArg (\path t -> t { tempCacheDir = Just path }) "PATH")
......
-- | Simplistic TAR archive reading. Only gets the file names and file contents.
module Network.Hackage.CabalInstall.Tar (readTarArchive) where
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Char (ord)
import Data.Int (Int8, Int64)
import Data.List (unfoldr)
import Data.Maybe (catMaybes)
import Numeric (readOct)
readTarArchive :: ByteString -> [(FilePath,ByteString)]
readTarArchive = catMaybes . unfoldr getTarEntry
getTarEntry :: ByteString -> Maybe (Maybe (FilePath,ByteString), ByteString)
getTarEntry bs | endBlock = Nothing
| BS.length hdr < 512 = error "Truncated TAR archive."
| not (checkChkSum hdr chkSum) = error "TAR checksum error."
| not normalFile = Just (Nothing, bs''')
| otherwise = Just (Just (path, cnt), bs''')
where (hdr,bs') = BS.splitAt 512 bs
endBlock = getByte 0 hdr == '\0'
fileSuffix = getString 0 100 hdr
chkSum = getOct 148 8 hdr
typ = getByte 156 hdr
size = getOct 124 12 hdr
filePrefix = getString 345 155 hdr
normalFile = typ == '0' || typ == '\0'
path = filePrefix ++ fileSuffix
padding = (512 - size) `mod` 512
(cnt,bs'') = BS.splitAt size bs'
bs''' = BS.drop padding bs''
checkChkSum :: ByteString -> Int -> Bool
checkChkSum hdr s = s == chkSum hdr' || s == signedChkSum hdr'
where
-- replace the checksum with spaces
hdr' = BS.concat [BS.take 148 hdr, BS.replicate 8 ' ', BS.drop 156 hdr]
-- tar.info says that Sun tar is buggy and
-- calculates the checksum using signed chars
chkSum = BS.foldl' (\x y -> x + ord y) 0
signedChkSum = BS.foldl' (\x y -> x + (ordSigned y)) 0
ordSigned :: Char -> Int
ordSigned c = fromIntegral (fromIntegral (ord c) :: Int8)
-- * TAR format primitive input
getOct :: Integral a => Int64 -> Int64 -> ByteString -> a
getOct off len = parseOct . getString off len
where parseOct "" = 0
parseOct s = case readOct s of
[(x,_)] -> x
_ -> error $ "Number format error: " ++ show s
getBytes :: Int64 -> Int64 -> ByteString -> ByteString
getBytes off len = BS.take len . BS.drop off
getByte :: Int64 -> ByteString -> Char
getByte off bs = BS.index bs off
getString :: Int64 -> Int64 -> ByteString -> String
getString off len = BS.unpack . BS.takeWhile (/='\0') . getBytes off len
......@@ -44,7 +44,6 @@ data TempFlags = TempFlags {
tempPkgListDir :: Maybe FilePath,
tempHcPkg :: Maybe FilePath, -- ^given hc-pkg location
tempPrefix :: Maybe FilePath,
tempServers :: [String], -- ^Available Hackage servers.
tempTarPath :: Maybe FilePath,
tempRunHc :: Maybe FilePath,
tempVerbose :: Verbosity, -- ^verbosity level
......@@ -60,7 +59,7 @@ data ConfigFlags = ConfigFlags {
configCacheDir :: FilePath,
configPkgListDir :: FilePath,
configPrefix :: Maybe FilePath,
configServers :: [String], -- ^Available Hackage servers.
configServers :: [Repo], -- ^Available Hackage servers.
configTarPath :: FilePath,
configRunHc :: FilePath,
configOutputGen :: OutputGen,
......@@ -69,6 +68,11 @@ data ConfigFlags = ConfigFlags {
configUserIns :: Bool -- ^--user-install flag
}
data Repo = Repo {
repoName :: String,
repoURL :: String
}
data OutputGen
= OutputGen
{ prepareInstall :: [(PackageIdentifier,[String],String)] -> IO ()
......
......@@ -14,8 +14,7 @@ module Network.Hackage.CabalInstall.Update
( update
) where
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen(..), PkgInfo(..))
import Network.Hackage.CabalInstall.Config (writeKnownPackages)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen(..), PkgInfo(..), Repo(..))
import Network.Hackage.CabalInstall.TarUtils (extractTarFile, tarballGetFiles)
import Network.Hackage.CabalInstall.Utils (isVerbose)
import Network.Hackage.CabalInstall.Fetch (downloadIndex, packagesDirectory)
......@@ -23,9 +22,12 @@ import Network.Hackage.CabalInstall.Fetch (downloadIndex, packagesDirectory)
import Distribution.Package (PackageIdentifier(..), pkgName, showPackageId)
import Distribution.PackageDescription (PackageDescription(..), readPackageDescription, GenericPackageDescription(..))
import Distribution.Verbosity
import System.FilePath ((</>), joinPath, addExtension, takeExtension)
import System.FilePath ((</>), joinPath, addExtension, takeExtension, dropExtension)
import Codec.Compression.GZip(decompress)
import Control.Monad (liftM, when)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.List (intersperse, isSuffixOf)
import Data.Version (showVersion)
......@@ -33,37 +35,18 @@ import Text.Printf
-- | 'update' downloads the package list from all known servers
update :: ConfigFlags -> IO ()
update cfg =
do packages <- concatMapM servers $ \server ->
do gettingPkgList output server
indexPath <- downloadIndex cfg server
extractTarFile tarPath indexPath
contents <- tarballGetFiles tarPath indexPath
when (isVerbose cfg) $ printf "Retrieved %d package descriptions\n" (length contents)
let packageDir = packagesDirectory cfg
cabalFiles = [ packageDir </> path
| path <- contents
, ".cabal" == takeExtension path ]
mapM (liftM (mkPkgInfo server)
. readPackageDescription (lessVerbose (configVerbose cfg)))
cabalFiles
when (isVerbose cfg) $ printf "Processed %d package descriptions\n" (length packages)
writeKnownPackages cfg packages
where servers = configServers cfg
output = configOutputGen cfg
tarPath = configTarPath cfg
update cfg = mapM_ (updateRepo cfg) (configServers cfg)
mkPkgInfo :: String -> GenericPackageDescription -> PkgInfo
mkPkgInfo server desc
= desc { packageDescription = (packageDescription desc) { pkgUrl = url } }
where url = pkgURL (package (packageDescription desc)) server
updateRepo :: ConfigFlags
-> Repo
-> IO ()
updateRepo cfg repo =
do gettingPkgList (configOutputGen cfg) (repoURL repo)
indexPath <- downloadIndex cfg repo
BS.readFile indexPath >>= BS.writeFile (dropExtension indexPath) . decompress
-- | Generate the URL of the tarball for a given package.
pkgURL :: PackageIdentifier -> String -> String
pkgURL pkg base = joinWith "/" [base, pkgName pkg, showVersion (pkgVersion pkg), showPackageId pkg]
pkgURL :: PackageIdentifier -> Repo -> String
pkgURL pkg repo = joinWith "/" [repoURL repo, pkgName pkg, showVersion (pkgVersion pkg), showPackageId pkg]
++ ".tar.gz"
where joinWith tok = concat . intersperse tok
concatMapM :: (Monad m) => [a] -> (a -> m [b]) -> m [b]
concatMapM amb f = liftM concat (mapM f amb)
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