summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog1
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Property/DiskImage.hs33
-rw-r--r--src/Propellor/Property/Machine.hs17
-rw-r--r--src/Propellor/Property/Mount.hs20
-rw-r--r--src/Propellor/Property/Uboot.hs36
-rw-r--r--src/Propellor/Types/Bootloader.hs9
7 files changed, 85 insertions, 32 deletions
diff --git a/debian/changelog b/debian/changelog
index d6be2ca7..894c906f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -12,6 +12,7 @@ propellor (4.9.1) UNRELEASED; urgency=medium
* Qemu: New module.
* FlashKernel: New module, can be used to create disk images for ARM
boards using flash-kernel.
+ * Uboot: New module.
* Machine: New module, machine-specific properties for ARM boards are
being collected here.
diff --git a/propellor.cabal b/propellor.cabal
index 51640658..239a00e6 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -157,6 +157,7 @@ Library
Propellor.Property.Systemd.Core
Propellor.Property.Timezone
Propellor.Property.Tor
+ Propellor.Property.Uboot
Propellor.Property.Unbound
Propellor.Property.User
Propellor.Property.Uwsgi
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 7493dd21..fe2e60ac 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -191,10 +191,14 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
-- Pick boot loader finalization based on which bootloader is
-- installed.
final = case fromInfo (containerInfo chroot) of
- [GrubInstalled] -> grubBooted
- [FlashKernelInstalled] -> \_ _ -> doNothing
[] -> unbootable "no bootloader is installed"
- _ -> unbootable "multiple bootloaders are installed; don't know which to use"
+ l -> case filter ignorablefinal l of
+ [] -> \_ _ _ -> doNothing
+ [GrubInstalled] -> grubFinalized
+ [UbootInstalled p] -> ubootFinalized p
+ _ -> unbootable "multiple bootloaders are installed; don't know which to use"
+ ignorablefinal FlashKernelInstalled = True
+ ignorablefinal _ = False
-- | This property is automatically added to the chroot when building a
-- disk image. It cleans any caches of information that can be omitted;
@@ -229,7 +233,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
mkimg' mnts mntopts parttable devs =
partitionsPopulated chrootdir mnts mntopts devs
`before`
- imageFinalized final mnts mntopts devs parttable
+ imageFinalized final dest mnts mntopts devs parttable
rmimg = undoRevertableProperty (buildDiskImage img)
`before` undoRevertableProperty (imageExists' dest dummyparttable)
dummyparttable = PartTable tabletype []
@@ -352,10 +356,10 @@ imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe`
--
-- It's ok if the property leaves additional things mounted
-- in the partition tree.
-type Finalization = (FilePath -> [LoopDev] -> Property Linux)
+type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux)
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized final mnts mntopts devs (PartTable _ parts) =
+imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
+imageFinalized final img mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
@@ -364,7 +368,7 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) =
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
- ensureProperty w $ final top devs
+ ensureProperty w $ final img top devs
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
@@ -400,18 +404,14 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) =
allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
unbootable :: String -> Finalization
-unbootable msg = \_ _ -> property desc $ do
+unbootable msg = \_ _ _ -> property desc $ do
warningMessage (desc ++ ": " ++ msg)
return FailedChange
where
desc = "image is not bootable"
--- | Makes grub be the boot loader of the disk image.
---
--- This does not install the grub package. You will need to add
--- the `Grub.installed` property to the chroot.
-grubBooted :: Finalization
-grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
+grubFinalized :: Finalization
+grubFinalized _img mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
`describe` "disk image boots using grub"
where
-- It doesn't matter which loopdev we use; all
@@ -421,6 +421,9 @@ grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
(l:_) -> wholeDiskLoopDev l
[] -> error "No loop devs provided!"
+ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
+ubootFinalized p (RawDiskImage img) mnt _loopdevs = p img mnt
+
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/Machine.hs b/src/Propellor/Property/Machine.hs
index 2f356bdd..5f5024df 100644
--- a/src/Propellor/Property/Machine.hs
+++ b/src/Propellor/Property/Machine.hs
@@ -14,6 +14,7 @@ module Propellor.Property.Machine (
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.FlashKernel as FlashKernel
+import qualified Propellor.Property.Uboot as Uboot
-- | Cubietech Cubietruck
--
@@ -21,21 +22,21 @@ import qualified Propellor.Property.FlashKernel as FlashKernel
-- this property. Also, see https://bugs.debian.org/844056
cubietech_Cubietruck :: Property (HasInfo + DebianLike)
cubietech_Cubietruck = FlashKernel.installed "Cubietech Cubietruck"
- `requires` sunixi
+ `requires` sunixi "Cubietruck"
`requires` lpae
-- | Olimex A10-OLinuXino-LIME
olimex_A10_OLinuXino_LIME :: Property (HasInfo + DebianLike)
olimex_A10_OLinuXino_LIME = FlashKernel.installed "Olimex A10-OLinuXino-LIME"
- `requires` sunixi
+ `requires` sunixi "A10-OLinuXino-Lime"
`requires` armmp
-sunixi :: Property DebianLike
-sunixi = Apt.installed
- [ "firmware-linux-free"
- , "u-boot"
- , "sunxi-tools"
- ]
+sunixi :: Uboot.BoardName -> Property (HasInfo + DebianLike)
+sunixi boardname = Uboot.sunxi boardname
+ `requires` Apt.installed
+ [ "firmware-linux-free"
+ , "sunxi-tools"
+ ]
armmp :: Property DebianLike
armmp = Apt.installed ["linux-image-armmp"]
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 2c4d9620..c047161d 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -90,18 +90,18 @@ mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
-- | Filesystem type mounted at a given location.
getFsType :: MountPoint -> IO (Maybe FsType)
-getFsType = findmntField "fstype"
+getFsType p = findmntField "fstype" [p]
-- | Mount options for the filesystem mounted at a given location.
getFsMountOpts :: MountPoint -> IO MountOpts
getFsMountOpts p = maybe mempty toMountOpts
- <$> findmntField "fs-options" p
+ <$> findmntField "fs-options" [p]
type UUID = String
-- | UUID of filesystem mounted at a given location.
getMountUUID :: MountPoint -> IO (Maybe UUID)
-getMountUUID = findmntField "uuid"
+getMountUUID p = findmntField "uuid" [p]
-- | UUID of a device
getSourceUUID :: Source -> IO (Maybe UUID)
@@ -111,7 +111,7 @@ type Label = String
-- | Label of filesystem mounted at a given location.
getMountLabel :: MountPoint -> IO (Maybe Label)
-getMountLabel = findmntField "label"
+getMountLabel p = findmntField "label" [p]
-- | Label of a device
getSourceLabel :: Source -> IO (Maybe UUID)
@@ -119,12 +119,16 @@ getSourceLabel = blkidTag "LABEL"
-- | Device mounted at a given location.
getMountSource :: MountPoint -> IO (Maybe Source)
-getMountSource = findmntField "source"
+getMountSource p = findmntField "source" [p]
-findmntField :: String -> FilePath -> IO (Maybe String)
-findmntField field mnt = catchDefaultIO Nothing $
+-- | Device that a given path is located within.
+getMountContaining :: FilePath -> IO (Maybe Source)
+getMountContaining p = findmntField "source" ["-T", p]
+
+findmntField :: String -> [String] -> IO (Maybe String)
+findmntField field ps = catchDefaultIO Nothing $
headMaybe . filter (not . null) . lines
- <$> readProcess "findmnt" ["-n", mnt, "--output", field]
+ <$> readProcess "findmnt" ("-n" : ps ++ ["--output", field])
blkidTag :: String -> Source -> IO (Maybe String)
blkidTag tag dev = catchDefaultIO Nothing $
diff --git a/src/Propellor/Property/Uboot.hs b/src/Propellor/Property/Uboot.hs
new file mode 100644
index 00000000..70b4dd68
--- /dev/null
+++ b/src/Propellor/Property/Uboot.hs
@@ -0,0 +1,36 @@
+module Propellor.Property.Uboot where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
+import Propellor.Property.Chroot
+import Propellor.Property.Mount
+import qualified Propellor.Property.Apt as Apt
+
+-- | Name of a board.
+type BoardName = String
+
+-- | Installs u-boot for Allwinner/sunxi platforms.
+--
+-- This includes writing it to the boot sector.
+sunxi :: BoardName -> Property (HasInfo + DebianLike)
+sunxi boardname = setInfoProperty (check (not <$> inChroot) go) info
+ `requires` Apt.installed ["u-boot", "u-boot-sunxi"]
+ where
+ go :: Property Linux
+ go = property' "u-boot installed" $ \w -> do
+ v <- liftIO $ getMountContaining "/boot"
+ case v of
+ Nothing -> error "unable to determine boot device"
+ Just dev -> ensureProperty w (dd dev "/")
+ dd :: FilePath -> FilePath -> Property Linux
+ dd dev prefix = tightenTargets $ cmdProperty "dd"
+ [ "conv=fsync,notrunc"
+ , "if=" ++ prefix </> "/usr/lib/u-boot"
+ </> boardname </> "u-boot-sunxi-with-spl.bin"
+ , "of=" ++ dev
+ , "bs=1024"
+ , "seek=8"
+ ]
+ `assume` NoChange
+ info = toInfo [UbootInstalled dd]
diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs
index 9822d520..fd929d7e 100644
--- a/src/Propellor/Types/Bootloader.hs
+++ b/src/Propellor/Types/Bootloader.hs
@@ -2,13 +2,20 @@
module Propellor.Types.Bootloader where
+import Propellor.Types
import Propellor.Types.Info
-- | Boot loader installed on a host.
data BootloaderInstalled
= GrubInstalled
| FlashKernelInstalled
- deriving (Typeable, Show)
+ | UbootInstalled (FilePath -> FilePath -> Property Linux)
+ deriving (Typeable)
+
+instance Show BootloaderInstalled where
+ show GrubInstalled = "GrubInstalled"
+ show FlashKernelInstalled = "FlashKernelInstalled"
+ show (UbootInstalled _) = "UbootInstalled"
instance IsInfo [BootloaderInstalled] where
propagateInfo _ = PropagateInfo False