bdcs 0.1.1 → 0.2.0
raw patch · 23 files changed
+619/−113 lines, 23 filesdep +listsafe
Dependencies added: listsafe
Files
- ChangeLog.md +8/−0
- bdcs.cabal +4/−1
- src/BDCS/Build/NPM.hs +5/−4
- src/BDCS/DB.hs +11/−8
- src/BDCS/Depclose.hs +1/−1
- src/BDCS/Exceptions.hs +8/−0
- src/BDCS/Export/FSTree.hs +311/−0
- src/BDCS/Export/Ostree.hs +8/−5
- src/BDCS/Export/Utils.hs +4/−4
- src/BDCS/Groups.hs +4/−5
- src/BDCS/Import/Comps.hs +11/−7
- src/BDCS/Import/RPM.hs +8/−5
- src/BDCS/Import/Repodata.hs +4/−2
- src/BDCS/Import/URI.hs +4/−5
- src/BDCS/KeyValue.hs +4/−1
- src/BDCS/RPM/Builds.hs +2/−2
- src/BDCS/RPM/Groups.hs +3/−4
- src/BDCS/RPM/Projects.hs +9/−8
- src/tests/BDCS/Export/FSTreeSpec.hs +179/−0
- src/tools/bdcs-tmpfiles.hs +6/−11
- src/tools/bdcs.hs +4/−6
- src/tools/export.hs +17/−25
- src/tools/inspect/inspect.hs +4/−9
ChangeLog.md view
@@ -1,3 +1,11 @@+## 0.2.0++* Add a module for building virtual filesystem trees.+* Remove use of partial functions.+* baseURI now returns a Maybe.+* getDbVersion now throws an error if there's no version in the database.+* Add a BadName exception that can be thrown by mkProject.+ ## 0.1.1 * Add a new projects function that returns a list of all projects.
bdcs.cabal view
@@ -1,5 +1,5 @@ name: bdcs-version: 0.1.1+version: 0.2.0 synopsis: Tools for managing a content store of software packages description: This module provides a library and various tools for managing a content store and metadata database. These store the contents of software packages that make up a@@ -62,6 +62,7 @@ BDCS.Depsolve, BDCS.Exceptions, BDCS.Export.Directory,+ BDCS.Export.FSTree, BDCS.Export.Qcow2, BDCS.Export.Ostree, BDCS.Export.Tar,@@ -136,6 +137,7 @@ gi-ostree >= 1.0.3 && < 1.1.0, gitrev >= 1.3.1 && < 1.4.0, http-conduit >= 2.2.3 && < 2.3.0,+ listsafe >= 0.1.0.1 && < 0.2.0, memory >= 0.14.3 && < 0.15.0, monad-control >= 1.0.1.0 && < 1.1.0.0, monad-logger >= 0.3.20.2 && < 0.4.0,@@ -373,6 +375,7 @@ filepath >= 1.4.1.1 && < 1.5.0.0, gi-gio >= 2.0.14 && < 2.1.0, gi-glib >= 2.0.14 && < 2.1.0,+ listsafe >= 0.1.0.1 && < 0.2.0, monad-logger >= 0.3.20.2 && < 0.4.0, mtl >= 2.2.1 && < 2.3, parsec >= 3.1.10 && < 3.2.0,
src/BDCS/Build/NPM.hs view
@@ -28,6 +28,7 @@ import Data.Bifunctor(bimap) import Data.Bits((.|.)) import Data.Conduit(sourceToList)+import Data.List(scanl') import qualified Data.Text as T import Data.Time.Clock(UTCTime, getCurrentTime) import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds)@@ -116,9 +117,9 @@ limit 1 return (projects ^. ProjectsName, sources ^. SourcesVersion) - when (null nv) $ throwError $ "No such source id " ++ show sourceId-- return $ bimap unValue unValue $ head nv+ case nv of+ hd:_ -> return $ bimap unValue unValue hd+ _ -> throwError $ "No such source id " ++ show sourceId relink :: (MonadBaseControl IO m, MonadIO m) => [Files] -> (T.Text, T.Text) -> [(T.Text, SemVer)] -> SqlPersistT m (Key Builds) relink sourceFiles (name, ver) depList = do@@ -161,7 +162,7 @@ (link,) <$> insert link mkdirs :: MonadIO m => UTCTime -> FilePath -> SqlPersistT m [(Files, Key Files)]- mkdirs buildTime path = mapM mkdir $ scanl1 (</>) $ splitDirectories path+ mkdirs buildTime path = mapM mkdir $ scanl' (</>) "/" $ splitDirectories path where mkdir :: MonadIO m => FilePath -> SqlPersistT m (Files, Key Files) mkdir subPath = let
src/BDCS/DB.hs view
@@ -33,7 +33,7 @@ import Data.Aeson((.:), (.=)) import Data.ByteString(ByteString) import Data.Int(Int64)-import Data.Maybe(fromJust, fromMaybe, listToMaybe)+import Data.Maybe(fromMaybe, listToMaybe) import qualified Data.Text as T import Data.Time(UTCTime) import Database.Esqueleto(Esqueleto, Entity, Key, PersistEntity, PersistField, SqlBackend, SqlPersistT, ToBackendKey, Value,@@ -56,8 +56,10 @@ schemaVersion = 4 -- | Return the version number stored in the database.-getDbVersion :: MonadIO m => SqlPersistT m Int64-getDbVersion = unSingle <$> head <$> rawSql "pragma user_version" []+getDbVersion :: (MonadError String m, MonadIO m) => SqlPersistT m Int64+getDbVersion = rawSql "pragma user_version" [] >>= \case+ [] -> throwError "Database does not contain a user_version"+ v:_ -> return $ unSingle v -- | Verify that the version number stored in the database matches the schema version number -- implemented by this module. If there is a version mismatch, throw an error.@@ -207,12 +209,13 @@ instance Aeson.ToJSON KeyVal where toJSON kv = let- v = fmap Aeson.toJSON (keyValVal_value kv)- e = fmap Aeson.toJSON (keyValExt_value kv)+ jsonVal :: Maybe Aeson.Value -> Maybe Aeson.Value -> Aeson.Value+ jsonVal Nothing _ = Aeson.Bool True+ jsonVal (Just v) Nothing = v+ jsonVal (Just v) (Just e) = if v == e then v else e in- if | v == Nothing -> Aeson.Bool True- | v == e || e == Nothing -> fromJust v- | otherwise -> fromJust e+ jsonVal (Aeson.toJSON <$> keyValVal_value kv)+ (Aeson.toJSON <$> keyValExt_value kv) -- | Run an SQL query, returning the first 'Entity' as a Maybe. Use this when you -- want a single row out of the database.
src/BDCS/Depclose.hs view
@@ -168,7 +168,7 @@ -- The solution to this requirement is an Or of all the possibilities -- The group ids that are definitely required by this formulas is the intersection of all of the individual sets let reqFormula = Or formulaList- let reqParents = foldl1 Set.intersection parentList+ let reqParents = foldr1 Set.intersection parentList -- Add the results to the accumulators return $ Just (reqFormula : formulaAcc, Set.union parentAcc reqParents)
src/BDCS/Exceptions.hs view
@@ -10,6 +10,7 @@ -- Utilities for working with database-related exceptions. module BDCS.Exceptions(DBException(..),+ isBadNameException, isDBExceptionException, isMissingRPMTagException, throwIfNothing,@@ -28,11 +29,13 @@ | MissingRPMTag String -- ^ A required tag was missing from the -- RPM being processed. The argument should -- be the name of the missing tag.+ | BadName String -- ^ The name of the package is not parseable. deriving(Eq, Typeable) instance Exception DBException instance Show DBException where+ show (BadName s) = "Package name is not parseable: " ++ s show (DBException s) = show s show (MissingRPMTag s) = "Missing required tag in RPM: " ++ s @@ -47,6 +50,11 @@ throwIfNothingOtherwise :: Exception e => Maybe a -> e -> (a -> b) -> b throwIfNothingOtherwise (Just v) _ fn = fn v throwIfNothingOtherwise _ exn _ = throw exn++-- | Is a given 'DBException' type a 'BadName'?+isBadNameException :: DBException -> Bool+isBadNameException (BadName _) = True+isBadNameException _ = False -- | Is a given 'DBException' type the general 'DBException'? isDBExceptionException :: DBException -> Bool
+ src/BDCS/Export/FSTree.hs view
@@ -0,0 +1,311 @@+-- Copyright (C) 2017 Red Hat, Inc.+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}++module BDCS.Export.FSTree(FSEntry,+ FSTree,+ filesToTree,+ fstreeSource)+ where++import Control.Conditional(whenM)+import Control.Monad(foldM)+import Control.Monad.Except(MonadError, throwError)+import Control.Monad.State(StateT, evalStateT, get, modify, withStateT)+import Data.Conduit(Sink, Source, yield)+import qualified Data.Conduit.List as CL+import Data.List.Safe(init, last)+import qualified Data.Text as T+import Data.Tree(Tree(..))+import System.FilePath(joinPath, splitDirectories)+import System.Posix.Files(directoryMode, fileTypeModes, intersectFileModes, symbolicLinkMode)+import System.Posix.Types(FileMode)++import BDCS.DB(Files(..))++import Prelude hiding(init, last)++-- FSTree types+-- A filesystem entry consists of a path component, and maybe a Files object.+-- Nothing for the object is used to represent placeholder directories.+-- e.g., if adding "/a/b" to an empty tree, a placeholder will be created for "a"+-- to hold the "b" entry. If "/a" is later added to the tree, the placeholder will+-- be replaced with a Files object for /a.++-- | A single node within a file system tree. The pair is a single path component+-- (e.g., "c" for the node at "/a/b/c"), and maybe a Files object. Automatically+-- created parent directories will use Nothing as the snd element.+type FSEntry = (FilePath, Maybe Files)++-- | A tree of file system entries.+type FSTree = Tree FSEntry++filesToTree :: MonadError String m => Sink Files m FSTree+filesToTree =+ let+ -- Create an empty tree. This tree starts one level above "/"+ rootTree = Node{rootLabel=("", Nothing), subForest=[]}+ in+ CL.foldM addFileToTree rootTree++addFileToTree :: MonadError String m => FSTree -> Files -> m FSTree+addFileToTree root object = do+ let rootZipper = (root, [])+ let pathComponents = splitDirectories $ T.unpack $ filesPath object++ dirComponents <- maybe (throwError $ "Invalid path on " ++ show object) return $ init pathComponents+ lastComponent <- maybe (throwError $ "Invalid path on " ++ show object) return $ last pathComponents++ -- Resolve the directory name+ dirZipper <- evalStateT (findDirectory rootZipper dirComponents) 0++ -- Wrap the new file in a tree node and add it to the directory+ let newEntry = Node (lastComponent, Just object) []+ getTree <$> evalStateT (addEntryToTree dirZipper newEntry) 0+ where+ -- Given a directory path, split into components, return a new zipper focused on this path+ -- If the directory or any parent directories do not exist, create placeholders for them+ findDirectory :: MonadError String m => FSZipper -> [FilePath] -> StateT Int m FSZipper+ -- End of the list, we found it+ findDirectory zipper [] = return zipper++ -- . and .. cases+ findDirectory zipper (".":xs) = findDirectory zipper xs+ findDirectory zipper ("..":xs) = findDirectory (goUp zipper) xs++ -- normal case: find the child entry, create if missing, recurse+ findDirectory zipper (pathComponent:xs) =+ let+ placeholder = Node (pathComponent, Nothing) []+ in+ -- Find this path component in the subForest for the current tree.+ -- Several things can happen:+ -- 1) We find nothing. That's fine. Add a placeholder to the tree, recurse.+ -- 2) We find a directory (or a placeholder). That's good. Recurse.+ -- 3) We find a file. That's bad. Fail.+ -- 4) We find a symlink. Oh boy!. Call findDirectory on the symlink target to+ -- get the actual directory we need to be in, then recurse.++ case findChild pathComponent zipper of+ -- No path found, add the placeholder and recurse+ Nothing -> findDirectory (addChild placeholder zipper) xs++ -- Grab the FSEntry out of the child tree, figure out what we found+ Just childZipper@(Node{..}, _) -> case categorize rootLabel of+ -- Found a placeholder, recurse+ Placeholder -> findDirectory childZipper xs++ -- existing directory, recurse+ Directory _ -> findDirectory childZipper xs++ -- symlink. Follow it, recurse on the symlink target+ -- check and increment the symlink level so we don't get stuck in a loop+ Symlink link -> do+ whenM ((>= maxSymlinks) <$> get) $+ throwError $ "Too many levels of symbolic links while resolving " ++ T.unpack (filesPath object)+ linkZipper <- withStateT (+1) $ resolveSymlink zipper link+ findDirectory linkZipper xs++ -- Anything else means there's a non-directory file in the middle of our path+ Other existing -> throwError $ "Unable to resolve path " ++ T.unpack (filesPath object) +++ ", non-directory object exists at " ++ T.unpack (filesPath existing)++ -- Wrapper for findDirectory with a symlink target. If it's an absolute symlink target,+ -- unzip the zipper to the top and call findDirectory, otherwise just call findDirectory+ resolveSymlink :: MonadError String m => FSZipper -> Files -> StateT Int m FSZipper+ resolveSymlink zipper Files{..} = do+ symlinkTarget <- maybe (throwError $ "Error: symlink with no target at " ++ T.unpack filesPath)+ (return . T.unpack) filesTarget+ let pathComponents = splitDirectories symlinkTarget+ let startZipper = if head pathComponents == "/" then getRoot zipper else zipper++ findDirectory startZipper pathComponents++ addEntryToTree :: MonadError String m => FSZipper -> FSTree -> StateT Int m FSZipper+ addEntryToTree zipper newEntry = do+ -- At this point, we have a directory to stick the new entry into, and the first thing to do is see+ -- if the directory already contains an entry with the same name. If it does:+ -- - The new entry matches the old entry. That's fine, let everything be and we're done+ -- - The existing entry is a placeholder:+ -- * are we adding a directory? replace the placeholder with the new real directory, move the placeholder's+ -- children to the real directory+ -- * are we adding a symlink? replace the placeholder with the symlink, and move all of the placeholder's+ -- children to the symlink target+ -- * are we adding a different placeholder? Add the new placeholder's children as children of the existing+ -- placeholder.+ -- * otherwise? we have a conflict, throw an error+ -- - The existing entry is a directory:+ -- * are we adding a placeholder? Add the new placeholder's children to the existing directory.+ -- * otherwise, conflict+ -- - The existing entry is a symlink:+ -- * Resolve the symlink target, add the new entry as a child of the target+ --+ -- The scenarios that involve adding new placeholders may seem a little odd, but they can arise+ -- when moving things around due to replacing placeholder directories with symlinks.+ -- For example, adding something like the following to a tree:+ --+ -- 1) /a/b/c+ -- 2) /d/b/+ -- 3) /a -> d+ --+ -- would do something like:+ --+ -- 1) create placeholder /a, placeholder /a/b, real entry /a/b/c+ -- 2) create placeholder /d, real entry /d/b/+ -- 3) replace placeholder /a with a symlink, move placeholder /a/b/ and children to /d/,+ -- find that there's already a b/ entry and move /a/b/c to /d/b/++ let entryName = fst $ rootLabel newEntry+ let maybeExisting = findChild entryName zipper++ case maybeExisting of+ -- The easy case: nothing there, just add it+ Nothing -> return $ addChild newEntry zipper++ Just existing@(self, crumbs) -> case ((categorize . rootLabel) self, (categorize . rootLabel) newEntry) of+ -- Move the new placeholder's children to the existing placeholder+ (Placeholder, Placeholder) -> addChildren existing newEntry+ -- Replace the existing placeholder, add its children to the new directory+ (Placeholder, Directory _) -> addChildren (newEntry, crumbs) self++ -- Replace the placeholder, find the symlink target, move the placeholder children to the target.+ -- The context for relative links is the directory, so one level above the new symlink+ (Placeholder, Symlink s) -> do+ let newZipper = (newEntry, crumbs)+ targetZipper <- withStateT (+1) $ resolveSymlink (goUp newZipper) s+ addChildren targetZipper self++ (Placeholder, _) -> throwError $ "Unable to add " ++ T.unpack (filesPath object) +++ ", directory added at path"++ (Directory _, Placeholder) -> addChildren existing newEntry++ -- Allow this if the same Files object is being added twice+ (Directory d1, Directory d2) -> if compareDirs d1 d2 then addChildren existing newEntry+ else throwError $ "Unable to add " ++ T.unpack (filesPath object) +++ ", file already added at this location"++ (Directory _, _) -> throwError $ "Unable to to add " ++ T.unpack (filesPath object) +++ ", file already added at this location"++ -- Follow the symlink, and repeat addEntryToTree with the symlink target as the new directory+ -- to add into.+ (Symlink s, _) -> do+ -- Check and increment the link count+ whenM ((>= maxSymlinks) <$> get) $+ throwError $ "Too many levels of symbolic links while resolving " ++ T.unpack (filesPath object)+ modify (+1)++ targetZipper <- resolveSymlink zipper s+ addEntryToTree targetZipper newEntry++ -- Otherwise, we have two non-directory, non-placeholder files, see if they match+ _ -> if self == newEntry then return existing+ else throwError $ "Unable to add " ++ T.unpack (filesPath object) +++ ", file already added at this location"++ addChildren :: MonadError String m => FSZipper -> FSTree -> StateT Int m FSZipper+ addChildren dirZipper newEntry = foldM (\z e -> goUp <$> addEntryToTree z e) dirZipper (subForest newEntry)++ -- Compare files, ignoring size and mtime, because the data for these is basically made up+ compareDirs :: Files -> Files -> Bool+ compareDirs f1 f2 = f1{filesMtime=0, filesSize=0} == f2{filesMtime=0, filesSize=0}++-- Walk a tree and emit the Files entries in order, modifying the paths as we go+-- to match the final, symlink-resolved results+fstreeSource :: Monad m => FSTree -> Source m Files+fstreeSource root = fstreeSource' [] root+ where+ fstreeSource' :: Monad m => [FilePath] -> FSTree -> Source m Files+ fstreeSource' prefix Node{rootLabel=(pathComponent, maybeFile), ..} =+ let newPrefix = prefix ++ [pathComponent]+ in yieldEntry (joinPath newPrefix) maybeFile >>+ mapM_ (fstreeSource' newPrefix) subForest++ -- yieldEntry :: Monad m => FilePath -> Maybe Files+ yieldEntry _ Nothing = return ()+ yieldEntry realPath (Just f) = yield f{filesPath=T.pack realPath}+++-- Private symbols+-- The FSZipper is the currently focused node of the tree, plus a trail of breadcrumbs leading+-- back up to the top of the tree. Each crumb contains the rootLabel of the parent of the focused+-- tree, the subForest to the left of the focused tree, and the subForest to the right of the+-- focused tree.+type FSCrumb = (FSEntry, [FSTree], [FSTree])+type FSZipper = (FSTree, [FSCrumb])++-- Zipper navigation+-- Change the focus to the parent of the current tree+goUp :: FSZipper -> FSZipper+-- Pop the head off of the breadcrumb trail, use it to reconstruct the parent Tree+goUp (self, (entry, left, right):crumbs) = (Node entry (left ++ [self] ++ right), crumbs)+-- already at the top, just stay at the top+goUp zipper@(_, []) = zipper++-- Change the focus all the way to the top of a zipper+getRoot :: FSZipper -> FSZipper+getRoot zipper@(_, []) = zipper+getRoot zipper = getRoot $ goUp zipper++-- Convert a zipper back into a tree+getTree :: FSZipper -> FSTree+getTree zipper = fst $ getRoot zipper++-- Attempt to focus on a child of the current tree that matches the given path component+-- If there is no such child, return nothing+findChild :: FilePath -> FSZipper -> Maybe FSZipper+findChild pathComponent (self, crumbs) =+ case break ((== pathComponent) . fst . rootLabel) $ subForest self of+ -- An empty right list means no node was found+ (_, []) -> Nothing+ -- If we did find something, the head of the right list is the new tree to focus on+ (left, node:right) -> let newCrumb = (rootLabel self, left, right)+ in Just (node, newCrumb:crumbs)++-- Add a new subtree to the currently focused tree, return a zipper focused on the new subtree+addChild :: FSTree -> FSZipper -> FSZipper+addChild subTree (Node{..}, crumbs) =+ let newCrumb = (rootLabel, subForest, [])+ in (subTree, newCrumb:crumbs)++-- Split FSEntries into categories, to simplify the conditionals involved in adding things to a FSTree+data FSCategory = Placeholder+ | Directory Files+ | Symlink Files+ | Other Files++categorize :: FSEntry -> FSCategory+categorize (_, Nothing) = Placeholder+categorize (_, Just f@Files{..}) =+ if | isDirectory -> Directory f+ | isSymlink -> Symlink f+ | otherwise -> Other f+ where+ getFileMode :: FileMode+ getFileMode = fromIntegral filesMode `intersectFileModes` fileTypeModes++ isDirectory :: Bool+ isDirectory = getFileMode == directoryMode++ isSymlink :: Bool+ isSymlink = getFileMode == symbolicLinkMode++-- Constant for detecting symlink loops, equivalent to MAXSYMLINKS in linux+maxSymlinks :: Int+maxSymlinks = 40
src/BDCS/Export/Ostree.hs view
@@ -21,14 +21,15 @@ import Conduit(Conduit, Consumer, Producer, (.|), bracketP, runConduit, sourceDirectory, yield) import Control.Conditional(condM, otherwiseM, whenM) import Control.Exception(SomeException, bracket_, catch)-import Control.Monad(void, when)+import Control.Monad(void) import Control.Monad.Except(MonadError) import Control.Monad.IO.Class(MonadIO, liftIO) import Control.Monad.Trans.Resource(MonadResource, runResourceT) import Crypto.Hash(SHA256(..), hashInitWith, hashFinalize, hashUpdate) import qualified Data.ByteString as BS (readFile) import qualified Data.Conduit.List as CL-import Data.List(isPrefixOf)+import Data.List(isPrefixOf, stripPrefix)+import Data.Maybe(fromJust) import qualified Data.Text as T import System.Directory import System.FilePath((</>), takeDirectory, takeFileName)@@ -192,9 +193,11 @@ -- Find a vmlinuz- file. kernelList <- filter ("vmlinuz-" `isPrefixOf`) <$> listDirectory bootDir- when (null kernelList) (error "No kernel found")- let kernel = bootDir </> head kernelList- let kver = drop (length ("vmlinuz-" :: String)) (head kernelList)+ let (kernel, kver) = case kernelList of+ -- Using fromJust is fine here - we've ensured they all have that+ -- prefix with the filter above.+ hd:_ -> (bootDir </> hd, fromJust $ stripPrefix "vmlinuz-" hd)+ _ -> error "No kernel found" -- Create the initramfs let initramfs = bootDir </> "initramfs-" ++ kver
src/BDCS/Export/Utils.hs view
@@ -35,10 +35,10 @@ -- set a root password -- pre-crypted from "redhat" shadowRecs <- map (splitOn ":") <$> lines <$> readFile (exportPath </> "etc" </> "shadow")- let newRecs = map (\rec -> if head rec == "root" then- ["root", "$6$3VLMX3dyCGRa.JX3$RpveyimtrKjqcbZNTanUkjauuTRwqAVzRK8GZFkEinbjzklo7Yj9Z6FqXNlyajpgCdsLf4FEQQKH6tTza35xs/"] ++ drop 2 rec- else- rec) shadowRecs+ let newRecs = map (\rec -> case rec of+ "root":_:rest -> ["root", "$6$3VLMX3dyCGRa.JX3$RpveyimtrKjqcbZNTanUkjauuTRwqAVzRK8GZFkEinbjzklo7Yj9Z6FqXNlyajpgCdsLf4FEQQKH6tTza35xs/"] ++ rest+ _ -> rec)+ shadowRecs writeFile (exportPath </> "etc" </> "shadow.new") (unlines $ map (intercalate ":") newRecs) renameFile (exportPath </> "etc" </> "shadow.new") (exportPath </> "etc" </> "shadow")
src/BDCS/Groups.hs view
@@ -38,9 +38,8 @@ import Data.Bifunctor(bimap) import Data.Conduit((.|), Conduit, Source) import qualified Data.Conduit.List as CL-import Data.Maybe(isNothing, fromJust) import qualified Data.Text as T-import Database.Esqueleto hiding (isNothing)+import Database.Esqueleto import BDCS.DB import BDCS.GroupKeyValue(getValueForGroup)@@ -118,9 +117,9 @@ r <- getValueForGroup groupId (TextKey "release") a <- getValueForGroup groupId (TextKey "arch") - if isNothing n || isNothing v || isNothing r || isNothing a- then return Nothing- else return $ Just $ T.concat [fromJust n, "-", epoch e, fromJust v, "-", fromJust r, ".", fromJust a]+ case (n, v, r, a) of+ (Just n', Just v', Just r', Just a') -> return $ Just $ T.concat [n', "-", epoch e, v', "-", r', ".", a']+ _ -> return Nothing where epoch :: Maybe T.Text -> T.Text epoch (Just e) = e `T.append` ":"
src/BDCS/Import/Comps.hs view
@@ -25,6 +25,7 @@ import Control.Monad.Reader(ReaderT) import Data.Conduit((.|), runConduitRes)+import Data.Maybe(mapMaybe) import qualified Data.Text as T import Network.URI(URI(..)) import Text.XML(Document, sinkDoc)@@ -66,19 +67,22 @@ -- Shouldn't happen, but this marks them so we'll know there's something to look into. toCompsPkg (_, n, _) = CPUnknown n -parseCompsGroup :: Cursor -> CompsGroup-parseCompsGroup cursor = do- let groupIds = cursor $/ laxElement "id" &/ content- let groupNames = cursor $/ laxElement "name" &/ content- let packages = cursor $// laxElement "packagereq" >=> parseCompsPkg- CompsGroup (head groupIds) (head groupNames) packages+parseCompsGroup :: Cursor -> Maybe CompsGroup+parseCompsGroup cursor = let+ groupIds = cursor $/ laxElement "id" &/ content+ groupNames = cursor $/ laxElement "name" &/ content+ packages = cursor $// laxElement "packagereq" >=> parseCompsPkg+ in+ case (groupIds, groupNames) of+ (fstId:_, fstName:_) -> Just $ CompsGroup fstId fstName packages+ _ -> Nothing extractGroups :: Document -> [CompsGroup] extractGroups doc = let cursor = fromDocument doc groupCursors = cursor $// laxElement "group" in- map parseCompsGroup groupCursors+ mapMaybe parseCompsGroup groupCursors loadFromURI :: URI -> ReaderT ImportState IO () loadFromURI uri = do
src/BDCS/Import/RPM.hs view
@@ -147,9 +147,11 @@ -- this could result in a very confused, incorrect mddb. It is currently for internal use only, but -- that might change in the future. unsafeLoadIntoMDDB :: (MonadBaseControl IO m, MonadResource m) => RPM -> [(T.Text, Maybe ObjectDigest)] -> SqlPersistT m Bool-unsafeLoadIntoMDDB RPM{..} checksums = do- let sigHeaders = headerTags $ head rpmSignatures- let tagHeaders = headerTags $ head rpmHeaders+unsafeLoadIntoMDDB RPM{rpmSignatures=[], ..} _ = return False+unsafeLoadIntoMDDB RPM{rpmHeaders=[], ..} _ = return False+unsafeLoadIntoMDDB RPM{rpmSignatures=fstSignature:_, rpmHeaders=fstHeader:_, ..} checksums = do+ let sigHeaders = headerTags fstSignature+ let tagHeaders = headerTags fstHeader projectId <- insertProject $ mkProject tagHeaders sourceId <- insertSource $ mkSource tagHeaders projectId@@ -214,6 +216,7 @@ -- from being added to the content store a second time. Note that 'loadIntoMDDB' also performs this -- check, but both of these functions are public and therefore both need to prevent duplicate imports. rpmExistsInMDDB :: MonadResource m => RPM -> SqlPersistT m Bool-rpmExistsInMDDB RPM{..} = do- let sigHeaders = headerTags $ head rpmSignatures+rpmExistsInMDDB RPM{rpmSignatures=[], ..} = return False+rpmExistsInMDDB RPM{rpmSignatures=hd:_, ..} = do+ let sigHeaders = headerTags hd buildImported sigHeaders
src/BDCS/Import/Repodata.hs view
@@ -20,7 +20,7 @@ where import Control.Applicative((<|>))-import Control.Exception(Exception)+import Control.Exception(Exception, throw) import Control.Monad.IO.Class(MonadIO) import Control.Monad.Reader(ReaderT) import Control.Monad.Trans.Resource(MonadBaseControl, MonadThrow)@@ -119,4 +119,6 @@ mapM_ RPM.loadFromURI locations where appendOrThrow :: T.Text -> URI- appendOrThrow path = appendURI (baseURI metadataURI) (T.unpack path) `throwIfNothing` RepoException+ appendOrThrow path = case baseURI metadataURI of+ Nothing -> throw RepoException+ Just uri -> appendURI uri (T.unpack path) `throwIfNothing` RepoException
src/BDCS/Import/URI.hs view
@@ -18,7 +18,6 @@ where import Data.List(isInfixOf, isSuffixOf)-import Data.Maybe(fromJust) import Network.URI(URI(..), escapeURIString, isUnescapedInURI, parseURIReference, pathSegments, relativeTo, unEscapeString, uriToString) @@ -30,10 +29,10 @@ -- | Go up one directory in the 'URI'. For instance: -- > ghci> let uri = parseURI "file:///path/to/repo/repodata/primary.xml" -- > ghci> baseURI (fromJust uri)--- > file:///path/to/repo/-baseURI :: URI -> URI-baseURI uri = let upOne = fromJust $ parseURIReference ".." in- relativeTo upOne uri+-- > Just file:///path/to/repo/+baseURI :: URI -> Maybe URI+baseURI uri = let upOne = parseURIReference ".." in+ fmap (`relativeTo` uri) upOne -- | Append a path to a 'URI'. appendURI :: URI -> String -> Maybe URI
src/BDCS/KeyValue.hs view
@@ -90,7 +90,10 @@ -- -- On the other hand, we don't do anything to LabelKeys. This means labels will always end up -- in a list named "labels".- pairs = map (\(k, v) -> if length v == 1 then k .= head v else k .= v) (Map.toList otherMap) +++ pairs = map (\(k, v) -> case v of+ [hd] -> k .= hd+ _ -> k .= v)+ (Map.toList otherMap) ++ map (uncurry (.=)) (Map.toList labelMap) in [T.pack "keyvals" .= object pairs]
src/BDCS/RPM/Builds.hs view
@@ -46,5 +46,5 @@ getBuildTime = findTag "BuildTime" tags >>= \t -> (tagValue t :: Maybe Word32) >>= Just . posixSecondsToUTCTime . realToFrac getChangelog = case findStringListTag "ChangeLogText" tags of- [] -> Nothing- lst -> Just $ pack $ head lst+ hd:_ -> Just $ pack hd+ _ -> Nothing
src/BDCS/RPM/Groups.hs view
@@ -17,11 +17,11 @@ import Codec.RPM.Tags(Tag, findStringTag, findStringListTag, findTag, findWord32ListTag, tagValue) import Control.Conditional((<&&>), whenM)-import Control.Monad(forM_, void, when)+import Control.Monad(forM_, when) import Control.Monad.IO.Class(MonadIO) import Control.Monad.State(State, execState, get, modify) import Data.Bits(testBit)-import Data.Maybe(fromJust, isJust)+import Data.Maybe(isJust) import qualified Data.Text as T import Data.Word(Word32) import Database.Persist.Sql(SqlPersistT, insert)@@ -135,8 +135,7 @@ uncurry insertGroupKeyValue tup Nothing groupId -- Add the epoch attribute, when it exists.- when (isJust epoch) $ void $- insertGroupKeyValue (TextKey "epoch") (fromJust epoch) Nothing groupId+ forM_ epoch $ \e -> insertGroupKeyValue (TextKey "epoch") e Nothing groupId forM_ [("Provide", "rpm-provide"), ("Conflict", "rpm-conflict"), ("Obsolete", "rpm-obsolete"), ("Order", "rpm-install-after")] $ \tup -> uncurry (addPRCO rpm groupId) tup
src/BDCS/RPM/Projects.hs view
@@ -20,14 +20,15 @@ import Data.Text.Encoding(decodeUtf8) import BDCS.DB(Projects(..))-import BDCS.Exceptions(DBException(..), throwIfNothingOtherwise)+import BDCS.Exceptions(DBException(..), throwIfNothing, throwIfNothingOtherwise) -- | Return a 'Projects' record for the RPM package. mkProject :: [Tag] -> Projects mkProject tags = let- projectName = throwIfNothingOtherwise (findStringTag "SourceRPM" tags)- (MissingRPMTag "SourceRPM")- (T.pack . srpmToName)+ srpmTag = findStringTag "SourceRPM" tags `throwIfNothing` MissingRPMTag "SourceRPM"+ projectName = throwIfNothingOtherwise (srpmToName srpmTag)+ (BadName srpmTag)+ T.pack summary = throwIfNothingOtherwise (findByteStringTag "Summary" tags) (MissingRPMTag "Summary") decodeUtf8@@ -45,8 +46,8 @@ -- This is essentially N-V-R.A.rpm. rpm does not allow hyphens in version of release, and epoch is -- not included in the SRPM name, so we can just take everything before the second-to-last hyphen -- as the name.- srpmToName :: String -> String+ srpmToName :: String -> Maybe String srpmToName s =- -- Find all the hyphens and take the second to last result- let nameHyphenIndex = head $ tail $ reverse $ elemIndices '-' s- in fst $ splitAt nameHyphenIndex s+ case reverse (elemIndices '-' s) of+ _:ndx:_ -> Just $ fst $ splitAt ndx s+ _ -> Nothing
+ src/tests/BDCS/Export/FSTreeSpec.hs view
@@ -0,0 +1,179 @@+-- Copyright (C) 2017 Red Hat, Inc.+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}++module BDCS.Export.FSTreeSpec(spec)+ where++import BDCS.DB(Files(..))+import BDCS.Export.FSTree++import Control.Monad.Except(runExceptT)+import Data.Bits((.|.))+import Data.Conduit((.|), runConduit)+import qualified Data.Conduit.List as CL+import Data.Either(isLeft)+import Data.Tree(Tree(..))+import System.Posix.Files(directoryMode, regularFileMode, symbolicLinkMode)++import Test.Hspec++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+spec :: Spec+spec = describe "Export.FSTree Tests" $ do+ it "Adding a regular file to an empty tree" $+ let file_a = regularTemplate{filesPath="/a"}+ in addFiles [file_a] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Nothing) [+ Node ("a", Just file_a) []+ ]+ ])+ )++ it "Adding directories before children" $+ let dir_slash = directoryTemplate{filesPath="/"}+ dir_a = directoryTemplate{filesPath="/a"}+ file_b = regularTemplate{filesPath="/a/b"}+ in addFiles [dir_slash, dir_a, file_b] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Just dir_slash) [+ Node ("a", Just dir_a) [+ Node ("b", Just file_b) []+ ]+ ]+ ])+ )++ it "Adding directories after children" $+ let dir_slash = directoryTemplate{filesPath="/"}+ dir_a = directoryTemplate{filesPath="/a"}+ file_b = regularTemplate{filesPath="/a/b"}+ in addFiles [file_b, dir_a, dir_slash] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Just dir_slash) [+ Node ("a", Just dir_a) [+ Node ("b", Just file_b) []+ ]+ ]+ ])+ )++ it "Replace a directory with a symlink" $+ let bin_grep = regularTemplate{filesPath="/bin/grep"}+ bin_link = symlinkTemplate{filesPath="/bin", filesTarget=Just "/usr/bin"}+ in addFiles [bin_grep, bin_link] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Nothing) [+ Node ("bin", Just bin_link) [],+ Node ("usr", Nothing) [+ Node ("bin", Nothing) [+ Node ("grep", Just bin_grep) []+ ]+ ]+ ]+ ])+ )++ it "Add a file to a symlink path" $+ let bin_grep = regularTemplate{filesPath="/bin/grep"}+ bin_link = symlinkTemplate{filesPath="/bin", filesTarget=Just "/usr/bin"}+ in addFiles [bin_link, bin_grep] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Nothing) [+ Node ("bin", Just bin_link) [],+ Node ("usr", Nothing) [+ Node ("bin", Nothing) [+ Node ("grep", Just bin_grep) []+ ]+ ]+ ]+ ])+ )++ it "Symlinks moving placeholders" $+ let dir_a = directoryTemplate{filesPath="/a/b/c"}+ dir_d = directoryTemplate{filesPath="/d/b"}+ link = symlinkTemplate{filesPath="/a", filesTarget = Just "d"}+ in addFiles [dir_a, dir_d, link] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Nothing) [+ Node ("a", Just link) [],+ Node ("d", Nothing) [+ Node ("b", Just dir_d) [+ Node ("c", Just dir_a) []+ ]+ ]+ ]+ ])+ )++ it "Symlink loop" $+ let link_a = symlinkTemplate{filesPath="/a", filesTarget=Just "b"}+ link_b = symlinkTemplate{filesPath="/b", filesTarget=Just "a"}+ file = regularTemplate{filesPath="/b/c"}+ in addFiles [link_a, link_b, file] >>= (`shouldSatisfy` isLeft)++ it "Symlink with .." $+ let link = symlinkTemplate{filesPath="/a/b", filesTarget=Just "../d"}+ file = regularTemplate{filesPath="/a/b/c"}+ in addFiles [link, file] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Nothing) [+ Node ("a", Nothing) [+ Node ("b", Just link) []+ ],+ Node ("d", Nothing) [+ Node ("c", Just file) []+ ]+ ]+ ])+ )++ it "Symlink with ." $+ let link = symlinkTemplate{filesPath="/a/b", filesTarget=Just "./d"}+ file = regularTemplate{filesPath="/a/b/c"}+ in addFiles [link, file] >>= (`shouldBe` Right (+ Node ("", Nothing) [+ Node ("/", Nothing) [+ Node ("a", Nothing) [+ Node ("b", Just link) [],+ Node ("d", Nothing) [+ Node ("c", Just file) []+ ]+ ]+ ]+ ])+ )++ it "Symlink loop, different case" $+ let link = symlinkTemplate{filesPath="/a", filesTarget=Just "."}+ file = regularTemplate{filesPath="/a"}+ in addFiles [link, file] >>= (`shouldSatisfy` isLeft)+ where+ -- Add a list of files and return the tree+ addFiles :: Monad m => [Files] -> m (Either String FSTree)+ addFiles files = runExceptT $ runConduit $ CL.sourceList files .| filesToTree++ -- Just fill in the paths+ regularTemplate :: Files+ regularTemplate = Files "" "root" "root" 0 Nothing (fromIntegral $ regularFileMode .|. 0o644) 0 Nothing++ directoryTemplate :: Files+ directoryTemplate = Files "" "root" "root" 0 Nothing (fromIntegral $ directoryMode .|. 0o755) 0 Nothing++ symlinkTemplate :: Files+ symlinkTemplate = Files "" "root" "root" 0 Nothing (fromIntegral $ symbolicLinkMode .|. 0o644) 0 Nothing
src/tools/bdcs-tmpfiles.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- Copyright (C) 2017 Red Hat, Inc. -- -- This library is free software; you can redistribute it and/or@@ -13,7 +15,6 @@ -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, see <http://www.gnu.org/licenses/>. -import Control.Monad(when) import System.Directory(createDirectoryIfMissing) import System.Environment(getArgs) import System.Exit(exitFailure)@@ -29,14 +30,8 @@ putStrLn " dest should be a destination directory." exitFailure -{-# ANN main ("HLint: ignore Use head" :: String) #-} main :: IO ()-main = do- argv <- getArgs-- when (length argv /= 2) usage-- let cfg = argv !! 0- let dir = argv !! 1- createDirectoryIfMissing True dir- setupFilesystem dir cfg+main = getArgs >>= \case+ cfg:dir:_ -> do createDirectoryIfMissing True dir+ setupFilesystem dir cfg+ _ -> usage
src/tools/bdcs.hs view
@@ -15,7 +15,7 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Monad(forM_, when)+import Control.Monad(forM_) import System.Environment(getArgs) import System.Exit(exitFailure) @@ -45,8 +45,6 @@ main = do argv <- getArgs - when (length argv < 1) usage- let subcmd = head argv- subcmdArgs = tail argv-- runSubcommand "bdcs-" subcmd subcmdArgs knownSubcommands usage+ case argv of+ subcmd:subcmdArgs -> runSubcommand "bdcs-" subcmd subcmdArgs knownSubcommands usage+ _ -> usage
src/tools/export.hs view
@@ -22,10 +22,10 @@ import Control.Monad(unless, when) import Control.Monad.Except(MonadError, runExceptT) import Control.Monad.IO.Class(MonadIO, liftIO)-import Data.Conduit(Consumer, (.|), runConduit)+import Data.Conduit(Consumer, (.|), runConduit, runConduitRes) import qualified Data.Conduit.List as CL import Data.ContentStore(openContentStore, runCsMonad)-import Data.List(isSuffixOf, isPrefixOf, partition)+import Data.List(isSuffixOf) import qualified Data.Text as T import System.Directory(doesFileExist, removePathForcibly) import System.Environment(getArgs)@@ -34,6 +34,7 @@ import qualified BDCS.CS as CS import BDCS.DB(Files, checkAndRunSqlite) import qualified BDCS.Export.Directory as Directory+import BDCS.Export.FSTree(filesToTree, fstreeSource) import qualified BDCS.Export.Qcow2 as Qcow2 import qualified BDCS.Export.Ostree as Ostree import qualified BDCS.Export.Tar as Tar@@ -71,31 +72,20 @@ -- TODO group id? exitFailure -needFilesystem :: IO ()-needFilesystem = do- printVersion "export"- putStrLn "ERROR: The tar needs to have the filesystem package included"- exitFailure- needKernel :: IO () needKernel = do printVersion "export" putStrLn "ERROR: ostree exports need a kernel package included" exitFailure -runCommand :: FilePath -> FilePath -> [String] -> IO ()-runCommand db repo args = do- let out_path = head args- allThings <- expandFileThings $ tail args+runCommand :: FilePath -> FilePath -> FilePath -> [String] -> IO ()+runCommand db repo out_path fileThings = do+ things <- map T.pack <$> expandFileThings fileThings cs <- runCsMonad (openContentStore repo) >>= \case Left e -> print e >> exitFailure Right r -> return r - let (match, otherThings) = partition (isPrefixOf "filesystem-") allThings- when (length match < 1) needFilesystem- let things = map T.pack $ head match : otherThings- when (".repo" `isSuffixOf` out_path) $ unless (any ("kernel-" `T.isPrefixOf`) things) needKernel @@ -104,12 +94,16 @@ (".repo" `isSuffixOf` out_path, (cleanupHandler out_path, Ostree.ostreeSink out_path)), (otherwise, (print, directoryOutput out_path))] - result <- runExceptT $ checkAndRunSqlite (T.pack db) $ runConduit $ CL.sourceList things- .| getGroupIdC- .| groupIdToFilesC- .| CS.filesToObjectsC cs- .| objectSink+ result <- runExceptT $ do+ -- Build the filesystem tree to export+ fstree <- checkAndRunSqlite (T.pack db) $ runConduit $ CL.sourceList things+ .| getGroupIdC+ .| groupIdToFilesC+ .| filesToTree + -- Traverse the tree and export the file contents+ runConduitRes $ fstreeSource fstree .| CS.filesToObjectsC cs .| objectSink+ whenLeft result (\e -> handler e >> exitFailure) where directoryOutput :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m ()@@ -125,7 +119,5 @@ main :: IO () main = commandLineArgs <$> getArgs >>= \case- Nothing -> usage- Just (db, repo, args) -> do- when (length args < 2) usage- runCommand db repo args+ Just (db, repo, out_path:things) -> runCommand db repo out_path things+ _ -> usage
src/tools/inspect/inspect.hs view
@@ -16,7 +16,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Monad(forM_, when)+import Control.Monad(forM_) import System.Environment(getArgs) import System.Exit(exitFailure) @@ -46,12 +46,7 @@ main :: IO () main = commandLineArgs <$> getArgs >>= \case- Just (db, repo, args) -> do- when (null args) usage-- let subcmd = head args- subcmdArgs = [db, repo] ++ tail args-- runSubcommand "inspect-" subcmd subcmdArgs knownSubcommands usage+ Just (db, repo, subcmd:args) ->+ runSubcommand "inspect-" subcmd ([db, repo] ++ args) knownSubcommands usage - _ -> usage+ _ -> usage