diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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.
diff --git a/bdcs.cabal b/bdcs.cabal
--- a/bdcs.cabal
+++ b/bdcs.cabal
@@ -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,
diff --git a/src/BDCS/Build/NPM.hs b/src/BDCS/Build/NPM.hs
--- a/src/BDCS/Build/NPM.hs
+++ b/src/BDCS/Build/NPM.hs
@@ -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
diff --git a/src/BDCS/DB.hs b/src/BDCS/DB.hs
--- a/src/BDCS/DB.hs
+++ b/src/BDCS/DB.hs
@@ -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.
diff --git a/src/BDCS/Depclose.hs b/src/BDCS/Depclose.hs
--- a/src/BDCS/Depclose.hs
+++ b/src/BDCS/Depclose.hs
@@ -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)
diff --git a/src/BDCS/Exceptions.hs b/src/BDCS/Exceptions.hs
--- a/src/BDCS/Exceptions.hs
+++ b/src/BDCS/Exceptions.hs
@@ -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
diff --git a/src/BDCS/Export/FSTree.hs b/src/BDCS/Export/FSTree.hs
new file mode 100644
--- /dev/null
+++ b/src/BDCS/Export/FSTree.hs
@@ -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 .
+
+{-# 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
diff --git a/src/BDCS/Export/Ostree.hs b/src/BDCS/Export/Ostree.hs
--- a/src/BDCS/Export/Ostree.hs
+++ b/src/BDCS/Export/Ostree.hs
@@ -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
diff --git a/src/BDCS/Export/Utils.hs b/src/BDCS/Export/Utils.hs
--- a/src/BDCS/Export/Utils.hs
+++ b/src/BDCS/Export/Utils.hs
@@ -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")
diff --git a/src/BDCS/Groups.hs b/src/BDCS/Groups.hs
--- a/src/BDCS/Groups.hs
+++ b/src/BDCS/Groups.hs
@@ -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` ":"
diff --git a/src/BDCS/Import/Comps.hs b/src/BDCS/Import/Comps.hs
--- a/src/BDCS/Import/Comps.hs
+++ b/src/BDCS/Import/Comps.hs
@@ -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
diff --git a/src/BDCS/Import/RPM.hs b/src/BDCS/Import/RPM.hs
--- a/src/BDCS/Import/RPM.hs
+++ b/src/BDCS/Import/RPM.hs
@@ -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
diff --git a/src/BDCS/Import/Repodata.hs b/src/BDCS/Import/Repodata.hs
--- a/src/BDCS/Import/Repodata.hs
+++ b/src/BDCS/Import/Repodata.hs
@@ -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
diff --git a/src/BDCS/Import/URI.hs b/src/BDCS/Import/URI.hs
--- a/src/BDCS/Import/URI.hs
+++ b/src/BDCS/Import/URI.hs
@@ -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
diff --git a/src/BDCS/KeyValue.hs b/src/BDCS/KeyValue.hs
--- a/src/BDCS/KeyValue.hs
+++ b/src/BDCS/KeyValue.hs
@@ -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]
diff --git a/src/BDCS/RPM/Builds.hs b/src/BDCS/RPM/Builds.hs
--- a/src/BDCS/RPM/Builds.hs
+++ b/src/BDCS/RPM/Builds.hs
@@ -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
diff --git a/src/BDCS/RPM/Groups.hs b/src/BDCS/RPM/Groups.hs
--- a/src/BDCS/RPM/Groups.hs
+++ b/src/BDCS/RPM/Groups.hs
@@ -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
diff --git a/src/BDCS/RPM/Projects.hs b/src/BDCS/RPM/Projects.hs
--- a/src/BDCS/RPM/Projects.hs
+++ b/src/BDCS/RPM/Projects.hs
@@ -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
diff --git a/src/tests/BDCS/Export/FSTreeSpec.hs b/src/tests/BDCS/Export/FSTreeSpec.hs
new file mode 100644
--- /dev/null
+++ b/src/tests/BDCS/Export/FSTreeSpec.hs
@@ -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 .
+
+{-# 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
diff --git a/src/tools/bdcs-tmpfiles.hs b/src/tools/bdcs-tmpfiles.hs
--- a/src/tools/bdcs-tmpfiles.hs
+++ b/src/tools/bdcs-tmpfiles.hs
@@ -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 .
-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
diff --git a/src/tools/bdcs.hs b/src/tools/bdcs.hs
--- a/src/tools/bdcs.hs
+++ b/src/tools/bdcs.hs
@@ -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
diff --git a/src/tools/export.hs b/src/tools/export.hs
--- a/src/tools/export.hs
+++ b/src/tools/export.hs
@@ -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
diff --git a/src/tools/inspect/inspect.hs b/src/tools/inspect/inspect.hs
--- a/src/tools/inspect/inspect.hs
+++ b/src/tools/inspect/inspect.hs
@@ -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