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 NoInfo
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 = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of
(Just d@(System (Debian _) _)) -> debootstrap d
(Just u@(System (Buntish _) _)) -> debootstrap u
_ -> error "os is not declared to be Debian or *buntu"
debootstrap targetos = ensureProperty $
Debootstrap.built' Debootstrap.sourceInstall
newOSDir targetos Debootstrap.DefaultConfig
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 "propellor re-debootstrapped in new os" $
return NoChange
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 NoInfo
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 NoInfo
preserveNetwork = go `requires` Network.cleanInterfacesFile
where
go = property "preserve network configuration" $ do
ls <- liftIO $ lines <$> readProcess "ip"
["route", "list", "scope", "global"]
case words <$> headMaybe ls of
Just ("default":"via":_:"dev":iface:_) ->
ensureProperty $ Network.static iface
_ -> do
warningMessage "did not find any default ipv4 route"
return FailedChange
preserveResolvConf :: Property NoInfo
preserveResolvConf = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do
ls <- liftIO $ lines <$> readFile oldloc
ensureProperty $ newloc `File.hasContent` ls
where
newloc = "/etc/resolv.conf"
oldloc = oldOSDir ++ newloc
preserveRootSshAuthorized :: Property NoInfo
preserveRootSshAuthorized = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do
ks <- liftIO $ lines <$> readFile oldloc
ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks)
where
newloc = "/root/.ssh/authorized_keys"
oldloc = oldOSDir ++ newloc
oldOSRemoved :: Confirmation -> Property NoInfo
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation
where
go = property "old OS backup removed" $ do
liftIO $ removeDirectoryRecursive oldOSDir
return MadeChange
oldOSDir :: FilePath
oldOSDir = "/old-os"
newOSDir :: FilePath
newOSDir = "/new-os"