module Propellor.Property.Reboot (
	now,
	atEnd,
	toDistroKernel,
	toKernelNewerThan,
	KernelVersion,
) where

import Propellor.Base

import Data.List
import Data.Version
import Text.ParserCombinators.ReadP

-- | Kernel version number, in a string. 
type KernelVersion = String

-- | Using this property causes an immediate reboot.
-- 
-- So, this is not a useful property on its own, but it can be useful to
-- compose with other properties. For example:
--
-- > Apt.installed ["new-kernel"]
-- >	`onChange` Reboot.now
now :: Property Linux
now :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
now = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
cmdProperty String
"reboot" []
	UncheckedProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> String
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall p. IsProp p => p -> String -> p
`describe` String
"reboot now"

type Force = Bool

-- | Schedules a reboot at the end of the current propellor run.
--
-- The `Result` code of the entire propellor run can be checked;
-- the reboot proceeds only if the function returns True.
--
-- The reboot can be forced to run, which bypasses the init system. Useful
-- if the init system might not be running for some reason.
atEnd :: Force -> (Result -> Bool) -> Property Linux
atEnd :: Bool
-> (Result -> Bool)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
atEnd Bool
force Result -> Bool
resultok = String
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"scheduled reboot at end of propellor run" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ do
	String -> (Result -> Propellor Result) -> Propellor ()
endAction String
"rebooting" Result -> Propellor Result
forall {m :: * -> *}. MonadIO m => Result -> m Result
atend
	Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
  where
	atend :: Result -> m Result
atend Result
r
		| Result -> Bool
resultok Result
r = IO Result -> m Result
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> m Result) -> IO Result -> m Result
forall a b. (a -> b) -> a -> b
$ Bool -> Result
forall t. ToResult t => t -> Result
toResult
			(Bool -> Result) -> IO Bool -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [CommandParam] -> IO Bool
boolSystem String
"reboot" [CommandParam]
rebootparams
		| Bool
otherwise = do
			String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
"Not rebooting, due to status of propellor run."
			Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
	rebootparams :: [CommandParam]
rebootparams
		| Bool
force = [String -> CommandParam
Param String
"--force"]
		| Bool
otherwise = []

-- | Reboots immediately if a kernel other than the distro-installed kernel is
-- running.
--
-- This will only work if you have taken measures to ensure that the other
-- kernel won't just get booted again.
-- See 'Propellor.Property.HostingProvider.DigitalOcean'
-- for an example of how to do this.
toDistroKernel :: Property DebianLike
toDistroKernel :: Property DebianLike
toDistroKernel = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property DebianLike
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Property DebianLike)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property DebianLike
forall a b. (a -> b) -> a -> b
$ IO Bool
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
runningInstalledKernel) Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
now
	Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> String
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall p. IsProp p => p -> String -> p
`describe` String
"running installed kernel"

-- | Given a kernel version string @v@, reboots immediately if the running
-- kernel version is strictly less than @v@ and there is an installed kernel
-- version is greater than or equal to @v@.  Fails if the requested kernel
-- version is not installed.
--
-- For this to be useful, you need to have ensured that the installed kernel
-- with the highest version number is the one that will be started after a
-- reboot.
--
-- This is useful when upgrading to a new version of Debian where you need to
-- ensure that a new enough kernel is running before ensuring other properties.
toKernelNewerThan :: KernelVersion -> Property DebianLike
toKernelNewerThan :: String -> Property DebianLike
toKernelNewerThan String
ver =
	String
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (String
"reboot to kernel newer than " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ver) ((OuterMetaTypesWitness
    '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
  -> Propellor Result)
 -> Property DebianLike)
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		wantV <- String -> Propellor Version
tryReadVersion String
ver
		runningV <- tryReadVersion =<< liftIO runningKernelVersion
		if runningV >= wantV then noChange
			else maximum <$> installedVs >>= \Version
installedV ->
				if Version
installedV Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
wantV
					then OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
now
					else String -> Propellor Result
forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage (String -> Propellor Result) -> String -> Propellor Result
forall a b. (a -> b) -> a -> b
$
						String
"kernel newer than "
						String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ver
						String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not installed"
  where
	installedVs :: Propellor [Version]
installedVs = (String -> Propellor Version) -> [String] -> Propellor [Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Propellor Version
tryReadVersion ([String] -> Propellor [Version])
-> Propellor [String] -> Propellor [Version]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String] -> Propellor [String]
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
installedKernelVersions

runningInstalledKernel :: IO Bool
runningInstalledKernel :: IO Bool
runningInstalledKernel = do
	kernelver <- IO String
runningKernelVersion
	when (null kernelver) $
		error "failed to read uname -r"
	kernelimages <- installedKernelImages
	when (null kernelimages) $
		error "failed to find any installed kernel images"
	findVersion kernelver <$>
		readProcess "file" ("-L" : kernelimages)

runningKernelVersion :: IO KernelVersion
runningKernelVersion :: IO String
runningKernelVersion = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"uname" [String
"-r"]

installedKernelImages :: IO [String]
installedKernelImages :: IO [String]
installedKernelImages = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [String]
kernelsIn [String
"/", String
"/boot/"]

-- | File output looks something like this, we want to unambiguously
-- match the running kernel version:
--   Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA
findVersion :: KernelVersion -> String -> Bool
findVersion :: String -> String -> Bool
findVersion String
ver String
s = (String
" version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ver String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s

installedKernelVersions :: IO [KernelVersion]
installedKernelVersions :: IO [String]
installedKernelVersions = do
	kernelimages <- IO [String]
installedKernelImages
	when (null kernelimages) $
		error "failed to find any installed kernel images"
	imageLines <- lines <$> readProcess "file" ("-L" : kernelimages)
	return $ extractKernelVersion <$> imageLines

kernelsIn :: FilePath -> IO [FilePath]
kernelsIn :: String -> IO [String]
kernelsIn String
d = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"vmlinu" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
dirContents String
d

extractKernelVersion :: String -> KernelVersion
extractKernelVersion :: String -> String
extractKernelVersion =
	[String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"version") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

readVersionMaybe :: KernelVersion -> Maybe Version
readVersionMaybe :: String -> Maybe Version
readVersionMaybe String
ver = case ((Version, String) -> Version) -> [(Version, String)] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map (Version, String) -> Version
forall a b. (a, b) -> a
fst ([(Version, String)] -> [Version])
-> [(Version, String)] -> [Version]
forall a b. (a -> b) -> a -> b
$ ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion String
ver of
	[] -> Maybe Version
forall a. Maybe a
Nothing
	[Version]
l -> Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ [Version] -> Version
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Version]
l

tryReadVersion :: KernelVersion -> Propellor Version
tryReadVersion :: String -> Propellor Version
tryReadVersion String
ver = case String -> Maybe Version
readVersionMaybe String
ver of
	Just Version
x -> Version -> Propellor Version
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Version
x
	Maybe Version
Nothing -> String -> Propellor Version
forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage (String
"couldn't parse version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ver)