{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module BDCS.Export.Ostree(ostreeSink)
where
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)
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, stripPrefix)
import Data.Maybe(fromJust)
import qualified Data.Text as T
import System.Directory
import System.FilePath((</>), takeDirectory, takeFileName)
import System.IO.Temp(createTempDirectory, withTempDirectory)
import System.Posix.Files(createSymbolicLink, fileGroup, fileMode, fileOwner, getFileStatus, readSymbolicLink)
import System.Process(callProcess)
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 Paths_bdcs(getDataFileName)
{-# ANN ostreeSink ("HLint: ignore Use ." :: String) #-}
ostreeSink :: (MonadError String m, MonadIO m, MonadResource m) => FilePath -> Consumer (Files, CS.Object) m ()
ostreeSink outPath = do
dst_repo <- liftIO $ open outPath
bracketP (createTempDirectory (takeDirectory outPath) "export")
removePathForcibly
(\tmpDir -> do
directorySink tmpDir
liftIO $ do
runHacks tmpDir
let localeDir = tmpDir </> "usr" </> "lib" </> "locale"
whenM (doesFileExist $ localeDir </> "locale-archive.tmpl")
(callProcess "chroot" [tmpDir, "/usr/sbin/build-locale-archive"])
installKernelInitrd tmpDir
getDataFileName "nsswitch-altfiles.conf" >>= readFile >>= writeFile (tmpDir </> "etc" </> "nsswitch.conf")
removeFile $ tmpDir </> "etc" </> "fstab"
renameDirs tmpDir
doSystemd tmpDir
convertVar tmpDir
let tmpfilesDir = tmpDir </> "usr" </> "lib" </> "tmpfiles.d"
getDataFileName "tmpfiles-ostree.conf" >>= readFile >>= writeFile (tmpfilesDir </> "weldr-ostree.conf")
replaceDirs tmpDir
createDirectory (tmpDir </> "sysroot")
removePathForcibly $ tmpDir </> "usr" </> "local"
createSymbolicLink "../var/usrlocal" $ tmpDir </> "usr" </> "local"
rpmdbDir <- makeAbsolute $ tmpDir </> "usr" </> "share" </> "rpm"
createDirectoryIfMissing True rpmdbDir
callProcess "rpmdb" ["--initdb", "--dbpath=" ++ rpmdbDir]
void $ 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 :: FilePath -> IO ()
installKernelInitrd exportDir = do
let bootDir = exportDir </> "boot"
kernelList <- filter ("vmlinuz-" `isPrefixOf`) <$> listDirectory bootDir
let (kernel, kver) = case kernelList of
hd:_ -> (bootDir </> hd, fromJust $ stripPrefix "vmlinuz-" hd)
_ -> error "No kernel found"
let initramfs = bootDir </> "initramfs-" ++ kver
withTempDirectory exportDir "dracut"
(\tmpDir -> callProcess "chroot"
[exportDir,
"dracut",
"--add", "ostree",
"--no-hostonly",
"--tmpdir=/" ++ takeFileName tmpDir,
"-f", "/boot/" ++ takeFileName initramfs,
kver])
kernelData <- BS.readFile kernel
initramfsData <- BS.readFile initramfs
let ctx = hashInitWith SHA256
let update1 = hashUpdate ctx kernelData
let update2 = hashUpdate update1 initramfsData
let digest = show $ hashFinalize update2
renameFile kernel (kernel ++ "-" ++ digest)
renameFile initramfs (initramfs ++ "-" ++ digest)
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 :: FilePath -> IO ()
doSystemd exportDir = do
let systemdDir = exportDir </> "usr" </> "etc" </> "systemd" </> "system"
createDirectoryIfMissing True systemdDir
createSymbolicLink "/usr/lib/systemd/system/multi-user.target" $ systemdDir </> "default.target"
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 =
catch (Just <$> repoResolveRev repo commitSum False)
(\(_ :: 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 =
bracket_ (repoPrepareTransaction repo noCancellable)
(repoCommitTransaction repo noCancellable)
(fn repo)