-- | 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
      + MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
installed Machine
machine = forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
setInfoProperty Property
  (MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
go (forall v. IsInfo v => v -> Info
toInfo [BootloaderInstalled
FlashKernelInstalled])
  where
	go :: CombinedType
  (Property
     (MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
  (Property
     (MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
go = [Machine]
-> Property
     (MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Apt.installed [Machine
"flash-kernel"]
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property UnixLike
configured
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property
  (MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
flashKernel
	configured :: CombinedType (Property UnixLike) (Property UnixLike)
configured = (Machine
"/etc/flash-kernel/machine" Machine -> [Machine] -> Property UnixLike
`File.hasContent` [Machine
machine])
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Machine -> Property UnixLike
File.dirExists Machine
"/etc/flash-kernel"

-- | Runs flash-kernel with whatever machine `installed` configured.
flashKernel :: Property DebianLike
flashKernel :: Property
  (MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
flashKernel = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$
	Machine -> [Machine] -> UncheckedProperty UnixLike
cmdProperty Machine
"flash-kernel" [] 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 = forall {k} (metatypes :: k).
SingI metatypes =>
Machine
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties Machine
desc forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	-- remove mounts that are done below to make sure the right thing
	-- gets mounted
	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
	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")
	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") forall a. Monoid a => a
mempty
	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") forall a. Monoid a => a
mempty
	-- update the initramfs so it gets the uuid of the root partition
	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"]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	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" []
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	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 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] forall a. [a] -> [a] -> [a]
++ [Machine]
ps)

	cleanupmounts :: Property Linux
	cleanupmounts :: Property Linux
cleanupmounts = forall {k} (metatypes :: k).
SingI metatypes =>
Machine -> Propellor Result -> Property (MetaTypes metatypes)
property Machine
desc 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
		Machine -> IO ()
cleanup Machine
"/sys"
		Machine -> IO ()
cleanup Machine
"/proc"
		Machine -> IO ()
cleanup Machine
"/dev"
		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 forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Machine -> IO Bool
isMounted Machine
mp) forall a b. (a -> b) -> a -> b
$
				Machine -> IO ()
umountLazy Machine
mp