{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Main where import qualified AptMethod import Chroot import Control.Exception import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import Data.List import qualified Data.Map as Map import Data.Maybe import qualified Debian.Control.ByteString as B import qualified Debian.Control.String as S import Debian.Repo.SourcesList import Debian.Repo.Types import qualified Debian.Version.ByteString as B import qualified Debian.Version.String as S import Network.URI import System.Cmd import System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.FilePath (dropFileName) import System.IO import System.Posix.Files import System.Posix.Signals import System.Unix.Directory import System.Unix.FilePath ((<++>)) import System.Unix.Mount import System.Unix.Process type Flags = [(String, String)] instance Show (B.Control' ByteString) where show (B.Control c) = "(B.Control " ++ show c ++ ")" instance Show (B.Paragraph' ByteString) where show (B.Paragraph p) = "(B.Paragraph " ++ show p ++ ")" instance Show (B.Field' ByteString) where show (B.Field f) = "(B.Field " ++ show f ++ ")" main :: IO () main = getArgs >>= computeFlags >>= getTempDir >>= checkHelp >>= mapM expandInclude >>= getArchitecture >>= buildEnv where computeFlags args = case getOpt Permute opts args of (o, [], []) -> return o (o, extra, []) -> error ("Unrecognized arguments: " ++ show extra) (_, _, errs) -> ioError (userError (concat errs ++ usage)) checkHelp flags = case lookup "Help" flags of Just _ -> do hPutStrLn stderr usage exitWith ExitSuccess Nothing -> return flags expandInclude ("Include", path) = do text <- readFile path return ("With", text) expandInclude x = return x getArchitecture flags = do let flag = lookup "Architecture" flags case flag of Just arch -> do hPutStrLn stderr ("Architecture: " ++ show flag) return flags Nothing -> do arch <- commandOutput cmd let arch' = either (const $ error (cmd ++ " failed")) (fixarch . words) arch hPutStrLn stderr ("Architecture: " ++ show arch') return $ ("Architecture", arch') : flags where fixarch [] = error (cmd ++ " failed") fixarch (x : _) = x cmd = "dpkg-architecture -qDEB_BUILD_ARCH" getTempDir :: Flags -> IO Flags getTempDir flags = case lookup "Temp-Dir" flags of Nothing -> do temp <- mkdtemp "/tmp/debian.XXXXXX" logNormal ("Temporary directory: " ++ temp ++ "\n") return $ ("Temp-Dir", temp) : flags Just d -> return flags buildEnv :: Flags -> IO () buildEnv flags = do mapM_ (\ s -> installHandler s (Catch (error ("Signal caught: " ++ show s))) Nothing) [sigABRT, {- sigALRM, -} sigFPE, sigHUP, sigILL, sigINT, sigPIPE, sigTERM, sigUSR1, sigUSR2, sigCONT, sigTSTP, sigTTIN, sigTTOU, sigVTALRM] try (buildFromSourcesList flags) >>= either (\ e -> do hPutStrLn stderr ("Exception: " ++ show e) cleanup flags (hasOpt "Keep-Tmp" flags) exitWith (ExitFailure 1)) (\ _ -> do cleanup flags False exitWith ExitSuccess) where outputDir = maybe (error "You must specify --output") id (lookup "Output" flags) buildFromSourcesList flags = do checkOutputDir createSkeleton cacheDir outputDir archiveDir copyEnv noUpdate outputDir writeDirFile outputDir srcsList <- readFile fakeSrcsListFn >>= return . filter isBinarySource . parseSourcesList let srcsUrls = concat . map (toURI architecture) $ srcsList -- mapM_ (debugoutput architecture) srcsList let srcsNames = concat . map (toLocal architecture) $ srcsList -- hPutStrLn stderr "srcsNames" -- mapM_ (hPutStrLn stderr . show) srcsNames let srcsLocal = map (if noUpdate then ((outputDir ++ "/var/lib/apt/lists/") ++) else ((cacheDir ++ "/") ++)) srcsNames -- hPutStrLn stderr $ "srcsLocal: " ++ show srcsLocal -- mapM_ (hPutStrLn stderr . show) srcsLocal let needsSSH = let methods = map uriScheme srcsUrls in elem "ssh" methods || elem "rsh" methods hPutStr stderr "Loading package lists...\n" packages <- do if noUpdate then return () else aptGetUpdate allowMissing srcsUrls srcsLocal controls <- mapM B.parseControlFromFile srcsLocal let controls' = map (either (\ e -> error . show $ e) id) controls return . computeNewest . B.unControl . B.mergeControls $ controls' let packageNames = map (fromJust . B.fieldValue "Package") packages -- hPutStrLn stderr $ "packageNames: " ++ show packageNames let packageMap = maybeMap (zip packageNames packages) -- We need makedev below to create random and urandom, and many, many -- post install scripts need it too. Because MAKEDEV will try to chown -- the devices it creates, we need base-passwd so the users and groups -- it wants will exist. let extraEssentialPackages' = "makedev" : "base-passwd" : "dpkg" : (if needsSSH then ["ssh"] else []) ++ extraEssentialPackages let essential = computeEssential (map C.pack extraEssentialPackages') (map C.pack nonEssentialPackages) packages let essentialNames = map (fromJust . B.fieldValue "Package") essential -- Map essential package name to latest versions --let (essentialMap :: Map.Map ByteString (Maybe B.Paragraph)) = maybeMap (zip essentialNames essential) -- hPutStrLn stderr ("essential packages:\n" ++ -- showListLines " " (map (\ p -> ((show . fromJust . B.fieldValue "Package" $ p) ++ "=" ++ -- (show . fromJust . B.fieldValue "Version" $ p))) -- essential)) -- In Ubuntu the coreutils package creates a diversion, and that -- fails if the diversions file doesn't exist. createDirectoryIfMissing True (outputDir ++ "/var/lib/dpkg") writeFile (outputDir ++ "/var/lib/dpkg/diversions") "" case noUpdate of True -> return () False -> aptGet "update -o APT::Cache-Limit=300000000 " case noEssential of True -> return () False -> do aptGet . ("install --yes --force-yes --download-only -o APT::Install-Recommends=False apt " ++) . concat . intersperse " " . map C.unpack $ essentialNames getDirectoryPaths (outputDir ++ "/var/cache/apt/archives") >>= return . filter (isSuffixOf ".deb") >>= mapM_ (\ deb -> command ("dpkg -x " ++ deb ++ " " ++ outputDir)) laterDebs <- if noEssential then return [] else reconfigureLaterDebs architecture packageMap {-mirrored-} tmpDir outputDir sshAuthSockDir <- getEnvMaybe "SSH_AUTH_SOCK" >>= maybe (return Nothing) (return . Just . dropFileName) case needsSSH of False -> return () True -> do command ("cp -a ~/.ssh " ++ outputDir) case sshAuthSockDir of Nothing -> return () Just dir -> do createDirectoryIfMissing True (outputDir ++ dir) command ("mount --bind " ++ dir ++ " " ++ outputDir ++ dir) case noUpdate of True -> return () False -> do command ("cp " ++ srcsListFn ++ " " ++ outputDir ++ "/tmp/sources.list") command ("cp " ++ preferencesFn ++ " " ++ outputDir ++ "/tmp/preferences") command ("cd " ++ outputDir ++ " && mkdir -p dev proc sys") -- We used to mount --bind the virtual file systems here, but this -- is not always a good idea, particularly for dev which may have -- a different udev configuration than the parent. if hasOpt "Mount-Kernel" flags then command ("sudo chroot " ++ outputDir ++ " sh -c '{ /etc/init.d/mountkernfs.sh start || /etc/init.d/mountvirtfs.sh start; }' && " ++ "mount --bind /dev " ++ outputDir ++ "/dev") else return () {- command ("mount --bind /proc " ++ outputDir ++ "/proc") command ("mount --bind /dev " ++ outputDir ++ "/dev") command ("mount --bind /sys " ++ outputDir ++ "/sys") -} fchroot outputDir (do -- Move start-stop-daemon and invoke-rc.d out of the -- way, we don't want to start daemons inside the -- chroot case noEssential of True -> return () False -> do command "cd /usr/bin && (test -f gawk && ln -s gawk awk) || (test -f mawk && ln -s mawk awk)" mapM_ neuterFile neuterFiles -- move ~/.ssh into place if sources.list requires ssh. -- DSF: I changed the destination from ~/ to /root/ in -- case $HOME is set to some user that only exists in -- the outside world. case needsSSH of False -> return () True -> command "if [ -d /.ssh ] ; then mv /.ssh/ /root/ ; fi" -- apt-get install the essential packages case noUpdate of True -> return () False -> do command "mv /tmp/sources.list /etc/apt/sources.list" command "mv /tmp/preferences /etc/apt/preferences" command "echo 'APT::Cache-Limit 300000000;' >/etc/apt/apt.conf" command "echo 'APT::Get::AllowUnauthenticated 1;' >>/etc/apt/apt.conf" command "echo 'Dpkg::MaxArgs 1024;' >>/etc/apt/apt.conf" command "echo 'Dpkg::MaxArgBytes 32000;' >>/etc/apt/apt.conf" case noEssential of True -> return () False -> do -- /var/lib/dpkg/info/base-passwd.postinst configure >/tmp/out 2>/tmp/err" command "if [ ! -e /etc/passwd ] ; then cp /usr/share/base-passwd/passwd.master /etc/passwd; fi" command "if [ ! -e /etc/group ] ; then cp /usr/share/base-passwd/group.master /etc/group; fi" command ("DEBIAN_FRONTEND=noninteractive apt-get install --yes -o APT::Cache-Limit=300000000 " ++ (if (hasOpt "Immediate-Configure" flags) then "-o APT::Immediate-Configure=false " else "") ++ "apt " ++ (if needsSSH then "ssh " else "") ++ (concat . intersperse " " . map show $ essentialNames)) -- unpack and configure any debs that had fake -- status file entries so that they are installed -- for real mapM_ (\ deb -> do command ("dpkg --unpack " ++ deb) command ("dpkg --configure --pending")) laterDebs -- Move start-stop-daemon and invoke-rc.d out -- of the way (again), we don't want to start -- daemons inside the chroot mapM_ neuterFile neuterFiles -- now we should have a fully functional -- system, so we can apt-get some additional -- packages let extra = (if noBuildEssential then [] else ["build-essential"]) ++ extraPackages command ("DEBIAN_FRONTEND=noninteractive apt-get install --yes -o APT::Cache-Limit=300000000 " ++ (concat . intersperse " " $ extra)) -- Restore neutered files mapM checkAndRestore ["/sbin/start-stop-daemon", "/usr/sbin/invoke-rc.d", "/sbin/init"] >>= return . catMaybes >>= (\ undead -> case undead of [] -> return () undead -> error ("Undead files: " ++ show undead)) -- Create a basic set of device nodes to help the package -- install scripts. prepareDevs -- The log_to_console function in lsb-base checks this to -- decide whether to log to the console or not, but it dies -- if the link doesn't exist at all. Bug? createDirectoryIfMissing True "/proc/self/fd" doesFileExist "/proc/self/fd/0" >>= bool (createSymbolicLink "/dev/null" "/proc/self/fd/0") (return ()) -- make sure .ssh does not escape into the wild case needsSSH of True -> command "rm -rf /root/.ssh" False -> return ()) hPutStrLn stderr "Finished." where isBinarySource (DebSource Deb _ _) = True isBinarySource _ = False checkOutputDir :: IO () checkOutputDir = do exists <- doesDirectoryExist outputDir case exists of False -> return () True -> if forceExists then return () else error ("Sorry, a directory or file named " ++ outputDir ++ " already exists.") fakeSrcsListFn = maybe srcsListFn id (lookup "Fake-Sources-List" flags) srcsListFn = maybe (error "You must specify --sources-list") id (lookup "Sources-List" flags) preferencesFn = maybe "/dev/null" id (lookup "Preferences" flags) archiveDir = lookup "Archive-Dir" flags noUpdate = hasOpt "No-Update" flags noEssential = hasOpt "No-Essential" flags noBuildEssential = hasOpt "No-Build-Essential" flags forceExists = hasOpt "Force-Exists" flags architecture = maybe "i386" id (lookup "Architecture" flags) -- mirrored = hasOpt "Mirrored" cacheDir = tmpDir ++ "/cache" outputDir = fromJust (lookup "Output" flags) aptGet cmd = command ("DEBIAN_FRONTEND=noninteractive apt-get -q " ++ aptOpts ++ cmd) aptOpts = (" -o=Dir::State::status=" ++ (addDotSlash outputDir) ++ "/var/lib/dpkg/status" ++ " -o=Dir::State::Lists=" ++ (addDotSlash outputDir) ++ "/var/lib/apt/lists" ++ " -o=Dir::Cache::Archives=" ++ (addDotSlash outputDir) ++ "/var/cache/apt/archives" ++ " -o=Dir::Etc::SourceList=" ++ (addDotSlash srcsListFn) ++ " " ++ " -o=Dir::Etc::SourceParts=\"\"" ++ " -o=Dir::Etc::Preferences=" ++ (addDotSlash preferencesFn) ++ " ") -- allow --with 'a b c' extraPackages = concat . map words . findAll "With" $ flags extraEssentialPackages = concat . map words . findAll "With-Essential" $ flags nonEssentialPackages = concat . map words . findAll "Omit-Essential" $ flags overwrite = hasOpt "Force-Overwrite" flags allowMissing = hasOpt "Allow-Missing-Indexes" flags tmpDir = fromJust (lookup "Temp-Dir" flags) addDotSlash path@('/' : _) = path addDotSlash path@('.' : '/' : _) = path -- addDotSlash path@('.' : '.' : '/' : _) = path addDotSlash path = "./" ++ path -- Sort packages so that newest comes first sortPackages :: [B.Paragraph] -> [B.Paragraph] -- Sort package list so newest version comes first sortPackages = sortBy (\ p1 p2 -> case (B.fieldValue "Version" p1, B.fieldValue "Version" p2) of (Just v1, Just v2) -> compare (B.parseDebianVersion v2) (B.parseDebianVersion v1)) neuterFiles = [("/sbin/start-stop-daemon", True), ("/usr/sbin/invoke-rc.d", True), ("/sbin/init", False), -- Previously, there was this comment here: -- -- /sbin/init must be present, so either sysvinit or upstart must be added to the essential list. -- Debian has (had?) sysvinit as essential, but it is not required to run dpkg, so that seems -- busted. Ubuntu has not added upstart to essential, presumably because of the same logic. ("/usr/sbin/policy-rc.d", False)] -- | Discard all but the newest version of each package. computeNewest :: [S.Paragraph' ByteString] -> [S.Paragraph' ByteString] computeNewest packages = map (head . sortByVersion) (groupByName packages) where sortByVersion packages = sortBy compareVersions packages compareVersions b a = case (B.fieldValue "Version" a, B.fieldValue "Version" b) of (Just a', Just b') -> compare (B.parseDebianVersion a') (B.parseDebianVersion b') _ -> error "Missing package version" groupByName packages = groupBy (\ a b -> B.fieldValue "Package" a == B.fieldValue "Package" b) (sortBy compareNames packages) where compareNames a b = case (B.fieldValue "Package" a, B.fieldValue "Package" b) of (Just a', Just b') -> compare a' b' _ -> error "Missing package name" -- | Retrieve the control info for the essential packages computeEssential :: [ByteString] -> [ByteString] -> [S.Paragraph' ByteString] -> [S.Paragraph' ByteString] computeEssential extra omit packages = case foldr checkEssential (extra, []) packages of ([], essential) -> essential -- Some package in the extra list wasn't in the package list, -- signal an error. (missing, _) -> error ("Some essential packages are missing: " ++ show missing) where checkEssential package (extra, essential) = case (B.fieldValue "Package" package, B.fieldValue "Essential" package) of (Nothing, _) -> error "Invalid package data: missing Package field" (Just name, Just status) | (C.unpack (B.stripWS status)) /= "no" -> let extra' = filter (/= name) extra in (extra', if elem name omit then essential else package : essential) (Just name, _) -> let extra' = filter (/= name) extra in (extra', if elem name extra then package : essential else essential) prepareDevs :: IO () -- ^ Create a basic set of basic device nodes in /dev. This is run -- inside a changeroot, so we can use MAKEDEV. Typically, in a -- working system udev will mount a tmpfs over this and create a full -- set of device nodes. prepareDevs = mapM_ system $ map ("cd /dev && /sbin/MAKEDEV " ++) names where names = ["null", "zero", "full", "console", "loop", -- Used by apt's ssh method "random", "urandom", -- For some Ubuntu packages, which otherwise try to -- use /dev/MAKEDEV rather than /sbin/MAKEDEV. "ppp", "raw1394"] getDirectoryPaths :: FilePath -> IO [FilePath] getDirectoryPaths dir = getDirectoryContents dir >>= return . map (dir <++>) reconfigureLaterDebs :: String -> (Map.Map ByteString (Maybe B.Paragraph)) -> FilePath -> FilePath -> IO [String] reconfigureLaterDebs architecture packageMap {-mirrored-} tmpDir outputDir = do fakeDebs <- mapM (control' outputDir) paths -- hPutStrLn stderr ("fakeDebs: " ++ show fakeDebs) -- hPutStrLn stderr ("fakeStatus: " ++ (concat . map ((++ "\n") . show . snd) $ fakeStatus)) -- hPutStrLn stderr ("/var/lib/dpkg/status: " ++ (show . map snd $ fakeStatus)) writeFile (outputDir ++ "/var/lib/dpkg/status") (concat $ map (show . fakeStatus) info) mapM_ (flip writeFile $ "") (map (\ name -> outputDir ++ "/var/lib/dpkg/info/" ++ name ++ ".list") names) return paths where paths :: [FilePath] paths = map (("/var/cache/apt/archives" <++>) . packageDebName architecture) info info :: [B.Paragraph] info = map (\ name -> maybe (error ("Couldn't get info on '" ++ name)) id (Map.findWithDefault Nothing (C.pack name) packageMap)) names names = ["dpkg"] formatParagraph (B.Paragraph fields) = concat $ map ((++ "\n") . formatField) fields formatField (B.Field (k, v)) = C.unpack k ++ ": " ++ C.unpack v -- Get the control information for a binary deb fakeStatus :: B.Paragraph -> S.Paragraph fakeStatus info = let package = C.unpack . fromJust . B.fieldValue "Package" $ info in let version = C.unpack . fromJust . B.fieldValue "Version" $ info in let status = "install ok installed" in S.Paragraph [S.Field ("Package", " " ++ package), S.Field ("Version", " " ++ version), S.Field ("Status", " install ok installed")] control' :: FilePath -> FilePath -> IO S.Paragraph control' outputDir path = let deb1 = outputDir ++ path deb2 = outputDir <++> path in if deb1 /= deb2 then error $ "a ++ b -> " ++ show deb1 ++ ", a <++> b -> " ++ show deb2 else control deb1 control :: FilePath -> IO S.Paragraph control deb = do let cmd = "dpkg -f " ++ deb ++ " > " ++ tmpDir <++> "control" command cmd result <- S.parseControlFromFile (tmpDir <++> "control") case either (error ("Failure: " ++ cmd)) id result of S.Control (p : _) -> return p _ -> error ("Couldn't get control info for " ++ deb) -- there is a hack -- namely only : is url encoded in filenames packageDebName :: String -> B.Paragraph -> String packageDebName arch control = let name = maybe (error "Missing Package field") C.unpack (B.fieldValue "Package" control) in let version = encode (maybe (error "Missing Version field") C.unpack (B.fieldValue "Version" control)) in let sourceDebArch = maybe (error "Missing Architecture field") C.unpack (B.fieldValue "Architecture" control) in {- note the '*' in the version. This is because the fullpool pool may contain cnrX things appended to the version, but the control file we read is from the mirrored pool. Since there should only be one version this ought to work, but it is just a hack to support the 'obsolete' coho stuff -- so I don't care to fix it right. -} let debArch = case sourceDebArch of "any" -> architecture x -> x in name ++ "_" ++ version ++ {-(if mirrored then "*_" else "_")-} "_" ++ debArch ++ ".deb" encode :: String -> String encode "" = "" encode (':' : s) = "%3a" ++ encode s encode (c : s) = c : encode s neuterFile :: (FilePath, Bool) -> IO () neuterFile (file, mustExist) = do logNormal ("Neutering file " ++ file ++ "\n") ; exists <- doesFileExist file case exists of True -> do same1 <- sameInode file "/bin/true" -- It can happen, though I don't know exactly what is doing it, -- that after we create a hard link to /bin/true that link is -- turned into a copy. same2 <- sameContents file "/bin/true" case (same1, same2) of (True, _) -> logNormal "File is already a hardlink to /bin/true\n" (_, True) -> logNormal "File is already a copy of /bin/true\n" _ -> do realExists <- doesFileExist (file ++ ".real") case realExists of True -> do sameContents <- sameContents file (file ++ ".real") case sameContents of True -> do logNormal "File already backed up. Unlinking.\n" removeFile file False -> error ("Error: " ++ file ++ " and " ++ file ++ ".real are not the same file.\n") False -> do logNormal "Backing up file.\n" renameFile file (file ++ ".real") logNormal "hardlinking to /bin/true.\n" createLink "/bin/true" file mapM_ (system . (\ x -> "ls -l " ++ x ++ " 1>&2")) ["/bin/true", file, file ++ ".real"] False -> case mustExist of True -> do error "Could not neuter non-existant file.\n" False -> logNormal "File does not exists, nothing to do...\n" checkAndRestore file = do exists <- doesFileExist file case exists of False -> return Nothing True -> do same1 <- sameInode file "/bin/true" same2 <- sameContents file "/bin/true" case same1 || same2 of True -> do logNormal ("Restoring " ++ file ++ "\n") renameFile (file ++ ".real") file return Nothing False -> return $ Just (file, "/bin/true") sameInode file1 file2 = do lstat1 <- getFileStatus file1 lstat2 <- getFileStatus file2 return $ fileID lstat1 == fileID lstat2 && deviceID lstat1 == deviceID lstat2 sameContents :: FilePath -> FilePath -> IO Bool sameContents a b = do aText <- readFile a bText <- readFile b return (aText == bText) {- -- |Return the list of files that apt-get update would write into -- \/var\/lib\/apt\/lists when it processed the given list of DebSource. -- This is basically what SourcesList.archFiles is supposed to do. -} -- |A DebSource can be converted into a list of URIs which refer to -- files on the remote server using [toURI], or into a list of FilePath -- which refer to the same files after they have been downloaded onto -- the local machine using [toLocal]. Both use [toPath] to generate the -- portion after the URI Scheme. toURI :: String -> DebSource -> [URI] toURI arch deb@(DebSource typ uri _) = catMaybes . map parseURI . map (prefix ++) $ toPaths typ arch deb where prefix = scheme ++ "//" ++ user ++ reg ++ port scheme = uriScheme uri user= maybe "" uriUserInfo auth reg = maybe "" uriRegName auth port = maybe "" uriPort auth auth = uriAuthority uri toLocal :: String -> DebSource -> [FilePath] toLocal arch deb@(DebSource typ uri _) = map (addPrefix . escapePath) (toPaths typ arch deb) where addPrefix s = prefix scheme user' pass' reg port ++ {- "_" ++ -} s prefix "http:" (Just user) Nothing (Just host) port = user ++ host ++ port prefix "http:" _ _ (Just host) port = host ++ port prefix "ftp:" _ _ (Just host) _ = host prefix "file:" Nothing Nothing Nothing "" = "" prefix "ssh:" (Just user) Nothing (Just host) port = user ++ host ++ port prefix "ssh:" _ _ (Just host) port = host ++ port prefix _ _ _ _ _ = error ("invalid DebSource: " ++ show deb) user' = maybeOfString user pass' = maybeOfString pass (user, pass) = break (== ':') userpass userpass = maybe "" uriUserInfo auth reg = maybeOfString $ maybe "" uriRegName auth port = maybe "" uriPort auth scheme = uriScheme uri auth = uriAuthority uri path = uriPath uri toPaths :: SourceType -> String -> DebSource -> [FilePath] toPaths Deb arch deb@(DebSource Deb uri distro) = map (++ "/binary-" ++ arch ++ "/Packages") (toPaths' deb) toPaths DebSrc _ deb@(DebSource DebSrc uri distro) = map (++ "/source/Sources") (toPaths' deb) toPaths' :: DebSource -> [FilePath] toPaths' deb@(DebSource typ uri (Left exact)) = [uriPath uri <++> exact] toPaths' deb@(DebSource typ uri (Right (dist, sections))) = map ((uriPath uri <++> "dists" <++> (releaseName' dist)) <++>) (map sectionName' sections) escapePath :: String -> String escapePath s = concat . intersperse "_" $ wordsBy (== '/') s maybeOfString :: String -> Maybe String maybeOfString "" = Nothing maybeOfString s = Just s -- |Create a map from a list of (key, value) pairs which returns a list -- of all the values that appeared under that key. listMap :: (Ord k) => [(k, a)] -> Map.Map k [a] listMap pairs = foldl insertPair Map.empty pairs where insertPair m (k,a) = Map.insert k (a : (Map.findWithDefault [] k m)) m maybeMap :: (Ord k) => [(k, a)] -> Map.Map k (Maybe a) maybeMap pairs = foldl insertPair Map.empty pairs where insertPair m (k,a) = case Map.findWithDefault Nothing k m of Nothing -> Map.insert k (Just a) m Just a' -> error "Duplicate key in maybeMap" wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]] wordsBy p s = case (break p s) of (s, []) -> [s] (h, t) -> h : wordsBy p (drop 1 t) createSkeleton :: FilePath -> FilePath -> Maybe FilePath -> IO () createSkeleton cacheDir outputDir archiveDir = do mapM_ (createDirectoryIfMissing True) dirs mapM_ touch files maybe (return ()) (\ dir -> command ("mount --bind " ++ dir ++ " " ++ outputDir ++ "/var/cache/apt/archives")) archiveDir where touch file = do exists <- doesFileExist file case exists of False -> writeFile file "" True -> return () dirs = [ cacheDir , outputDir ++ "/etc" , outputDir ++ "/usr/info" , outputDir ++ "/var/lib/dpkg" , outputDir ++ "/var/cache/apt/archives/partial" , outputDir ++ "/var/lib/apt/lists/partial" , outputDir ++ "/var/backups" , outputDir ++ "/usr/lib/locale" ] files = [ outputDir ++ "/var/lib/dpkg/status" , outputDir ++ "/var/lib/dpkg/available" , outputDir ++ "/etc/fstab" ] copyEnv True _ = return () copyEnv False outputDir = mapM_ copyIfExists ["/etc/timezone", "/etc/resolv.conf", "/etc/hosts", "/usr/lib/locale/locale-archive" , "/etc/localtime" -- only needed because tzdata fails to configure in gutsy with out it ] where copyIfExists path = doesFileExist path >>= bool (return ()) (copyFile path (outputDir ++ path)) writeDirFile outputDir = do writeFile (outputDir ++ "/var/backups/infodir.bak") dirText writeFile (outputDir ++ "/usr/info/dir") dirText -- this line only needed for 4.0, but doesn't hurt anything where dirText = ("-*- Text -*-\n" ++ "This is the file .../info/dir, which contains the topmost node of\n" ++ "the Info hierarchy. The first time you invoke Info you start off\n" ++ "looking at that node, which is (dir)Top.\n" ++ "\US\n" ++ "File: dir\tNode: Top\tThis is the top of the INFO tree\n" ++ " This (the Directory node) gives a menu of major topics. Typing \"d\"\n" ++ " returns here, \"q\" exits, \"?\" lists all INFO commands, \"h\" gives a\n" ++ " primer for first-timers, \"mTexinfo\" visits Texinfo topic,\n" ++ " etc.\n" ++ " Or click mouse button 2 on a menu item or cross reference to select\n" ++ " it.\n" ++ " --- PLEASE ADD DOCUMENTATION TO THIS TREE. (See INFO topic first.) ---\n" ++ "\n" ++ "In Debian GNU/Linux, Info `dir' entries are added with the command\n" ++ "`install-info'. Please refer to install-info(8) for usage details.\n" ++ "\n" ++ "* Menu: The list of major topics begins on the next line.\n" ++ "\n" ++ "Basics\n" ++ "* Finding files: (find). Operating on files matching certain criteria.\n" ++ "\n" ++ "Miscellaneous:\n" ++ "\n" ++ "Development\n" ++ "* Ipc: (ipc).\t\t System V interprocess communication facilities\n" ++ "\n" ++ "General Commands\n" ++ "* grep: (grep). \t Print lines matching a pattern.\n" ++ "* sed: (sed).\t\t Stream EDitor.\n" ++ "* Tar: (tar).\t\t Making tape (or disk) archives.") command :: String -> IO () command cmd = do hPutStrLn stderr ("--> " ++ cmd) result <- system cmd case result of ExitSuccess -> return () ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n) cleanup :: Flags -> Bool -> IO () -- ^ Kill all processes and unmount everything inside the build environment. cleanup flags keepTmp = do hPutStrLn stderr "Cleaning up." let outputDir = fromJust $ lookup "Output" flags -- unmount the stuff we mounted up before exiting logNormal ("Killing all process with cwd under " ++ outputDir ++ " ...\n") ; result <- killByCwd outputDir; logNormal $ showListLines " " result logNormal ("Unmounting anything mounted under " ++ outputDir ++ " ...\n") ; result <- umountBelow outputDir logNormal $ showListLines " " result if not keepTmp then maybe (return ()) removeRecursiveSafely (lookup "Temp-Dir" flags) else return () -- Display a list one line per element showListLines indent elems = indent ++ "[" ++ concat (intersperse ("\n " ++ indent) (map show elems)) ++ "]\n" logNormal s = hPutStr stderr s hasOpt s flags = maybe False (\ _ -> True) (lookup s flags) findAll s flags = map snd . filter (test s) $ flags where test s (a, b) = a == s usage = usageInfo ("Usage: build-env [options].\n\n" ++ "Build-env creates a directory containing a clean build environment.\n" ++ "Use use-env to use the environtment.\n\n" ++ "Currently, the Packages files in the fullpool have had the Essential:\n" ++ "lines removed, so you will need to construct a fake sources.list file\n" ++ "that points to the mirrored pool so that the program can calculate the\n" ++ "Essential packages to install from the fullpool.\n\n" ++ "Examples:\n\n" ++ "\tbuild-env -m -s marlin.list -o marlin with ssh\n\n" ++ "Options:\n") opts aptGetUpdate :: Bool -> [URI] -> [FilePath] -> IO () aptGetUpdate allowMissing srcsUrls srcsLocal = case (srcsUrls, srcsLocal) of (url : url_tl, local : local_tl) -> do AptMethod.fetch allowMissing url local aptGetUpdate allowMissing url_tl local_tl ([], []) -> return () _ -> hPutStrLn stderr ("aptGetUpdate - invalid arguments: " ++ show (srcsUrls, srcsLocal)) >> return () opts :: [OptDescr (String, String)] opts = [Option ['f'] ["fakesrcslist", "fake-sources-list"] (ReqArg (\ x -> ("Fake-Sources-List", x)) "PATH") "fake sources.list file to build environment from", Option [] ["force-exists"] (NoArg ("Force-Exists", "yes")) "do not abort if output directory already exists.", Option [] ["no-update"] (NoArg ("No-Update", "yes")) ("assume apt files in build environment have already been updated.\n" ++ " Implies --force-exists. Overrides --srcslist."), Option [] ["no-essential"] (NoArg ("No-Essential", "yes")) "assume that essential packages are already installed.", Option [] ["no-build-essential"] (NoArg ("No-Build-Essential", "yes")) "do not install build essential packages.", Option [] ["force-overwrite"] (NoArg ("Force-Overwrite", "yes")) "use dpkg --force-overwrite for essential packages.", Option [] ["allow-missing-indexes"] (NoArg ("Allow-Missing-Indexes", "yes")) ("Do not fail if apt-get update detects missing index files.\n" ++ "It appears that apt's http method cannot distinguish between\n" ++ "empty index files and missing index files."), {-Option ['m'] ["mirrored"] (NoArg ("Mirrored", "yes")) "automatically replace 'fullpool' with 'mirrored'",-} Option ['k'] ["keep-tmp"] (NoArg ("Keep-Tmp", "yes")) "don't remove the temporary directory on failure.", Option ['o'] ["output"] (ReqArg (\ x -> ("Output", x)) "PATH") "directory to build environment in", Option ['s'] ["srcslist", "sources-list"] (ReqArg (\ x -> ("Sources-List", x)) "PATH") "sources.list file to build environment from", Option ['p'] ["preferences"] (ReqArg (\ x -> ("Preferences", x)) "PATH") "apt preferences file to use", Option ['a'] ["architecture"] (ReqArg (\ x -> ("Architecture", x)) "ARCHITECTURE") "Architecture to build, default i386", Option [] ["archive-dir"] (ReqArg (\ x -> ("Archive-Dir", x)) "PATH") "deb archive directory to mount --bind inside build environment", Option [] ["with"] (ReqArg (\ x -> ("With", x)) "'PACKAGE PACKAGE ...'") "A list of extra packages to install.", Option [] ["with-essential"] (ReqArg (\ x -> ("With-Essential", x)) "'PACKAGE PACKAGE ...'") "A list of extra packages to consider essential, and install earlier.", Option [] ["omit-essential"] (ReqArg (\ x -> ("Omit-Essential", x)) "'PACKAGE PACKAGE ...'") "A list of extra packages which should *not* be considered essential.", Option [] ["immediate-configure-false"] (NoArg ("Immediate-Configure","false")) ("pass -o APT::Immediate-Configure=false to apt-get during first run of apt-get install.\n"++ "Only use if you get an error about package 'x' failed to immediately configure."), Option [] ["include"] (ReqArg (\ x -> ("Include", x)) "PATH PATH ...") "A list of files containing the list of extra packages to install.", Option ['m'] ["mount-kernel"] (NoArg ("Mount-Kernel", "yes")) "Mount the virtual file systems (/sys, /proc, etc) in the newly created environment.", Option ['u'] ["mount-udev"] (NoArg ("Mount-Udev", "yes")) "Mount the parent directory's /dev in the newly created environment.", Option ['t'] ["tmp-dir"] (ReqArg (\ x -> ("Tmp-Dir", x)) "PATH") "Temporary directory, the default is to use mkdtemp(2)", Option ['h'] ["help"] (NoArg ("Help", "yes")) "print help"] bool f _ False = f bool _ t True = t getEnvMaybe :: String -> IO (Maybe String) getEnvMaybe name = try (getEnv name) >>= return . either (const Nothing) Just mapSnd :: (b -> c) -> [(a, b)] -> [(a, c)] mapSnd f [] = [] mapSnd f ((a, b) : etc) = (a, f b) : mapSnd f etc debugoutput arch deb@(DebSource typ uri _) = do hPutStrLn stderr $ "-- deb: " ++ show deb hPutStrLn stderr $ "-- arch: " ++ arch hPutStrLn stderr $ "-- prefix: " ++ prefix hPutStrLn stderr $ "-- toPaths: " ++ show (toPaths typ arch deb) hPutStrLn stderr $ "-- uris: " ++ show (map (prefix ++) (toPaths typ arch deb)) hPutStrLn stderr $ "-- uris: " ++ show (toURI arch deb) where prefix = scheme ++ "//" ++ user ++ reg ++ port scheme = uriScheme uri user= maybe "" uriUserInfo auth reg = maybe "" uriRegName auth port = maybe "" uriPort auth auth = uriAuthority uri