summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-01-25 15:16:58 -0400
committerJoey Hess2015-01-25 15:16:58 -0400
commit401b857eef13ca7d3f7b8f6b88e9237884fcd906 (patch)
treeeb4b5c189349b5a86b3b39edbe039956d3a1a3b8
parent1df70ba81ddfbd4ceeb5344793f7714a35706c8f (diff)
parentcdd88b080af534231aae8a64ef327f0597a5b5b3 (diff)
Merge branch 'joeyconfig'
Conflicts: doc/todo/info_propigation_out_of_nested_properties.mdwn privdata.joey/privdata.gpg
-rw-r--r--config-joey.hs62
-rw-r--r--debian/changelog28
-rw-r--r--debian/control2
-rw-r--r--doc/todo/RevertableProperty_with_NoInfo.mdwn29
-rw-r--r--doc/todo/info_propigation_out_of_nested_properties.mdwn2
-rw-r--r--propellor.cabal9
-rw-r--r--src/Propellor.hs8
-rw-r--r--src/Propellor/CmdLine.hs1
-rw-r--r--src/Propellor/Engine.hs13
-rw-r--r--src/Propellor/Host.hs64
-rw-r--r--src/Propellor/Info.hs15
-rw-r--r--src/Propellor/PrivData.hs93
-rw-r--r--src/Propellor/PropAccum.hs92
-rw-r--r--src/Propellor/Property.hs105
-rw-r--r--src/Propellor/Property/Apache.hs14
-rw-r--r--src/Propellor/Property/Apt.hs75
-rw-r--r--src/Propellor/Property/Chroot.hs30
-rw-r--r--src/Propellor/Property/Cmd.hs8
-rw-r--r--src/Propellor/Property/Cron.hs6
-rw-r--r--src/Propellor/Property/Debootstrap.hs52
-rw-r--r--src/Propellor/Property/Dns.hs31
-rw-r--r--src/Propellor/Property/DnsSec.hs14
-rw-r--r--src/Propellor/Property/Docker.hs75
-rw-r--r--src/Propellor/Property/File.hs30
-rw-r--r--src/Propellor/Property/Firewall.hs5
-rw-r--r--src/Propellor/Property/Git.hs8
-rw-r--r--src/Propellor/Property/Gpg.hs4
-rw-r--r--src/Propellor/Property/Group.hs2
-rw-r--r--src/Propellor/Property/Grub.hs10
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs2
-rw-r--r--src/Propellor/Property/HostingProvider/DigitalOcean.hs2
-rw-r--r--src/Propellor/Property/HostingProvider/Linode.hs2
-rw-r--r--src/Propellor/Property/Hostname.hs6
-rw-r--r--src/Propellor/Property/Journald.hs53
-rw-r--r--src/Propellor/Property/List.hs63
-rw-r--r--src/Propellor/Property/Network.hs105
-rw-r--r--src/Propellor/Property/Nginx.hs10
-rw-r--r--src/Propellor/Property/OS.hs29
-rw-r--r--src/Propellor/Property/Obnam.hs14
-rw-r--r--src/Propellor/Property/OpenId.hs4
-rw-r--r--src/Propellor/Property/Postfix.hs26
-rw-r--r--src/Propellor/Property/Prosody.hs10
-rw-r--r--src/Propellor/Property/Reboot.hs4
-rw-r--r--src/Propellor/Property/Scheduled.hs8
-rw-r--r--src/Propellor/Property/Service.hs8
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs66
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs451
-rw-r--r--src/Propellor/Property/Ssh.hs38
-rw-r--r--src/Propellor/Property/Sudo.hs2
-rw-r--r--src/Propellor/Property/Systemd.hs83
-rw-r--r--src/Propellor/Property/Systemd/Core.hs2
-rw-r--r--src/Propellor/Property/Tor.hs12
-rw-r--r--src/Propellor/Property/User.hs18
-rw-r--r--src/Propellor/Spin.hs1
-rw-r--r--src/Propellor/Types.hs348
-rw-r--r--src/Propellor/Types/CmdLine.hs27
-rw-r--r--src/Propellor/Types/PrivData.hs4
-rw-r--r--src/Propellor/Types/Result.hs37
-rw-r--r--src/Propellor/Types/Val.hs22
-rw-r--r--src/Utility/DataUnits.hs161
-rw-r--r--src/Utility/HumanNumber.hs21
-rw-r--r--src/Utility/Table.hs13
63 files changed, 1634 insertions, 907 deletions
diff --git a/config-joey.hs b/config-joey.hs
index 705ad0f6..1f8a021e 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -25,6 +25,7 @@ import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Systemd as Systemd
+import qualified Propellor.Property.Journald as Journald
import qualified Propellor.Property.OS as OS
import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
@@ -46,7 +47,6 @@ hosts = -- (o) `
, kite
, diatom
, elephant
- , testvm
] ++ monsters
testvm :: Host
@@ -140,11 +140,13 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
, (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3")
]
+ & Network.static "eth0" `requires` Network.cleanInterfacesFile
& Apt.installed ["linux-image-amd64"]
& Linode.chainPVGrub 5
& Apt.unattendedUpgrades
& Systemd.installed
& Systemd.persistentJournal
+ & Journald.systemMaxUse "500MiB"
& Ssh.passwordAuthentication True
-- Since ssh password authentication is allowed:
& Apt.serviceInstalledRunning "fail2ban"
@@ -254,7 +256,7 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64"
& JoeySites.oldUseNetServer hosts
& alias "ns2.kitenet.net"
- & myDnsPrimary False "kitenet.net" []
+ & myDnsPrimary True "kitenet.net" []
& myDnsPrimary True "joeyh.name" []
& myDnsPrimary True "ikiwiki.info" []
& myDnsPrimary True "olduse.net"
@@ -327,13 +329,14 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& Ssh.listenPort 80
- --' __|II| ,.
- ---- __|II|II|__ ( \_,/\
- ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-
- ----------------------- | [Docker] / ----------------------
- ----------------------- : / -----------------------
- ------------------------ \____, o ,' ------------------------
- ------------------------- '--,___________,' -------------------------
+ --' __|II| ,.
+ ---- __|II|II|__ ( \_,/\
+--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'-
+-------------------------- | [Docker] / --------------------------
+-------------------------- : / ---------------------------
+--------------------------- \____, o ,' ----------------------------
+---------------------------- '--,___________,' -----------------------------
+
-- Simple web server, publishing the outside host's /var/www
webserver :: Docker.Container
webserver = standardStableContainer "webserver"
@@ -434,13 +437,12 @@ dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch
dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch
dockerImage _ = "debian-stable-official" -- does not currently exist!
-myDnsSecondary :: Property
-myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp
- [ Dns.secondary hosts "kitenet.net"
- , Dns.secondary hosts "joeyh.name"
- , Dns.secondary hosts "ikiwiki.info"
- , Dns.secondary hosts "olduse.net"
- ]
+myDnsSecondary :: Property HasInfo
+myDnsSecondary = propertyList "dns secondary for all my domains" $ props
+ & Dns.secondary hosts "kitenet.net"
+ & Dns.secondary hosts "joeyh.name"
+ & Dns.secondary hosts "ikiwiki.info"
+ & Dns.secondary hosts "olduse.net"
branchableSecondary :: RevertableProperty
branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"
@@ -456,23 +458,11 @@ myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly No
, (RootDomain, NS $ AbsDomain "ns4.kitenet.net")
, (RootDomain, NS $ AbsDomain "ns6.gandi.net")
, (RootDomain, MX 0 $ AbsDomain "kitenet.net")
- -- SPF only allows IP address of kitenet.net to send mail.
- , (RootDomain, TXT "v=spf1 a:kitenet.net -all")
+ , (RootDomain, TXT "v=spf1 a a:kitenet.net ~all")
, JoeySites.domainKey
] ++ extras
- -- o
- -- ___ o o
- {-----\ / o \ ___o o
- { \ __ \ / _ (X___>-- __o
- _____________________{ ______\___ \__/ | \__/ \____ |X__>
- < \___//|\\___/\ \____________ _
- \ ___/ | \___ # # \ (-)
- \ O O O # | \ # >=)
- \______________________________# # / #__________________/ (-}
-
-
monsters :: [Host] -- Systems I don't manage with propellor,
monsters = -- but do want to track their public keys etc.
[ host "usw-s002.rsync.net"
@@ -508,3 +498,17 @@ monsters = -- but do want to track their public keys etc.
& ipv4 "76.7.162.101"
& ipv4 "76.7.162.186"
]
+
+
+
+ -- o
+ -- ___ o o
+ {-----\ / o \ ___o o
+ { \ __ \ / _ (X___>-- __o
+ _____________________{ ______\___ \__/ | \__/ \____ |X__>
+ < \___//|\\___/\ \____________ _
+ \ ___/ | \___ # # \ (-)
+ \ O O O # | \ # >=)
+ \______________________________# # / #__________________/ (-}
+
+
diff --git a/debian/changelog b/debian/changelog
index 44335711..abf6bd16 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,31 @@
+propellor (2.0.0) UNRELEASED; urgency=medium
+
+ * Property has been converted to a GADT, and will be Property NoInfo
+ or Property HasInfo.
+ This was done to make sure that ensureProperty is only used on
+ properties that do not have Info.
+ Transition guide:
+ - Change all "Property" to "Property NoInfo" or "Property WithInfo"
+ (The compiler can tell you if you got it wrong!)
+ - To construct a RevertableProperty, it is useful to use the new
+ (<!>) operator
+ - Constructing a list of properties can be problimatic, since
+ Property NoInto and Property WithInfo are different types and cannot
+ appear in the same list. To deal with this, "props" has been added,
+ and can built up a list of properties of different types,
+ using the same (&) and (!) operators that are used to build
+ up a host's properties.
+ * Add descriptions of how to set missing fields to --list-fields output.
+ * Properties now form a tree, instead of the flat list used before.
+ This includes the properties used inside a container.
+ * Fix info propigation from fallback combinator's second Property.
+ * Added systemd configuration properties.
+ * Added journald configuration properties.
+ * Added more network interface configuration properties.
+ * Implemented OS.preserveNetwork.
+
+ -- Joey Hess <id@joeyh.name> Thu, 15 Jan 2015 20:14:29 -0400
+
propellor (1.3.2) unstable; urgency=medium
* SSHFP records are also generated for CNAMES of hosts.
diff --git a/debian/control b/debian/control
index 24ff39cb..a9b6c2ce 100644
--- a/debian/control
+++ b/debian/control
@@ -18,7 +18,7 @@ Build-Depends:
libghc-monadcatchio-transformers-dev,
Maintainer: Gergely Nagy <algernon@madhouse-project.org>
Standards-Version: 3.9.6
-Vcs-Git: git://git.kitenet.net/propellor
+Vcs-Git: git://git.joeyh.name/propellor
Homepage: http://propellor.branchable.com/
Package: propellor
diff --git a/doc/todo/RevertableProperty_with_NoInfo.mdwn b/doc/todo/RevertableProperty_with_NoInfo.mdwn
new file mode 100644
index 00000000..e9c1eb5d
--- /dev/null
+++ b/doc/todo/RevertableProperty_with_NoInfo.mdwn
@@ -0,0 +1,29 @@
+Currently, a RevertableProperty's Properties always both HasInfo. This
+means that if a Property NoInfo is updated to be a RevertableProperty, and
+someplace called ensureProperty on it, that will refuse to compile.
+
+The workaround is generally to export the original NoInfo property under
+a different name, so it can still be used with ensureProperty.
+
+This could be fixed:
+
+ data RevertableProperty i1 i2 where
+ RProp :: Property i1 -> Property i2 -> RevertableProperty i1 i2
+
+However, needing to write "RevertableProperty HasInfo NoInfo" is quite
+a mouthful!
+
+Since only 2 places in the propellor source code currently need to deal
+with this, it doesn't currently seem worth making the change, unless a less
+intrusive way can be found.
+
+Probably related would be to make RevertableProperty a constructor in the
+Property GADT, which would allow more property combinators to work on
+RevertableProperties. That would look like:
+
+ data Propety i where
+ ...
+ RProp :: Property i1 -> Property i2 -> Property (CInfo i1 i2)
+
+In this case, there's only one Info/NoInfo encompassing both sides, and
+so ensureProperty could only be used on it if both sides were NoInfo.
diff --git a/doc/todo/info_propigation_out_of_nested_properties.mdwn b/doc/todo/info_propigation_out_of_nested_properties.mdwn
index 33ac1424..536d6719 100644
--- a/doc/todo/info_propigation_out_of_nested_properties.mdwn
+++ b/doc/todo/info_propigation_out_of_nested_properties.mdwn
@@ -1,3 +1,5 @@
+> Now [[fixed|done]]!! --[[Joey]]
+
Currently, Info about a Host's Properties is propigated to the host by
examining the tree of Properties.
diff --git a/propellor.cabal b/propellor.cabal
index 982df527..523cf19f 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -85,6 +85,7 @@ Library
Propellor.Property.Gpg
Propellor.Property.Group
Propellor.Property.Grub
+ Propellor.Property.Journald
Propellor.Property.Mount
Propellor.Property.Network
Propellor.Property.Nginx
@@ -94,6 +95,7 @@ Library
Propellor.Property.Postfix
Propellor.Property.Prosody
Propellor.Property.Reboot
+ Propellor.Property.List
Propellor.Property.Scheduled
Propellor.Property.Service
Propellor.Property.Ssh
@@ -108,7 +110,7 @@ Library
Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder
- Propellor.Host
+ Propellor.PropAccum
Propellor.CmdLine
Propellor.Info
Propellor.Message
@@ -122,6 +124,9 @@ Library
Propellor.Types.Empty
Propellor.Types.OS
Propellor.Types.PrivData
+ Propellor.Types.Val
+ Propellor.Types.Result
+ Propellor.Types.CmdLine
Other-Modules:
Propellor.Git
Propellor.Gpg
@@ -133,11 +138,13 @@ Library
Propellor.Property.Chroot.Util
Utility.Applicative
Utility.Data
+ Utility.DataUnits
Utility.Directory
Utility.Env
Utility.Exception
Utility.FileMode
Utility.FileSystemEncoding
+ Utility.HumanNumber
Utility.LinuxMkLibs
Utility.Misc
Utility.Monad
diff --git a/src/Propellor.hs b/src/Propellor.hs
index 0e34e988..51079ed0 100644
--- a/src/Propellor.hs
+++ b/src/Propellor.hs
@@ -27,13 +27,14 @@
--
-- See config.hs for a more complete example, and clone Propellor's
-- git repository for a deployable system using Propellor:
--- git clone <git://git.kitenet.net/propellor>
+-- git clone <git://git.joeyh.name/propellor>
module Propellor (
module Propellor.Types
, module Propellor.Property
+ , module Propellor.Property.List
, module Propellor.Property.Cmd
- , module Propellor.Host
+ , module Propellor.PropAccum
, module Propellor.Info
, module Propellor.PrivData
, module Propellor.Types.PrivData
@@ -48,13 +49,14 @@ module Propellor (
import Propellor.Types
import Propellor.Property
import Propellor.Engine
+import Propellor.Property.List
import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Types.PrivData
import Propellor.Message
import Propellor.Exception
import Propellor.Info
-import Propellor.Host
+import Propellor.PropAccum
import Utility.PartialPrelude as X
import Utility.Process as X
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 378367e8..15dc09c3 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -13,6 +13,7 @@ import Propellor
import Propellor.Gpg
import Propellor.Git
import Propellor.Spin
+import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 667f6bfb..99f1660d 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GADTs #-}
module Propellor.Engine (
mainProperties,
@@ -35,7 +36,7 @@ import Utility.Monad
mainProperties :: Host -> IO ()
mainProperties host = do
ret <- runPropellor host $
- ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
+ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
h <- mkMessageHandle
whenConsole h $
setTitle "propellor: done"
@@ -43,6 +44,8 @@ mainProperties host = do
case ret of
FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess
+ where
+ ps = map ignoreInfo $ hostProperties host
-- | Runs a Propellor action with the specified host.
--
@@ -62,11 +65,13 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
-- | For when code running in the Propellor monad needs to ensure a
-- Property.
-ensureProperty :: Property -> Propellor Result
+--
+-- This can only be used on a Property that has NoInfo.
+ensureProperty :: Property NoInfo -> Propellor Result
ensureProperty = catchPropellor . propertySatisfy
-- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property] -> Propellor Result
+ensureProperties :: [Property NoInfo] -> Propellor Result
ensureProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
@@ -77,7 +82,7 @@ ensureProperties ps = ensure ps NoChange
-- | Lifts an action into a different host.
--
--- For example, `fromHost hosts "otherhost" getPubKey`
+-- > fromHost hosts "otherhost" getPubKey
fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
fromHost l hn getter = case findHost l hn of
Nothing -> return Nothing
diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs
deleted file mode 100644
index 14d56e20..00000000
--- a/src/Propellor/Host.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Host where
-
-import Data.Monoid
-import qualified Data.Set as S
-
-import Propellor.Types
-import Propellor.Info
-import Propellor.Property
-import Propellor.PrivData
-
--- | Starts accumulating the properties of a Host.
---
--- > host "example.com"
--- > & someproperty
--- > ! oldproperty
--- > & otherproperty
-host :: HostName -> Host
-host hn = Host hn [] mempty
-
--- | Something that can accumulate properties.
-class Hostlike h where
- -- | Adds a property.
- --
- -- Can add Properties and RevertableProperties
- (&) :: IsProp p => h -> p -> h
-
- -- | Like (&), but adds the property as the
- -- first property of the host. Normally, property
- -- order should not matter, but this is useful
- -- when it does.
- (&^) :: IsProp p => h -> p -> h
-
- getHost :: h -> Host
-
-instance Hostlike Host where
- (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
- (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
- getHost h = h
-
--- | Adds a property in reverted form.
-(!) :: Hostlike h => h -> RevertableProperty -> h
-h ! p = h & revert p
-
-infixl 1 &^
-infixl 1 &
-infixl 1 !
-
--- | When eg, docking a container, some of the Info about the container
--- should propigate out to the Host it's on. This includes DNS info,
--- so that eg, aliases of the container are reflected in the dns for the
--- host where it runs.
---
--- This adjusts the Property that docks a container, to include such info
--- from the container.
-propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property
-propigateInfo hl p f = combineProperties (propertyDesc p) $
- p' : dnsprops ++ privprops
- where
- p' = p { propertyInfo = f (propertyInfo p) }
- i = hostInfo (getHost hl)
- dnsprops = map addDNS (S.toList $ _dns i)
- privprops = map addPrivDataField (S.toList $ _privDataFields i)
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index ccb27cf3..f1f23b96 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -3,6 +3,7 @@
module Propellor.Info where
import Propellor.Types
+import Propellor.Types.Val
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
@@ -11,13 +12,13 @@ import Data.Maybe
import Data.Monoid
import Control.Applicative
-pureInfoProperty :: Desc -> Info -> Property
-pureInfoProperty desc = Property ("has " ++ desc) (return NoChange)
+pureInfoProperty :: Desc -> Info -> Property HasInfo
+pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
askInfo :: (Info -> Val a) -> Propellor (Maybe a)
askInfo f = asks (fromVal . f . hostInfo)
-os :: System -> Property
+os :: System -> Property HasInfo
os system = pureInfoProperty ("Operating " ++ show system) $
mempty { _os = Val system }
@@ -33,11 +34,11 @@ getOS = askInfo _os
-- When propellor --spin is used to deploy a host, it checks
-- if the host's IP Property matches the DNS. If the DNS is missing or
-- out of date, the host will instead be contacted directly by IP address.
-ipv4 :: String -> Property
+ipv4 :: String -> Property HasInfo
ipv4 = addDNS . Address . IPv4
-- | Indidate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property
+ipv6 :: String -> Property HasInfo
ipv6 = addDNS . Address . IPv6
-- | Indicates another name for the host in the DNS.
@@ -46,7 +47,7 @@ ipv6 = addDNS . Address . IPv6
-- to use their address, rather than using a CNAME. This avoids various
-- problems with CNAMEs, and also means that when multiple hosts have the
-- same alias, a DNS round-robin is automatically set up.
-alias :: Domain -> Property
+alias :: Domain -> Property HasInfo
alias d = pureInfoProperty ("alias " ++ d) $ mempty
{ _aliases = S.singleton d
-- A CNAME is added here, but the DNS setup code converts it to an
@@ -54,7 +55,7 @@ alias d = pureInfoProperty ("alias " ++ d) $ mempty
, _dns = S.singleton $ CNAME $ AbsDomain d
}
-addDNS :: Record -> Property
+addDNS :: Record -> Property HasInfo
addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
where
rdesc (CNAME d) = unwords ["alias", ddesc d]
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 6643d81d..71aa820d 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -1,6 +1,19 @@
{-# LANGUAGE PackageImports #-}
-
-module Propellor.PrivData where
+{-# LANGUAGE FlexibleContexts #-}
+
+module Propellor.PrivData (
+ withPrivData,
+ withSomePrivData,
+ addPrivData,
+ setPrivData,
+ dumpPrivData,
+ editPrivData,
+ filterPrivData,
+ listPrivDataFields,
+ makePrivDataDir,
+ decryptPrivData,
+ PrivMap,
+) where
import Control.Applicative
import System.IO
@@ -48,29 +61,29 @@ import Utility.Table
-- being used, which is necessary to ensure that the privdata is sent to
-- the remote host by propellor.
withPrivData
- :: (IsContext c, IsPrivDataSource s)
+ :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> s
-> c
- -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property)
- -> Property
+ -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)
+ -> Property HasInfo
withPrivData s = withPrivData' snd [s]
-- Like withPrivData, but here any one of a list of PrivDataFields can be used.
withSomePrivData
- :: (IsContext c, IsPrivDataSource s)
+ :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> [s]
-> c
- -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property)
- -> Property
+ -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)
+ -> Property HasInfo
withSomePrivData = withPrivData' id
withPrivData'
- :: (IsContext c, IsPrivDataSource s)
+ :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> ((PrivDataField, PrivData) -> v)
-> [s]
-> c
- -> (((v -> Propellor Result) -> Propellor Result) -> Property)
- -> Property
+ -> (((v -> Propellor Result) -> Propellor Result) -> Property i)
+ -> Property HasInfo
withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
maybe missing (a . feed) =<< getM get fieldlist
where
@@ -82,20 +95,28 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
Context cname <- mkHostContext hc <$> asks hostName
warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")"
liftIO $ putStrLn $ "Fix this by running:"
- liftIO $ forM_ srclist $ \src -> do
- putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "' \\"
- maybe noop (\d -> putStrLn $ " " ++ d) (describePrivDataSource src)
- putStrLn ""
+ liftIO $ showSet $
+ map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
return FailedChange
- addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = fieldset } }
+ addinfo p = infoProperty
+ (propertyDesc p)
+ (propertySatisfy p)
+ (propertyInfo p <> mempty { _privData = privset })
+ (propertyChildren p)
+ privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
fieldnames = map show fieldlist
- fieldset = S.fromList $ zip fieldlist (repeat hc)
fieldlist = map privDataField srclist
hc = asHostContext c
-addPrivDataField :: (PrivDataField, HostContext) -> Property
-addPrivDataField v = pureInfoProperty (show v) $
- mempty { _privDataFields = S.singleton v }
+showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO ()
+showSet l = forM_ l $ \(f, Context c, md) -> do
+ putStrLn $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"
+ maybe noop (\d -> putStrLn $ " " ++ d) md
+ putStrLn ""
+
+addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
+addPrivData v = pureInfoProperty (show v) $
+ mempty { _privData = S.singleton v }
{- Gets the requested field's value, in the specified context if it's
- available, from the host's local privdata cache. -}
@@ -107,12 +128,12 @@ getLocalPrivData field context =
type PrivMap = M.Map (PrivDataField, Context) PrivData
-{- Get only the set of PrivData that the Host's Info says it uses. -}
+-- | Get only the set of PrivData that the Host's Info says it uses.
filterPrivData :: Host -> PrivMap -> PrivMap
filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
where
- used = S.map (\(f, c) -> (f, mkHostContext c (hostName host))) $
- _privDataFields $ hostInfo host
+ used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
+ _privData $ hostInfo host
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
getPrivData field context = M.lookup (field, context)
@@ -142,10 +163,17 @@ editPrivData field context = do
listPrivDataFields :: [Host] -> IO ()
listPrivDataFields hosts = do
m <- decryptPrivData
- showtable "Currently set data:" $
- map mkrow (M.keys m)
- showtable "Data that would be used if set:" $
- map mkrow (M.keys $ M.difference wantedmap m)
+
+ section "Currently set data:"
+ showtable $ map mkrow (M.keys m)
+ let missing = M.keys $ M.difference wantedmap m
+
+ unless (null missing) $ do
+ section "Missing data that would be used if set:"
+ showtable $ map mkrow missing
+
+ section "How to set missing data:"
+ showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
where
header = ["Field", "Context", "Used by"]
mkrow k@(field, (Context context)) =
@@ -153,12 +181,13 @@ listPrivDataFields hosts = do
, shellEscape context
, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
]
- mkhostmap host = M.fromList $ map (\(f, c) -> ((f, mkHostContext c (hostName host)), [hostName host])) $
- S.toList $ _privDataFields $ hostInfo host
- usedby = M.unionsWith (++) $ map mkhostmap hosts
+ mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $
+ S.toList $ _privData $ hostInfo host
+ usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts
wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")
- showtable desc rows = do
- putStrLn $ "\n" ++ desc
+ descmap = M.unions $ map (\h -> mkhostmap h id) hosts
+ section desc = putStrLn $ "\n" ++ desc
+ showtable rows = do
putStr $ unlines $ formatTable $ tableWithHeader header rows
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
new file mode 100644
index 00000000..139f1471
--- /dev/null
+++ b/src/Propellor/PropAccum.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.PropAccum where
+
+import Data.Monoid
+
+import Propellor.Types
+import Propellor.Property
+
+-- | Starts accumulating the properties of a Host.
+--
+-- > host "example.com"
+-- > & someproperty
+-- > ! oldproperty
+-- > & otherproperty
+host :: HostName -> Host
+host hn = Host hn [] mempty
+
+-- | Starts accumulating a list of properties.
+--
+-- > propertyList "foo" $ props
+-- > & someproperty
+-- > ! oldproperty
+-- > & otherproperty
+props :: PropList
+props = PropList []
+
+-- | Something that can accumulate properties.
+class PropAccum h where
+ -- | Adds a property.
+ --
+ -- Can add Properties and RevertableProperties
+ (&) :: IsProp p => h -> p -> h
+
+ -- | Like (&), but adds the property at the front of the list.
+ (&^) :: IsProp p => h -> p -> h
+
+ getProperties :: h -> [Property HasInfo]
+
+instance PropAccum Host where
+ (Host hn ps is) & p = Host hn (ps ++ [toProp p])
+ (is <> getInfoRecursive p)
+ (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps)
+ (getInfoRecursive p <> is)
+ getProperties = hostProperties
+
+data PropList = PropList [Property HasInfo]
+
+instance PropAccum PropList where
+ PropList l & p = PropList (l ++ [toProp p])
+ PropList l &^ p = PropList ([toProp p] ++ l)
+ getProperties (PropList l) = l
+
+-- | Adds a property in reverted form.
+(!) :: PropAccum h => h -> RevertableProperty -> h
+h ! p = h & revert p
+
+infixl 1 &^
+infixl 1 &
+infixl 1 !
+
+-- | Adjust the provided Property, adding to its
+-- propertyChidren the properties of the provided container.
+--
+-- The Info of the propertyChildren is adjusted to only include
+-- info that should be propigated out to the Property.
+--
+-- DNS Info is propigated, so that eg, aliases of a PropAccum
+-- are reflected in the dns for the host where it runs.
+--
+-- PrivData Info is propigated, so that properties used inside a
+-- PropAccum will have the necessary PrivData available.
+propigateContainer
+ :: (PropAccum container)
+ => container
+ -> Property HasInfo
+ -> Property HasInfo
+propigateContainer c prop = infoProperty
+ (propertyDesc prop)
+ (propertySatisfy prop)
+ (propertyInfo prop)
+ (propertyChildren prop ++ hostprops)
+ where
+ hostprops = map go $ getProperties c
+ go p =
+ let i = propertyInfo p
+ i' = mempty
+ { _dns = _dns i
+ , _privData = _privData i
+ }
+ cs = map go (propertyChildren p)
+ in infoProperty (propertyDesc p) (propertySatisfy p) i' cs
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index c0878fb6..1801902e 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property where
@@ -11,47 +12,21 @@ import "mtl" Control.Monad.RWS.Strict
import Propellor.Types
import Propellor.Info
-import Propellor.Engine
import Utility.Monad
--- Constructs a Property.
-property :: Desc -> Propellor Result -> Property
-property d s = Property d s mempty
-
--- | Combines a list of properties, resulting in a single property
--- that when run will run each property in the list in turn,
--- and print out the description of each as it's run. Does not stop
--- on failure; does propigate overall success/failure.
-propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps)
-
--- | Combines a list of properties, resulting in one property that
--- ensures each in turn. Stops if a property fails.
-combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps)
- where
- go [] rs = return rs
- go (l:ls) rs = do
- r <- ensureProperty l
- case r of
- FailedChange -> return FailedChange
- _ -> go ls (r <> rs)
-
--- | Combines together two properties, resulting in one property
--- that ensures the first, and if the first succeeds, ensures the second.
--- The property uses the description of the first property.
-before :: Property -> Property -> Property
-p1 `before` p2 = p2 `requires` p1
- `describe` (propertyDesc p1)
+-- | Constructs a Property, from a description and an action to run to
+-- ensure the Property is met.
+property :: Desc -> Propellor Result -> Property NoInfo
+property d s = simpleProperty d s mempty
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
-flagFile :: Property -> FilePath -> Property
+flagFile :: Property i -> FilePath -> Property i
flagFile p = flagFile' p . return
-flagFile' :: Property -> IO FilePath -> Property
-flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
+flagFile' :: Property i -> IO FilePath -> Property i
+flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
flagfile <- liftIO getflagfile
go satisfy flagfile =<< liftIO (doesFileExist flagfile)
where
@@ -64,37 +39,40 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
writeFile flagfile ""
return r
---- | Whenever a change has to be made for a Property, causes a hook
+-- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
-onChange :: Property -> Property -> Property
-p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook)
- where
- satisfy = do
- r <- ensureProperty p
- case r of
- MadeChange -> do
- r' <- ensureProperty hook
- return $ r <> r'
- _ -> return r
-
-(==>) :: Desc -> Property -> Property
+onChange
+ :: (Combines (Property x) (Property y))
+ => Property x
+ -> Property y
+ -> CombinedType (Property x) (Property y)
+onChange = combineWith $ \p hook -> do
+ r <- p
+ case r of
+ MadeChange -> do
+ r' <- hook
+ return $ r <> r'
+ _ -> return r
+
+-- | Alias for @flip describe@
+(==>) :: IsProp (Property i) => Desc -> Property i -> Property i
(==>) = flip describe
infixl 1 ==>
-- | Makes a Property only need to do anything when a test succeeds.
-check :: IO Bool -> Property -> Property
-check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
+check :: IO Bool -> Property i -> Property i
+check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c)
( satisfy
, return NoChange
)
-- | Tries the first property, but if it fails to work, instead uses
-- the second.
-fallback :: Property -> Property -> Property
-fallback p1 p2 = adjustProperty p1 $ \satisfy -> do
- r <- satisfy
+fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2)
+fallback = combineWith $ \a1 a2 -> do
+ r <- a1
if r == FailedChange
- then propertySatisfy p2
+ then a2
else return r
-- | Marks a Property as trivial. It can only return FailedChange or
@@ -103,44 +81,33 @@ fallback p1 p2 = adjustProperty p1 $ \satisfy -> do
-- Useful when it's just as expensive to check if a change needs
-- to be made as it is to just idempotently assure the property is
-- satisfied. For example, chmodding a file.
-trivial :: Property -> Property
-trivial p = adjustProperty p $ \satisfy -> do
+trivial :: Property i -> Property i
+trivial p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
if r == MadeChange
then return NoChange
else return r
-doNothing :: Property
-doNothing = property "noop property" noChange
-
-- | Makes a property that is satisfied differently depending on the host's
-- operating system.
--
-- Note that the operating system may not be declared for some hosts.
-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
+withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
withOS desc a = property desc $ a =<< getOS
-- | Undoes the effect of a property.
revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
--- | Changes the action that is performed to satisfy a property.
-adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
-adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
-
--- | Combines the Info of two properties.
-combineInfo :: (IsProp p, IsProp q) => p -> q -> Info
-combineInfo p q = getInfo p <> getInfo q
-
-combineInfos :: IsProp p => [p] -> Info
-combineInfos = mconcat . map getInfo
-
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange
+doNothing :: Property NoInfo
+doNothing = property "noop property" noChange
+
-- | Registers an action that should be run at the very end,
endAction :: Desc -> (Result -> Propellor Result) -> Propellor ()
endAction desc a = tell [EndAction desc a]
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index 1ce187d8..e598de1f 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -9,7 +9,7 @@ import Utility.SafeCommand
type ConfigFile = [String]
siteEnabled :: HostName -> ConfigFile -> RevertableProperty
-siteEnabled hn cf = RevertableProperty enable disable
+siteEnabled hn cf = enable <!> disable
where
enable = combineProperties ("apache site enabled " ++ hn)
[ siteAvailable hn cf
@@ -28,14 +28,14 @@ siteEnabled hn cf = RevertableProperty enable disable
`onChange` reloaded
isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn]
-siteAvailable :: HostName -> ConfigFile -> Property
+siteAvailable :: HostName -> ConfigFile -> Property NoInfo
siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $
map (`File.hasContent` (comment:cf)) (siteCfg hn)
where
comment = "# deployed with propellor, do not modify"
modEnabled :: String -> RevertableProperty
-modEnabled modname = RevertableProperty enable disable
+modEnabled modname = enable <!> disable
where
enable = check (not <$> isenabled) $
cmdProperty "a2enmod" ["--quiet", modname]
@@ -59,18 +59,18 @@ siteCfg hn =
, "/etc/apache2/sites-available/" ++ hn ++ ".conf"
]
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["apache2"]
-restarted :: Property
+restarted :: Property NoInfo
restarted = Service.restarted "apache2"
-reloaded :: Property
+reloaded :: Property NoInfo
reloaded = Service.reloaded "apache2"
-- | Configure apache to use SNI to differentiate between
-- https hosts.
-multiSSL :: Property
+multiSSL :: Property NoInfo
multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`
[ "NameVirtualHost *:443"
, "SSLStrictSNIVHostCheck off"
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 2dd9ca16..75c59772 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.Apt where
import Data.Maybe
@@ -77,36 +79,36 @@ securityUpdates suite
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
-stdSourcesList :: Property
+stdSourcesList :: Property NoInfo
stdSourcesList = withOS ("standard sources.list") $ \o ->
case o of
(Just (System (Debian suite) _)) ->
ensureProperty $ stdSourcesListFor suite
_ -> error "os is not declared to be Debian"
-stdSourcesListFor :: DebianSuite -> Property
+stdSourcesListFor :: DebianSuite -> Property NoInfo
stdSourcesListFor suite = stdSourcesList' suite []
-- | Adds additional sources.list generators.
--
-- Note that if a Property needs to enable an apt source, it's better
-- to do so via a separate file in </etc/apt/sources.list.d/>
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property
+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
stdSourcesList' suite more = setSourcesList
(concatMap (\gen -> gen suite) generators)
`describe` ("standard sources.list for " ++ show suite)
where
generators = [debCdn, kernelOrg, securityUpdates] ++ more
-setSourcesList :: [Line] -> Property
+setSourcesList :: [Line] -> Property NoInfo
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
-setSourcesListD :: [Line] -> FilePath -> Property
+setSourcesListD :: [Line] -> FilePath -> Property NoInfo
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
-runApt :: [String] -> Property
+runApt :: [String] -> Property NoInfo
runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
@@ -115,26 +117,26 @@ noninteractiveEnv =
, ("APT_LISTCHANGES_FRONTEND", "none")
]
-update :: Property
+update :: Property NoInfo
update = runApt ["update"]
`describe` "apt update"
-upgrade :: Property
+upgrade :: Property NoInfo
upgrade = runApt ["-y", "dist-upgrade"]
`describe` "apt dist-upgrade"
type Package = String
-installed :: [Package] -> Property
+installed :: [Package] -> Property NoInfo
installed = installed' ["-y"]
-installed' :: [String] -> [Package] -> Property
+installed' :: [String] -> [Package] -> Property NoInfo
installed' params ps = robustly $ check (isInstallable ps) go
`describe` (unwords $ "apt installed":ps)
where
go = runApt $ params ++ ["install"] ++ ps
-installedBackport :: [Package] -> Property
+installedBackport :: [Package] -> Property NoInfo
installedBackport ps = trivial $ withOS desc $ \o -> case o of
Nothing -> error "cannot install backports; os not declared"
(Just (System (Debian suite) _)) -> case backportSuite suite of
@@ -147,16 +149,16 @@ installedBackport ps = trivial $ withOS desc $ \o -> case o of
notsupported o = error $ "backports not supported on " ++ show o
-- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property
+installedMin :: [Package] -> Property NoInfo
installedMin = installed' ["--no-install-recommends", "-y"]
-removed :: [Package] -> Property
+removed :: [Package] -> Property NoInfo
removed ps = check (or <$> isInstalled' ps) go
`describe` (unwords $ "apt removed":ps)
where
go = runApt $ ["-y", "remove"] ++ ps
-buildDep :: [Package] -> Property
+buildDep :: [Package] -> Property NoInfo
buildDep ps = robustly go
`describe` (unwords $ "apt build-dep":ps)
where
@@ -165,7 +167,7 @@ buildDep ps = robustly go
-- | Installs the build deps for the source package unpacked
-- in the specifed directory, with a dummy package also
-- installed so that autoRemove won't remove them.
-buildDepIn :: FilePath -> Property
+buildDepIn :: FilePath -> Property NoInfo
buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
where
go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]
@@ -173,11 +175,13 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
-robustly :: Property -> Property
-robustly p = adjustProperty p $ \satisfy -> do
+robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
+robustly p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
if r == FailedChange
- then ensureProperty $ p `requires` update
+ -- Safe to use ignoreInfo because we're re-running
+ -- the same property.
+ then ensureProperty $ ignoreInfo $ p `requires` update
else return r
isInstallable :: [Package] -> IO Bool
@@ -203,13 +207,13 @@ isInstalled' ps = catMaybes . map parse . lines <$> policy
environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ)
-autoRemove :: Property
+autoRemove :: Property NoInfo
autoRemove = runApt ["-y", "autoremove"]
`describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades :: RevertableProperty
-unattendedUpgrades = RevertableProperty enable disable
+unattendedUpgrades = enable <!> disable
where
enable = setup True
`before` Service.running "cron"
@@ -237,7 +241,7 @@ unattendedUpgrades = RevertableProperty enable disable
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
-reConfigure :: Package -> [(String, String, String)] -> Property
+reConfigure :: Package -> [(String, String, String)] -> Property NoInfo
reConfigure package vals = reconfigure `requires` setselections
`describe` ("reconfigure " ++ package)
where
@@ -253,7 +257,7 @@ reConfigure package vals = reconfigure `requires` setselections
--
-- Assumes that there is a 1:1 mapping between service names and apt
-- package names.
-serviceInstalledRunning :: Package -> Property
+serviceInstalledRunning :: Package -> Property NoInfo
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
@@ -262,20 +266,27 @@ data AptKey = AptKey
}
trustsKey :: AptKey -> RevertableProperty
-trustsKey k = RevertableProperty trust untrust
+trustsKey k = trustsKey' k <!> untrustKey k
+
+trustsKey' :: AptKey -> Property NoInfo
+trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
+ withHandle StdinHandle createProcessSuccess
+ (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
+ hPutStr h (pubkey k)
+ hClose h
+ nukeFile $ f ++ "~" -- gpg dropping
where
desc = "apt trusts key " ++ keyname k
- f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
- untrust = File.notPresent f
- trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
- withHandle StdinHandle createProcessSuccess
- (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
- hPutStr h (pubkey k)
- hClose h
- nukeFile $ f ++ "~" -- gpg dropping
+ f = aptKeyFile k
+
+untrustKey :: AptKey -> Property NoInfo
+untrustKey = File.notPresent . aptKeyFile
+
+aptKeyFile :: AptKey -> FilePath
+aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-- | Cleans apt's cache of downloaded packages to avoid using up disk
-- space.
-cacheCleaned :: Property
+cacheCleaned :: Property NoInfo
cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"]
`describe` "apt cache cleaned"
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 3da8b0d6..e56cb6ed 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -1,5 +1,8 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.Chroot (
Chroot(..),
+ BuilderConf(..),
debootstrapped,
provisioned,
-- * Internal use
@@ -10,6 +13,7 @@ module Propellor.Property.Chroot (
) where
import Propellor
+import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
@@ -28,10 +32,10 @@ data BuilderConf
= UsingDeboostrap Debootstrap.DebootstrapConfig
deriving (Show)
-instance Hostlike Chroot where
+instance PropAccum Chroot where
(Chroot l s c h) & p = Chroot l s c (h & p)
(Chroot l s c h) &^ p = Chroot l s c (h &^ p)
- getHost (Chroot _ _ _ h) = h
+ getProperties (Chroot _ _ _ h) = hostProperties h
-- | Defines a Chroot at the given location, built with debootstrap.
--
@@ -57,12 +61,13 @@ debootstrapped system conf location = case system of
provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propigateChrootInfo c) c False
-provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty
-provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty
+provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
+provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
(propigator $ go "exists" setup)
+ <!>
(go "removed" teardown)
where
- go desc a = property (chrootDesc c desc) $ ensureProperties [a]
+ go desc a = propertyList (chrootDesc c desc) [a]
setup = propellChroot c (inChrootProcess c) systemdonly
`requires` toProp built
@@ -75,15 +80,21 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert
teardown = toProp (revert built)
-propigateChrootInfo :: Chroot -> Property -> Property
-propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c)
+propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
+propigateChrootInfo c p = propigateContainer c p'
+ where
+ p' = infoProperty
+ (propertyDesc p)
+ (propertySatisfy p)
+ (propertyInfo p <> chrootInfo c)
+ (propertyChildren p)
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ _ h) =
mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
-- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property
+propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo
propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@@ -140,7 +151,8 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
r <- runPropellor h $ ensureProperties $
if systemdonly
then [Systemd.installed]
- else hostProperties h
+ else map ignoreInfo $
+ hostProperties h
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index d24b1a8a..7fd189df 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -19,12 +19,12 @@ import Utility.Env
-- | A property that can be satisfied by running a command.
--
-- The command must exit 0 on success.
-cmdProperty :: String -> [String] -> Property
+cmdProperty :: String -> [String] -> Property NoInfo
cmdProperty cmd params = cmdProperty' cmd params []
-- | A property that can be satisfied by running a command,
-- with added environment.
-cmdProperty' :: String -> [String] -> [(String, String)] -> Property
+cmdProperty' :: String -> [String] -> [(String, String)] -> Property NoInfo
cmdProperty' cmd params env = property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment
toResult <$> boolSystemEnv cmd (map Param params) (Just env')
@@ -32,14 +32,14 @@ cmdProperty' cmd params env = property desc $ liftIO $ do
desc = unwords $ cmd : params
-- | A property that can be satisfied by running a series of shell commands.
-scriptProperty :: [String] -> Property
+scriptProperty :: [String] -> Property NoInfo
scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
where
shellcmd = intercalate " ; " ("set -e" : script)
-- | A property that can satisfied by running a series of shell commands,
-- as user (cd'd to their home directory).
-userScriptProperty :: UserName -> [String] -> Property
+userScriptProperty :: UserName -> [String] -> Property NoInfo
userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]
where
shellcmd = intercalate " ; " ("set -e" : "cd" : script)
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 26cf312f..15cdd983 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -19,7 +19,7 @@ type CronTimes = String
-- job file.
--
-- The cron job's output will only be emailed if it exits nonzero.
-job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
+job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo
job desc times user cddir command = combineProperties ("cronned " ++ desc)
[ cronjobfile `File.hasContent`
[ "# Generated by propellor"
@@ -52,10 +52,10 @@ job desc times user cddir command = combineProperties ("cronned " ++ desc)
| otherwise = '_'
-- | Installs a cron job, and runs it niced and ioniced.
-niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
+niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo
niceJob desc times user cddir command = job desc times user cddir
("nice ionice -c 3 sh -c " ++ shellEscape command)
-- | Installs a cron job to run propellor.
-runPropellor :: CronTimes -> Property
+runPropellor :: CronTimes -> Property NoInfo
runPropellor times = niceJob "propellor" times "root" localdir "./propellor"
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 300edb42..d4947ab7 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
@@ -56,19 +58,18 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
-- Note that reverting this property does not stop any processes
-- currently running in the chroot.
built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty
-built = built' (toProp installed)
-
-built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty
-built' installprop target system@(System _ arch) config =
- RevertableProperty setup teardown
+built target system config = built' (toProp installed) target system config <!> teardown
where
- setup = check (unpopulated target <||> ispartial) setupprop
- `requires` installprop
-
teardown = check (not <$> unpopulated target) teardownprop
- unpopulated d = null <$> catchDefaultIO [] (dirContents d)
+ teardownprop = property ("removed debootstrapped " ++ target) $
+ makeChange (removetarget target)
+built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
+built' installprop target system@(System _ arch) config =
+ check (unpopulated target <||> ispartial) setupprop
+ `requires` installprop
+ where
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
-- Don't allow non-root users to see inside the chroot,
@@ -93,24 +94,25 @@ built' installprop target system@(System _ arch) config =
, return FailedChange
)
- teardownprop = property ("removed debootstrapped " ++ target) $
- makeChange removetarget
-
- removetarget = do
- submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
- . filter (dirContains target)
- <$> mountPoints
- forM_ submnts umountLazy
- removeDirectoryRecursive target
-
-- A failed debootstrap run will leave a debootstrap directory;
-- recover by deleting it and trying again.
ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
( do
- removetarget
+ removetarget target
return True
, return False
)
+
+unpopulated :: FilePath -> IO Bool
+unpopulated d = null <$> catchDefaultIO [] (dirContents d)
+
+removetarget :: FilePath -> IO ()
+removetarget target = do
+ submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
+ . filter (dirContains target)
+ <$> mountPoints
+ forM_ submnts umountLazy
+ removeDirectoryRecursive target
extractSuite :: System -> Maybe String
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
@@ -122,7 +124,7 @@ extractSuite (System (Ubuntu r) _) = Just r
-- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification.
installed :: RevertableProperty
-installed = RevertableProperty install remove
+installed = install <!> remove
where
install = withOS "debootstrap installed" $ \o ->
ifM (liftIO $ isJust <$> programPath)
@@ -142,18 +144,18 @@ installed = RevertableProperty install remove
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
-sourceInstall :: Property
+sourceInstall :: Property NoInfo
sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
`requires` perlInstalled
`requires` arInstalled
-perlInstalled :: Property
+perlInstalled :: Property NoInfo
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl"
]
-arInstalled :: Property
+arInstalled :: Property NoInfo
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils"
@@ -197,7 +199,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
-sourceRemove :: Property
+sourceRemove :: Property NoInfo
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index ceda2e07..a7dbf86a 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -58,7 +58,7 @@ import Data.List
-- In either case, the secondary dns server Host should have an ipv4 and/or
-- ipv6 property defined.
primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
-primary hosts domain soa rs = RevertableProperty setup cleanup
+primary hosts domain soa rs = setup <!> cleanup
where
setup = setupPrimary zonefile id hosts domain soa rs
`onChange` Service.reloaded "bind9"
@@ -67,7 +67,7 @@ primary hosts domain soa rs = RevertableProperty setup cleanup
zonefile = "/etc/bind/propellor/db." ++ domain
-setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property
+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo
setupPrimary zonefile mknamedconffile hosts domain soa rs =
withwarnings baseprop
`requires` servingZones
@@ -77,8 +77,8 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
- baseprop = Property ("dns primary for " ++ domain) satisfy
- (addNamedConf conf)
+ baseprop = infoProperty ("dns primary for " ++ domain) satisfy
+ (addNamedConf conf) []
satisfy = do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
let zone = partialzone
@@ -87,7 +87,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
( makeChange $ writeZoneFile zone zonefile
, noChange
)
- withwarnings p = adjustProperty p $ \a -> do
+ withwarnings p = adjustPropertySatisfy p $ \a -> do
mapM_ warningMessage $ zonewarnings ++ secondarywarnings
a
conf = NamedConf
@@ -117,7 +117,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
in z /= oldzone || oldserial < sSerial (zSOA zone)
-cleanupPrimary :: FilePath -> Domain -> Property
+cleanupPrimary :: FilePath -> Domain -> Property NoInfo
cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
property ("removed dns primary for " ++ domain)
(makeChange $ removeZoneFile zonefile)
@@ -150,13 +150,14 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
-- want to later disable DNSSEC you will need to adjust the serial number
-- passed to mkSOA to ensure it is larger.
signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
-signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup
+signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
where
- setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
- [ setupPrimary zonefile signedZoneFile hosts domain soa rs'
- , toProp (zoneSigned domain zonefile)
- , forceZoneSigned domain zonefile `period` recurrance
- ]
+ setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
+ (props
+ & setupPrimary zonefile signedZoneFile hosts domain soa rs'
+ & zoneSigned domain zonefile
+ & forceZoneSigned domain zonefile `period` recurrance
+ )
`onChange` Service.reloaded "bind9"
cleanup = cleanupPrimary zonefile domain
@@ -186,7 +187,7 @@ secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts d
-- | This variant is useful if the primary server does not have its DNS
-- configured via propellor.
secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
-secondaryFor masters hosts domain = RevertableProperty setup cleanup
+secondaryFor masters hosts domain = setup <!> cleanup
where
setup = pureInfoProperty desc (addNamedConf conf)
`requires` servingZones
@@ -214,12 +215,12 @@ otherServers wantedtype hosts domain =
-- | Rewrites the whole named.conf.local file to serve the zones
-- configured by `primary` and `secondary`, and ensures that bind9 is
-- running.
-servingZones :: Property
+servingZones :: Property NoInfo
servingZones = namedConfWritten
`onChange` Service.reloaded "bind9"
`requires` Apt.serviceInstalledRunning "bind9"
-namedConfWritten :: Property
+namedConfWritten :: Property NoInfo
namedConfWritten = property "named.conf configured" $ do
zs <- getNamedConf
ensureProperty $
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index b7557006..3acaee8d 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -8,7 +8,7 @@ import qualified Propellor.Property.File as File
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
keysInstalled :: Domain -> RevertableProperty
-keysInstalled domain = RevertableProperty setup cleanup
+keysInstalled domain = setup <!> cleanup
where
setup = propertyList "DNSSEC keys installed" $
map installkey keys
@@ -38,16 +38,14 @@ keysInstalled domain = RevertableProperty setup cleanup
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
zoneSigned :: Domain -> FilePath -> RevertableProperty
-zoneSigned domain zonefile = RevertableProperty setup cleanup
+zoneSigned domain zonefile = setup <!> cleanup
where
setup = check needupdate (forceZoneSigned domain zonefile)
`requires` toProp (keysInstalled domain)
- cleanup = combineProperties ("removed signed zone for " ++ domain)
- [ File.notPresent (signedZoneFile zonefile)
- , File.notPresent dssetfile
- , toProp (revert (keysInstalled domain))
- ]
+ cleanup = File.notPresent (signedZoneFile zonefile)
+ `before` File.notPresent dssetfile
+ `before` toProp (revert (keysInstalled domain))
dssetfile = dir </> "-" ++ domain ++ "."
dir = takeDirectory zonefile
@@ -65,7 +63,7 @@ zoneSigned domain zonefile = RevertableProperty setup cleanup
t2 <- getModificationTime f
return (t2 >= t1)
-forceZoneSigned :: Domain -> FilePath -> Property
+forceZoneSigned :: Domain -> FilePath -> Property NoInfo
forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
salt <- take 16 <$> saltSha1
let p = proc "dnssec-signzone"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index eb0d8ec5..6ca5005c 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
-- | Docker support for propellor
--
@@ -40,6 +40,7 @@ module Propellor.Property.Docker (
import Propellor hiding (init)
import Propellor.Types.Docker
+import Propellor.Types.CmdLine
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Shim as Shim
@@ -55,12 +56,12 @@ import Data.List hiding (init)
import Data.List.Utils
import qualified Data.Map as M
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
-configured :: Property
+configured :: Property HasInfo
configured = prop `requires` installed
where
prop = withPrivData src anyContext $ \getcfg ->
@@ -77,10 +78,10 @@ type ContainerName = String
-- | A docker container.
data Container = Container Image Host
-instance Hostlike Container where
+instance PropAccum Container where
(Container i h) & p = Container i (h & p)
(Container i h) &^ p = Container i (h &^ p)
- getHost (Container _ h) = h
+ getProperties (Container _ h) = hostProperties h
-- | Defines a Container with a given name, image, and properties.
-- Properties can be added to configure the Container.
@@ -105,8 +106,9 @@ container cn image = Container image (Host cn [] info)
-- Reverting this property ensures that the container is stopped and
-- removed.
docked :: Container -> RevertableProperty
-docked ctr@(Container _ h) = RevertableProperty
+docked ctr@(Container _ h) =
(propigateContainerInfo ctr (go "docked" setup))
+ <!>
(go "undocked" teardown)
where
cn = hostName h
@@ -133,10 +135,14 @@ docked ctr@(Container _ h) = RevertableProperty
]
]
-propigateContainerInfo :: Container -> Property -> Property
-propigateContainerInfo ctr@(Container _ h) p =
- propigateInfo ctr p (<> dockerinfo)
+propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
+propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p'
where
+ p' = infoProperty
+ (propertyDesc p)
+ (propertySatisfy p)
+ (propertyInfo p <> dockerinfo)
+ (propertyChildren p)
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton (hostName h) h }
@@ -164,7 +170,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
-- that were not set up using propellor.
--
-- Generally, should come after the properties for the desired containers.
-garbageCollected :: Property
+garbageCollected :: Property NoInfo
garbageCollected = propertyList "docker garbage collected"
[ gccontainers
, gcimages
@@ -180,7 +186,7 @@ garbageCollected = propertyList "docker garbage collected"
-- Currently, this consists of making pam_loginuid lines optional in
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
-tweaked :: Property
+tweaked :: Property NoInfo
tweaked = trivial $
cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"]
`describe` "tweaked for docker"
@@ -191,7 +197,7 @@ tweaked = trivial $
-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
--
-- Only takes effect after reboot. (Not automated.)
-memoryLimited :: Property
+memoryLimited :: Property NoInfo
memoryLimited = "/etc/default/grub" `File.containsLine` cfg
`describe` "docker memory limited"
`onChange` cmdProperty "update-grub" []
@@ -208,44 +214,44 @@ type RunParam = String
type Image = String
-- | Set custom dns server for container.
-dns :: String -> Property
+dns :: String -> Property HasInfo
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> Property
+hostname :: String -> Property HasInfo
hostname = runProp "hostname"
-- | Set name of container.
-name :: String -> Property
+name :: String -> Property HasInfo
name = runProp "name"
-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> Property
+publish :: String -> Property HasInfo
publish = runProp "publish"
-- | Expose a container's port without publishing it.
-expose :: String -> Property
+expose :: String -> Property HasInfo
expose = runProp "expose"
-- | Username or UID for container.
-user :: String -> Property
+user :: String -> Property HasInfo
user = runProp "user"
-- | Mount a volume
-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
-- With just a directory, creates a volume in the container.
-volume :: String -> Property
+volume :: String -> Property HasInfo
volume = runProp "volume"
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> Property
+volumes_from :: ContainerName -> Property HasInfo
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> Property
+workdir :: String -> Property HasInfo
workdir = runProp "workdir"
-- | Memory limit for container.
@@ -253,18 +259,18 @@ workdir = runProp "workdir"
--
-- Note: Only takes effect when the host has the memoryLimited property
-- enabled.
-memory :: String -> Property
+memory :: String -> Property HasInfo
memory = runProp "memory"
-- | CPU shares (relative weight).
--
-- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property
+cpuShares :: Int -> Property HasInfo
cpuShares = runProp "cpu-shares" . show
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property
+link :: ContainerName -> ContainerAlias -> Property HasInfo
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
@@ -276,19 +282,19 @@ type ContainerAlias = String
-- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or
-- after docker is upgraded.
-restartAlways :: Property
+restartAlways :: Property HasInfo
restartAlways = runProp "restart" "always"
-- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many
-- times.
-restartOnFailure :: Maybe Int -> Property
+restartOnFailure :: Maybe Int -> Property HasInfo
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
-- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot!
-restartNever :: Property
+restartNever :: Property HasInfo
restartNever = runProp "restart" "no"
-- | A container is identified by its name, and the host
@@ -322,12 +328,12 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
myContainerSuffix :: String
myContainerSuffix = ".propellor"
-containerDesc :: ContainerId -> Property -> Property
+containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc cid p = p `describe` desc
where
desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
-runningContainer :: ContainerId -> Image -> [RunParam] -> Property
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
@@ -442,7 +448,7 @@ init s = case toContainerId s of
-- | Once a container is running, propellor can be run inside
-- it to provision it.
-provisionContainer :: ContainerId -> Property
+provisionContainer :: ContainerId -> Property NoInfo
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
@@ -472,7 +478,8 @@ chain hostlist hn s = case toContainerId s of
changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $ do
r <- runPropellor h $ ensureProperties $
- hostProperties h
+ map ignoreInfo $
+ hostProperties h
putStrLn $ "\n" ++ show r
stopContainer :: ContainerId -> IO Bool
@@ -481,7 +488,7 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
-stoppedContainer :: ContainerId -> Property
+stoppedContainer :: ContainerId -> Property NoInfo
stoppedContainer cid = containerDesc cid $ property desc $
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( liftIO cleanup `after` ensureProperty
@@ -533,13 +540,13 @@ listContainers status =
listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> Property
+runProp :: String -> RunParam -> Property HasInfo
runProp field val = pureInfoProperty (param) $ dockerInfo $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
-genProp :: String -> (HostName -> RunParam) -> Property
+genProp :: String -> (HostName -> RunParam) -> Property HasInfo
genProp field mkval = pureInfoProperty field $ dockerInfo $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 032268c4..7167d61e 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -9,7 +9,7 @@ import System.PosixCompat.Types
type Line = String
-- | Replaces all the content of a file.
-hasContent :: FilePath -> [Line] -> Property
+hasContent :: FilePath -> [Line] -> Property NoInfo
f `hasContent` newcontent = fileProperty ("replace " ++ f)
(\_oldcontent -> newcontent) f
@@ -17,25 +17,25 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f)
--
-- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600.
-hasPrivContent :: IsContext c => FilePath -> c -> Property
+hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo
hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
-- | Like hasPrivContent, but allows specifying a source
-- for PrivData, rather than using PrivDataSourceFile.
-hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property
+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
hasPrivContentFrom = hasPrivContent' writeFileProtected
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
--
-- Use with caution!
-hasPrivContentExposed :: IsContext c => FilePath -> c -> Property
+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
-hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property
+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
hasPrivContentExposedFrom = hasPrivContent' writeFile
-hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property HasInfo
hasPrivContent' writer source f context =
withPrivData source context $ \getcontent ->
property desc $ getcontent $ \privcontent ->
@@ -45,10 +45,10 @@ hasPrivContent' writer source f context =
desc = "privcontent " ++ f
-- | Ensures that a line is present in a file, adding it to the end if not.
-containsLine :: FilePath -> Line -> Property
+containsLine :: FilePath -> Line -> Property NoInfo
f `containsLine` l = f `containsLines` [l]
-containsLines :: FilePath -> [Line] -> Property
+containsLines :: FilePath -> [Line] -> Property NoInfo
f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
where
go content = content ++ filter (`notElem` content) ls
@@ -56,17 +56,17 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
-- | Ensures that a line is not present in a file.
-- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written.
-lacksLine :: FilePath -> Line -> Property
+lacksLine :: FilePath -> Line -> Property NoInfo
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
-notPresent :: FilePath -> Property
+notPresent :: FilePath -> Property NoInfo
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
makeChange $ nukeFile f
-fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
+fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
fileProperty = fileProperty' writeFile
-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property
+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
where
go True = do
@@ -86,12 +86,12 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-- | Ensures a directory exists.
-dirExists :: FilePath -> Property
+dirExists :: FilePath -> Property NoInfo
dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
makeChange $ createDirectoryIfMissing True d
-- | Ensures that a file/dir has the specified owner and group.
-ownerGroup :: FilePath -> UserName -> GroupName -> Property
+ownerGroup :: FilePath -> UserName -> GroupName -> Property NoInfo
ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
r <- ensureProperty $ cmdProperty "chown" [og, f]
if r == FailedChange
@@ -101,7 +101,7 @@ ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
og = owner ++ ":" ++ group
-- | Ensures that a file/dir has the specfied mode.
-mode :: FilePath -> FileMode -> Property
+mode :: FilePath -> FileMode -> Property NoInfo
mode f v = property (f ++ " mode " ++ show v) $ do
liftIO $ modifyFileMode f (\_old -> v)
noChange
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index 3018f989..66292c8b 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -9,6 +9,7 @@ module Propellor.Property.Firewall (
Target(..),
Proto(..),
Rules(..),
+ Port,
ConnectionState(..)
) where
@@ -21,10 +22,10 @@ import Utility.SafeCommand
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["iptables"]
-rule :: Chain -> Target -> Rules -> Property
+rule :: Chain -> Target -> Rules -> Property NoInfo
rule c t rs = property ("firewall rule: " <> show r) addIpTable
where
r = Rule c t rs
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index eb7801c1..c363d8c8 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -13,7 +13,7 @@ import Data.List
--
-- Note that reverting this property does not remove or stop inetd.
daemonRunning :: FilePath -> RevertableProperty
-daemonRunning exportdir = RevertableProperty setup unsetup
+daemonRunning exportdir = setup <!> unsetup
where
setup = containsLine conf (mkl "tcp4")
`requires`
@@ -48,7 +48,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup
, exportdir
]
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["git"]
type RepoUrl = String
@@ -62,7 +62,7 @@ type Branch = String
-- it will be recursively deleted first.
--
-- A branch can be specified, to check out.
-cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
+cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo
cloned owner url dir mbranch = check originurl (property desc checkout)
`requires` installed
where
@@ -98,7 +98,7 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
data GitShared = Shared GroupName | SharedAll | NotShared
-bareRepo :: FilePath -> UserName -> GitShared -> Property
+bareRepo :: FilePath -> UserName -> GitShared -> Property NoInfo
bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
dirExists repo : case gitshared of
NotShared ->
diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs
index 4a3e1872..dfb9d429 100644
--- a/src/Propellor/Property/Gpg.hs
+++ b/src/Propellor/Property/Gpg.hs
@@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["gnupg"]
-- A numeric id, or a description of the key, in a form understood by gpg.
@@ -20,7 +20,7 @@ newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String }
--
-- Recommend only using this for low-value dedicated role keys.
-- No attempt has been made to scrub the key out of memory once it's used.
-keyImported :: GpgKeyId -> UserName -> Property
+keyImported :: GpgKeyId -> UserName -> Property HasInfo
keyImported (GpgKeyId keyid) user = flagFile' prop genflag
`requires` installed
where
diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs
index 978d3bff..15524eb4 100644
--- a/src/Propellor/Property/Group.hs
+++ b/src/Propellor/Property/Group.hs
@@ -4,7 +4,7 @@ import Propellor
type GID = Int
-exists :: GroupName -> Maybe GID -> Property
+exists :: GroupName -> Maybe GID -> Property NoInfo
exists group' mgid = check test (cmdProperty "addgroup" $ args mgid)
`describe` unwords ["group", group']
where
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 71593523..1084ef9e 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -4,10 +4,10 @@ import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
--- | Eg, "hd0,0" or "xen/xvda1"
+-- | Eg, \"hd0,0\" or \"xen/xvda1\"
type GrubDevice = String
--- | Eg, "/dev/sda"
+-- | Eg, \"\/dev/sda\"
type OSDevice = String
type TimeoutSecs = Int
@@ -21,7 +21,7 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- This includes running update-grub, so that the grub boot menu is
-- created. It will be automatically updated when kernel packages are
-- installed.
-installed :: BIOS -> Property
+installed :: BIOS -> Property NoInfo
installed bios =
Apt.installed [pkg] `describe` "grub package installed"
`before`
@@ -43,7 +43,7 @@ installed bios =
-- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce.
-boots :: OSDevice -> Property
+boots :: OSDevice -> Property NoInfo
boots dev = cmdProperty "grub-install" [dev]
`describe` ("grub boots " ++ dev)
@@ -55,7 +55,7 @@ boots dev = cmdProperty "grub-install" [dev]
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
chainPVGrub rootdev bootdev timeout = combineProperties desc
[ File.dirExists "/boot/grub"
, "/boot/grub/menu.lst" `File.hasContent`
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index 84c8a787..2cfdb951 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -6,7 +6,7 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.User as User
-- Clean up a system as installed by cloudatcost.com
-decruft :: Property
+decruft :: Property NoInfo
decruft = propertyList "cloudatcost cleanup"
[ Hostname.sane
, "worked around grub/lvm boot bug #743126" ==>
diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
index 4d2534ec..be62ccdc 100644
--- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs
+++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
@@ -18,7 +18,7 @@ import Data.List
-- If the power is cycled, the non-distro kernel still boots up.
-- So, this property also checks if the running kernel is present in /boot,
-- and if not, reboots immediately into a distro kernel.
-distroKernel :: Property
+distroKernel :: Property NoInfo
distroKernel = propertyList "digital ocean distro kernel hack"
[ Apt.installed ["grub-pc", "kexec-tools", "file"]
, "/etc/default/kexec" `File.containsLines`
diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs
index 34d72184..90f41bf8 100644
--- a/src/Propellor/Property/HostingProvider/Linode.hs
+++ b/src/Propellor/Property/HostingProvider/Linode.hs
@@ -6,5 +6,5 @@ import qualified Propellor.Property.Grub as Grub
-- | Linode's pv-grub-x86_64 does not currently support booting recent
-- Debian kernels compressed with xz. This sets up pv-grub chaing to enable
-- it.
-chainPVGrub :: Grub.TimeoutSecs -> Property
+chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index f1709d4d..20181213 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -17,10 +17,10 @@ import Data.List
-- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any
-- other hostnames there is not best practices and can lead to annoying
-- messages from eg, apache.
-sane :: Property
+sane :: Property NoInfo
sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
-setTo :: HostName -> Property
+setTo :: HostName -> Property NoInfo
setTo hn = combineProperties desc go
where
desc = "hostname " ++ hn
@@ -46,7 +46,7 @@ setTo hn = combineProperties desc go
-- | Makes </etc/resolv.conf> contain search and domain lines for
-- the domain that the hostname is in.
-searchDomain :: Property
+searchDomain :: Property NoInfo
searchDomain = property desc (ensureProperty . go =<< asks hostName)
where
desc = "resolv.conf search and domain configured"
diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs
new file mode 100644
index 00000000..3ab4e9d7
--- /dev/null
+++ b/src/Propellor/Property/Journald.hs
@@ -0,0 +1,53 @@
+module Propellor.Property.Journald where
+import Propellor
+import qualified Propellor.Property.Systemd as Systemd
+import Utility.DataUnits
+
+-- | Configures journald, restarting it so the changes take effect.
+configured :: Systemd.Option -> String -> Property NoInfo
+configured option value =
+ Systemd.configured "/etc/systemd/journald.conf" option value
+ `onChange` Systemd.restarted "systemd-journald"
+
+-- The string is parsed to get a data size.
+-- Examples: "100 megabytes" or "0.5tb"
+type DataSize = String
+
+configuredSize :: Systemd.Option -> DataSize -> Property NoInfo
+configuredSize option s = case readSize dataUnits s of
+ Just sz -> configured option (systemdSizeUnits sz)
+ Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange
+
+systemMaxUse :: DataSize -> Property NoInfo
+systemMaxUse = configuredSize "SystemMaxUse"
+
+runtimeMaxUse :: DataSize -> Property NoInfo
+runtimeMaxUse = configuredSize "RuntimeMaxUse"
+
+systemKeepFree :: DataSize -> Property NoInfo
+systemKeepFree = configuredSize "SystemKeepFree"
+
+runtimeKeepFree :: DataSize -> Property NoInfo
+runtimeKeepFree = configuredSize "RuntimeKeepFree"
+
+systemMaxFileSize :: DataSize -> Property NoInfo
+systemMaxFileSize = configuredSize "SystemMaxFileSize"
+
+runtimeMaxFileSize :: DataSize -> Property NoInfo
+runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"
+
+-- Generates size units as used in journald.conf.
+systemdSizeUnits :: Integer -> String
+systemdSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz)
+ where
+ cfgfileunits :: [Unit]
+ cfgfileunits =
+ [ Unit (p 6) "E" "exabyte"
+ , Unit (p 5) "P" "petabyte"
+ , Unit (p 4) "T" "terabyte"
+ , Unit (p 3) "G" "gigabyte"
+ , Unit (p 2) "M" "megabyte"
+ , Unit (p 1) "K" "kilobyte"
+ ]
+ p :: Integer -> Integer
+ p n = 1024^n
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
new file mode 100644
index 00000000..283c5ec7
--- /dev/null
+++ b/src/Propellor/Property/List.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Property.List (
+ PropertyList(..),
+ PropertyListType,
+) where
+
+import Propellor.Types
+import Propellor.Engine
+import Propellor.PropAccum
+
+import Data.Monoid
+
+class PropertyList l where
+ -- | Combines a list of properties, resulting in a single property
+ -- that when run will run each property in the list in turn,
+ -- and print out the description of each as it's run. Does not stop
+ -- on failure; does propigate overall success/failure.
+ --
+ -- Note that Property HasInfo and Property NoInfo are not the same
+ -- type, and so cannot be mixed in a list. To make a list of
+ -- mixed types, which can also include RevertableProperty,
+ -- use `props`:
+ --
+ -- > propertyList "foo" $ props
+ -- > & someproperty
+ -- > ! oldproperty
+ -- > & otherproperty
+ propertyList :: Desc -> l -> Property (PropertyListType l)
+
+ -- | Combines a list of properties, resulting in one property that
+ -- ensures each in turn. Stops if a property fails.
+ combineProperties :: Desc -> l -> Property (PropertyListType l)
+
+-- | Type level function to calculate whether a PropertyList has Info.
+type family PropertyListType t
+type instance PropertyListType [Property HasInfo] = HasInfo
+type instance PropertyListType [Property NoInfo] = NoInfo
+type instance PropertyListType PropList = HasInfo
+
+instance PropertyList [Property NoInfo] where
+ propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
+ combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
+
+instance PropertyList [Property HasInfo] where
+ -- It's ok to use ignoreInfo here, because the ps are made the
+ -- child properties of the property, and so their info is visible
+ -- that way.
+ propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
+ combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
+
+instance PropertyList PropList where
+ propertyList desc = propertyList desc . getProperties
+ combineProperties desc = combineProperties desc . getProperties
+
+combineSatisfy :: [Property i] -> Result -> Propellor Result
+combineSatisfy [] rs = return rs
+combineSatisfy (l:ls) rs = do
+ r <- ensureProperty $ ignoreInfo l
+ case r of
+ FailedChange -> return FailedChange
+ _ -> combineSatisfy ls (r <> rs)
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 6009778a..4d7ccffb 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -3,28 +3,93 @@ module Propellor.Property.Network where
import Propellor
import Propellor.Property.File
-interfaces :: FilePath
-interfaces = "/etc/network/interfaces"
+type Interface = String
+
+ifUp :: Interface -> Property NoInfo
+ifUp iface = cmdProperty "ifup" [iface]
+
+-- | Resets /etc/network/interfaces to a clean and empty state,
+-- containing just the standard loopback interface, and with
+-- interfacesD enabled.
+--
+-- This can be used as a starting point to defining other interfaces.
+--
+-- No interfaces are brought up or down by this property.
+cleanInterfacesFile :: Property NoInfo
+cleanInterfacesFile = hasContent interfacesFile
+ [ "# Deployed by propellor, do not edit."
+ , ""
+ , "source-directory interfaces.d"
+ , ""
+ , "# The loopback network interface"
+ , "auto lo"
+ , "iface lo inet loopback"
+ ]
+ `describe` ("clean " ++ interfacesFile)
+
+-- | Writes a static interface file for the specified interface.
+--
+-- The interface has to be up already. It could have been brought up by
+-- DHCP, or by other means. The current ipv4 addresses
+-- and routing configuration of the interface are written into the file.
+--
+-- If the interface file already exists, this property does nothing,
+-- no matter its content.
+--
+-- (ipv6 addresses are not included because it's assumed they come up
+-- automatically in most situations.)
+static :: Interface -> Property NoInfo
+static iface = check (not <$> doesFileExist f) setup
+ `describe` desc
+ `requires` interfacesDEnabled
+ where
+ f = interfaceDFile iface
+ desc = "static " ++ iface
+ setup = property desc $ do
+ ls <- liftIO $ lines <$> readProcess "ip"
+ ["-o", "addr", "show", iface, "scope", "global"]
+ stanzas <- liftIO $ concat <$> mapM mkstanza ls
+ ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas
+ mkstanza ipline = case words ipline of
+ -- Note that the IP address is written CIDR style, so
+ -- the netmask does not need to be specified separately.
+ (_:iface':"inet":addr:_) | iface' == iface -> do
+ gw <- getgateway
+ return $ catMaybes
+ [ Just $ "iface " ++ iface ++ " inet static"
+ , Just $ "\taddress " ++ addr
+ , ("\tgateway " ++) <$> gw
+ ]
+ _ -> return []
+ getgateway = do
+ rs <- lines <$> readProcess "ip"
+ ["route", "show", "scope", "global", "dev", iface]
+ return $ case words <$> headMaybe rs of
+ Just ("default":"via":gw:_) -> Just gw
+ _ -> Nothing
-- | 6to4 ipv6 connection, should work anywhere
-ipv6to4 :: Property
-ipv6to4 = fileProperty "ipv6to4" go interfaces
+ipv6to4 :: Property NoInfo
+ipv6to4 = hasContent (interfaceDFile "sit0")
+ [ "# Deployed by propellor, do not edit."
+ , "iface sit0 inet6 static"
+ , "\taddress 2002:5044:5531::1"
+ , "\tnetmask 64"
+ , "\tgateway ::192.88.99.1"
+ , "auto sit0"
+ ]
+ `describe` "ipv6to4"
+ `requires` interfacesDEnabled
`onChange` ifUp "sit0"
- where
- go ls
- | all (`elem` ls) stanza = ls
- | otherwise = ls ++ stanza
- stanza =
- [ "# Automatically added by propeller"
- , "iface sit0 inet6 static"
- , "\taddress 2002:5044:5531::1"
- , "\tnetmask 64"
- , "\tgateway ::192.88.99.1"
- , "auto sit0"
- , "# End automatically added by propeller"
- ]
-type Interface = String
+interfacesFile :: FilePath
+interfacesFile = "/etc/network/interfaces"
-ifUp :: Interface -> Property
-ifUp iface = cmdProperty "ifup" [iface]
+-- | A file in the interfaces.d directory.
+interfaceDFile :: Interface -> FilePath
+interfaceDFile iface = "/etc/network/interfaces.d" </> iface
+
+-- | Ensures that files in the the interfaces.d directory are used.
+interfacesDEnabled :: Property NoInfo
+interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
+ `describe` "interfaces.d directory enabled"
diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs
index 397570d2..02ca202f 100644
--- a/src/Propellor/Property/Nginx.hs
+++ b/src/Propellor/Property/Nginx.hs
@@ -9,7 +9,7 @@ import System.Posix.Files
type ConfigFile = [String]
siteEnabled :: HostName -> ConfigFile -> RevertableProperty
-siteEnabled hn cf = RevertableProperty enable disable
+siteEnabled hn cf = enable <!> disable
where
enable = check test prop
`describe` ("nginx site enabled " ++ hn)
@@ -27,7 +27,7 @@ siteEnabled hn cf = RevertableProperty enable disable
`requires` installed
`onChange` reloaded
-siteAvailable :: HostName -> ConfigFile -> Property
+siteAvailable :: HostName -> ConfigFile -> Property NoInfo
siteAvailable hn cf = ("nginx site available " ++ hn) ==>
siteCfg hn `File.hasContent` (comment : cf)
where
@@ -42,11 +42,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn
siteValRelativeCfg :: HostName -> FilePath
siteValRelativeCfg hn = "../sites-available/" ++ hn
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["nginx"]
-restarted :: Property
+restarted :: Property NoInfo
restarted = Service.restarted "nginx"
-reloaded :: Property
+reloaded :: Property NoInfo
reloaded = Service.reloaded "nginx"
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index b60151e8..7a6857fb 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -10,6 +10,7 @@ module Propellor.Property.OS (
import Propellor
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Ssh as Ssh
+import qualified Propellor.Property.Network as Network
import qualified Propellor.Property.User as User
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Reboot as Reboot
@@ -51,7 +52,7 @@ import Control.Exception (throw)
-- > `onChange` propertyList "fixing up after clean install"
-- > [ preserveNetwork
-- > , preserveResolvConf
--- > , preserverRootSshAuthorized
+-- > , preserveRootSshAuthorized
-- > , Apt.update
-- > -- , Grub.boots "/dev/sda"
-- > -- `requires` Grub.installed Grub.PC
@@ -64,7 +65,7 @@ import Control.Exception (throw)
-- > & User.accountFor "joey"
-- > & User.hasSomePassword "joey"
-- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property
+cleanInstallOnce :: Confirmation -> Property NoInfo
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
@@ -88,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
(Just u@(System (Ubuntu _) _)) -> debootstrap u
_ -> error "os is not declared to be Debian or Ubuntu"
- debootstrap targetos = ensureProperty $ toProp $
+ debootstrap targetos = ensureProperty $
-- Ignore the os setting, and install debootstrap from
-- source, since we don't know what OS we're running in yet.
Debootstrap.built' Debootstrap.sourceInstall
@@ -179,7 +180,7 @@ massRename = go []
data Confirmation = Confirmed HostName
-confirmed :: Desc -> Confirmation -> Property
+confirmed :: Desc -> Confirmation -> Property NoInfo
confirmed desc (Confirmed c) = property desc $ do
hostname <- asks hostName
if hostname /= c
@@ -191,11 +192,21 @@ confirmed desc (Confirmed c) = property desc $ do
-- | </etc/network/interfaces> is configured to bring up the network
-- interface that currently has a default route configured, using
-- the same (static) IP address.
-preserveNetwork :: Property
-preserveNetwork = undefined -- TODO
+preserveNetwork :: Property NoInfo
+preserveNetwork = go `requires` Network.cleanInterfacesFile
+ where
+ go = property "preserve network configuration" $ do
+ ls <- liftIO $ lines <$> readProcess "ip"
+ ["route", "list", "scope", "global"]
+ case words <$> headMaybe ls of
+ Just ("default":"via":_:"dev":iface:_) ->
+ ensureProperty $ Network.static iface
+ _ -> do
+ warningMessage "did not find any default ipv4 route"
+ return FailedChange
-- | </etc/resolv.conf> is copied from the old OS
-preserveResolvConf :: Property
+preserveResolvConf :: Property NoInfo
preserveResolvConf = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do
ls <- liftIO $ lines <$> readFile oldloc
@@ -207,7 +218,7 @@ preserveResolvConf = check (fileExist oldloc) $
-- | </root/.ssh/authorized_keys> has added to it any ssh keys that
-- were authorized in the old OS. Any other contents of the file are
-- retained.
-preserveRootSshAuthorized :: Property
+preserveRootSshAuthorized :: Property NoInfo
preserveRootSshAuthorized = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do
ks <- liftIO $ lines <$> readFile oldloc
@@ -217,7 +228,7 @@ preserveRootSshAuthorized = check (fileExist oldloc) $
oldloc = oldOSDir ++ newloc
-- Removes the old OS's backup from </old-os>
-oldOSRemoved :: Confirmation -> Property
+oldOSRemoved :: Confirmation -> Property NoInfo
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation
where
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 4dc895ef..adaf255c 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -36,7 +36,7 @@ data NumClients = OnlyClient | MultipleClients
-- > `requires` Ssh.keyImported SshRsa "root" (Context hostname)
--
-- How awesome is that?
-backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
backup dir crontimes params numclients =
backup' dir crontimes params numclients
`requires` restored dir params
@@ -46,7 +46,7 @@ backup dir crontimes params numclients =
--
-- The gpg secret key will be automatically imported
-- into root's keyring using Propellor.Property.Gpg.keyImported
-backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property
+backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo
backupEncrypted dir crontimes params numclients keyid =
backup dir crontimes params' numclients
`requires` Gpg.keyImported keyid "root"
@@ -54,7 +54,7 @@ backupEncrypted dir crontimes params numclients keyid =
params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params
-- | Does a backup, but does not automatically restore.
-backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
backup' dir crontimes params numclients = cronjob `describe` desc
where
desc = dir ++ " backed up by obnam"
@@ -80,7 +80,7 @@ backup' dir crontimes params numclients = cronjob `describe` desc
--
-- The restore is performed atomically; restoring to a temp directory
-- and then moving it to the directory.
-restored :: FilePath -> [ObnamParam] -> Property
+restored :: FilePath -> [ObnamParam] -> Property NoInfo
restored dir params = property (dir ++ " restored by obnam") go
`requires` installed
where
@@ -108,17 +108,17 @@ restored dir params = property (dir ++ " restored by obnam") go
, return FailedChange
)
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["obnam"]
-- | Ensures that a recent version of obnam gets installed.
--
-- Only does anything for Debian Stable.
-latestVersion :: Property
+latestVersion :: Property NoInfo
latestVersion = withOS "obnam latest version" $ \o -> case o of
(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $
Apt.setSourcesListD (stablesources suite) "obnam"
- `requires` toProp (Apt.trustsKey key)
+ `requires` Apt.trustsKey' key
_ -> noChange
where
stablesources suite =
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index f8045027..7ecf345f 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -7,8 +7,8 @@ import qualified Propellor.Property.Service as Service
import Data.List
-providerFor :: [UserName] -> String -> Property
-providerFor users baseurl = propertyList desc $
+providerFor :: [UserName] -> String -> Property HasInfo
+providerFor users baseurl = propertyList desc $ map toProp
[ Apt.serviceInstalledRunning "apache2"
, Apt.installed ["simpleid"]
`onChange` Service.restarted "apache2"
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 7821b333..fbb1ea51 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.Postfix where
import Propellor
@@ -9,13 +11,13 @@ import qualified Data.Map as M
import Data.List
import Data.Char
-installed :: Property
+installed :: Property NoInfo
installed = Apt.serviceInstalledRunning "postfix"
-restarted :: Property
+restarted :: Property NoInfo
restarted = Service.restarted "postfix"
-reloaded :: Property
+reloaded :: Property NoInfo
reloaded = Service.reloaded "postfix"
-- | Configures postfix as a satellite system, which
@@ -24,7 +26,7 @@ reloaded = Service.reloaded "postfix"
-- The smarthost may refuse to relay mail on to other domains, without
-- futher coniguration/keys. But this should be enough to get cron job
-- mail flowing to a place where it will be seen.
-satellite :: Property
+satellite :: Property NoInfo
satellite = check (not <$> mainCfIsSet "relayhost") setup
`requires` installed
where
@@ -45,13 +47,17 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
-- | Sets up a file by running a property (which the filename is passed
-- to). If the setup property makes a change, postmap will be run on the
-- file, and postfix will be reloaded.
-mappedFile :: FilePath -> (FilePath -> Property) -> Property
+mappedFile
+ :: Combines (Property x) (Property NoInfo)
+ => FilePath
+ -> (FilePath -> Property x)
+ -> Property (CInfo x NoInfo)
mappedFile f setup = setup f
`onChange` cmdProperty "postmap" [f]
-- | Run newaliases command, which should be done after changing
-- </etc/aliases>.
-newaliases :: Property
+newaliases :: Property NoInfo
newaliases = trivial $ cmdProperty "newaliases" []
-- | The main config file for postfix.
@@ -59,7 +65,7 @@ mainCfFile :: FilePath
mainCfFile = "/etc/postfix/main.cf"
-- | Sets a main.cf name=value pair. Does not reload postfix immediately.
-mainCf :: (String, String) -> Property
+mainCf :: (String, String) -> Property NoInfo
mainCf (name, value) = check notset set
`describe` ("postfix main.cf " ++ setting)
where
@@ -77,8 +83,8 @@ getMainCf name = parse . lines <$> readProcess "postconf" [name]
(_, v) -> v
parse [] = Nothing
--- | Checks if a main.cf field is set. A field that is set to ""
--- is considered not set.
+-- | Checks if a main.cf field is set. A field that is set to
+-- the empty string is considered not set.
mainCfIsSet :: String -> IO Bool
mainCfIsSet name = do
v <- getMainCf name
@@ -96,7 +102,7 @@ mainCfIsSet name = do
--
-- Note that multiline configurations that continue onto the next line
-- are not currently supported.
-dedupMainCf :: Property
+dedupMainCf :: Property NoInfo
dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile
dedupCf :: [String] -> [String]
diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs
index 06e2355f..31b6a624 100644
--- a/src/Propellor/Property/Prosody.hs
+++ b/src/Propellor/Property/Prosody.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
type Conf = String
confEnabled :: Conf -> ConfigFile -> RevertableProperty
-confEnabled conf cf = RevertableProperty enable disable
+confEnabled conf cf = enable <!> disable
where
enable = check test prop
`describe` ("prosody conf enabled " ++ conf)
@@ -30,7 +30,7 @@ confEnabled conf cf = RevertableProperty enable disable
`requires` installed
`onChange` reloaded
-confAvailable :: Conf -> ConfigFile -> Property
+confAvailable :: Conf -> ConfigFile -> Property NoInfo
confAvailable conf cf = ("prosody conf available " ++ conf) ==>
confAvailPath conf `File.hasContent` (comment : cf)
where
@@ -42,11 +42,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" </> conf <.> "cfg.lua"
confValPath :: Conf -> FilePath
confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua"
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["prosody"]
-restarted :: Property
+restarted :: Property NoInfo
restarted = Service.restarted "prosody"
-reloaded :: Property
+reloaded :: Property NoInfo
reloaded = Service.reloaded "prosody"
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index ac6f3a44..750968ff 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -3,7 +3,7 @@ module Propellor.Property.Reboot where
import Propellor
import Utility.SafeCommand
-now :: Property
+now :: Property NoInfo
now = cmdProperty "reboot" []
`describe` "reboot now"
@@ -14,7 +14,7 @@ now = cmdProperty "reboot" []
--
-- The reboot can be forced to run, which bypasses the init system. Useful
-- if the init system might not be running for some reason.
-atEnd :: Bool -> (Result -> Bool) -> Property
+atEnd :: Bool -> (Result -> Bool) -> Property NoInfo
atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
endAction "rebooting" atend
return NoChange
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index f2911e50..06efacdf 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.Scheduled
( period
, periodParse
@@ -18,8 +20,8 @@ import qualified Data.Map as M
--
-- This uses the description of the Property to keep track of when it was
-- last run.
-period :: Property -> Recurrance -> Property
-period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do
+period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
+period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
lasttime <- liftIO $ getLastChecked (propertyDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
@@ -34,7 +36,7 @@ period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy ->
desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | Like period, but parse a human-friendly string.
-periodParse :: Property -> String -> Property
+periodParse :: Property NoInfo -> String -> Property NoInfo
periodParse prop s = case toRecurrance s of
Just recurrance -> period prop recurrance
Nothing -> property "periodParse" $ do
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index 93e959c6..8da502f7 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -12,16 +12,16 @@ type ServiceName = String
-- Note that due to the general poor state of init scripts, the best
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
-running :: ServiceName -> Property
+running :: ServiceName -> Property NoInfo
running = signaled "start" "running"
-restarted :: ServiceName -> Property
+restarted :: ServiceName -> Property NoInfo
restarted = signaled "restart" "restarted"
-reloaded :: ServiceName -> Property
+reloaded :: ServiceName -> Property NoInfo
reloaded = signaled "reload" "reloaded"
-signaled :: String -> Desc -> ServiceName -> Property
+signaled :: String -> Desc -> ServiceName -> Property NoInfo
signaled cmd desc svc = property (desc ++ " " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index bf87b210..7fc523f9 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.SiteSpecific.GitAnnexBuilder where
import Propellor
@@ -23,54 +25,56 @@ builddir = gitbuilderdir </> "build"
type TimeOut = String -- eg, 5h
-autobuilder :: Architecture -> CronTimes -> TimeOut -> Property
-autobuilder arch crontimes timeout = combineProperties "gitannexbuilder"
- [ Apt.serviceInstalledRunning "cron"
- , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $
- "git pull ; timeout " ++ timeout ++ " ./autobuild"
+autobuilder :: Architecture -> CronTimes -> TimeOut -> Property HasInfo
+autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
+ & Apt.serviceInstalledRunning "cron"
+ & Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir
+ ("git pull ; timeout " ++ timeout ++ " ./autobuild")
+ & rsyncpassword
+ where
+ context = Context ("gitannexbuilder " ++ arch)
+ pwfile = homedir </> "rsyncpassword"
-- The builduser account does not have a password set,
-- instead use the password privdata to hold the rsync server
-- password used to upload the built image.
- , withPrivData (Password builduser) context $ \getpw ->
+ rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
property "rsync password" $ getpw $ \pw -> do
oldpw <- liftIO $ catchDefaultIO "" $
readFileStrict pwfile
if pw /= oldpw
then makeChange $ writeFile pwfile pw
else noChange
- ]
- where
- context = Context ("gitannexbuilder " ++ arch)
- pwfile = homedir </> "rsyncpassword"
-tree :: Architecture -> Property
-tree buildarch = combineProperties "gitannexbuilder tree"
- [ Apt.installed ["git"]
+tree :: Architecture -> Property HasInfo
+tree buildarch = combineProperties "gitannexbuilder tree" $ props
+ & Apt.installed ["git"]
-- gitbuilderdir directory already exists when docker volume is used,
-- but with wrong owner.
- , File.dirExists gitbuilderdir
- , File.ownerGroup gitbuilderdir builduser builduser
- , check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
+ & File.dirExists gitbuilderdir
+ & File.ownerGroup gitbuilderdir builduser builduser
+ & gitannexbuildercloned
+ & builddircloned
+ where
+ gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
userScriptProperty builduser
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
, "cd " ++ gitbuilderdir
, "git checkout " ++ buildarch
]
`describe` "gitbuilder setup"
- , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
+ builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
[ "git clone git://git-annex.branchable.com/ " ++ builddir
]
- ]
-buildDepsApt :: Property
-buildDepsApt = combineProperties "gitannexbuilder build deps"
- [ Apt.buildDep ["git-annex"]
- , Apt.installed ["liblockfile-simple-perl"]
- , buildDepsNoHaskellLibs
- , "git-annex source build deps installed" ==> Apt.buildDepIn builddir
- ]
+buildDepsApt :: Property HasInfo
+buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
+ & Apt.buildDep ["git-annex"]
+ & Apt.installed ["liblockfile-simple-perl"]
+ & buildDepsNoHaskellLibs
+ & Apt.buildDepIn builddir
+ `describe` "git-annex source build deps installed"
-buildDepsNoHaskellLibs :: Property
+buildDepsNoHaskellLibs :: Property NoInfo
buildDepsNoHaskellLibs = Apt.installed
["git", "rsync", "moreutils", "ca-certificates",
"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",
@@ -82,7 +86,7 @@ buildDepsNoHaskellLibs = Apt.installed
-- Installs current versions of git-annex's deps from cabal, but only
-- does so once.
-cabalDeps :: Property
+cabalDeps :: Property NoInfo
cabalDeps = flagFile go cabalupdated
where
go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
@@ -108,7 +112,13 @@ androidAutoBuilderContainer dockerImage crontimes timeout =
& autobuilder "android" crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container
+androidContainer
+ :: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
+ => (System -> Docker.Image)
+ -> Docker.ContainerName
+ -> Property i
+ -> FilePath
+ -> Docker.Container
androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
(dockerImage osver)
& os osver
diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs
index 6ed02146..59e62d80 100644
--- a/src/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/src/Propellor/Property/SiteSpecific/GitHome.hs
@@ -6,7 +6,7 @@ import Propellor.Property.User
import Utility.SafeCommand
-- | Clones Joey Hess's git home directory, and runs its fixups script.
-installedFor :: UserName -> Property
+installedFor :: UserName -> Property NoInfo
installedFor user = check (not <$> hasGitDir user) $
property ("githome " ++ user) (go =<< liftIO (homedir user))
`requires` Apt.installed ["git"]
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index a2eb44b0..34a5f02f 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -22,22 +22,18 @@ import Data.List
import System.Posix.Files
import Data.String.Utils
-oldUseNetServer :: [Host] -> Property
-oldUseNetServer hosts = propertyList ("olduse.net server")
- [ oldUseNetInstalled "oldusenet-server"
- , Obnam.latestVersion
- , Obnam.backup datadir "33 4 * * *"
- [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
- , "--client-name=spool"
- ] Obnam.OnlyClient
- `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net")
- `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
- , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $
- property "olduse.net spool in place" $ makeChange $ do
+oldUseNetServer :: [Host] -> Property HasInfo
+oldUseNetServer hosts = propertyList "olduse.net server" $ props
+ & oldUseNetInstalled "oldusenet-server"
+ & Obnam.latestVersion
+ & oldUseNetBackup
+ & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
+ (property "olduse.net spool in place" $ makeChange $ do
removeDirectoryRecursive newsspool
createSymbolicLink (datadir </> "news") newsspool
- , Apt.installed ["leafnode"]
- , "/etc/news/leafnode/config" `File.hasContent`
+ )
+ & Apt.installed ["leafnode"]
+ & "/etc/news/leafnode/config" `File.hasContent`
[ "# olduse.net configuration (deployed by propellor)"
, "expire = 1000000" -- no expiry via texpire
, "server = " -- no upstream server
@@ -45,17 +41,22 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
, "allowSTRANGERS = 42" -- lets anyone connect
, "nopost = 1" -- no new posting (just gather them)
]
- , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
- , Apt.serviceInstalledRunning "openbsd-inetd"
- , File.notPresent "/etc/cron.daily/leafnode"
- , File.notPresent "/etc/cron.d/leafnode"
- , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";"
+ & "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
+ & Apt.serviceInstalledRunning "openbsd-inetd"
+ & File.notPresent "/etc/cron.daily/leafnode"
+ & File.notPresent "/etc/cron.d/leafnode"
+ & Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool expirecommand
+ & Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" uucpcommand
+ & Apache.siteEnabled "nntp.olduse.net" nntpcfg
+ where
+ newsspool = "/var/spool/news"
+ datadir = "/var/spool/oldusenet"
+ expirecommand = intercalate ";"
[ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm"
, "find -type d -empty | xargs --no-run-if-empty rmdir"
]
- , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $
- "/usr/bin/uucp " ++ datadir
- , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False
+ uucpcommand = "/usr/bin/uucp " ++ datadir
+ nntpcfg = apachecfg "nntp.olduse.net" False
[ " DocumentRoot " ++ datadir ++ "/"
, " <Directory " ++ datadir ++ "/>"
, " Options Indexes FollowSymlinks"
@@ -63,23 +64,25 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
, Apache.allowAll
, " </Directory>"
]
- ]
- where
- newsspool = "/var/spool/news"
- datadir = "/var/spool/oldusenet"
-oldUseNetShellBox :: Property
-oldUseNetShellBox = propertyList "olduse.net shellbox"
- [ oldUseNetInstalled "oldusenet"
- , Service.running "shellinabox"
- ]
+ oldUseNetBackup = Obnam.backup datadir "33 4 * * *"
+ [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
+ , "--client-name=spool"
+ ] Obnam.OnlyClient
+ `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net")
+ `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
-oldUseNetInstalled :: Apt.Package -> Property
+oldUseNetShellBox :: Property HasInfo
+oldUseNetShellBox = propertyList "olduse.net shellbox" $ props
+ & oldUseNetInstalled "oldusenet"
+ & Service.running "shellinabox"
+
+oldUseNetInstalled :: Apt.Package -> Property HasInfo
oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
- propertyList ("olduse.net " ++ pkg)
- [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
+ propertyList ("olduse.net " ++ pkg) $ props
+ & Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
`describe` "olduse.net build deps"
- , scriptProperty
+ & scriptProperty
[ "rm -rf /root/tmp/oldusenet" -- idenpotency
, "git clone git://olduse.net/ /root/tmp/oldusenet/source"
, "cd /root/tmp/oldusenet/source/"
@@ -88,12 +91,15 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
, "apt-get -fy install" -- dependencies
, "rm -rf /root/tmp/oldusenet"
] `describe` "olduse.net built"
- ]
-
-kgbServer :: Property
-kgbServer = propertyList desc
- [ withOS desc $ \o -> case o of
+kgbServer :: Property HasInfo
+kgbServer = propertyList desc $ props
+ & installed
+ & File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
+ `onChange` Service.restarted "kgb-bot"
+ where
+ desc = "kgb.kitenet.net setup"
+ installed = withOS desc $ \o -> case o of
(Just (System (Debian Unstable) _)) ->
ensureProperty $ propertyList desc
[ Apt.serviceInstalledRunning "kgb-bot"
@@ -102,28 +108,22 @@ kgbServer = propertyList desc
`onChange` Service.running "kgb-bot"
]
_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
- , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
- `onChange` Service.restarted "kgb-bot"
- ]
- where
- desc = "kgb.kitenet.net setup"
-mumbleServer :: [Host] -> Property
-mumbleServer hosts = combineProperties hn
- [ Apt.serviceInstalledRunning "mumble-server"
- , Obnam.latestVersion
- , Obnam.backup "/var/lib/mumble-server" "55 5 * * *"
+mumbleServer :: [Host] -> Property HasInfo
+mumbleServer hosts = combineProperties hn $ props
+ & Apt.serviceInstalledRunning "mumble-server"
+ & Obnam.latestVersion
+ & Obnam.backup "/var/lib/mumble-server" "55 5 * * *"
[ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam"
, "--client-name=mumble"
] Obnam.OnlyClient
`requires` Ssh.keyImported SshRsa "root" (Context hn)
`requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root"
- , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]
- ]
+ & trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"])
where
hn = "mumble.debian.net"
-obnamLowMem :: Property
+obnamLowMem :: Property NoInfo
obnamLowMem = combineProperties "obnam tuned for low memory use"
[ Obnam.latestVersion
, "/etc/obnam.conf" `File.containsLines`
@@ -135,10 +135,10 @@ obnamLowMem = combineProperties "obnam tuned for low memory use"
]
-- git.kitenet.net and git.joeyh.name
-gitServer :: [Host] -> Property
-gitServer hosts = propertyList "git.kitenet.net setup"
- [ Obnam.latestVersion
- , Obnam.backupEncrypted "/srv/git" "33 3 * * *"
+gitServer :: [Host] -> Property HasInfo
+gitServer hosts = propertyList "git.kitenet.net setup" $ props
+ & Obnam.latestVersion
+ & Obnam.backupEncrypted "/srv/git" "33 3 * * *"
[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
, "--client-name=wren" -- historical
] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1")
@@ -146,14 +146,14 @@ gitServer hosts = propertyList "git.kitenet.net setup"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
`requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net")
`requires` User.accountFor "family"
- , Apt.installed ["git", "rsync", "gitweb"]
+ & Apt.installed ["git", "rsync", "gitweb"]
-- backport avoids channel flooding on branch merge
- , Apt.installedBackport ["kgb-client"]
+ & Apt.installedBackport ["kgb-client"]
-- backport supports ssh event notification
- , Apt.installedBackport ["git-annex"]
- , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext
- , toProp $ Git.daemonRunning "/srv/git"
- , "/etc/gitweb.conf" `File.containsLines`
+ & Apt.installedBackport ["git-annex"]
+ & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext
+ & Git.daemonRunning "/srv/git"
+ & "/etc/gitweb.conf" `File.containsLines`
[ "$projectroot = '/srv/git';"
, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
, "# disable snapshot download; overloads server"
@@ -161,15 +161,14 @@ gitServer hosts = propertyList "git.kitenet.net setup"
]
`describe` "gitweb configured"
-- Repos push on to github.
- , Ssh.knownHost hosts "github.com" "joey"
+ & Ssh.knownHost hosts "github.com" "joey"
-- I keep the website used for gitweb checked into git..
- , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
- , website "git.kitenet.net"
- , website "git.joeyh.name"
- , toProp $ Apache.modEnabled "cgi"
- ]
+ & Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+ & website "git.kitenet.net"
+ & website "git.joeyh.name"
+ & Apache.modEnabled "cgi"
where
- website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True
+ website hn = apacheSite hn True
[ " DocumentRoot /srv/web/git.kitenet.net/"
, " <Directory /srv/web/git.kitenet.net/>"
, " Options Indexes ExecCGI FollowSymlinks"
@@ -188,18 +187,17 @@ gitServer hosts = propertyList "git.kitenet.net setup"
type AnnexUUID = String
-- | A website, with files coming from a git-annex repository.
-annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property
-annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex")
- [ Git.cloned "joey" origin dir Nothing
+annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo
+annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props
+ & Git.cloned "joey" origin dir Nothing
`onChange` setup
- , alias hn
- , postupdatehook `File.hasContent`
+ & alias hn
+ & postupdatehook `File.hasContent`
[ "#!/bin/sh"
, "exec git update-server-info"
] `onChange`
(postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes)))
- , setupapache
- ]
+ & setupapache
where
dir = "/srv/web/" ++ hn
postupdatehook = dir </> ".git/hooks/post-update"
@@ -212,7 +210,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, "git update-server-info"
]
addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url
- setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $
+ setupapache = apacheSite hn True
[ " ServerAlias www."++hn
, ""
, " DocumentRoot /srv/web/"++hn
@@ -230,6 +228,9 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, " </Directory>"
]
+apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty
+apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle
+
apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
apachecfg hn withssl middle
| withssl = vhost False ++ vhost True
@@ -268,20 +269,19 @@ mainhttpscert True =
, " SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
]
-gitAnnexDistributor :: Property
-gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer"
- [ Apt.installed ["rsync"]
- , File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
+gitAnnexDistributor :: Property HasInfo
+gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
+ & Apt.installed ["rsync"]
+ & File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
`onChange` Service.restarted "rsync"
- , File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor")
+ & File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor")
`onChange` Service.restarted "rsync"
- , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
+ & "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
`onChange` Service.running "rsync"
- , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
- , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"
+ & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
+ & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"
-- git-annex distribution signing key
- , Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey"
- ]
+ & Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey"
where
endpoint d = combineProperties ("endpoint " ++ d)
[ File.dirExists d
@@ -289,50 +289,48 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
]
-- Twitter, you kill us.
-twitRss :: Property
-twitRss = combineProperties "twitter rss"
- [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing
- , check (not <$> doesFileExist (dir </> "twitRss")) $
- userScriptProperty "joey"
- [ "cd " ++ dir
- , "ghc --make twitRss"
- ]
- `requires` Apt.installed
- [ "libghc-xml-dev"
- , "libghc-feed-dev"
- , "libghc-tagsoup-dev"
- ]
- , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
- , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
- ]
+twitRss :: Property HasInfo
+twitRss = combineProperties "twitter rss" $ props
+ & Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing
+ & check (not <$> doesFileExist (dir </> "twitRss")) compiled
+ & feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
+ & feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
where
dir = "/srv/web/tmp.kitenet.net/twitrss"
crontime = "15 * * * *"
feed url desc = Cron.job desc crontime "joey" dir $
"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
+ compiled = userScriptProperty "joey"
+ [ "cd " ++ dir
+ , "ghc --make twitRss"
+ ]
+ `requires` Apt.installed
+ [ "libghc-xml-dev"
+ , "libghc-feed-dev"
+ , "libghc-tagsoup-dev"
+ ]
-- Work around for expired ssl cert.
-- (no longer expired, TODO remove this and change urls)
-pumpRss :: Property
+pumpRss :: Property NoInfo
pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/"
"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null"
-ircBouncer :: Property
-ircBouncer = propertyList "IRC bouncer"
- [ Apt.installed ["znc"]
- , User.accountFor "znc"
- , File.dirExists (takeDirectory conf)
- , File.hasPrivContent conf anyContext
- , File.ownerGroup conf "znc" "znc"
- , Cron.job "znconboot" "@reboot" "znc" "~" "znc"
+ircBouncer :: Property HasInfo
+ircBouncer = propertyList "IRC bouncer" $ props
+ & Apt.installed ["znc"]
+ & User.accountFor "znc"
+ & File.dirExists (takeDirectory conf)
+ & File.hasPrivContent conf anyContext
+ & File.ownerGroup conf "znc" "znc"
+ & Cron.job "znconboot" "@reboot" "znc" "~" "znc"
-- ensure running if it was not already
- , trivial $ userScriptProperty "znc" ["znc || true"]
+ & trivial (userScriptProperty "znc" ["znc || true"])
`describe` "znc running"
- ]
where
conf = "/home/znc/.znc/configs/znc.conf"
-kiteShellBox :: Property
+kiteShellBox :: Property NoInfo
kiteShellBox = propertyList "kitenet.net shellinabox"
[ Apt.installed ["shellinabox"]
, File.hasContent "/etc/default/shellinabox"
@@ -345,28 +343,34 @@ kiteShellBox = propertyList "kitenet.net shellinabox"
, Service.running "shellinabox"
]
-githubBackup :: Property
-githubBackup = propertyList "github-backup box"
- [ Apt.installed ["github-backup", "moreutils"]
- , let f = "/home/joey/.github-keys"
- in File.hasPrivContent f anyContext
- `onChange` File.ownerGroup f "joey" "joey"
- , Cron.niceJob "github-backup run" "30 4 * * *" "joey"
- "/home/joey/lib/backup" $ intercalate "&&" $
- [ "mkdir -p github"
- , "cd github"
- , ". $HOME/.github-keys"
- , "github-backup joeyh"
- ]
- , Cron.niceJob "gitriddance" "30 4 * * *" "joey"
- "/home/joey/lib/backup" $ intercalate "&&" $
- [ "cd github"
- , ". $HOME/.github-keys"
- ] ++ map gitriddance githubMirrors
- ]
+githubBackup :: Property HasInfo
+githubBackup = propertyList "github-backup box" $ props
+ & Apt.installed ["github-backup", "moreutils"]
+ & githubKeys
+ & Cron.niceJob "github-backup run" "30 4 * * *" "joey"
+ "/home/joey/lib/backup" backupcmd
+ & Cron.niceJob "gitriddance" "30 4 * * *" "joey"
+ "/home/joey/lib/backup" gitriddancecmd
where
+ backupcmd = intercalate "&&" $
+ [ "mkdir -p github"
+ , "cd github"
+ , ". $HOME/.github-keys"
+ , "github-backup joeyh"
+ ]
+ gitriddancecmd = intercalate "&&" $
+ [ "cd github"
+ , ". $HOME/.github-keys"
+ ] ++ map gitriddance githubMirrors
gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
+githubKeys :: Property HasInfo
+githubKeys =
+ let f = "/home/joey/.github-keys"
+ in File.hasPrivContent f anyContext
+ `onChange` File.ownerGroup f "joey" "joey"
+
+
-- these repos are only mirrored on github, I don't want
-- all the proprietary features
githubMirrors :: [(String, String)]
@@ -380,12 +384,12 @@ githubMirrors =
where
plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests"
-rsyncNetBackup :: [Host] -> Property
+rsyncNetBackup :: [Host] -> Property NoInfo
rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *"
"joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "joey"
-backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property
+backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property NoInfo
backupsBackedupTo hosts desthost destdir = Cron.niceJob desc
"1 1 * * 3" "joey" "/" cmd
`requires` Ssh.knownHost hosts desthost "joey"
@@ -393,7 +397,7 @@ backupsBackedupTo hosts desthost destdir = Cron.niceJob desc
desc = "backups copied to " ++ desthost ++ " weekly"
cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir
-obnamRepos :: [String] -> Property
+obnamRepos :: [String] -> Property NoInfo
obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
(mkbase : map mkrepo rs)
where
@@ -403,23 +407,22 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
mkdir d = File.dirExists d
`before` File.ownerGroup d "joey" "joey"
-podcatcher :: Property
+podcatcher :: Property NoInfo
podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *"
"joey" "/home/joey/lib/sound/podcasts"
"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update"
`requires` Apt.installed ["git-annex", "myrepos"]
-kiteMailServer :: Property
-kiteMailServer = propertyList "kitenet.net mail server"
- [ Postfix.installed
- , Apt.installed ["postfix-pcre"]
- , Apt.serviceInstalledRunning "postgrey"
+kiteMailServer :: Property HasInfo
+kiteMailServer = propertyList "kitenet.net mail server" $ props
+ & Postfix.installed
+ & Apt.installed ["postfix-pcre"]
+ & Apt.serviceInstalledRunning "postgrey"
- , Apt.serviceInstalledRunning "spamassassin"
- , "/etc/default/spamassassin" `File.containsLines`
+ & Apt.serviceInstalledRunning "spamassassin"
+ & "/etc/default/spamassassin" `File.containsLines`
[ "# Propellor deployed"
, "ENABLED=1"
- , "CRON=1"
, "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\""
, "CRON=1"
, "NICE=\"--nicelevel 15\""
@@ -427,15 +430,15 @@ kiteMailServer = propertyList "kitenet.net mail server"
`describe` "spamd enabled"
`requires` Apt.serviceInstalledRunning "cron"
- , Apt.serviceInstalledRunning "spamass-milter"
+ & Apt.serviceInstalledRunning "spamass-milter"
-- Add -m to prevent modifying messages Subject or body.
- , "/etc/default/spamass-milter" `File.containsLine`
+ & "/etc/default/spamass-milter" `File.containsLine`
"OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\""
`onChange` Service.restarted "spamass-milter"
`describe` "spamass-milter configured"
- , Apt.serviceInstalledRunning "amavisd-milter"
- , "/etc/default/amavisd-milter" `File.containsLines`
+ & Apt.serviceInstalledRunning "amavisd-milter"
+ & "/etc/default/amavisd-milter" `File.containsLines`
[ "# Propellor deployed"
, "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock"
, "MILTERSOCKETOWNER=\"postfix:postfix\""
@@ -443,12 +446,12 @@ kiteMailServer = propertyList "kitenet.net mail server"
]
`onChange` Service.restarted "amavisd-milter"
`describe` "amavisd-milter configured for postfix"
- , Apt.serviceInstalledRunning "clamav-freshclam"
+ & Apt.serviceInstalledRunning "clamav-freshclam"
- , dkimInstalled
+ & dkimInstalled
- , Apt.installed ["maildrop"]
- , "/etc/maildroprc" `File.hasContent`
+ & Apt.installed ["maildrop"]
+ & "/etc/maildroprc" `File.hasContent`
[ "# Global maildrop filter file (deployed with propellor)"
, "DEFAULT=\"$HOME/Maildir\""
, "MAILBOX=\"$DEFAULT/.\""
@@ -462,19 +465,19 @@ kiteMailServer = propertyList "kitenet.net mail server"
]
`describe` "maildrop configured"
- , "/etc/aliases" `File.hasPrivContentExposed` ctx
+ & "/etc/aliases" `File.hasPrivContentExposed` ctx
`onChange` Postfix.newaliases
- , hasJoeyCAChain
- , hasPostfixCert ctx
+ & hasJoeyCAChain
+ & hasPostfixCert ctx
- , "/etc/postfix/mydomain" `File.containsLines`
+ & "/etc/postfix/mydomain" `File.containsLines`
[ "/.*\\.kitenet\\.net/\tOK"
, "/ikiwiki\\.info/\tOK"
, "/joeyh\\.name/\tOK"
]
`onChange` Postfix.reloaded
`describe` "postfix mydomain file configured"
- , "/etc/postfix/obscure_client_relay.pcre" `File.hasContent`
+ & "/etc/postfix/obscure_client_relay.pcre" `File.hasContent`
-- Remove received lines for mails relayed from trusted
-- clients. These can be a privacy violation, or trigger
-- spam filters.
@@ -486,16 +489,16 @@ kiteMailServer = propertyList "kitenet.net mail server"
]
`onChange` Postfix.reloaded
`describe` "postfix obscure_client_relay file configured"
- , Postfix.mappedFile "/etc/postfix/virtual"
+ & Postfix.mappedFile "/etc/postfix/virtual"
(flip File.containsLines
[ "# *@joeyh.name to joey"
, "@joeyh.name\tjoey"
]
) `describe` "postfix virtual file configured"
`onChange` Postfix.reloaded
- , Postfix.mappedFile "/etc/postfix/relay_clientcerts" $
- flip File.hasPrivContentExposed ctx
- , Postfix.mainCfFile `File.containsLines`
+ & Postfix.mappedFile "/etc/postfix/relay_clientcerts"
+ (flip File.hasPrivContentExposed ctx)
+ & Postfix.mainCfFile `File.containsLines`
[ "myhostname = kitenet.net"
, "mydomain = $myhostname"
, "append_dot_mydomain = no"
@@ -544,24 +547,24 @@ kiteMailServer = propertyList "kitenet.net mail server"
`onChange` Postfix.reloaded
`describe` "postfix configured"
- , Apt.serviceInstalledRunning "dovecot-imapd"
- , Apt.serviceInstalledRunning "dovecot-pop3d"
- , "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
+ & Apt.serviceInstalledRunning "dovecot-imapd"
+ & Apt.serviceInstalledRunning "dovecot-pop3d"
+ & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
"mail_location = maildir:~/Maildir"
`onChange` Service.reloaded "dovecot"
`describe` "dovecot mail.conf"
- , "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine`
+ & "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine`
"!include auth-passwdfile.conf.ext"
`onChange` Service.restarted "dovecot"
`describe` "dovecot auth.conf"
- , File.hasPrivContent dovecotusers ctx
+ & File.hasPrivContent dovecotusers ctx
`onChange` (dovecotusers `File.mode`
combineModes [ownerReadMode, groupReadMode])
- , File.ownerGroup dovecotusers "root" "dovecot"
+ & File.ownerGroup dovecotusers "root" "dovecot"
- , Apt.installed ["mutt", "bsd-mailx", "alpine"]
+ & Apt.installed ["mutt", "bsd-mailx", "alpine"]
- , pinescript `File.hasContent`
+ & pinescript `File.hasContent`
[ "#!/bin/sh"
, "# deployed with propellor"
, "set -e"
@@ -575,14 +578,13 @@ kiteMailServer = propertyList "kitenet.net mail server"
`onChange` (pinescript `File.mode`
combineModes (readModes ++ executeModes))
`describe` "pine wrapper script"
- , "/etc/pine.conf" `File.hasContent`
+ & "/etc/pine.conf" `File.hasContent`
[ "# deployed with propellor"
, "inbox-path={localhost/novalidate-cert/NoRsh}inbox"
]
`describe` "pine configured to use local imap server"
- , Apt.serviceInstalledRunning "mailman"
- ]
+ & Apt.serviceInstalledRunning "mailman"
where
ctx = Context "kitenet.net"
pinescript = "/usr/local/bin/pine"
@@ -590,7 +592,7 @@ kiteMailServer = propertyList "kitenet.net mail server"
-- Configures postfix to relay outgoing mail to kitenet.net, with
-- verification via tls cert.
-postfixClientRelay :: Context -> Property
+postfixClientRelay :: Context -> Property HasInfo
postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
[ "relayhost = kitenet.net"
, "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem"
@@ -606,7 +608,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
`requires` hasPostfixCert ctx
-- Configures postfix to have the dkim milter, and no other milters.
-dkimMilter :: Property
+dkimMilter :: Property HasInfo
dkimMilter = Postfix.mainCfFile `File.containsLines`
[ "smtpd_milters = inet:localhost:8891"
, "non_smtpd_milters = inet:localhost:8891"
@@ -619,22 +621,22 @@ dkimMilter = Postfix.mainCfFile `File.containsLines`
-- This does not configure postfix to use the dkim milter,
-- nor does it set up domainkey DNS.
-dkimInstalled :: Property
-dkimInstalled = propertyList "opendkim installed"
- [ Apt.serviceInstalledRunning "opendkim"
- , File.dirExists "/etc/mail"
- , File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net")
- , File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim"
- , "/etc/default/opendkim" `File.containsLine`
- "SOCKET=\"inet:8891@localhost\""
- , "/etc/opendkim.conf" `File.containsLines`
- [ "KeyFile /etc/mail/dkim.key"
- , "SubDomains yes"
- , "Domain *"
- , "Selector mail"
- ]
- ]
- `onChange` Service.restarted "opendkim"
+dkimInstalled :: Property HasInfo
+dkimInstalled = go `onChange` Service.restarted "opendkim"
+ where
+ go = propertyList "opendkim installed" $ props
+ & Apt.serviceInstalledRunning "opendkim"
+ & File.dirExists "/etc/mail"
+ & File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net")
+ & File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim"
+ & "/etc/default/opendkim" `File.containsLine`
+ "SOCKET=\"inet:8891@localhost\""
+ & "/etc/opendkim.conf" `File.containsLines`
+ [ "KeyFile /etc/mail/dkim.key"
+ , "SubDomains yes"
+ , "Domain *"
+ , "Selector mail"
+ ]
-- This is the dkim public key, corresponding with /etc/mail/dkim.key
-- This value can be included in a domain's additional records to make
@@ -642,37 +644,36 @@ dkimInstalled = propertyList "opendkim installed"
domainKey :: (BindDomain, Record)
domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
-hasJoeyCAChain :: Property
+hasJoeyCAChain :: Property HasInfo
hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
Context "joeyca.pem"
-hasPostfixCert :: Context -> Property
+hasPostfixCert :: Context -> Property HasInfo
hasPostfixCert ctx = combineProperties "postfix tls cert installed"
[ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
, "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
]
-kitenetHttps :: Property
-kitenetHttps = propertyList "kitenet.net https certs"
- [ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
- , File.hasPrivContent "/etc/ssl/private/web.pem" ctx
- , File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx
- , toProp $ Apache.modEnabled "ssl"
- ]
+kitenetHttps :: Property HasInfo
+kitenetHttps = propertyList "kitenet.net https certs" $ props
+ & File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
+ & File.hasPrivContent "/etc/ssl/private/web.pem" ctx
+ & File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx
+ & Apache.modEnabled "ssl"
where
ctx = Context "kitenet.net"
-- Legacy static web sites and redirections from kitenet.net to newer
-- sites.
-legacyWebSites :: Property
-legacyWebSites = propertyList "legacy web sites"
- [ Apt.serviceInstalledRunning "apache2"
- , toProp $ Apache.modEnabled "rewrite"
- , toProp $ Apache.modEnabled "cgi"
- , toProp $ Apache.modEnabled "speling"
- , userDirHtml
- , kitenetHttps
- , toProp $ Apache.siteEnabled "kitenet.net" $ apachecfg "kitenet.net" True
+legacyWebSites :: Property HasInfo
+legacyWebSites = propertyList "legacy web sites" $ props
+ & Apt.serviceInstalledRunning "apache2"
+ & Apache.modEnabled "rewrite"
+ & Apache.modEnabled "cgi"
+ & Apache.modEnabled "speling"
+ & userDirHtml
+ & kitenetHttps
+ & apacheSite "kitenet.net" True
-- /var/www is empty
[ "DocumentRoot /var/www"
, "<Directory /var/www>"
@@ -759,8 +760,8 @@ legacyWebSites = propertyList "legacy web sites"
, "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]"
, "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]"
]
- , alias "anna.kitenet.net"
- , toProp $ Apache.siteEnabled "anna.kitenet.net" $ apachecfg "anna.kitenet.net" False
+ & alias "anna.kitenet.net"
+ & apacheSite "anna.kitenet.net" False
[ "DocumentRoot /home/anna/html"
, "<Directory /home/anna/html/>"
, " Options Indexes ExecCGI"
@@ -768,9 +769,9 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , alias "sows-ear.kitenet.net"
- , alias "www.sows-ear.kitenet.net"
- , toProp $ Apache.siteEnabled "sows-ear.kitenet.net" $ apachecfg "sows-ear.kitenet.net" False
+ & alias "sows-ear.kitenet.net"
+ & alias "www.sows-ear.kitenet.net"
+ & apacheSite "sows-ear.kitenet.net" False
[ "ServerAlias www.sows-ear.kitenet.net"
, "DocumentRoot /srv/web/sows-ear.kitenet.net"
, "<Directory /srv/web/sows-ear.kitenet.net>"
@@ -779,9 +780,9 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , alias "wortroot.kitenet.net"
- , alias "www.wortroot.kitenet.net"
- , toProp $ Apache.siteEnabled "wortroot.kitenet.net" $ apachecfg "wortroot.kitenet.net" False
+ & alias "wortroot.kitenet.net"
+ & alias "www.wortroot.kitenet.net"
+ & apacheSite "wortroot.kitenet.net" False
[ "ServerAlias www.wortroot.kitenet.net"
, "DocumentRoot /srv/web/wortroot.kitenet.net"
, "<Directory /srv/web/wortroot.kitenet.net>"
@@ -790,8 +791,8 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , alias "creeksidepress.com"
- , toProp $ Apache.siteEnabled "creeksidepress.com" $ apachecfg "creeksidepress.com" False
+ & alias "creeksidepress.com"
+ & apacheSite "creeksidepress.com" False
[ "ServerAlias www.creeksidepress.com"
, "DocumentRoot /srv/web/www.creeksidepress.com"
, "<Directory /srv/web/www.creeksidepress.com>"
@@ -800,8 +801,8 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , alias "joey.kitenet.net"
- , toProp $ Apache.siteEnabled "joey.kitenet.net" $ apachecfg "joey.kitenet.net" False
+ & alias "joey.kitenet.net"
+ & apacheSite "joey.kitenet.net" False
[ "DocumentRoot /var/www"
, "<Directory /var/www/>"
, " Options Indexes ExecCGI"
@@ -821,12 +822,12 @@ legacyWebSites = propertyList "legacy web sites"
, "# Redirect all to joeyh.name."
, "rewriterule (.*) http://joeyh.name$1 [r]"
]
- ]
-userDirHtml :: Property
+userDirHtml :: Property HasInfo
userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
`onChange` Apache.reloaded
`requires` (toProp $ Apache.modEnabled "userdir")
where
munge = replace "public_html" "html"
conf = "/etc/apache2/mods-available/userdir.conf"
+
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 238e67e4..9290ea1e 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -1,4 +1,5 @@
module Propellor.Property.Ssh (
+ PubKeyText,
setSshdConfig,
permitRootLogin,
passwordAuthentication,
@@ -35,7 +36,7 @@ sshBool False = "no"
sshdConfig :: FilePath
sshdConfig = "/etc/ssh/sshd_config"
-setSshdConfig :: String -> Bool -> Property
+setSshdConfig :: String -> Bool -> Property NoInfo
setSshdConfig setting allowed = combineProperties "sshd config"
[ sshdConfig `File.lacksLine` (sshline $ not allowed)
, sshdConfig `File.containsLine` (sshline allowed)
@@ -45,10 +46,10 @@ setSshdConfig setting allowed = combineProperties "sshd config"
where
sshline v = setting ++ " " ++ sshBool v
-permitRootLogin :: Bool -> Property
+permitRootLogin :: Bool -> Property NoInfo
permitRootLogin = setSshdConfig "PermitRootLogin"
-passwordAuthentication :: Bool -> Property
+passwordAuthentication :: Bool -> Property NoInfo
passwordAuthentication = setSshdConfig "PasswordAuthentication"
dotDir :: UserName -> IO FilePath
@@ -66,13 +67,13 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys"
where
go f = not . null <$> catchDefaultIO "" (readFile f)
-restarted :: Property
+restarted :: Property NoInfo
restarted = Service.restarted "ssh"
-- | Blows away existing host keys and make new ones.
-- Useful for systems installed from an image that might reuse host keys.
-- A flag file is used to only ever do this once.
-randomHostKeys :: Property
+randomHostKeys :: Property NoInfo
randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restarted
where
@@ -89,7 +90,7 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
-- The corresponding private keys come from the privdata.
--
-- Any host keysthat are not in the list are removed from the host.
-hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property
+hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
hostKeys ctx l = propertyList desc $ catMaybes $
map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
where
@@ -100,19 +101,20 @@ hostKeys ctx l = propertyList desc $ catMaybes $
removestale b = map (File.notPresent . flip keyFile b) staletypes
cleanup
| null staletypes || null l = Nothing
- | otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $
- ensureProperty $
- combineProperties desc (removestale True ++ removestale False)
- `onChange` restarted
+ | otherwise = Just $ toProp $
+ property ("any other ssh host keys removed " ++ typelist staletypes) $
+ ensureProperty $
+ combineProperties desc (removestale True ++ removestale False)
+ `onChange` restarted
-- | Installs a single ssh host key of a particular type.
--
-- The public key is provided to this function;
-- the private key comes from the privdata;
-hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property
+hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
hostKey context keytype pub = combineProperties desc
[ pubKey keytype pub
- , property desc $ install writeFile True pub
+ , toProp $ property desc $ install writeFile True pub
, withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
property desc $ getkey $ install writeFileProtected False
]
@@ -136,7 +138,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
-- | Indicates the host key that is used by a Host, but does not actually
-- configure the host to use it. Normally this does not need to be used;
-- use 'hostKey' instead.
-pubKey :: SshKeyType -> PubKeyText -> Property
+pubKey :: SshKeyType -> PubKeyText -> Property HasInfo
pubKey t k = pureInfoProperty ("ssh pubkey known") $
mempty { _sshPubKey = M.singleton t k }
@@ -145,7 +147,7 @@ getPubKey = asks (_sshPubKey . hostInfo)
-- | Sets up a user with a ssh private key and public key pair from the
-- PrivData.
-keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property
+keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property HasInfo
keyImported keytype user context = combineProperties desc
[ installkey (SshPubKey keytype user) (install writeFile ".pub")
, installkey (SshPrivKey keytype user) (install writeFileProtected "")
@@ -178,7 +180,7 @@ fromKeyType SshEd25519 = "ed25519"
-- | Puts some host's ssh public key(s), as set using 'pubKey',
-- into the known_hosts file for a user.
-knownHost :: [Host] -> HostName -> UserName -> Property
+knownHost :: [Host] -> HostName -> UserName -> Property NoInfo
knownHost hosts hn user = property desc $
go =<< fromHost hosts hn getPubKey
where
@@ -198,7 +200,7 @@ knownHost hosts hn user = property desc $
-- | Makes a user have authorized_keys from the PrivData
--
-- This removes any other lines from the file.
-authorizedKeys :: IsContext c => UserName -> c -> Property
+authorizedKeys :: IsContext c => UserName -> c -> Property HasInfo
authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get ->
property (user ++ " has authorized_keys") $ get $ \v -> do
f <- liftIO $ dotFile "authorized_keys" user
@@ -212,7 +214,7 @@ authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \g
-- | Ensures that a user's authorized_keys contains a line.
-- Any other lines in the file are preserved as-is.
-authorizedKey :: UserName -> String -> Property
+authorizedKey :: UserName -> String -> Property NoInfo
authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do
f <- liftIO $ dotFile "authorized_keys" user
ensureProperty $
@@ -225,7 +227,7 @@ authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do
--
-- Revert to prevent it listening on a particular port.
listenPort :: Int -> RevertableProperty
-listenPort port = RevertableProperty enable disable
+listenPort port = enable <!> disable
where
portline = "Port " ++ show port
enable = sshdConfig `File.containsLine` portline
diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs
index 3651891d..c183a8a3 100644
--- a/src/Propellor/Property/Sudo.hs
+++ b/src/Propellor/Property/Sudo.hs
@@ -9,7 +9,7 @@ import Propellor.Property.User
-- | Allows a user to sudo. If the user has a password, sudo is configured
-- to require it. If not, NOPASSWORD is enabled for the user.
-enabledFor :: UserName -> Property
+enabledFor :: UserName -> Property NoInfo
enabledFor user = property desc go `requires` Apt.installed ["sudo"]
where
go = do
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index e80c32be..07cf81ee 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -1,10 +1,16 @@
module Propellor.Property.Systemd (
module Propellor.Property.Systemd.Core,
+ ServiceName,
+ MachineName,
started,
stopped,
enabled,
disabled,
+ restarted,
persistentJournal,
+ Option,
+ configured,
+ journaldConfigured,
daemonReloaded,
Container,
container,
@@ -33,33 +39,38 @@ type MachineName = String
data Container = Container MachineName Chroot.Chroot Host
deriving (Show)
-instance Hostlike Container where
- (Container n c h) & p = Container n c (h & p)
- (Container n c h) &^ p = Container n c (h &^ p)
- getHost (Container _ _ h) = h
+instance PropAccum Container where
+ (Container n c h) & p = Container n c (h & p)
+ (Container n c h) &^ p = Container n c (h &^ p)
+ getProperties (Container _ _ h) = hostProperties h
-- | Starts a systemd service.
-started :: ServiceName -> Property
+started :: ServiceName -> Property NoInfo
started n = trivial $ cmdProperty "systemctl" ["start", n]
`describe` ("service " ++ n ++ " started")
-- | Stops a systemd service.
-stopped :: ServiceName -> Property
+stopped :: ServiceName -> Property NoInfo
stopped n = trivial $ cmdProperty "systemctl" ["stop", n]
`describe` ("service " ++ n ++ " stopped")
-- | Enables a systemd service.
-enabled :: ServiceName -> Property
+enabled :: ServiceName -> Property NoInfo
enabled n = trivial $ cmdProperty "systemctl" ["enable", n]
`describe` ("service " ++ n ++ " enabled")
-- | Disables a systemd service.
-disabled :: ServiceName -> Property
+disabled :: ServiceName -> Property NoInfo
disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
`describe` ("service " ++ n ++ " disabled")
+-- | Restarts a systemd service.
+restarted :: ServiceName -> Property NoInfo
+restarted n = trivial $ cmdProperty "systemctl" ["restart", n]
+ `describe` ("service " ++ n ++ " restarted")
+
-- | Enables persistent storage of the journal.
-persistentJournal :: Property
+persistentJournal :: Property NoInfo
persistentJournal = check (not <$> doesDirectoryExist dir) $
combineProperties "persistent systemd journal"
[ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
@@ -70,8 +81,35 @@ persistentJournal = check (not <$> doesDirectoryExist dir) $
where
dir = "/var/log/journal"
+type Option = String
+
+-- | Ensures that an option is configured in one of systemd's config files.
+-- Does not ensure that the relevant daemon notices the change immediately.
+--
+-- This assumes that there is only one [Header] per file, which is
+-- currently the case. And it assumes the file already exists with
+-- the right [Header], so new lines can just be appended to the end.
+configured :: FilePath -> Option -> String -> Property NoInfo
+configured cfgfile option value = combineProperties desc
+ [ File.fileProperty desc (mapMaybe removeother) cfgfile
+ , File.containsLine cfgfile line
+ ]
+ where
+ setting = option ++ "="
+ line = setting ++ value
+ desc = cfgfile ++ " " ++ line
+ removeother l
+ | setting `isPrefixOf` l = Nothing
+ | otherwise = Just l
+
+-- | Configures journald, restarting it so the changes take effect.
+journaldConfigured :: Option -> String -> Property NoInfo
+journaldConfigured option value =
+ configured "/etc/systemd/journald.conf" option value
+ `onChange` restarted "systemd-journald"
+
-- | Causes systemd to reload its configuration files.
-daemonReloaded :: Property
+daemonReloaded :: Property NoInfo
daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
-- | Defines a container with a given machine name.
@@ -105,17 +143,12 @@ container name mkchroot = Container name c h
-- and deletes the chroot and all its contents.
nspawned :: Container -> RevertableProperty
nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
- RevertableProperty setup teardown
+ p `describe` ("nspawned " ++ name)
where
- setup = combineProperties ("nspawned " ++ name) $
- map toProp steps ++ [containerprovisioned]
- teardown = combineProperties ("not nspawned " ++ name) $
- map (toProp . revert) (reverse steps)
- steps =
- [ enterScript c
- , chrootprovisioned
- , nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
- ]
+ p = enterScript c
+ `before` chrootprovisioned
+ `before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
+ `before` containerprovisioned
-- Chroot provisioning is run in systemd-only mode,
-- which sets up the chroot and ensures systemd and dbus are
@@ -125,15 +158,17 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
-- Use nsenter to enter container and and run propellor to
-- finish provisioning.
- containerprovisioned = Chroot.propellChroot chroot
- (enterContainerProcess c) False
+ containerprovisioned =
+ Chroot.propellChroot chroot (enterContainerProcess c) False
+ <!>
+ doNothing
chroot = Chroot.Chroot loc system builderconf h
-- | Sets up the service file for the container, and then starts
-- it running.
nspawnService :: Container -> ChrootCfg -> RevertableProperty
-nspawnService (Container name _ _) cfg = RevertableProperty setup teardown
+nspawnService (Container name _ _) cfg = setup <!> teardown
where
service = nspawnServiceName name
servicefile = "/etc/systemd/system/multi-user.target.wants" </> service
@@ -177,7 +212,7 @@ nspawnServiceParams (SystemdNspawnCfg ps) =
-- This uses nsenter to enter the container, by looking up the pid of the
-- container's init process and using its namespace.
enterScript :: Container -> RevertableProperty
-enterScript c@(Container name _ _) = RevertableProperty setup teardown
+enterScript c@(Container name _ _) = setup <!> teardown
where
setup = combineProperties ("generated " ++ enterScriptFile c)
[ scriptfile `File.hasContent`
diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs
index 441717e1..b27a8e38 100644
--- a/src/Propellor/Property/Systemd/Core.hs
+++ b/src/Propellor/Property/Systemd/Core.hs
@@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt
-- dbus is only a Recommends of systemd, but is needed for communication
-- from the systemd inside a container to the one outside, so make sure it
-- gets installed.
-installed :: Property
+installed :: Property NoInfo
installed = Apt.installed ["systemd", "dbus"]
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index 9c63980c..9a0fe477 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -10,7 +10,7 @@ import System.Posix.Files
type HiddenServiceName = String
-isBridge :: Property
+isBridge :: Property NoInfo
isBridge = setup `requires` Apt.installed ["tor"]
`describe` "tor bridge"
where
@@ -21,7 +21,7 @@ isBridge = setup `requires` Apt.installed ["tor"]
, "Exitpolicy reject *:*"
] `onChange` restarted
-hiddenServiceAvailable :: HiddenServiceName -> Int -> Property
+hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
hiddenServiceAvailable hn port = hiddenServiceHostName prop
where
prop = mainConfig `File.containsLines`
@@ -30,13 +30,13 @@ hiddenServiceAvailable hn port = hiddenServiceHostName prop
]
`describe` "hidden service available"
`onChange` Service.reloaded "tor"
- hiddenServiceHostName p = adjustProperty p $ \satisfy -> do
+ hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
h <- liftIO $ readFile (varLib </> hn </> "hostname")
warningMessage $ unwords ["hidden service hostname:", h]
return r
-hiddenService :: HiddenServiceName -> Int -> Property
+hiddenService :: HiddenServiceName -> Int -> Property NoInfo
hiddenService hn port = mainConfig `File.containsLines`
[ unwords ["HiddenServiceDir", varLib </> hn]
, unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
@@ -44,7 +44,7 @@ hiddenService hn port = mainConfig `File.containsLines`
`describe` unwords ["hidden service available:", hn, show port]
`onChange` restarted
-hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property
+hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo
hiddenServiceData hn context = combineProperties desc
[ installonion "hostname"
, installonion "private_key"
@@ -66,7 +66,7 @@ hiddenServiceData hn context = combineProperties desc
]
)
-restarted :: Property
+restarted :: Property NoInfo
restarted = Service.restarted "tor"
mainConfig :: FilePath
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index f79ede63..9e115290 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -6,7 +6,7 @@ import Propellor
data Eep = YesReallyDeleteHome
-accountFor :: UserName -> Property
+accountFor :: UserName -> Property NoInfo
accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
[ "--disabled-password"
, "--gecos", ""
@@ -15,7 +15,7 @@ accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdPropert
`describe` ("account for " ++ user)
-- | Removes user home directory!! Use with caution.
-nuked :: UserName -> Eep -> Property
+nuked :: UserName -> Eep -> Property NoInfo
nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel"
[ "-r"
, user
@@ -24,13 +24,13 @@ nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "use
-- | Only ensures that the user has some password set. It may or may
-- not be a password from the PrivData.
-hasSomePassword :: UserName -> Property
+hasSomePassword :: UserName -> Property HasInfo
hasSomePassword user = hasSomePassword' user hostContext
-- | While hasSomePassword uses the name of the host as context,
-- this allows specifying a different context. This is useful when
-- you want to use the same password on multiple hosts, for example.
-hasSomePassword' :: IsContext c => UserName -> c -> Property
+hasSomePassword' :: IsContext c => UserName -> c -> Property HasInfo
hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
hasPassword' user context
@@ -40,10 +40,10 @@ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus us
-- A user's password can be stored in the PrivData in either of two forms;
-- the full cleartext <Password> or a <CryptPassword> hash. The latter
-- is obviously more secure.
-hasPassword :: UserName -> Property
+hasPassword :: UserName -> Property HasInfo
hasPassword user = hasPassword' user hostContext
-hasPassword' :: IsContext c => UserName -> c -> Property
+hasPassword' :: IsContext c => UserName -> c -> Property HasInfo
hasPassword' user context = go `requires` shadowConfig True
where
go = withSomePrivData srcs context $
@@ -66,7 +66,7 @@ setPassword getpassword = getpassword $ go
hPutStrLn h $ user ++ ":" ++ v
hClose h
-lockedPassword :: UserName -> Property
+lockedPassword :: UserName -> Property NoInfo
lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
[ "--lock"
, user
@@ -90,7 +90,7 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
homedir :: UserName -> IO FilePath
homedir user = homeDirectory <$> getUserEntryForName user
-hasGroup :: UserName -> GroupName -> Property
+hasGroup :: UserName -> GroupName -> Property NoInfo
hasGroup user group' = check test $ cmdProperty "adduser"
[ user
, group'
@@ -100,7 +100,7 @@ hasGroup user group' = check test $ cmdProperty "adduser"
test = not . elem group' . words <$> readProcess "groups" [user]
-- | Controls whether shadow passwords are enabled or not.
-shadowConfig :: Bool -> Property
+shadowConfig :: Bool -> Property NoInfo
shadowConfig True = check (not <$> shadowExists) $
cmdProperty "shadowconfig" ["on"]
`describe` "shadow passwords enabled"
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 339428ba..5063145e 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -24,6 +24,7 @@ import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Ssh
import Propellor.Gpg
+import Propellor.Types.CmdLine
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index ca3a9582..ba63cf9d 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,44 +1,48 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
module Propellor.Types
( Host(..)
+ , Desc
+ , Property
+ , HasInfo
+ , NoInfo
+ , CInfo
+ , infoProperty
+ , simpleProperty
+ , adjustPropertySatisfy
+ , propertyInfo
+ , propertyDesc
+ , propertyChildren
+ , RevertableProperty(..)
+ , (<!>)
+ , IsProp(..)
+ , Combines(..)
+ , CombinedType
+ , before
+ , combineWith
, Info(..)
- , getInfo
, Propellor(..)
- , Property(..)
- , RevertableProperty(..)
- , IsProp
- , describe
- , toProp
- , requires
- , Desc
- , Result(..)
- , ToResult(..)
- , ActionResult(..)
- , CmdLine(..)
- , PrivDataField(..)
- , PrivData
- , Context(..)
- , anyContext
- , SshKeyType(..)
- , Val(..)
- , fromVal
- , RunLog
, EndAction(..)
, module Propellor.Types.OS
, module Propellor.Types.Dns
+ , module Propellor.Types.Result
+ , propertySatisfy
+ , ignoreInfo
) where
import Data.Monoid
import Control.Applicative
-import System.Console.ANSI
-import System.Posix.Types
import "mtl" Control.Monad.RWS.Strict
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified Propellor.Types.Dns as Dns
import Propellor.Types.OS
import Propellor.Types.Chroot
@@ -46,137 +50,228 @@ import Propellor.Types.Dns
import Propellor.Types.Docker
import Propellor.Types.PrivData
import Propellor.Types.Empty
+import Propellor.Types.Val
+import Propellor.Types.Result
+import qualified Propellor.Types.Dns as Dns
-- | Everything Propellor knows about a system: Its hostname,
--- properties and other info.
+-- properties and their collected info.
data Host = Host
{ hostName :: HostName
- , hostProperties :: [Property]
+ , hostProperties :: [Property HasInfo]
, hostInfo :: Info
}
deriving (Show)
-- | Propellor's monad provides read-only access to info about the host
--- it's running on, and a writer to accumulate logs about the run.
-newtype Propellor p = Propellor { runWithHost :: RWST Host RunLog () IO p }
+-- it's running on, and a writer to accumulate EndActions.
+newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
deriving
( Monad
, Functor
, Applicative
, MonadReader Host
- , MonadWriter RunLog
+ , MonadWriter [EndAction]
, MonadIO
, MonadCatchIO
)
+instance Monoid (Propellor Result) where
+ mempty = return NoChange
+ -- | The second action is only run if the first action does not fail.
+ mappend x y = do
+ rx <- x
+ case rx of
+ FailedChange -> return FailedChange
+ _ -> do
+ ry <- y
+ return (rx <> ry)
+
+-- | An action that Propellor runs at the end, after trying to satisfy all
+-- properties. It's passed the combined Result of the entire Propellor run.
+data EndAction = EndAction Desc (Result -> Propellor Result)
+
+type Desc = String
+
-- | The core data type of Propellor, this represents a property
-- that the system should have, and an action to ensure it has the
-- property.
-data Property = Property
- { propertyDesc :: Desc
- , propertySatisfy :: Propellor Result
- -- ^ must be idempotent; may run repeatedly
- , propertyInfo :: Info
- -- ^ a property can add info to the host.
- }
+data Property i where
+ IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
+ SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
+
+-- | Indicates that a Property has associated Info.
+data HasInfo
+-- | Indicates that a Property does not have Info.
+data NoInfo
+
+-- | Type level calculation of the combination of HasInfo and/or NoInfo
+type family CInfo x y
+type instance CInfo HasInfo HasInfo = HasInfo
+type instance CInfo HasInfo NoInfo = HasInfo
+type instance CInfo NoInfo HasInfo = HasInfo
+type instance CInfo NoInfo NoInfo = NoInfo
+
+-- | Constructs a Property with associated Info.
+infoProperty
+ :: Desc -- ^ description of the property
+ -> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
+ -> Info -- ^ info associated with the property
+ -> [Property i] -- ^ child properties
+ -> Property HasInfo
+infoProperty d a i cs = IProperty d a i (map toIProperty cs)
+
+-- | Constructs a Property with no Info.
+simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
+simpleProperty = SProperty
+
+toIProperty :: Property i -> Property HasInfo
+toIProperty p@(IProperty {}) = p
+toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs)
+
+toSProperty :: Property i -> Property NoInfo
+toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs)
+toSProperty p@(SProperty {}) = p
+
+-- | Makes a version of a Proprty without its Info.
+-- Use with caution!
+ignoreInfo :: Property i -> Property NoInfo
+ignoreInfo = toSProperty
+
+-- | Gets the action that can be run to satisfy a Property.
+-- You should never run this action directly. Use
+-- 'Propellor.Engine.ensureProperty` instead.
+propertySatisfy :: Property i -> Propellor Result
+propertySatisfy (IProperty _ a _ _) = a
+propertySatisfy (SProperty _ a _) = a
+
+instance Show (Property i) where
+ show p = "property " ++ show (propertyDesc p)
+
+-- | Changes the action that is performed to satisfy a property.
+adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
+adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
+adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs
-instance Show Property where
- show p = "property " ++ show (propertyDesc p)
+propertyInfo :: Property i -> Info
+propertyInfo (IProperty _ _ i _) = i
+propertyInfo (SProperty {}) = mempty
+
+propertyDesc :: Property i -> Desc
+propertyDesc (IProperty d _ _ _) = d
+propertyDesc (SProperty d _ _) = d
+
+-- | A Property can include a list of child properties that it also
+-- satisfies. This allows them to be introspected to collect their info, etc.
+propertyChildren :: Property i -> [Property i]
+propertyChildren (IProperty _ _ _ cs) = cs
+propertyChildren (SProperty _ _ cs) = cs
-- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
+data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo)
+
+-- | Makes a revertable property; the first Property is run
+-- normally and the second is run when it's reverted.
+(<!>) :: Property i1 -> Property i2 -> RevertableProperty
+p1 <!> p2 = RevertableProperty (toIProperty p1) (toIProperty p2)
class IsProp p where
-- | Sets description.
describe :: p -> Desc -> p
- toProp :: p -> Property
- -- | Indicates that the first property can only be satisfied
- -- once the second one is.
- requires :: p -> Property -> p
- getInfo :: p -> Info
-
-instance IsProp Property where
- describe p d = p { propertyDesc = d }
- toProp p = p
- getInfo = propertyInfo
- x `requires` y = Property (propertyDesc x) satisfy info
- where
- info = getInfo y <> getInfo x
- satisfy = do
- r <- propertySatisfy y
- case r of
- FailedChange -> return FailedChange
- _ -> propertySatisfy x
-
+ toProp :: p -> Property HasInfo
+ getDesc :: p -> Desc
+ -- | Gets the info of the property, combined with all info
+ -- of all children properties.
+ getInfoRecursive :: p -> Info
+
+instance IsProp (Property HasInfo) where
+ describe (IProperty _ a i cs) d = IProperty d a i cs
+ toProp = id
+ getDesc = propertyDesc
+ getInfoRecursive (IProperty _ _ i cs) =
+ i <> mconcat (map getInfoRecursive cs)
+instance IsProp (Property NoInfo) where
+ describe (SProperty _ a cs) d = SProperty d a cs
+ toProp = toIProperty
+ getDesc = propertyDesc
+ getInfoRecursive _ = mempty
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
describe (RevertableProperty p1 p2) d =
RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
+ getDesc (RevertableProperty p1 _) = getDesc p1
toProp (RevertableProperty p1 _) = p1
- (RevertableProperty p1 p2) `requires` y =
- RevertableProperty (p1 `requires` y) p2
-- | Return the Info of the currently active side.
- getInfo (RevertableProperty p1 _p2) = getInfo p1
+ getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
-type Desc = String
+-- | Type level calculation of the type that results from combining two types
+-- with `requires`.
+type family CombinedType x y
+type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
+type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty
+type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty
+type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty
+
+class Combines x y where
+ -- | Indicates that the first property depends on the second,
+ -- so before the first is ensured, the second will be ensured.
+ requires :: x -> y -> CombinedType x y
+
+-- | Combines together two properties, resulting in one property
+-- that ensures the first, and if the first succeeds, ensures the second.
+-- The property uses the description of the first property.
+before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x
+before x y = (y `requires` x) `describe` (getDesc x)
+
+-- | Combines together two properties, yielding a property that
+-- has the description and info of the first, and that has the second
+-- property as a child. The two actions to satisfy the properties
+-- are passed to a function that can combine them in arbitrary ways.
+combineWith
+ :: (Combines (Property x) (Property y))
+ => (Propellor Result -> Propellor Result -> Propellor Result)
+ -> Property x
+ -> Property y
+ -> CombinedType (Property x) (Property y)
+combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ ->
+ f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y)
+
+instance Combines (Property HasInfo) (Property HasInfo) where
+ requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (a2 <> a1) i1 (y : cs1)
+
+instance Combines (Property HasInfo) (Property NoInfo) where
+ requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
+ IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)
+
+instance Combines (Property NoInfo) (Property HasInfo) where
+ requires (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1)
+
+instance Combines (Property NoInfo) (Property NoInfo) where
+ requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
+ SProperty d1 (a2 <> a1) (y : cs1)
-data Result = NoChange | MadeChange | FailedChange
- deriving (Read, Show, Eq)
-
-instance Monoid Result where
- mempty = NoChange
-
- mappend FailedChange _ = FailedChange
- mappend _ FailedChange = FailedChange
- mappend MadeChange _ = MadeChange
- mappend _ MadeChange = MadeChange
- mappend NoChange NoChange = NoChange
-
-class ToResult t where
- toResult :: t -> Result
-
-instance ToResult Bool where
- toResult False = FailedChange
- toResult True = MadeChange
-
--- | Results of actions, with color.
-class ActionResult a where
- getActionResult :: a -> (String, ColorIntensity, Color)
-
-instance ActionResult Bool where
- getActionResult False = ("failed", Vivid, Red)
- getActionResult True = ("done", Dull, Green)
-
-instance ActionResult Result where
- getActionResult NoChange = ("ok", Dull, Green)
- getActionResult MadeChange = ("done", Vivid, Green)
- getActionResult FailedChange = ("failed", Vivid, Red)
-
-data CmdLine
- = Run HostName
- | Spin [HostName] (Maybe HostName)
- | SimpleRun HostName
- | Set PrivDataField Context
- | Dump PrivDataField Context
- | Edit PrivDataField Context
- | ListFields
- | AddKey String
- | Merge
- | Serialized CmdLine
- | Continue CmdLine
- | Update (Maybe HostName)
- | Relay HostName
- | DockerInit HostName
- | DockerChain HostName String
- | ChrootChain HostName FilePath Bool Bool
- | GitPush Fd Fd
- deriving (Read, Show, Eq)
+instance Combines RevertableProperty (Property HasInfo) where
+ requires (RevertableProperty p1 p2) y =
+ RevertableProperty (p1 `requires` y) p2
+
+instance Combines RevertableProperty (Property NoInfo) where
+ requires (RevertableProperty p1 p2) y =
+ RevertableProperty (p1 `requires` toIProperty y) p2
+
+instance Combines RevertableProperty RevertableProperty where
+ requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) =
+ RevertableProperty
+ (x1 `requires` y1)
+ -- when reverting, run actions in reverse order
+ (y2 `requires` x2)
-- | Information about a host.
data Info = Info
{ _os :: Val System
- , _privDataFields :: S.Set (PrivDataField, HostContext)
+ , _privData :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext)
, _sshPubKey :: M.Map SshKeyType String
, _aliases :: S.Set HostName
, _dns :: S.Set Dns.Record
@@ -190,7 +285,7 @@ instance Monoid Info where
mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty
mappend old new = Info
{ _os = _os old <> _os new
- , _privDataFields = _privDataFields old <> _privDataFields new
+ , _privData = _privData old <> _privData new
, _sshPubKey = _sshPubKey new `M.union` _sshPubKey old
, _aliases = _aliases old <> _aliases new
, _dns = _dns old <> _dns new
@@ -202,7 +297,7 @@ instance Monoid Info where
instance Empty Info where
isEmpty i = and
[ isEmpty (_os i)
- , isEmpty (_privDataFields i)
+ , isEmpty (_privData i)
, isEmpty (_sshPubKey i)
, isEmpty (_aliases i)
, isEmpty (_dns i)
@@ -210,26 +305,3 @@ instance Empty Info where
, isEmpty (_dockerinfo i)
, isEmpty (_chrootinfo i)
]
-
-data Val a = Val a | NoVal
- deriving (Eq, Show)
-
-instance Monoid (Val a) where
- mempty = NoVal
- mappend old new = case new of
- NoVal -> old
- _ -> new
-
-instance Empty (Val a) where
- isEmpty NoVal = True
- isEmpty _ = False
-
-fromVal :: Val a -> Maybe a
-fromVal (Val a) = Just a
-fromVal NoVal = Nothing
-
-type RunLog = [EndAction]
-
--- | An action that Propellor runs at the end, after trying to satisfy all
--- properties. It's passed the combined Result of the entire Propellor run.
-data EndAction = EndAction Desc (Result -> Propellor Result)
diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs
new file mode 100644
index 00000000..b8f488a4
--- /dev/null
+++ b/src/Propellor/Types/CmdLine.hs
@@ -0,0 +1,27 @@
+module Propellor.Types.CmdLine where
+
+import Propellor.Types.OS
+import Propellor.Types.PrivData
+
+import System.Posix.Types
+
+data CmdLine
+ = Run HostName
+ | Spin [HostName] (Maybe HostName)
+ | SimpleRun HostName
+ | Set PrivDataField Context
+ | Dump PrivDataField Context
+ | Edit PrivDataField Context
+ | ListFields
+ | AddKey String
+ | Merge
+ | Serialized CmdLine
+ | Continue CmdLine
+ | Update (Maybe HostName)
+ | Relay HostName
+ | DockerInit HostName
+ | DockerChain HostName String
+ | ChrootChain HostName FilePath Bool Bool
+ | GitPush Fd Fd
+ deriving (Read, Show, Eq)
+
diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs
index c7909a6b..6b3c35a2 100644
--- a/src/Propellor/Types/PrivData.hs
+++ b/src/Propellor/Types/PrivData.hs
@@ -24,9 +24,11 @@ data PrivDataSource
| PrivDataSourceFileFromCommand PrivDataField FilePath String
| PrivDataSource PrivDataField String
+type PrivDataSourceDesc = String
+
class IsPrivDataSource s where
privDataField :: s -> PrivDataField
- describePrivDataSource :: s -> Maybe String
+ describePrivDataSource :: s -> Maybe PrivDataSourceDesc
instance IsPrivDataSource PrivDataField where
privDataField = id
diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs
new file mode 100644
index 00000000..9def9a3f
--- /dev/null
+++ b/src/Propellor/Types/Result.hs
@@ -0,0 +1,37 @@
+module Propellor.Types.Result where
+
+import Data.Monoid
+import System.Console.ANSI
+
+-- | There can be three results of satisfying a Property.
+data Result = NoChange | MadeChange | FailedChange
+ deriving (Read, Show, Eq)
+
+instance Monoid Result where
+ mempty = NoChange
+
+ mappend FailedChange _ = FailedChange
+ mappend _ FailedChange = FailedChange
+ mappend MadeChange _ = MadeChange
+ mappend _ MadeChange = MadeChange
+ mappend NoChange NoChange = NoChange
+
+class ToResult t where
+ toResult :: t -> Result
+
+instance ToResult Bool where
+ toResult False = FailedChange
+ toResult True = MadeChange
+
+-- | Results of actions, with color.
+class ActionResult a where
+ getActionResult :: a -> (String, ColorIntensity, Color)
+
+instance ActionResult Bool where
+ getActionResult False = ("failed", Vivid, Red)
+ getActionResult True = ("done", Dull, Green)
+
+instance ActionResult Result where
+ getActionResult NoChange = ("ok", Dull, Green)
+ getActionResult MadeChange = ("done", Vivid, Green)
+ getActionResult FailedChange = ("failed", Vivid, Red)
diff --git a/src/Propellor/Types/Val.hs b/src/Propellor/Types/Val.hs
new file mode 100644
index 00000000..8890bee8
--- /dev/null
+++ b/src/Propellor/Types/Val.hs
@@ -0,0 +1,22 @@
+module Propellor.Types.Val where
+
+import Data.Monoid
+
+import Propellor.Types.Empty
+
+data Val a = Val a | NoVal
+ deriving (Eq, Show)
+
+instance Monoid (Val a) where
+ mempty = NoVal
+ mappend old new = case new of
+ NoVal -> old
+ _ -> new
+
+instance Empty (Val a) where
+ isEmpty NoVal = True
+ isEmpty _ = False
+
+fromVal :: Val a -> Maybe a
+fromVal (Val a) = Just a
+fromVal NoVal = Nothing
diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs
new file mode 100644
index 00000000..2ece1430
--- /dev/null
+++ b/src/Utility/DataUnits.hs
@@ -0,0 +1,161 @@
+{- data size display and parsing
+ -
+ - Copyright 2011 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -
+ -
+ - And now a rant:
+ -
+ - In the beginning, we had powers of two, and they were good.
+ -
+ - Disk drive manufacturers noticed that some powers of two were
+ - sorta close to some powers of ten, and that rounding down to the nearest
+ - power of ten allowed them to advertise their drives were bigger. This
+ - was sorta annoying.
+ -
+ - Then drives got big. Really, really big. This was good.
+ -
+ - Except that the small rounding error perpretrated by the drive
+ - manufacturers suffered the fate of a small error, and became a large
+ - error. This was bad.
+ -
+ - So, a committee was formed. And it arrived at a committee-like decision,
+ - which satisfied noone, confused everyone, and made the world an uglier
+ - place. As with all committees, this was meh.
+ -
+ - And the drive manufacturers happily continued selling drives that are
+ - increasingly smaller than you'd expect, if you don't count on your
+ - fingers. But that are increasingly too big for anyone to much notice.
+ - This caused me to need git-annex.
+ -
+ - Thus, I use units here that I loathe. Because if I didn't, people would
+ - be confused that their drives seem the wrong size, and other people would
+ - complain at me for not being standards compliant. And we call this
+ - progress?
+ -}
+
+module Utility.DataUnits (
+ dataUnits,
+ storageUnits,
+ memoryUnits,
+ bandwidthUnits,
+ oldSchoolUnits,
+ Unit(..),
+
+ roughSize,
+ compareSizes,
+ readSize
+) where
+
+import Data.List
+import Data.Char
+
+import Utility.HumanNumber
+
+type ByteSize = Integer
+type Name = String
+type Abbrev = String
+data Unit = Unit ByteSize Abbrev Name
+ deriving (Ord, Show, Eq)
+
+dataUnits :: [Unit]
+dataUnits = storageUnits ++ memoryUnits
+
+{- Storage units are (stupidly) powers of ten. -}
+storageUnits :: [Unit]
+storageUnits =
+ [ Unit (p 8) "YB" "yottabyte"
+ , Unit (p 7) "ZB" "zettabyte"
+ , Unit (p 6) "EB" "exabyte"
+ , Unit (p 5) "PB" "petabyte"
+ , Unit (p 4) "TB" "terabyte"
+ , Unit (p 3) "GB" "gigabyte"
+ , Unit (p 2) "MB" "megabyte"
+ , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
+ , Unit (p 0) "B" "byte"
+ ]
+ where
+ p :: Integer -> Integer
+ p n = 1000^n
+
+{- Memory units are (stupidly named) powers of 2. -}
+memoryUnits :: [Unit]
+memoryUnits =
+ [ Unit (p 8) "YiB" "yobibyte"
+ , Unit (p 7) "ZiB" "zebibyte"
+ , Unit (p 6) "EiB" "exbibyte"
+ , Unit (p 5) "PiB" "pebibyte"
+ , Unit (p 4) "TiB" "tebibyte"
+ , Unit (p 3) "GiB" "gibibyte"
+ , Unit (p 2) "MiB" "mebibyte"
+ , Unit (p 1) "KiB" "kibibyte"
+ , Unit (p 0) "B" "byte"
+ ]
+ where
+ p :: Integer -> Integer
+ p n = 2^(n*10)
+
+{- Bandwidth units are only measured in bits if you're some crazy telco. -}
+bandwidthUnits :: [Unit]
+bandwidthUnits = error "stop trying to rip people off"
+
+{- Do you yearn for the days when men were men and megabytes were megabytes? -}
+oldSchoolUnits :: [Unit]
+oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
+ where
+ mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
+
+{- approximate display of a particular number of bytes -}
+roughSize :: [Unit] -> Bool -> ByteSize -> String
+roughSize units short i
+ | i < 0 = '-' : findUnit units' (negate i)
+ | otherwise = findUnit units' i
+ where
+ units' = sortBy (flip compare) units -- largest first
+
+ findUnit (u@(Unit s _ _):us) i'
+ | i' >= s = showUnit i' u
+ | otherwise = findUnit us i'
+ findUnit [] i' = showUnit i' (last units') -- bytes
+
+ showUnit x (Unit size abbrev name) = s ++ " " ++ unit
+ where
+ v = (fromInteger x :: Double) / fromInteger size
+ s = showImprecise 2 v
+ unit
+ | short = abbrev
+ | s == "1" = name
+ | otherwise = name ++ "s"
+
+{- displays comparison of two sizes -}
+compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String
+compareSizes units abbrev old new
+ | old > new = roughSize units abbrev (old - new) ++ " smaller"
+ | old < new = roughSize units abbrev (new - old) ++ " larger"
+ | otherwise = "same"
+
+{- Parses strings like "10 kilobytes" or "0.5tb". -}
+readSize :: [Unit] -> String -> Maybe ByteSize
+readSize units input
+ | null parsednum || null parsedunit = Nothing
+ | otherwise = Just $ round $ number * fromIntegral multiplier
+ where
+ (number, rest) = head parsednum
+ multiplier = head parsedunit
+ unitname = takeWhile isAlpha $ dropWhile isSpace rest
+
+ parsednum = reads input :: [(Double, String)]
+ parsedunit = lookupUnit units unitname
+
+ lookupUnit _ [] = [1] -- no unit given, assume bytes
+ lookupUnit [] _ = []
+ lookupUnit (Unit s a n:us) v
+ | a ~~ v || n ~~ v = [s]
+ | plural n ~~ v || a ~~ byteabbrev v = [s]
+ | otherwise = lookupUnit us v
+
+ a ~~ b = map toLower a == map toLower b
+
+ plural n = n ++ "s"
+ byteabbrev a = a ++ "b"
diff --git a/src/Utility/HumanNumber.hs b/src/Utility/HumanNumber.hs
new file mode 100644
index 00000000..c3fede95
--- /dev/null
+++ b/src/Utility/HumanNumber.hs
@@ -0,0 +1,21 @@
+{- numbers for humans
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.HumanNumber where
+
+{- Displays a fractional value as a string with a limited number
+ - of decimal digits. -}
+showImprecise :: RealFrac a => Int -> a -> String
+showImprecise precision n
+ | precision == 0 || remainder == 0 = show (round n :: Integer)
+ | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)
+ where
+ int :: Integer
+ (int, frac) = properFraction n
+ remainder = round (frac * 10 ^ precision) :: Integer
+ pad0s s = replicate (precision - length s) '0' ++ s
+ striptrailing0s = reverse . dropWhile (== '0') . reverse
diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs
index 4e862ff6..20adf40d 100644
--- a/src/Utility/Table.hs
+++ b/src/Utility/Table.hs
@@ -16,13 +16,14 @@ tableWithHeader header rows = header : map linesep header : rows
where
linesep = map (const '-')
--- | Formats a table to lines, automatically padding rows to the same size.
+-- | Formats a table to lines, automatically padding columns to the same size.
formatTable :: Table -> [String]
-formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table
+formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table
where
pad (cell, size) = cell ++ take (size - length cell) padding
padding = repeat ' '
- rowsizes = sumrows (map (map length) table)
- sumrows [] = repeat 0
- sumrows [r] = r
- sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs
+ colsizes = reverse $ (0:) $ drop 1 $ reverse $
+ sumcols (map (map length) table)
+ sumcols [] = repeat 0
+ sumcols [r] = r
+ sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs