-- | Make ARM systems bootable using Debian's flash-kernel package.

module Propellor.Property.FlashKernel where

import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Mount
import Propellor.Types.Bootloader
import Propellor.Types.Info

-- | A machine name, such as "Cubietech Cubietruck" or "Olimex A10-OLinuXino-LIME"
--
-- flash-kernel supports many different machines,
-- see its file /usr/share/flash-kernel/db/all.db for a list.
type Machine = String

-- | Uses flash-kernel to make a machine bootable.
--
-- Before using this, an appropriate kernel needs to already be installed, 
-- and on many machines, u-boot needs to be installed too.
installed :: Machine -> Property (HasInfo + DebianLike)
installed :: Machine -> Property (HasInfo + DebianLike)
installed Machine
machine = Property DebianLike
-> Info
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall k (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
setInfoProperty Property DebianLike
go ([BootloaderInstalled] -> Info
forall v. IsInfo v => v -> Info
toInfo [BootloaderInstalled
FlashKernelInstalled])
  where
	go :: CombinedType (Property DebianLike) (Property DebianLike)
go = Machine
"/etc/flash-kernel/machine" Machine -> [Machine] -> Property UnixLike
`File.hasContent` [Machine
machine]
		Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
flashKernel
		Property DebianLike
-> Property UnixLike
-> CombinedType (Property DebianLike) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Machine -> Property UnixLike
File.dirExists Machine
"/etc/flash-kernel"
		Property DebianLike
-> Property DebianLike
-> CombinedType (Property DebianLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` [Machine] -> Property DebianLike
Apt.installed [Machine
"flash-kernel"]

-- | Runs flash-kernel with whatever machine `installed` configured.
flashKernel :: Property DebianLike
flashKernel :: Property DebianLike
flashKernel = Property UnixLike -> Property DebianLike
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property DebianLike)
-> Property UnixLike -> Property DebianLike
forall a b. (a -> b) -> a -> b
$
	Machine -> [Machine] -> UncheckedProperty UnixLike
cmdProperty Machine
"flash-kernel" [] UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange

-- | Runs flash-kernel in the system mounted at a particular directory.
flashKernelMounted :: FilePath -> Property Linux
flashKernelMounted :: Machine -> Property Linux
flashKernelMounted Machine
mnt = Machine -> Props Linux -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
Machine
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties Machine
desc (Props Linux -> Property Linux) -> Props Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	-- remove mounts that are done below to make sure the right thing
	-- gets mounted
	Props UnixLike
-> Property Linux
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property Linux
cleanupmounts
	Props Linux
-> Property Linux
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Machine -> Machine -> Property Linux
bindMount Machine
"/dev" (Machine -> Machine
inmnt Machine
"/dev")
	Props Linux
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Machine -> Machine -> Machine -> MountOpts -> Property UnixLike
mounted Machine
"proc" Machine
"proc" (Machine -> Machine
inmnt Machine
"/proc") MountOpts
forall a. Monoid a => a
mempty
	Props Linux
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Machine -> Machine -> Machine -> MountOpts -> Property UnixLike
mounted Machine
"sysfs" Machine
"sys" (Machine -> Machine
inmnt Machine
"/sys") MountOpts
forall a. Monoid a => a
mempty
	-- update the initramfs so it gets the uuid of the root partition
	Props Linux
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Machine -> [Machine] -> UncheckedProperty UnixLike
inchroot Machine
"update-initramfs" [Machine
"-u"]
		UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	Props Linux
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Machine -> [Machine] -> UncheckedProperty UnixLike
inchroot Machine
"flash-kernel" []
		UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	Props Linux
-> Property Linux
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall a p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property Linux
cleanupmounts
  where
	desc :: Machine
desc = Machine
"flash-kernel run"

	-- cannot use </> since the filepath is absolute
	inmnt :: Machine -> Machine
inmnt Machine
f = Machine
mnt Machine -> Machine -> Machine
forall a. [a] -> [a] -> [a]
++ Machine
f

	inchroot :: Machine -> [Machine] -> UncheckedProperty UnixLike
inchroot Machine
cmd [Machine]
ps = Machine -> [Machine] -> UncheckedProperty UnixLike
cmdProperty Machine
"chroot" ([Machine
mnt, Machine
cmd] [Machine] -> [Machine] -> [Machine]
forall a. [a] -> [a] -> [a]
++ [Machine]
ps)

	cleanupmounts :: Property Linux
	cleanupmounts :: Property Linux
cleanupmounts = Machine -> Propellor Result -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
Machine -> Propellor Result -> Property (MetaTypes metatypes)
property Machine
desc (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ do
		Machine -> IO ()
cleanup Machine
"/sys"
		Machine -> IO ()
cleanup Machine
"/proc"
		Machine -> IO ()
cleanup Machine
"/dev"
		Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
	  where
		cleanup :: Machine -> IO ()
cleanup Machine
m =
			let mp :: Machine
mp = Machine -> Machine
inmnt Machine
m
			in IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Machine -> IO Bool
isMounted Machine
mp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
				Machine -> IO ()
umountLazy Machine
mp