propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

FlashKernel.hs (2248B)


      1 -- | Make ARM systems bootable using Debian's flash-kernel package.
      2 
      3 module Propellor.Property.FlashKernel where
      4 
      5 import Propellor.Base
      6 import qualified Propellor.Property.File as File
      7 import qualified Propellor.Property.Apt as Apt
      8 import Propellor.Property.Mount
      9 import Propellor.Types.Bootloader
     10 import Propellor.Types.Info
     11 
     12 -- | A machine name, such as "Cubietech Cubietruck" or "Olimex A10-OLinuXino-LIME"
     13 --
     14 -- flash-kernel supports many different machines,
     15 -- see its file /usr/share/flash-kernel/db/all.db for a list.
     16 type Machine = String
     17 
     18 -- | Uses flash-kernel to make a machine bootable.
     19 --
     20 -- Before using this, an appropriate kernel needs to already be installed, 
     21 -- and on many machines, u-boot needs to be installed too.
     22 installed :: Machine -> Property (HasInfo + DebianLike)
     23 installed machine = setInfoProperty go (toInfo [FlashKernelInstalled])
     24   where
     25 	go = "/etc/flash-kernel/machine" `File.hasContent` [machine]
     26 		`onChange` flashKernel
     27 		`requires` File.dirExists "/etc/flash-kernel"
     28 		`requires` Apt.installed ["flash-kernel"]
     29 
     30 -- | Runs flash-kernel with whatever machine `installed` configured.
     31 flashKernel :: Property DebianLike
     32 flashKernel = tightenTargets $
     33 	cmdProperty "flash-kernel" [] `assume` MadeChange
     34 
     35 -- | Runs flash-kernel in the system mounted at a particular directory.
     36 flashKernelMounted :: FilePath -> Property Linux
     37 flashKernelMounted mnt = combineProperties desc $ props
     38 	-- remove mounts that are done below to make sure the right thing
     39 	-- gets mounted
     40 	& cleanupmounts
     41 	& bindMount "/dev" (inmnt "/dev")
     42 	& mounted "proc" "proc" (inmnt "/proc") mempty
     43 	& mounted "sysfs" "sys" (inmnt "/sys") mempty
     44 	-- update the initramfs so it gets the uuid of the root partition
     45 	& inchroot "update-initramfs" ["-u"]
     46 		`assume` MadeChange
     47 	& inchroot "flash-kernel" []
     48 		`assume` MadeChange
     49 	& cleanupmounts
     50   where
     51 	desc = "flash-kernel run"
     52 
     53 	-- cannot use </> since the filepath is absolute
     54 	inmnt f = mnt ++ f
     55 
     56 	inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
     57 
     58 	cleanupmounts :: Property Linux
     59 	cleanupmounts = property desc $ liftIO $ do
     60 		cleanup "/sys"
     61 		cleanup "/proc"
     62 		cleanup "/dev"
     63 		return NoChange
     64 	  where
     65 		cleanup m =
     66 			let mp = inmnt m
     67 			in whenM (isMounted mp) $
     68 				umountLazy mp