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 -> Property DebianLike
cleanInstallOnce Confirmation
confirmation = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO Bool
doesFileExist HostName
flagfile) forall a b. (a -> b) -> a -> b
$
Property DebianLike
go forall x y. Combines x y => x -> y -> CombinedType x y
`requires` HostName -> Confirmation -> Property UnixLike
confirmed HostName
"clean install confirmed" Confirmation
confirmation
where
go :: CombinedType
(CombinedType
(CombinedType
(CombinedType (Property DebianLike) (Property Linux))
(Property UnixLike))
(Property Linux))
(Property Linux)
go =
Property UnixLike
finalized
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
Bool -> Property DebianLike
User.shadowConfig Bool
True
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
Bool -> (Result -> Bool) -> Property Linux
Reboot.atEnd Bool
True (forall a. Eq a => a -> a -> Bool
/= Result
FailedChange)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
Property UnixLike
propellorbootstrapped
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
Property Linux
flipped
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
Property Linux
osbootstrapped
osbootstrapped :: Property Linux
osbootstrapped :: Property Linux
osbootstrapped = forall {k} (metatypes :: k).
SingI metatypes =>
HostName
-> (OuterMetaTypesWitness metatypes
-> Maybe System -> Propellor Result)
-> Property (MetaTypes metatypes)
withOS (HostName
newOSDir forall a. [a] -> [a] -> [a]
++ HostName
" bootstrapped") forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w Maybe System
o -> case Maybe System
o of
(Just d :: System
d@(System (Debian DebianKernel
_ DebianSuite
_) Architecture
_)) -> forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$
System -> Property Linux
debootstrap System
d
(Just u :: System
u@(System (Buntish HostName
_) Architecture
_)) -> forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$
System -> Property Linux
debootstrap System
u
Maybe System
_ -> HasCallStack => Propellor Result
unsupportedOS'
debootstrap :: System -> Property Linux
debootstrap :: System -> Property Linux
debootstrap System
targetos =
Property Linux
-> HostName -> System -> DebootstrapConfig -> Property Linux
Debootstrap.built' Property Linux
Debootstrap.sourceInstall
HostName
newOSDir System
targetos DebootstrapConfig
Debootstrap.DefaultConfig
flipped :: Property Linux
flipped :: Property Linux
flipped = forall {k} (metatypes :: k).
SingI metatypes =>
HostName -> Propellor Result -> Property (MetaTypes metatypes)
property (HostName
newOSDir forall a. [a] -> [a] -> [a]
++ HostName
" moved into place") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
HostName
devfstype <- forall a. a -> Maybe a -> a
fromMaybe HostName
"devtmpfs" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO (Maybe HostName)
getFsType HostName
"/dev"
[HostName]
mnts <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (HostName
"/"forall a. a -> [a] -> [a]
: [HostName]
trickydirs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [HostName]
mountPoints
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [HostName]
mnts) HostName -> IO ()
umountLazy
[(HostName, HostName, IO Bool)]
renamesout <- forall a b. (a -> b) -> [a] -> [b]
map (\HostName
d -> (HostName
d, HostName
oldOSDir forall a. [a] -> [a] -> [a]
++ HostName
d, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HostName
d forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (HostName
oldOSDirforall a. a -> [a] -> [a]
:HostName
newOSDirforall a. a -> [a] -> [a]
:[HostName]
trickydirs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO [HostName]
dirContents HostName
"/"
[(HostName, HostName, IO Bool)]
renamesin <- forall a b. (a -> b) -> [a] -> [b]
map (\HostName
d -> let dest :: HostName
dest = HostName
"/" forall a. [a] -> [a] -> [a]
++ HostName -> HostName
takeFileName HostName
d in (HostName
d, HostName
dest, Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO Bool
fileExist HostName
dest))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO [HostName]
dirContents HostName
newOSDir
Bool -> HostName -> IO ()
createDirectoryIfMissing Bool
True HostName
oldOSDir
[(HostName, HostName, IO Bool)] -> IO ()
massRename ([(HostName, HostName, IO Bool)]
renamesout forall a. [a] -> [a] -> [a]
++ [(HostName, HostName, IO Bool)]
renamesin)
HostName -> IO ()
removeDirectoryRecursive HostName
newOSDir
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ HostName -> HostName -> Bool -> IO ()
setEnv HostName
"PATH" HostName
stdPATH Bool
True
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ HostName -> IO ()
unsetEnv HostName
"LANG"
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (HostName -> HostName -> HostName -> MountOpts -> IO Bool
mount HostName
devfstype HostName
devfstype HostName
"/dev" forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadIO m => HostName -> m ()
warningMessage forall a b. (a -> b) -> a -> b
$ HostName
"failed mounting /dev using " forall a. [a] -> [a] -> [a]
++ HostName
devfstype forall a. [a] -> [a] -> [a]
++ HostName
"; falling back to MAKEDEV generic"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ HostName -> [CommandParam] -> IO Bool
boolSystem HostName
"sh" [HostName -> CommandParam
Param HostName
"-c", HostName -> CommandParam
Param HostName
"cd /dev && /sbin/MAKEDEV generic"]
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (HostName -> HostName -> HostName -> MountOpts -> IO Bool
mount HostName
"sysfs" HostName
"sysfs" HostName
"/sys" forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). MonadIO m => HostName -> m ()
warningMessage HostName
"failed mounting /sys"
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (HostName -> HostName -> HostName -> MountOpts -> IO Bool
mount HostName
"devpts" HostName
"devpts" HostName
"/dev/pts" forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). MonadIO m => HostName -> m ()
warningMessage HostName
"failed mounting /dev/pts"
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
propellorbootstrapped :: Property UnixLike
propellorbootstrapped :: Property UnixLike
propellorbootstrapped = forall {k} (metatypes :: k).
SingI metatypes =>
HostName -> Propellor Result -> Property (MetaTypes metatypes)
property HostName
"propellor re-debootstrapped in new os" forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
finalized :: Property UnixLike
finalized :: Property UnixLike
finalized = forall {k} (metatypes :: k).
SingI metatypes =>
HostName -> Propellor Result -> Property (MetaTypes metatypes)
property HostName
"clean OS installed" forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HostName -> HostName -> IO ()
writeFile HostName
flagfile HostName
""
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
flagfile :: HostName
flagfile = HostName
"/etc/propellor-cleaninstall"
trickydirs :: [HostName]
trickydirs =
[ HostName
"/tmp"
, HostName
"/proc"
]
massRename :: [(FilePath, FilePath, IO Bool)] -> IO ()
massRename :: [(HostName, HostName, IO Bool)] -> IO ()
massRename = [(HostName, HostName)] -> [(HostName, HostName, IO Bool)] -> IO ()
go []
where
go :: [(HostName, HostName)] -> [(HostName, HostName, IO Bool)] -> IO ()
go [(HostName, HostName)]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go [(HostName, HostName)]
undo ((HostName
from, HostName
to, IO Bool
test):[(HostName, HostName, IO Bool)]
rest) = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM IO Bool
test
( forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryNonAsync (HostName -> HostName -> IO ()
rename HostName
from HostName
to)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(forall {t :: * -> *} {e} {b}.
(Foldable t, Exception e) =>
t (HostName, HostName) -> e -> IO b
rollback [(HostName, HostName)]
undo)
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ [(HostName, HostName)] -> [(HostName, HostName, IO Bool)] -> IO ()
go ((HostName
to, HostName
from)forall a. a -> [a] -> [a]
:[(HostName, HostName)]
undo) [(HostName, HostName, IO Bool)]
rest)
, [(HostName, HostName)] -> [(HostName, HostName, IO Bool)] -> IO ()
go [(HostName, HostName)]
undo [(HostName, HostName, IO Bool)]
rest
)
rollback :: t (HostName, HostName) -> e -> IO b
rollback t (HostName, HostName)
undo e
e = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HostName -> HostName -> IO ()
rename) t (HostName, HostName)
undo
forall a e. Exception e => e -> a
throw e
e
data Confirmation = Confirmed HostName
confirmed :: Desc -> Confirmation -> Property UnixLike
confirmed :: HostName -> Confirmation -> Property UnixLike
confirmed HostName
desc (Confirmed HostName
c) = forall {k} (metatypes :: k).
SingI metatypes =>
HostName -> Propellor Result -> Property (MetaTypes metatypes)
property HostName
desc forall a b. (a -> b) -> a -> b
$ do
HostName
hostname <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> HostName
hostName
if HostName
hostname forall a. Eq a => a -> a -> Bool
/= HostName
c
then do
forall (m :: * -> *). MonadIO m => HostName -> m ()
warningMessage HostName
"Run with a bad confirmation, not matching hostname."
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
else forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
preserveNetwork :: Property DebianLike
preserveNetwork :: Property DebianLike
preserveNetwork = Property DebianLike
go forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
Network.cleanInterfacesFile
where
go :: Property DebianLike
go :: Property DebianLike
go = forall {k} (metatypes :: k).
SingI metatypes =>
HostName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' HostName
"preserve network configuration" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
[HostName]
ls <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HostName -> [HostName]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> [HostName] -> IO HostName
readProcess HostName
"ip"
[HostName
"route", HostName
"list", HostName
"scope", HostName
"global"]
case HostName -> [HostName]
words forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
headMaybe [HostName]
ls of
Just (HostName
"default":HostName
"via":HostName
_:HostName
"dev":HostName
iface:[HostName]
_) ->
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ HostName -> Property DebianLike
Network.preserveStatic HostName
iface
Maybe [HostName]
_ -> do
forall (m :: * -> *). MonadIO m => HostName -> m ()
warningMessage HostName
"did not find any default ipv4 route"
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
preserveResolvConf :: Property Linux
preserveResolvConf :: Property Linux
preserveResolvConf = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (HostName -> IO Bool
fileExist HostName
oldloc) forall a b. (a -> b) -> a -> b
$
forall {k} (metatypes :: k).
SingI metatypes =>
HostName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (HostName
newloc forall a. [a] -> [a] -> [a]
++ HostName
" copied from old OS") forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w -> do
[HostName]
ls <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HostName -> [HostName]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO HostName
readFile HostName
oldloc
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$ HostName
newloc HostName -> [HostName] -> Property UnixLike
`File.hasContent` [HostName]
ls
where
newloc :: HostName
newloc = HostName
"/etc/resolv.conf"
oldloc :: HostName
oldloc = HostName
oldOSDir forall a. [a] -> [a] -> [a]
++ HostName
newloc
preserveRootSshAuthorized :: Property UnixLike
preserveRootSshAuthorized :: Property UnixLike
preserveRootSshAuthorized = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (HostName -> IO Bool
fileExist HostName
oldloc) forall a b. (a -> b) -> a -> b
$
forall {k} (metatypes :: k).
SingI metatypes =>
HostName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' HostName
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
w -> do
[HostName]
ks <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HostName -> [HostName]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO HostName
readFile HostName
oldloc
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
w forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
HostName
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties HostName
desc forall a b. (a -> b) -> a -> b
$
forall {k} (metatypes :: k).
[Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
toProps forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property setupmetatypes
setupRevertableProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> HostName -> RevertableProperty UnixLike UnixLike
Ssh.authorizedKey (HostName -> User
User HostName
"root")) [HostName]
ks
where
desc :: HostName
desc = HostName
newloc forall a. [a] -> [a] -> [a]
++ HostName
" copied from old OS"
newloc :: HostName
newloc = HostName
"/root/.ssh/authorized_keys"
oldloc :: HostName
oldloc = HostName
oldOSDir forall a. [a] -> [a] -> [a]
++ HostName
newloc
oldOSRemoved :: Confirmation -> Property UnixLike
oldOSRemoved :: Confirmation -> Property UnixLike
oldOSRemoved Confirmation
confirmation = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (HostName -> IO Bool
doesDirectoryExist HostName
oldOSDir) forall a b. (a -> b) -> a -> b
$
Property UnixLike
go forall x y. Combines x y => x -> y -> CombinedType x y
`requires` HostName -> Confirmation -> Property UnixLike
confirmed HostName
"old OS backup removal confirmed" Confirmation
confirmation
where
go :: Property UnixLike
go :: Property UnixLike
go = forall {k} (metatypes :: k).
SingI metatypes =>
HostName -> Propellor Result -> Property (MetaTypes metatypes)
property HostName
"old OS backup removed" forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HostName -> IO ()
removeDirectoryRecursive HostName
oldOSDir
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
oldOSDir :: FilePath
oldOSDir :: HostName
oldOSDir = HostName
"/old-os"
newOSDir :: FilePath
newOSDir :: HostName
newOSDir = HostName
"/new-os"