summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2018-06-12 10:55:00 -0400
committerJoey Hess2018-06-12 10:55:00 -0400
commitd1164739fb1844dd9a5c4e57c76ce1cd2dbddebc (patch)
tree781c4133132251559bf7a647fd821f395f332e57
parent70f318e44d12500c62dd1ad1164fbf7fd9ca8726 (diff)
parentdca1c56e612757c4bb306fb45675337dc52eb201 (diff)
Merge branch 'joeyconfig'
l---------config.hs2
-rw-r--r--debian/changelog9
-rw-r--r--debian/control4
-rw-r--r--joeyconfig.hs1
-rw-r--r--privdata/relocate1
-rw-r--r--src/Propellor/Bootstrap.hs7
-rw-r--r--src/Propellor/EnsureProperty.hs8
-rw-r--r--src/Propellor/Git/VerifiedBranch.hs9
-rw-r--r--src/Propellor/PropAccum.hs6
-rw-r--r--src/Propellor/Property/Qemu.hs5
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs20
-rw-r--r--src/Propellor/Types.hs20
-rw-r--r--src/Propellor/Types/MetaTypes.hs195
13 files changed, 142 insertions, 145 deletions
diff --git a/config.hs b/config.hs
index ec313725..97d90636 120000
--- a/config.hs
+++ b/config.hs
@@ -1 +1 @@
-config-simple.hs \ No newline at end of file
+joeyconfig.hs \ No newline at end of file
diff --git a/debian/changelog b/debian/changelog
index ae97e9db..c4707e71 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,12 @@
+propellor (5.4.1) UNRELEASED; urgency=medium
+
+ * Modernized and simplified the MetaTypes implementation now that
+ compatability with ghc 7 is no longer needed.
+ * Use git verify-commit to verify gpg signatures, rather than the old
+ method of parsing git log output. Needs git 2.0.
+
+ -- Joey Hess <id@joeyh.name> Fri, 18 May 2018 10:25:05 -0400
+
propellor (5.4.0) unstable; urgency=medium
[ Sean Whitton ]
diff --git a/debian/control b/debian/control
index 5a041c90..0a8701a0 100644
--- a/debian/control
+++ b/debian/control
@@ -3,7 +3,7 @@ Section: admin
Priority: optional
Build-Depends:
debhelper (>= 9),
- git,
+ git (>= 2.0),
ghc (>= 7.6),
cabal-install,
libghc-async-dev,
@@ -43,7 +43,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-stm-dev,
libghc-text-dev,
libghc-hashable-dev,
- git,
+ git (>= 2.0),
Description: property-based host configuration management in haskell
Propellor ensures that the system it's run in satisfies a list of
properties, taking action as necessary when a property is not yet met.
diff --git a/joeyconfig.hs b/joeyconfig.hs
index ce4ddbee..5793a655 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -185,6 +185,7 @@ honeybee = host "honeybee.kitenet.net" $ props
`setSize` MegaBytes 8000
)
& JoeySites.cubieTruckOneWire
+ & Apt.installed ["i2c-tools"]
& Apt.installed ["firmware-brcm80211"]
-- Workaround for https://bugs.debian.org/844056
diff --git a/privdata/relocate b/privdata/relocate
new file mode 100644
index 00000000..271692d8
--- /dev/null
+++ b/privdata/relocate
@@ -0,0 +1 @@
+.joeyconfig
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 04f23f85..eba291c4 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -100,10 +100,9 @@ checkDepsCommand bs sys = go (getBuilder bs)
--
-- When bootstrapping Robustly, first try to install the builder,
-- and all haskell libraries that propellor uses from OS packages.
--- Some packages may not be available in some versions of Debian
--- (eg, Debian wheezy lacks async), or propellor may need a newer version.
--- So, as a second step, any other dependencies are installed from source
--- using the builder.
+-- Some packages may not be available in some versions of the OS,
+-- or propellor may need a newer version. So, as a second step,
+-- ny other dependencies are installed from source using the builder.
--
-- Note: May succeed and leave some deps not installed.
depsCommand :: Bootstrapper -> Maybe System -> ShellCommand
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index 5a07107c..6c720e2b 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -50,10 +50,10 @@ ensureProperty
ensureProperty _ = maybe (return NoChange) catchPropellor . getSatisfy
-- The name of this was chosen to make type errors a bit more understandable.
-type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool
-type instance Cannot_ensureProperty_WithInfo '[] = 'True
-type instance Cannot_ensureProperty_WithInfo (t ': ts) =
- Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts
+type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool where
+ Cannot_ensureProperty_WithInfo '[] = 'True
+ Cannot_ensureProperty_WithInfo (t ': ts) =
+ Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts
-- | Constructs a property, like `property`, but provides its
-- `OuterMetaTypesWitness`.
diff --git a/src/Propellor/Git/VerifiedBranch.hs b/src/Propellor/Git/VerifiedBranch.hs
index df607bd2..61f5baa0 100644
--- a/src/Propellor/Git/VerifiedBranch.hs
+++ b/src/Propellor/Git/VerifiedBranch.hs
@@ -6,9 +6,8 @@ import Propellor.PrivData.Paths
import Utility.FileMode
{- To verify origin branch commit's signature, have to convince gpg
- - to use our keyring.
- - While running git log. Which has no way to pass options to gpg.
- - Argh!
+ - to use our keyring while running git verify-tag.
+ - Which has no way to pass options to gpg. Argh!
-}
verifyOriginBranch :: String -> IO Bool
verifyOriginBranch originbranch = do
@@ -20,12 +19,12 @@ verifyOriginBranch originbranch = do
]
-- gpg is picky about perms
modifyFileMode privDataDir (removeModes otherGroupModes)
- s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
+ verified <- boolSystemEnv "git" [Param "verify-commit", Param originbranch]
(Just [("GNUPGHOME", privDataDir)])
nukeFile $ privDataDir </> "trustdb.gpg"
nukeFile $ privDataDir </> "pubring.gpg"
nukeFile $ privDataDir </> "gpg.conf"
- return (s == "U\n" || s == "G\n")
+ return verified
-- Returns True if HEAD is changed by fetching and merging from origin.
fetchOrigin :: IO Bool
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 5d1d3afb..c60ced73 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -41,9 +41,9 @@ infixl 1 &
infixl 1 &^
infixl 1 !
-type family GetMetaTypes x
-type instance GetMetaTypes (Property (MetaTypes t)) = MetaTypes t
-type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t
+type family GetMetaTypes x where
+ GetMetaTypes (Property (MetaTypes t)) = MetaTypes t
+ GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t
-- | Adds a property to a Props.
--
diff --git a/src/Propellor/Property/Qemu.hs b/src/Propellor/Property/Qemu.hs
index f204a0e1..a6e7e849 100644
--- a/src/Propellor/Property/Qemu.hs
+++ b/src/Propellor/Property/Qemu.hs
@@ -5,6 +5,11 @@ import qualified Propellor.Property.Apt as Apt
-- | Installs qemu user mode emulation binaries, built statically,
-- which allow foreign binaries to run directly.
+--
+-- Note that this is not necessary after qemu 2.12~rc3+dfsg-1.
+-- See http://bugs.debian.org/868030
+-- It's currently always done to support older versions, but
+-- could be skipped with the newer version.
foreignBinariesEmulated :: RevertableProperty Linux Linux
foreignBinariesEmulated = (setup <!> cleanup)
`describe` "foreign binary emulation"
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index ceee7bf3..ff2fab79 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -920,6 +920,9 @@ homePower user hosts ctx sshkey = propertyList "home power" $ props
& Systemd.enabled setupservicename
`requires` setupserviceinstalled
`onChange` Systemd.started setupservicename
+ & Systemd.enabled watchdogservicename
+ `requires` watchdogserviceinstalled
+ `onChange` Systemd.started watchdogservicename
& Systemd.enabled pollerservicename
`requires` pollerserviceinstalled
`onChange` Systemd.started pollerservicename
@@ -991,6 +994,22 @@ homePower user hosts ctx sshkey = propertyList "home power" $ props
, "[Install]"
, "WantedBy=multi-user.target"
]
+ watchdogservicename = "homepower-watchdog"
+ watchdogservicefile = "/etc/systemd/system/" ++ watchdogservicename ++ ".service"
+ watchdogserviceinstalled = watchdogservicefile `File.hasContent`
+ [ "[Unit]"
+ , "Description=home power watchdog"
+ , ""
+ , "[Service]"
+ , "ExecStart=" ++ d ++ "/watchdog"
+ , "WorkingDirectory=" ++ d
+ , "User=root"
+ , "Group=root"
+ , "Restart=always"
+ , ""
+ , "[Install]"
+ , "WantedBy=multi-user.target"
+ ]
setupservicename = "homepower-setup"
setupservicefile = "/etc/systemd/system/" ++ setupservicename ++ ".service"
setupserviceinstalled = setupservicefile `File.hasContent`
@@ -1126,6 +1145,7 @@ laptopSoftware = Apt.installed
, "w3m", "sm", "weechat"
, "borgbackup", "wipe", "smartmontools", "libgfshare-bin"
, "units"
+ , "virtualbox", "qemu-kvm"
]
`requires` baseSoftware
`requires` devSoftware
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 7cbe9f13..e10e0f5b 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -154,13 +154,19 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where
-- | Type level calculation of the type that results from combining two
-- types of properties.
-type family CombinedType x y
-type instance CombinedType (Property (MetaTypes x)) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y))
-type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) = RevertableProperty (MetaTypes (Combine x y)) (MetaTypes (Combine x' y'))
--- When only one of the properties is revertable, the combined property is
--- not fully revertable, so is not a RevertableProperty.
-type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y))
-type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y))
+type family CombinedType x y where
+ CombinedType (Property (MetaTypes x)) (Property (MetaTypes y)) =
+ Property (MetaTypes (Combine x y))
+ CombinedType
+ (RevertableProperty (MetaTypes x) (MetaTypes x'))
+ (RevertableProperty (MetaTypes y) (MetaTypes y')) =
+ RevertableProperty (MetaTypes (Combine x y)) (MetaTypes (Combine x' y'))
+ -- When only one of the properties is revertable, the combined
+ -- property is not fully revertable, so is not a RevertableProperty.
+ CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) =
+ Property (MetaTypes (Combine x y))
+ CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) =
+ Property (MetaTypes (Combine x y))
type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (Propellor Result)
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index 4e4472eb..0c476e87 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -30,6 +30,8 @@ module Propellor.Types.MetaTypes (
import Propellor.Types.Singletons
import Propellor.Types.OS
+import Data.Type.Bool
+
data MetaType
= Targeting TargetOS -- ^ A target OS of a Property
| WithInfo -- ^ Indicates that a Property has associated Info
@@ -60,8 +62,8 @@ type ArchLinux = MetaTypes '[ 'Targeting 'OSArchLinux ]
-- | Used to indicate that a Property adds Info to the Host where it's used.
type HasInfo = MetaTypes '[ 'WithInfo ]
-type family IncludesInfo t :: Bool
-type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l
+type family IncludesInfo t :: Bool where
+ IncludesInfo (MetaTypes l) = Elem 'WithInfo l
type MetaTypes = Sing
@@ -95,21 +97,21 @@ instance SingKind ('KProxy :: KProxy MetaType) where
-- Which is shorthand for this type:
--
-- > MetaTypes '[WithInfo, Targeting OSDebian]
-type family a + b :: ab
-type instance (MetaTypes a) + (MetaTypes b) = MetaTypes (Concat a b)
+type family a + b :: * where
+ (MetaTypes a) + (MetaTypes b) = MetaTypes (Concat a b)
-type family Concat (list1 :: [a]) (list2 :: [a]) :: [a]
-type instance Concat '[] bs = bs
-type instance Concat (a ': as) bs = a ': (Concat as bs)
+type family Concat (list1 :: [a]) (list2 :: [a]) :: [a] where
+ Concat '[] bs = bs
+ Concat (a ': as) bs = a ': (Concat as bs)
-- | Combine two MetaTypes lists, yielding a list
-- that has targets present in both, and nontargets present in either.
-type family Combine (list1 :: [a]) (list2 :: [a]) :: [a]
-type instance Combine (list1 :: [a]) (list2 :: [a]) =
- (Concat
- (NonTargets list1 `Union` NonTargets list2)
- (Targets list1 `Intersect` Targets list2)
- )
+type family Combine (list1 :: [a]) (list2 :: [a]) :: [a] where
+ Combine (list1 :: [a]) (list2 :: [a]) =
+ (Concat
+ (NonTargets list1 `Union` NonTargets list2)
+ (Targets list1 `Intersect` Targets list2)
+ )
-- | Checks if two MetaTypes lists can be safely combined.
--
@@ -117,121 +119,76 @@ type instance Combine (list1 :: [a]) (list2 :: [a]) =
-- constraint. For example:
--
-- > foo :: (CheckCombinable x y ~ 'CanCombine) => x -> y -> Combine x y
-type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine
--- As a special case, if either list is empty, let it be combined with the
--- other. This relies on MetaTypes list always containing at least
--- one target, so can only happen if there's already been a type error.
--- This special case lets the type checker show only the original type
--- error, and not an extra error due to a later CheckCombinable constraint.
-type instance CheckCombinable '[] list2 = 'CanCombine
-type instance CheckCombinable list1 '[] = 'CanCombine
-type instance CheckCombinable (l1 ': list1) (l2 ': list2) =
- CheckCombinable' (Combine (l1 ': list1) (l2 ': list2))
-type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine
-type instance CheckCombinable' '[] = 'CannotCombineTargets
-type instance CheckCombinable' (a ': rest)
- = If (IsTarget a)
- 'CanCombine
- (CheckCombinable' rest)
+type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine where
+ -- As a special case, if either list is empty, let it be combined
+ -- with the other. This relies on MetaTypes list always containing
+ -- at least one target, so can only happen if there's already been
+ -- a type error. This special case lets the type checker show only
+ -- the original type error, and not an extra error due to a later
+ -- CheckCombinable constraint.
+ CheckCombinable '[] list2 = 'CanCombine
+ CheckCombinable list1 '[] = 'CanCombine
+ CheckCombinable (l1 ': list1) (l2 ': list2) =
+ CheckCombinable' (Combine (l1 ': list1) (l2 ': list2))
+type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine where
+ CheckCombinable' '[] = 'CannotCombineTargets
+ CheckCombinable' (a ': rest)
+ = If (IsTarget a)
+ 'CanCombine
+ (CheckCombinable' rest)
data CheckCombine = CannotCombineTargets | CanCombine
-- | Every item in the subset must be in the superset.
--
-- The name of this was chosen to make type errors more understandable.
-type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombine
-type instance NotSuperset superset '[] = 'CanCombine
-type instance NotSuperset superset (s ': rest) =
- If (Elem s superset)
- (NotSuperset superset rest)
- 'CannotCombineTargets
-
-type family IsTarget (a :: t) :: Bool
-type instance IsTarget ('Targeting a) = 'True
-type instance IsTarget 'WithInfo = 'False
-
-type family Targets (l :: [a]) :: [a]
-type instance Targets '[] = '[]
-type instance Targets (x ': xs) =
- If (IsTarget x)
- (x ': Targets xs)
- (Targets xs)
-
-type family NonTargets (l :: [a]) :: [a]
-type instance NonTargets '[] = '[]
-type instance NonTargets (x ': xs) =
- If (IsTarget x)
- (NonTargets xs)
- (x ': NonTargets xs)
+type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombine where
+ NotSuperset superset '[] = 'CanCombine
+ NotSuperset superset (s ': rest) =
+ If (Elem s superset)
+ (NotSuperset superset rest)
+ 'CannotCombineTargets
+
+type family IsTarget (a :: t) :: Bool where
+ IsTarget ('Targeting a) = 'True
+ IsTarget 'WithInfo = 'False
+
+type family Targets (l :: [a]) :: [a] where
+ Targets '[] = '[]
+ Targets (x ': xs) =
+ If (IsTarget x)
+ (x ': Targets xs)
+ (Targets xs)
+
+type family NonTargets (l :: [a]) :: [a] where
+ NonTargets '[] = '[]
+ NonTargets (x ': xs) =
+ If (IsTarget x)
+ (NonTargets xs)
+ (x ': NonTargets xs)
-- | Type level elem
-type family Elem (a :: t) (list :: [t]) :: Bool
-type instance Elem a '[] = 'False
-type instance Elem a (b ': bs) = EqT a b || Elem a bs
+type family Elem (a :: t) (list :: [t]) :: Bool where
+ Elem a '[] = 'False
+ Elem a (b ': bs) = EqT a b || Elem a bs
-- | Type level union.
-type family Union (list1 :: [a]) (list2 :: [a]) :: [a]
-type instance Union '[] list2 = list2
-type instance Union (a ': rest) list2 =
- If (Elem a list2 || Elem a rest)
- (Union rest list2)
- (a ': Union rest list2)
+type family Union (list1 :: [a]) (list2 :: [a]) :: [a] where
+ Union '[] list2 = list2
+ Union (a ': rest) list2 =
+ If (Elem a list2 || Elem a rest)
+ (Union rest list2)
+ (a ': Union rest list2)
-- | Type level intersection. Duplicate list items are eliminated.
-type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a]
-type instance Intersect '[] list2 = '[]
-type instance Intersect (a ': rest) list2 =
- If (Elem a list2 && Not (Elem a rest))
- (a ': Intersect rest list2)
- (Intersect rest list2)
-
--- | Type level equality
---
--- This is a very clumsy implmentation, but it works back to ghc 7.6.
-type family EqT (a :: t) (b :: t) :: Bool
-type instance EqT ('Targeting a) ('Targeting b) = EqT a b
-type instance EqT 'WithInfo 'WithInfo = 'True
-type instance EqT 'WithInfo ('Targeting b) = 'False
-type instance EqT ('Targeting a) 'WithInfo = 'False
-type instance EqT 'OSDebian 'OSDebian = 'True
-type instance EqT 'OSBuntish 'OSBuntish = 'True
-type instance EqT 'OSFreeBSD 'OSFreeBSD = 'True
-type instance EqT 'OSDebian 'OSBuntish = 'False
-type instance EqT 'OSDebian 'OSFreeBSD = 'False
-type instance EqT 'OSBuntish 'OSDebian = 'False
-type instance EqT 'OSBuntish 'OSFreeBSD = 'False
-type instance EqT 'OSFreeBSD 'OSDebian = 'False
-type instance EqT 'OSFreeBSD 'OSBuntish = 'False
-type instance EqT 'OSArchLinux 'OSArchLinux = 'True
-type instance EqT 'OSArchLinux 'OSDebian = 'False
-type instance EqT 'OSArchLinux 'OSBuntish = 'False
-type instance EqT 'OSArchLinux 'OSFreeBSD = 'False
-type instance EqT 'OSDebian 'OSArchLinux = 'False
-type instance EqT 'OSBuntish 'OSArchLinux = 'False
-type instance EqT 'OSFreeBSD 'OSArchLinux = 'False
-
--- More modern version if the combinatiorial explosion gets too bad later:
---
--- type family Eq (a :: MetaType) (b :: MetaType) where
--- Eq a a = True
--- Eq a b = False
-
--- | An equivilant to the following is in Data.Type.Bool in
--- modern versions of ghc, but is included here to support ghc 7.6.
-type family If (cond :: Bool) (tru :: a) (fls :: a) :: a
-type instance If 'True tru fls = tru
-type instance If 'False tru fls = fls
-type family (a :: Bool) || (b :: Bool) :: Bool
-type instance 'False || 'False = 'False
-type instance 'True || 'True = 'True
-type instance 'True || 'False = 'True
-type instance 'False || 'True = 'True
-type family (a :: Bool) && (b :: Bool) :: Bool
-type instance 'False && 'False = 'False
-type instance 'True && 'True = 'True
-type instance 'True && 'False = 'False
-type instance 'False && 'True = 'False
-type family Not (a :: Bool) :: Bool
-type instance Not 'False = 'True
-type instance Not 'True = 'False
-
+type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a] where
+ Intersect '[] list2 = '[]
+ Intersect (a ': rest) list2 =
+ If (Elem a list2 && Not (Elem a rest))
+ (a ': Intersect rest list2)
+ (Intersect rest list2)
+
+-- | Type level equality of metatypes.
+type family EqT (a :: MetaType) (b :: MetaType) where
+ EqT a a = 'True
+ EqT a b = 'False