module Propellor.Property.OS (
cleanInstallOnce,
Confirmation(..),
preserveNetwork,
preserveResolvConf,
preserveRootSshAuthorized,
oldOSRemoved,
) where
import Propellor.Base
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Ssh as Ssh
import qualified Propellor.Property.Network as Network
import qualified Propellor.Property.User as User
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Reboot as Reboot
import Propellor.Property.Mount
import Propellor.Property.Chroot.Util (stdPATH)
import System.Posix.Files (rename, fileExist)
import Control.Exception (throw)
cleanInstallOnce :: Confirmation -> Property DebianLike
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
go =
finalized
`requires`
User.shadowConfig True
`requires`
Reboot.atEnd True (/= FailedChange)
`requires`
propellorbootstrapped
`requires`
flipped
`requires`
osbootstrapped
osbootstrapped :: Property Linux
osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of
(Just d@(System (Debian _ _) _)) -> ensureProperty w $
debootstrap d
(Just u@(System (Buntish _) _)) -> ensureProperty w $
debootstrap u
_ -> unsupportedOS'
debootstrap :: System -> Property Linux
debootstrap targetos =
Debootstrap.built' Debootstrap.sourceInstall
newOSDir targetos Debootstrap.DefaultConfig
flipped :: Property Linux
flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
devfstype <- fromMaybe "devtmpfs" <$> getFsType "/dev"
mnts <- filter (`notElem` ("/": trickydirs)) <$> mountPoints
forM_ (reverse mnts) umountLazy
renamesout <- map (\d -> (d, oldOSDir ++ d, pure $ d `notElem` (oldOSDir:newOSDir:trickydirs)))
<$> dirContents "/"
renamesin <- map (\d -> let dest = "/" ++ takeFileName d in (d, dest, not <$> fileExist dest))
<$> dirContents newOSDir
createDirectoryIfMissing True oldOSDir
massRename (renamesout ++ renamesin)
removeDirectoryRecursive newOSDir
void $ setEnv "PATH" stdPATH True
void $ unsetEnv "LANG"
unlessM (mount devfstype devfstype "/dev" mempty) $ do
warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic"
void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"]
unlessM (mount "sysfs" "sysfs" "/sys" mempty) $
warningMessage "failed mounting /sys"
unlessM (mount "devpts" "devpts" "/dev/pts" mempty) $
warningMessage "failed mounting /dev/pts"
return MadeChange
propellorbootstrapped :: Property UnixLike
propellorbootstrapped = property "propellor re-debootstrapped in new os" $
return NoChange
finalized :: Property UnixLike
finalized = property "clean OS installed" $ do
liftIO $ writeFile flagfile ""
return MadeChange
flagfile = "/etc/propellor-cleaninstall"
trickydirs =
[ "/tmp"
, "/proc"
]
massRename :: [(FilePath, FilePath, IO Bool)] -> IO ()
massRename = go []
where
go _ [] = return ()
go undo ((from, to, test):rest) = ifM test
( tryNonAsync (rename from to)
>>= either
(rollback undo)
(const $ go ((to, from):undo) rest)
, go undo rest
)
rollback undo e = do
mapM_ (uncurry rename) undo
throw e
data Confirmation = Confirmed HostName
confirmed :: Desc -> Confirmation -> Property UnixLike
confirmed desc (Confirmed c) = property desc $ do
hostname <- asks hostName
if hostname /= c
then do
warningMessage "Run with a bad confirmation, not matching hostname."
return FailedChange
else return NoChange
preserveNetwork :: Property DebianLike
preserveNetwork = go `requires` Network.cleanInterfacesFile
where
go :: Property DebianLike
go = property' "preserve network configuration" $ \w -> do
ls <- liftIO $ lines <$> readProcess "ip"
["route", "list", "scope", "global"]
case words <$> headMaybe ls of
Just ("default":"via":_:"dev":iface:_) ->
ensureProperty w $ Network.preserveStatic iface
_ -> do
warningMessage "did not find any default ipv4 route"
return FailedChange
preserveResolvConf :: Property Linux
preserveResolvConf = check (fileExist oldloc) $
property' (newloc ++ " copied from old OS") $ \w -> do
ls <- liftIO $ lines <$> readFile oldloc
ensureProperty w $ newloc `File.hasContent` ls
where
newloc = "/etc/resolv.conf"
oldloc = oldOSDir ++ newloc
preserveRootSshAuthorized :: Property UnixLike
preserveRootSshAuthorized = check (fileExist oldloc) $
property' desc $ \w -> do
ks <- liftIO $ lines <$> readFile oldloc
ensureProperty w $ combineProperties desc $
toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks
where
desc = newloc ++ " copied from old OS"
newloc = "/root/.ssh/authorized_keys"
oldloc = oldOSDir ++ newloc
oldOSRemoved :: Confirmation -> Property UnixLike
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation
where
go :: Property UnixLike
go = property "old OS backup removed" $ do
liftIO $ removeDirectoryRecursive oldOSDir
return MadeChange
oldOSDir :: FilePath
oldOSDir = "/old-os"
newOSDir :: FilePath
newOSDir = "/new-os"