Merge 68cebc6 into 9c04105

weldr · Feb 28, 2018 · ea29b6e · ea29b6e
2 parents 9c04105 + 68cebc6
commit ea29b6e
Show file tree

Hide file tree

Showing 4 changed files with 102 additions and 81 deletions.
diff --git a/bdcs.cabal b/bdcs.cabal
@@ -61,6 +61,7 @@ library
                         BDCS.Depclose,
                         BDCS.Depsolve,
                         BDCS.Exceptions,
+                        BDCS.Export,
                         BDCS.Export.Directory,
                         BDCS.Export.FSTree,
                         BDCS.Export.Qcow2,

diff --git a/src/BDCS/Export.hs b/src/BDCS/Export.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- |
+-- Module: BDCS.Export
+-- Copyright: (c) 2017-2018 Red Hat, Inc.
+-- License: LGPL
+--
+-- Maintainer: https://github.com/weldr
+-- Stability: alpha
+-- Portability: portable
+--
+-- Top-level function for exporting objects from the BDCS.
+
+module BDCS.Export(export)
+ where
+
+import           Control.Conditional(cond)
+import           Control.Monad.Except(MonadError, runExceptT, throwError)
+import           Control.Monad.IO.Class(MonadIO, liftIO)
+import           Control.Monad.Trans.Resource(MonadBaseControl, MonadResource)
+import           Data.Conduit(Consumer, (.|), runConduit, runConduitRes)
+import           Data.Conduit.List as CL
+import           Data.ContentStore(openContentStore)
+import           Data.List(isSuffixOf)
+import qualified Data.Text as T
+import           Database.Esqueleto(SqlPersistT)
+
+import qualified BDCS.CS as CS
+import           BDCS.DB(Files)
+import qualified BDCS.Export.Directory as Directory
+import           BDCS.Export.FSTree(filesToTree, fstreeSource)
+import qualified BDCS.Export.Ostree as Ostree
+import qualified BDCS.Export.Qcow2 as Qcow2
+import qualified BDCS.Export.Tar as Tar
+import           BDCS.Export.Utils(runHacks, runTmpfiles)
+import           BDCS.Files(groupIdToFilesC)
+import           BDCS.Groups(getGroupIdC)
+
+export :: (MonadBaseControl IO m, MonadError String m, MonadIO m, MonadResource m) => FilePath -> FilePath -> [T.Text] -> SqlPersistT m ()
+export repo out_path things | kernelMissing out_path things = throwError "ERROR: ostree exports need a kernel package included"
+                            | otherwise                     = do
+    let objectSink = cond [(".tar" `isSuffixOf` out_path,   CS.objectToTarEntry .| Tar.tarSink out_path),
+                           (".qcow2" `isSuffixOf` out_path, Qcow2.qcow2Sink out_path),
+                           (".repo" `isSuffixOf` out_path,  Ostree.ostreeSink out_path),
+                           (otherwise,                      directoryOutput out_path)]
+
+    runExceptT (openContentStore repo) >>= \case
+        Left e   -> throwError $ show e
+        Right cs -> do
+            fstree <- runConduit $ CL.sourceList things
+                          .| getGroupIdC
+                          .| groupIdToFilesC
+                          .| filesToTree
+            runConduitRes $ fstreeSource fstree .| CS.filesToObjectsC cs .| objectSink
+ where
+    directoryOutput :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m ()
+    directoryOutput path = do
+        -- Apply tmpfiles.d to the directory first
+        liftIO $ runTmpfiles path
+
+        Directory.directorySink path
+        liftIO $ runHacks path
+
+    kernelMissing :: FilePath -> [T.Text] -> Bool
+    kernelMissing out lst = ".repo" `isSuffixOf` out && not (any ("kernel-" `T.isPrefixOf`) lst)
diff --git a/src/BDCS/Export/Utils.hs b/src/BDCS/Export/Utils.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- |
 -- Module: BDCS.Export.Utils
 -- Copyright: (c) 2017 Red Hat, Inc.
@@ -10,18 +12,20 @@
 -- Miscellaneous utilities useful in exporting objects.
 
 module BDCS.Export.Utils(runHacks,
-                         runTmpfiles)
+                         runTmpfiles,
+                         supportedOutputs)
  where
 
-import Control.Conditional(whenM)
-import Control.Exception(tryJust)
-import Control.Monad(guard)
-import Data.List(intercalate)
-import Data.List.Split(splitOn)
-import System.Directory(createDirectoryIfMissing, doesFileExist, listDirectory, removePathForcibly, renameFile)
-import System.FilePath((</>))
-import System.IO.Error(isDoesNotExistError)
-import System.Process(callProcess)
+import           Control.Conditional(whenM)
+import           Control.Exception(tryJust)
+import           Control.Monad(guard)
+import           Data.List(intercalate)
+import           Data.List.Split(splitOn)
+import qualified Data.Text as T
+import           System.Directory(createDirectoryIfMissing, doesFileExist, listDirectory, removePathForcibly, renameFile)
+import           System.FilePath((</>))
+import           System.IO.Error(isDoesNotExistError)
+import           System.Process(callProcess)
 
 import BDCS.Export.TmpFiles(setupFilesystem)
 
@@ -74,3 +78,10 @@ runTmpfiles :: FilePath -> IO ()
 runTmpfiles exportPath = do
     configPath <- getDataFileName "tmpfiles-default.conf"
     setupFilesystem exportPath configPath
+
+-- | List the supported output formats.
+-- Note that any time a new output format file is added in BDCS/Export (and thus to
+-- the runCommand block in tools/export.hs), it should also be added here.  There's
+-- not really any better way to accomplish this.
+supportedOutputs :: [T.Text]
+supportedOutputs = ["directory", "ostree", "qcow2", "tar"]
diff --git a/src/tools/export.hs b/src/tools/export.hs
@@ -13,37 +13,19 @@
 -- 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 LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
 
-import           Control.Conditional(cond, ifM)
-import           Control.Monad(unless, when)
-import           Control.Monad.Except(MonadError, runExceptT)
-import           Control.Monad.IO.Class(MonadIO, liftIO)
-import           Data.Conduit(Consumer, (.|), runConduit, runConduitRes)
-import qualified Data.Conduit.List as CL
-import           Data.ContentStore(openContentStore, runCsMonad)
-import           Data.List(isSuffixOf)
+import           Control.Conditional(ifM)
+import           Control.Monad.Except(runExceptT)
 import qualified Data.Text as T
 import           System.Directory(doesFileExist, removePathForcibly)
 import           System.Environment(getArgs)
-import           System.Exit(exitFailure)
+import           System.Exit(exitFailure, exitSuccess)
 
-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
-import           BDCS.Export.Utils(runHacks, runTmpfiles)
-import           BDCS.Files(groupIdToFilesC)
-import           BDCS.Groups(getGroupIdC)
-import           BDCS.Utils.Either(whenLeft)
-import           BDCS.Utils.Monad(concatMapM)
-import           BDCS.Version
+import BDCS.DB(checkAndRunSqlite)
+import BDCS.Export(export)
+import BDCS.Utils.Monad(concatMapM)
+import BDCS.Version
 
 import Utils.GetOpt(commandLineArgs)
 
@@ -72,52 +54,11 @@ usage = do
     -- TODO group id?
     exitFailure
 
-needKernel :: IO ()
-needKernel = do
-    printVersion "export"
-    putStrLn "ERROR: ostree exports need a kernel package included"
-    exitFailure
-
-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
-
-    when (".repo" `isSuffixOf` out_path) $
-        unless (any ("kernel-" `T.isPrefixOf`) things) needKernel
-
-    let (handler, objectSink) = cond [(".tar" `isSuffixOf` out_path,   (cleanupHandler out_path, CS.objectToTarEntry .| Tar.tarSink out_path)),
-                                      (".qcow2" `isSuffixOf` out_path, (cleanupHandler out_path, Qcow2.qcow2Sink out_path)),
-                                      (".repo" `isSuffixOf` out_path,  (cleanupHandler out_path, Ostree.ostreeSink out_path)),
-                                      (otherwise,                      (print, directoryOutput out_path))]
-
-    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 ()
-    directoryOutput path = do
-        -- Apply tmpfiles.d to the directory first
-        liftIO $ runTmpfiles path
-
-        Directory.directorySink path
-        liftIO $ runHacks path
-
-    cleanupHandler :: Show a => FilePath -> a -> IO ()
-    cleanupHandler path e = print e >> removePathForcibly path
-
 main :: IO ()
 main = commandLineArgs <$> getArgs >>= \case
-    Just (db, repo, out_path:things) -> runCommand db repo out_path things
+    Just (db, repo, out_path:things) -> do things' <- map T.pack <$> expandFileThings things
+                                           result  <- runExceptT $ checkAndRunSqlite (T.pack db) $ export repo out_path things'
+                                           case result of
+                                               Left err -> removePathForcibly out_path >> print err >> exitFailure
+                                               Right _  -> exitSuccess
     _                                -> usage