module BDCS.Export.Ostree(ostreeSink)
where
import Conduit(Conduit, Consumer, Producer, (.|), bracketP, runConduit, sourceDirectory, yield)
import Control.Conditional(condM, otherwiseM, whenM)
import qualified Control.Exception.Lifted as CEL
import Control.Monad(void)
import Control.Monad.Except(MonadError)
import Control.Monad.IO.Class(MonadIO, liftIO)
import Control.Monad.Logger(MonadLoggerIO, logDebugN, logInfoN)
import Control.Monad.Trans(lift)
import Control.Monad.Trans.Control(MonadBaseControl, liftBaseOp)
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, stripPrefix)
import Data.Maybe(fromJust)
import qualified Data.Text as T
import System.Directory
import System.FilePath((</>), takeDirectory, takeFileName)
import System.IO.Temp(createTempDirectory)
import System.Posix.Files(createSymbolicLink, fileGroup, fileMode, fileOwner, getFileStatus, readSymbolicLink)
import Text.Printf(printf)
import GI.Gio(File, fileNewForPath, noCancellable)
import GI.OSTree
import qualified BDCS.CS as CS
import BDCS.DB(Files)
import BDCS.Export.Directory(directorySink)
import BDCS.Export.Utils(runHacks)
import BDCS.Utils.Conduit(awaitWith)
import BDCS.Utils.Process(callProcessLogged)
import Paths_bdcs(getDataFileName)
ostreeSink :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m ()
ostreeSink outPath = do
dst_repo <- liftIO $ open outPath
void $ bracketP (createTempDirectory (takeDirectory outPath) "export")
removePathForcibly
(\tmpDir -> do
logDebugN "Exporting to directory"
directorySink tmpDir
logDebugN "Running standard hacks"
lift $ runHacks tmpDir
let localeDir = tmpDir </> "usr" </> "lib" </> "locale"
whenM (liftIO $ doesFileExist $ localeDir </> "locale-archive.tmpl") $
callProcessLogged "chroot" [tmpDir, "/usr/sbin/build-locale-archive"]
lift $ installKernelInitrd tmpDir
logDebugN "Modifying /etc files"
liftIO $ getDataFileName "data/nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir </> "etc" </> "nsswitch.conf")
liftIO $ removeFile $ tmpDir </> "etc" </> "fstab"
liftIO $ renameDirs tmpDir
logDebugN "Enabling systemd services"
doSystemd tmpDir
logDebugN "Running tmpfiles and creating symlinks"
liftIO $ convertVar tmpDir
let tmpfilesDir = tmpDir </> "usr" </> "lib" </> "tmpfiles.d"
liftIO $ getDataFileName "data/tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir </> "weldr-ostree.conf")
liftIO $ replaceDirs tmpDir
liftIO $ createDirectory (tmpDir </> "sysroot")
liftIO $ do
removePathForcibly $ tmpDir </> "usr" </> "local"
createSymbolicLink "../var/usrlocal" $ tmpDir </> "usr" </> "local"
rpmdbDir <- liftIO $ makeAbsolute $ tmpDir </> "usr" </> "share" </> "rpm"
liftIO $ createDirectoryIfMissing True rpmdbDir
callProcessLogged "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir]
logDebugN "Storing results as a new commit"
liftIO $ withTransaction dst_repo $ \r -> do
f <- storeDirectory r tmpDir
commit r f "Export commit" Nothing)
repoRegenerateSummary dst_repo Nothing noCancellable
where
convertVar :: FilePath -> IO ()
convertVar exportDir = do
let tmpfilesDir = exportDir </> "usr" </> "lib" </> "tmpfiles.d"
createDirectoryIfMissing True tmpfilesDir
let varDir = exportDir </> "var"
writeFile (tmpfilesDir </> "weldr-var.conf") =<<
unlines <$>
runResourceT (runConduit $ convertToTmp "/var" varDir .| CL.consume)
convertToTmp :: MonadResource m => FilePath -> FilePath -> Producer m String
convertToTmp basePath realPath =
sourceDirectory realPath .| recurseAndEmit
where
recurseAndEmit :: MonadResource m => Conduit FilePath m String
recurseAndEmit = awaitWith $ \path -> do
let baseFilePath = basePath </> takeFileName path
whenM (liftIO $ doesDirectoryExist path) (convertToTmp baseFilePath path)
condM [(liftIO $ pathIsSymbolicLink path, yieldLink baseFilePath path),
(liftIO $ doesDirectoryExist path, yieldDir baseFilePath path),
(otherwiseM, liftIO $ putStrLn $ "Warning: Unable to convert " ++ baseFilePath ++ " to a tmpfile")]
liftIO $ removePathForcibly path
recurseAndEmit
yieldLink :: MonadIO m => FilePath -> FilePath -> Producer m String
yieldLink baseFilePath realFilePath = do
target <- liftIO $ readSymbolicLink realFilePath
yield $ printf "L %s - - - - %s" baseFilePath target
yieldDir :: MonadIO m => FilePath -> FilePath -> Producer m String
yieldDir baseDirPath realDirPath = do
stat <- liftIO $ getFileStatus realDirPath
let mode = fromIntegral $ fileMode stat :: Integer
let userId = fromIntegral $ fileOwner stat :: Integer
let groupId = fromIntegral $ fileGroup stat :: Integer
yield $ printf "d %s %#o %d %d - -" baseDirPath mode userId groupId
installKernelInitrd :: (MonadBaseControl IO m, MonadLoggerIO m) => FilePath -> m ()
installKernelInitrd exportDir = do
let bootDir = exportDir </> "boot"
kernelList <- filter ("vmlinuz-" `isPrefixOf`) <$> liftIO (listDirectory bootDir)
let (kernel, kver) = case kernelList of
hd:_ -> (bootDir </> hd, fromJust $ stripPrefix "vmlinuz-" hd)
_ -> error "No kernel found"
let initramfs = bootDir </> "initramfs-" ++ kver
logInfoN $ "Installing kernel " `T.append` T.pack kernel
logInfoN $ "Installing initrd " `T.append` T.pack initramfs
withTempDirectory' exportDir "dracut" $ \tmpDir ->
callProcessLogged "chroot" [exportDir,
"dracut",
"--add", "ostree",
"--no-hostonly",
"--tmpdir=/" ++ takeFileName tmpDir,
"-f", "/boot/" ++ takeFileName initramfs,
kver]
kernelData <- liftIO $ BS.readFile kernel
initramfsData <- liftIO $ BS.readFile initramfs
let ctx = hashInitWith SHA256
let update1 = hashUpdate ctx kernelData
let update2 = hashUpdate update1 initramfsData
let digest = show $ hashFinalize update2
liftIO $ renameFile kernel (kernel ++ "-" ++ digest)
liftIO $ renameFile initramfs (initramfs ++ "-" ++ digest)
withTempDirectory' :: (MonadBaseControl IO m, MonadLoggerIO m) => FilePath -> String -> (FilePath -> m a) -> m a
withTempDirectory' target template = liftBaseOp $
CEL.bracket (createTempDirectory target template)
(\path -> removePathForcibly path `CEL.catch` (\(_ :: CEL.SomeException) -> return ()))
renameDirs :: FilePath -> IO ()
renameDirs exportDir = do
let etcPath = exportDir </> "etc"
let usrEtcPath = exportDir </> "usr" </> "etc"
removePathForcibly usrEtcPath
renameDirectory etcPath usrEtcPath
let usrLibPath = exportDir </> "usr" </> "lib"
renameFile (usrEtcPath </> "passwd") (usrLibPath </> "passwd")
renameFile (usrEtcPath </> "group") (usrLibPath </> "group")
writeFile (usrEtcPath </> "passwd") "root:x:0:0:root:/root:/bin/bash\n"
writeFile (usrEtcPath </> "group") "root:x:0:\nwheel:x:10:\n"
replaceDirs :: FilePath -> IO ()
replaceDirs exportDir = do
mapM_ (\dir -> whenM (doesPathExist dir) (removeDirectory dir))
(map (exportDir </>) ["home", "media", "mnt", "opt", "root", "srv", "tmp"])
createSymbolicLink "var/home" (exportDir </> "home")
createSymbolicLink "run/media" (exportDir </> "media")
createSymbolicLink "var/mnt" (exportDir </> "mnt")
createSymbolicLink "var/opt" (exportDir </> "opt")
createSymbolicLink "sysroot/ostree" (exportDir </> "ostree")
createSymbolicLink "var/roothome" (exportDir </> "root")
createSymbolicLink "var/srv" (exportDir </> "srv")
createSymbolicLink "sysroot/tmp" (exportDir </> "tmp")
doSystemd :: MonadLoggerIO m => FilePath -> m ()
doSystemd exportDir = do
let systemdDir = exportDir </> "usr" </> "etc" </> "systemd" </> "system"
liftIO $ createDirectoryIfMissing True systemdDir
liftIO $ createSymbolicLink "/usr/lib/systemd/system/multi-user.target" $ systemdDir </> "default.target"
liftIO $ do
createDirectoryIfMissing True $ systemdDir </> "getty.target.wants"
createDirectoryIfMissing True $ systemdDir </> "local-fs.target.wants"
createSymbolicLink "/usr/lib/systemd/system/getty@.service" $ systemdDir </> "getty.target.wants" </> "getty@tty1.service"
createSymbolicLink "/usr/lib/systemd/system/ostree-remount.service" $ systemdDir </> "local-fs.target.wants" </> "ostree-remount.service"
commit :: IsRepo a => a -> File -> T.Text -> Maybe T.Text -> IO T.Text
commit repo repoFile subject body =
unsafeCastTo RepoFile repoFile >>= \root -> do
parent <- parentCommit repo "master"
checksum <- repoWriteCommit repo parent (Just subject) body Nothing root noCancellable
repoTransactionSetRef repo Nothing "master" (Just checksum)
return checksum
open :: FilePath -> IO Repo
open fp = do
path <- fileNewForPath fp
repo <- repoNew path
doesDirectoryExist fp >>= \case
True -> repoOpen repo noCancellable >> return repo
False -> repoCreate repo RepoModeArchiveZ2 noCancellable >> return repo
parentCommit :: IsRepo a => a -> T.Text -> IO (Maybe T.Text)
parentCommit repo commitSum =
CEL.catch (Just <$> repoResolveRev repo commitSum False)
(\(_ :: CEL.SomeException) -> return Nothing)
storeDirectory :: IsRepo a => a -> FilePath -> IO File
storeDirectory repo path = do
importFile <- fileNewForPath path
mtree <- mutableTreeNew
repoWriteDirectoryToMtree repo importFile mtree Nothing noCancellable
repoWriteMtree repo mtree noCancellable
withTransaction :: IsRepo a => a -> (a -> IO b) -> IO b
withTransaction repo fn =
CEL.bracket_ (repoPrepareTransaction repo noCancellable)
(repoCommitTransaction repo noCancellable)
(fn repo)