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 Linux
now = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property Linux
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 Linux)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property Linux
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 :: Force -> (Result -> Force) -> Property Linux
atEnd Force
force Result -> Force
resultok = String -> Propellor Result -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"scheduled reboot at end of propellor run" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
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 (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
  where
	atend :: Result -> m Result
atend Result
r
		| Result -> Force
resultok Result
r = IO Result -> m Result
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
$ Force -> Result
forall t. ToResult t => t -> Result
toResult
			(Force -> Result) -> IO Force -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [CommandParam] -> IO Force
boolSystem String
"reboot" [CommandParam]
rebootparams
		| Force
otherwise = do
			String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
"Not rebooting, due to status of propellor run."
			Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
	rebootparams :: [CommandParam]
rebootparams
		| Force
force = [String -> CommandParam
Param String
"--force"]
		| Force
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 Linux -> Property DebianLike
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property Linux -> Property DebianLike)
-> Property Linux -> Property DebianLike
forall a b. (a -> b) -> a -> b
$ IO Force -> Property Linux -> Property Linux
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Force -> p i -> Property i
check (Force -> Force
not (Force -> Force) -> IO Force -> IO Force
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Force
runningInstalledKernel) Property Linux
now
	Property Linux -> String -> Property Linux
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
		Version
wantV <- String -> Propellor Version
tryReadVersion String
ver
		Version
runningV <- 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
runningKernelVersion
		if Version
runningV Version -> Version -> Force
forall a. Ord a => a -> a -> Force
>= Version
wantV then Propellor Result
noChange
			else [Version] -> Version
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Version] -> Version) -> Propellor [Version] -> Propellor Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Propellor [Version]
installedVs Propellor Version
-> (Version -> Propellor Result) -> Propellor Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Version
installedV ->
				if Version
installedV Version -> Version -> Force
forall a. Ord a => a -> a -> Force
>= Version
wantV
					then OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Property Linux -> 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 Linux
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)
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
installedKernelVersions

runningInstalledKernel :: IO Bool
runningInstalledKernel :: IO Force
runningInstalledKernel = do
	String
kernelver <- IO String
runningKernelVersion
	Force -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Force -> f () -> f ()
when (String -> Force
forall (t :: * -> *) a. Foldable t => t a -> Force
null String
kernelver) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall a. HasCallStack => String -> a
error String
"failed to read uname -r"
	[String]
kernelimages <- IO [String]
installedKernelImages
	Force -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Force -> f () -> f ()
when ([String] -> Force
forall (t :: * -> *) a. Foldable t => t a -> Force
null [String]
kernelimages) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall a. HasCallStack => String -> a
error String
"failed to find any installed kernel images"
	String -> String -> Force
findVersion String
kernelver (String -> Force) -> IO String -> IO Force
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
		String -> [String] -> IO String
readProcess String
"file" (String
"-L" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
kernelimages)

runningKernelVersion :: IO KernelVersion
runningKernelVersion :: IO String
runningKernelVersion = (Char -> Force) -> String -> String
forall a. (a -> Force) -> [a] -> [a]
takeWhile (Char -> Char -> Force
forall a. Eq a => a -> a -> Force
/= 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)
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 -> Force
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 -> Force
forall a. Eq a => [a] -> [a] -> Force
`isInfixOf` String
s

installedKernelVersions :: IO [KernelVersion]
installedKernelVersions :: IO [String]
installedKernelVersions = do
	[String]
kernelimages <- IO [String]
installedKernelImages
	Force -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Force -> f () -> f ()
when ([String] -> Force
forall (t :: * -> *) a. Foldable t => t a -> Force
null [String]
kernelimages) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall a. HasCallStack => String -> a
error String
"failed to find any installed kernel images"
	[String]
imageLines <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"file" (String
"-L" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
kernelimages)
	[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String
extractKernelVersion (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
imageLines

kernelsIn :: FilePath -> IO [FilePath]
kernelsIn :: String -> IO [String]
kernelsIn String
d = (String -> Force) -> [String] -> [String]
forall a. (a -> Force) -> [a] -> [a]
filter (String
"vmlinu" String -> String -> Force
forall a. Eq a => [a] -> [a] -> Force
`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 -> Force) -> [String] -> [String]
forall a. (a -> Force) -> [a] -> [a]
dropWhile (String -> String -> Force
forall a. Eq a => a -> a -> Force
/= 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 (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 (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)