summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
l---------config.hs2
-rw-r--r--debian/changelog23
-rw-r--r--doc/install.mdwn3
-rw-r--r--doc/news/version_3.2.1.mdwn5
-rw-r--r--doc/news/version_3.2.2.mdwn5
-rw-r--r--doc/news/version_3.4.0.mdwn14
-rw-r--r--doc/news/version_3.4.1.mdwn3
-rw-r--r--privdata/relocate1
-rw-r--r--propellor.cabal3
-rw-r--r--src/Propellor/DotDir.hs4
-rw-r--r--src/Propellor/Property/Apache.hs10
-rw-r--r--src/Propellor/Property/Apt.hs2
-rw-r--r--src/Propellor/Property/Apt/PPA.hs27
-rw-r--r--src/Propellor/Property/Attic.hs10
-rw-r--r--src/Propellor/Property/Borg.hs10
-rw-r--r--src/Propellor/Property/Ccache.hs2
-rw-r--r--src/Propellor/Property/Dns.hs14
-rw-r--r--src/Propellor/Property/Docker.hs6
-rw-r--r--src/Propellor/Property/File.hs6
-rw-r--r--src/Propellor/Property/Firewall.hs77
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs12
-rw-r--r--src/Propellor/Property/Grub.hs2
-rw-r--r--src/Propellor/Property/Logcheck.hs12
-rw-r--r--src/Propellor/Property/Munin.hs4
-rw-r--r--src/Propellor/Property/Obnam.hs2
-rw-r--r--src/Propellor/Property/OpenId.hs2
-rw-r--r--src/Propellor/Property/Parted.hs76
-rw-r--r--src/Propellor/Property/Sbuild.hs28
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs26
-rw-r--r--src/Propellor/Property/Ssh.hs8
-rw-r--r--src/Propellor/Property/Systemd.hs2
-rw-r--r--src/Propellor/Property/Tor.hs4
-rw-r--r--src/Propellor/Property/Unbound.hs4
-rw-r--r--src/Propellor/Spin.hs2
-rw-r--r--src/Propellor/Types.hs2
-rw-r--r--src/Propellor/Types/ConfigurableValue.hs44
-rw-r--r--src/Propellor/Types/Dns.hs9
-rw-r--r--src/Propellor/Types/OS.hs22
-rw-r--r--src/Propellor/Types/ZFS.hs77
39 files changed, 321 insertions, 244 deletions
diff --git a/config.hs b/config.hs
index 97d90636..ec313725 120000
--- a/config.hs
+++ b/config.hs
@@ -1 +1 @@
-joeyconfig.hs \ No newline at end of file
+config-simple.hs \ No newline at end of file
diff --git a/debian/changelog b/debian/changelog
index d4587ceb..485cb9d9 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,26 @@
+propellor (3.4.1) unstable; urgency=medium
+
+ * Fixed https url to propellor git repository.
+
+ -- Joey Hess <id@joeyh.name> Wed, 01 Mar 2017 16:50:05 -0400
+
+propellor (3.4.0) unstable; urgency=medium
+
+ * Added ConfigurableValue type class, for values that can be used in a
+ config file, or to otherwise configure a program.
+ * The val function converts such values to String.
+ * Removed fromPort and fromIPAddr (use val instead). (API change)
+ * Removed several Show instances that were only used for generating
+ configuration, replacing with ConfigurableValue instances. (API change)
+ * The github mirror of propellor's git repository has been removed,
+ since github's terms of service has started imposing unwanted licensing
+ requirements.
+ * propellor --init: The option to clone propellor's git repository
+ used to use the github mirror, and has been changed to use a different
+ mirror.
+
+ -- Joey Hess <id@joeyh.name> Wed, 01 Mar 2017 16:44:20 -0400
+
propellor (3.3.1) unstable; urgency=medium
* Apt: Removed the mirrors.kernel.org line from stdSourcesList etc.
diff --git a/doc/install.mdwn b/doc/install.mdwn
index f64519a7..8db966f1 100644
--- a/doc/install.mdwn
+++ b/doc/install.mdwn
@@ -1,4 +1,3 @@
`git clone git://propellor.branchable.com/propellor`
-Or get it [from github](https://github.com/joeyh/propellor).
-Propellor is recently available in Debian.
+Propellor is also available in Debian.
diff --git a/doc/news/version_3.2.1.mdwn b/doc/news/version_3.2.1.mdwn
deleted file mode 100644
index 214ef427..00000000
--- a/doc/news/version_3.2.1.mdwn
+++ /dev/null
@@ -1,5 +0,0 @@
-propellor 3.2.1 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Simplify Debootstrap.sourceInstall since #770217 was fixed.
- * Debootstap.installed: Fix inverted logic that made this never install
- debootstrap. Thanks, mithrandi."""]] \ No newline at end of file
diff --git a/doc/news/version_3.2.2.mdwn b/doc/news/version_3.2.2.mdwn
deleted file mode 100644
index 19acc9f7..00000000
--- a/doc/news/version_3.2.2.mdwn
+++ /dev/null
@@ -1,5 +0,0 @@
-propellor 3.2.2 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Added Linode.serialGrub property.
- * Clean up build warnings about redundant constraints when built with ghc 8.0.
- * Added Group.hasUser property. Thanks, Daniel Brooks"""]] \ No newline at end of file
diff --git a/doc/news/version_3.4.0.mdwn b/doc/news/version_3.4.0.mdwn
new file mode 100644
index 00000000..d38716e1
--- /dev/null
+++ b/doc/news/version_3.4.0.mdwn
@@ -0,0 +1,14 @@
+propellor 3.4.0 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * Added ConfigurableValue type class, for values that can be used in a
+ config file, or to otherwise configure a program.
+ * The val function converts such values to String.
+ * Removed fromPort and fromIPAddr (use val instead). (API change)
+ * Removed several Show instances that were only used for generating
+ configuration, replacing with ConfigurableValue instances. (API change)
+ * The github mirror of propellor's git repository has been removed,
+ since github's terms of service has started imposing unwanted licensing
+ requirements.
+ * propellor --init: The option to clone propellor's git repository
+ used to use the github mirror, and has been changed to use a different
+ mirror."""]] \ No newline at end of file
diff --git a/doc/news/version_3.4.1.mdwn b/doc/news/version_3.4.1.mdwn
new file mode 100644
index 00000000..51d9c2ac
--- /dev/null
+++ b/doc/news/version_3.4.1.mdwn
@@ -0,0 +1,3 @@
+propellor 3.4.1 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * Fixed https url to propellor git repository."""]] \ No newline at end of file
diff --git a/privdata/relocate b/privdata/relocate
deleted file mode 100644
index 271692d8..00000000
--- a/privdata/relocate
+++ /dev/null
@@ -1 +0,0 @@
-.joeyconfig
diff --git a/propellor.cabal b/propellor.cabal
index 345b51dd..9e7d8479 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 3.3.1
+Version: 3.4.1
Cabal-Version: >= 1.8
License: BSD2
Maintainer: Joey Hess <id@joeyh.name>
@@ -171,6 +171,7 @@ Library
Propellor.EnsureProperty
Propellor.Exception
Propellor.Types
+ Propellor.Types.ConfigurableValue
Propellor.Types.Core
Propellor.Types.Chroot
Propellor.Types.CmdLine
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index 417abcfa..ffde705c 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -47,10 +47,10 @@ disthead = distdir </> "head"
upstreambranch :: String
upstreambranch = "upstream/master"
--- Using the github mirror of the main propellor repo because
+-- Using the joeyh.name mirror of the main propellor repo because
-- it is accessible over https for better security.
netrepo :: String
-netrepo = "https://github.com/joeyh/propellor.git"
+netrepo = "https://git.joeyh.name/git/propellor.git"
dotPropellor :: IO FilePath
dotPropellor = do
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index f321143f..d912acc1 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -72,7 +72,7 @@ listenPorts :: [Port] -> Property DebianLike
listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps
`onChange` restarted
where
- portline port = "Listen " ++ fromPort port
+ portline port = "Listen " ++ val port
-- This is a list of config files because different versions of apache
-- use different filenames. Propellor simply writes them all.
@@ -135,8 +135,8 @@ virtualHost domain port docroot = virtualHost' domain port docroot []
-- | Like `virtualHost` but with additional config lines added.
virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike
virtualHost' domain port docroot addedcfg = siteEnabled domain $
- [ "<VirtualHost *:" ++ fromPort port ++ ">"
- , "ServerName " ++ domain ++ ":" ++ fromPort port
+ [ "<VirtualHost *:" ++ val port ++ ">"
+ , "ServerName " ++ domain ++ ":" ++ val port
, "DocumentRoot " ++ docroot
, "ErrorLog /var/log/apache2/error.log"
, "LogLevel warn"
@@ -202,8 +202,8 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
]
sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf"
vhost p ls =
- [ "<VirtualHost *:" ++ fromPort p ++">"
- , "ServerName " ++ domain ++ ":" ++ fromPort p
+ [ "<VirtualHost *:" ++ val p ++">"
+ , "ServerName " ++ domain ++ ":" ++ val p
, "DocumentRoot " ++ docroot
, "ErrorLog /var/log/apache2/error.log"
, "LogLevel warn"
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 9a55c367..4490aa95 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -452,7 +452,7 @@ suitePinBlock p suite pin =
[ "Explanation: This file added by propellor"
, "Package: " ++ p
, "Pin: release " ++ suitePin suite
- , "Pin-Priority: " ++ show pin
+ , "Pin-Priority: " ++ val pin
]
dpkgStatus :: FilePath
diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs
index 49fa9fa7..346125ff 100644
--- a/src/Propellor/Property/Apt/PPA.hs
+++ b/src/Propellor/Property/Apt/PPA.hs
@@ -25,8 +25,8 @@ data PPA = PPA
, ppaArchive :: String -- ^ The name of the archive.
} deriving (Eq, Ord)
-instance Show PPA where
- show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p]
+instance ConfigurableValue PPA where
+ val p = concat ["ppa:", ppaAccount p, "/", ppaArchive p]
instance IsString PPA where
-- | Parse strings like "ppa:zfs-native/stable" into a PPA.
@@ -40,9 +40,9 @@ instance IsString PPA where
-- | Adds a PPA to the local system repositories.
addPpa :: PPA -> Property DebianLike
addPpa p =
- cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv
+ cmdPropertyEnv "apt-add-repository" ["--yes", val p] Apt.noninteractiveEnv
`assume` MadeChange
- `describe` ("Added PPA " ++ (show p))
+ `describe` ("Added PPA " ++ (val p))
`requires` installed
-- | A repository key ID to be downloaded with apt-key.
@@ -52,14 +52,11 @@ data AptKeyId = AptKeyId
, akiServer :: String
} deriving (Eq, Ord)
-instance Show AptKeyId where
- show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k]
-
-- | Adds an 'AptKeyId' from the specified GPG server.
addKeyId :: AptKeyId -> Property DebianLike
addKeyId keyId =
check keyTrusted akcmd
- `describe` (unwords ["Add third-party Apt key", show keyId])
+ `describe` (unwords ["Add third-party Apt key", desc keyId])
where
akcmd =
tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId]
@@ -72,10 +69,12 @@ addKeyId keyId =
nkid = take 8 (akiId keyId)
in
(isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"]
+ desc k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k]
-- | An Apt source line that apt-add-repository will just add to
--- sources.list. It's also an instance of both 'Show' and 'IsString' to make
--- using 'OverloadedStrings' in the configuration file easier.
+-- sources.list. It's also an instance of both 'ConfigurableValue'
+-- and 'IsString' to make using 'OverloadedStrings' in the configuration
+-- file easier.
--
-- | FIXME there's apparently an optional "options" fragment that I've
-- definitely not parsed here.
@@ -85,8 +84,8 @@ data AptSource = AptSource
, asComponents :: [String] -- ^ The list of components to install from this repository.
} deriving (Eq, Ord)
-instance Show AptSource where
- show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc]
+instance ConfigurableValue AptSource where
+ val asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc]
instance IsString AptSource where
fromString s =
@@ -103,7 +102,7 @@ addRepository :: AptRepository -> Property DebianLike
addRepository (AptRepositoryPPA p) = addPpa p
addRepository (AptRepositorySource src) =
check repoExists addSrc
- `describe` unwords ["Adding APT repository", show src]
+ `describe` unwords ["Adding APT repository", val src]
`requires` installed
where
allSourceLines =
@@ -112,4 +111,4 @@ addRepository (AptRepositorySource src) =
. filter (not . isPrefixOf "#")
. filter (/= "") . lines <$> allSourceLines
repoExists = isInfixOf [src] <$> activeSources
- addSrc = cmdProperty "apt-add-source" [show src]
+ addSrc = cmdProperty "apt-add-source" [val src]
diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs
index 4415f8c0..3059a04b 100644
--- a/src/Propellor/Property/Attic.hs
+++ b/src/Propellor/Property/Attic.hs
@@ -131,11 +131,11 @@ backup' dir backupdir crontimes extraargs kp = cronjob
-- passed to the `backup` property, they will run attic prune to clean out
-- generations not specified here.
keepParam :: KeepPolicy -> AtticParam
-keepParam (KeepHours n) = "--keep-hourly=" ++ show n
-keepParam (KeepDays n) = "--keep-daily=" ++ show n
-keepParam (KeepWeeks n) = "--keep-daily=" ++ show n
-keepParam (KeepMonths n) = "--keep-monthly=" ++ show n
-keepParam (KeepYears n) = "--keep-yearly=" ++ show n
+keepParam (KeepHours n) = "--keep-hourly=" ++ val n
+keepParam (KeepDays n) = "--keep-daily=" ++ val n
+keepParam (KeepWeeks n) = "--keep-daily=" ++ val n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ val n
+keepParam (KeepYears n) = "--keep-yearly=" ++ val n
-- | Policy for backup generations to keep. For example, KeepDays 30 will
-- keep the latest backup for each day when a backup was made, and keep the
diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs
index 16030562..7ed39794 100644
--- a/src/Propellor/Property/Borg.hs
+++ b/src/Propellor/Property/Borg.hs
@@ -137,11 +137,11 @@ backup' dir backupdir crontimes extraargs kp = cronjob
-- passed to the `backup` property, they will run borg prune to clean out
-- generations not specified here.
keepParam :: KeepPolicy -> BorgParam
-keepParam (KeepHours n) = "--keep-hourly=" ++ show n
-keepParam (KeepDays n) = "--keep-daily=" ++ show n
-keepParam (KeepWeeks n) = "--keep-daily=" ++ show n
-keepParam (KeepMonths n) = "--keep-monthly=" ++ show n
-keepParam (KeepYears n) = "--keep-yearly=" ++ show n
+keepParam (KeepHours n) = "--keep-hourly=" ++ val n
+keepParam (KeepDays n) = "--keep-daily=" ++ val n
+keepParam (KeepWeeks n) = "--keep-daily=" ++ val n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ val n
+keepParam (KeepYears n) = "--keep-yearly=" ++ val n
-- | Policy for backup generations to keep. For example, KeepDays 30 will
-- keep the latest backup for each day when a backup was made, and keep the
diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs
index c0b8d539..a2bef117 100644
--- a/src/Propellor/Property/Ccache.hs
+++ b/src/Propellor/Property/Ccache.hs
@@ -76,7 +76,7 @@ limitToParams NoLimit = []
limitToParams (MaxSize s) = case maxSizeParam s of
Just param -> [Right param]
Nothing -> [Left $ "unable to parse data size " ++ s]
-limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ show f]
+limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ val f]
limitToParams (l1 :+ l2) = limitToParams l1 <> limitToParams l2
-- | Configures a ccache in /var/cache for a group
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 2e2710a6..889aece5 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -250,7 +250,7 @@ confStanza c =
cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
ipblock name l =
[ "\t" ++ name ++ " {" ] ++
- (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++
+ (map (\ip -> "\t\t" ++ val ip ++ ";") l) ++
[ "\t};" ]
mastersblock
| null (confMasters c) = []
@@ -307,17 +307,17 @@ rValue :: Record -> Maybe String
rValue (Address (IPv4 addr)) = Just addr
rValue (Address (IPv6 addr)) = Just addr
rValue (CNAME d) = Just $ dValue d
-rValue (MX pri d) = Just $ show pri ++ " " ++ dValue d
+rValue (MX pri d) = Just $ val pri ++ " " ++ dValue d
rValue (NS d) = Just $ dValue d
rValue (SRV priority weight port target) = Just $ unwords
- [ show priority
- , show weight
- , show port
+ [ val priority
+ , val weight
+ , val port
, dValue target
]
rValue (SSHFP x y s) = Just $ unwords
- [ show x
- , show y
+ [ val x
+ , val y
, s
]
rValue (INCLUDE f) = Just f
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 0bfcc781..d2b2ee35 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -323,7 +323,7 @@ class Publishable p where
toPublish :: p -> String
instance Publishable (Bound Port) where
- toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p)
+ toPublish p = val (hostSide p) ++ ":" ++ val (containerSide p)
-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
instance Publishable String where
@@ -660,10 +660,10 @@ listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property (HasInfo + Linux)
-runProp field val = tightenTargets $ pureInfoProperty (param) $
+runProp field v = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
- param = field++"="++val
+ param = field++"="++v
genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
genProp field mkval = tightenTargets $ pureInfoProperty field $
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 869fa48b..459fe2c7 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -20,6 +20,12 @@ f `hasContent` newcontent = fileProperty
(\_oldcontent -> newcontent) f
-- | Ensures that a line is present in a file, adding it to the end if not.
+--
+-- For example:
+--
+-- > & "/etc/default/daemon.conf" `File.containsLine` ("cachesize = " ++ val 1024)
+--
+-- The above example uses `val` to serialize a `ConfigurableValue`
containsLine :: FilePath -> Line -> Property UnixLike
f `containsLine` l = f `containsLines` [l]
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index 3ea19ffa..736a4458 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -15,7 +15,6 @@ module Propellor.Property.Firewall (
TCPFlag(..),
Frequency(..),
IPWithMask(..),
- fromIPWithMask
) where
import Data.Monoid
@@ -44,16 +43,16 @@ rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable
toIpTable :: Rule -> [CommandParam]
toIpTable r = map Param $
- fromChain (ruleChain r) :
+ val (ruleChain r) :
toIpTableArg (ruleRules r) ++
- ["-t", fromTable (ruleTable r), "-j", fromTarget (ruleTarget r)]
+ ["-t", val (ruleTable r), "-j", val (ruleTarget r)]
toIpTableArg :: Rules -> [String]
toIpTableArg Everything = []
toIpTableArg (Proto proto) = ["-p", map toLower $ show proto]
-toIpTableArg (DPort port) = ["--dport", fromPort port]
+toIpTableArg (DPort port) = ["--dport", val port]
toIpTableArg (DPortRange (portf, portt)) =
- ["--dport", fromPort portf ++ ":" ++ fromPort portt]
+ ["--dport", val portf ++ ":" ++ val portt]
toIpTableArg (InIFace iface) = ["-i", iface]
toIpTableArg (OutIFace iface) = ["-o", iface]
toIpTableArg (Ctstate states) =
@@ -64,12 +63,12 @@ toIpTableArg (Ctstate states) =
toIpTableArg (ICMPType i) =
[ "-m"
, "icmp"
- , "--icmp-type", fromICMPTypeMatch i
+ , "--icmp-type", val i
]
toIpTableArg (RateLimit f) =
[ "-m"
, "limit"
- , "--limit", fromFrequency f
+ , "--limit", val f
]
toIpTableArg (TCPFlags m c) =
[ "-m"
@@ -87,30 +86,30 @@ toIpTableArg (GroupOwner (Group g)) =
]
toIpTableArg (Source ipwm) =
[ "-s"
- , intercalate "," (map fromIPWithMask ipwm)
+ , intercalate "," (map val ipwm)
]
toIpTableArg (Destination ipwm) =
[ "-d"
- , intercalate "," (map fromIPWithMask ipwm)
+ , intercalate "," (map val ipwm)
]
toIpTableArg (NotDestination ipwm) =
[ "!"
, "-d"
- , intercalate "," (map fromIPWithMask ipwm)
+ , intercalate "," (map val ipwm)
]
toIpTableArg (NatDestination ip mport) =
[ "--to-destination"
- , fromIPAddr ip ++ maybe "" (\p -> ":" ++ fromPort p) mport
+ , val ip ++ maybe "" (\p -> ":" ++ val p) mport
]
toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r'
data IPWithMask = IPWithNoMask IPAddr | IPWithIPMask IPAddr IPAddr | IPWithNumMask IPAddr Int
deriving (Eq, Show)
-fromIPWithMask :: IPWithMask -> String
-fromIPWithMask (IPWithNoMask ip) = fromIPAddr ip
-fromIPWithMask (IPWithIPMask ip ipm) = fromIPAddr ip ++ "/" ++ fromIPAddr ipm
-fromIPWithMask (IPWithNumMask ip m) = fromIPAddr ip ++ "/" ++ show m
+instance ConfigurableValue IPWithMask where
+ val (IPWithNoMask ip) = val ip
+ val (IPWithIPMask ip ipm) = val ip ++ "/" ++ val ipm
+ val (IPWithNumMask ip m) = val ip ++ "/" ++ val m
data Rule = Rule
{ ruleChain :: Chain
@@ -122,33 +121,33 @@ data Rule = Rule
data Table = Filter | Nat | Mangle | Raw | Security
deriving (Eq, Show)
-fromTable :: Table -> String
-fromTable Filter = "filter"
-fromTable Nat = "nat"
-fromTable Mangle = "mangle"
-fromTable Raw = "raw"
-fromTable Security = "security"
+instance ConfigurableValue Table where
+ val Filter = "filter"
+ val Nat = "nat"
+ val Mangle = "mangle"
+ val Raw = "raw"
+ val Security = "security"
data Target = ACCEPT | REJECT | DROP | LOG | TargetCustom String
deriving (Eq, Show)
-fromTarget :: Target -> String
-fromTarget ACCEPT = "ACCEPT"
-fromTarget REJECT = "REJECT"
-fromTarget DROP = "DROP"
-fromTarget LOG = "LOG"
-fromTarget (TargetCustom t) = t
+instance ConfigurableValue Target where
+ val ACCEPT = "ACCEPT"
+ val REJECT = "REJECT"
+ val DROP = "DROP"
+ val LOG = "LOG"
+ val (TargetCustom t) = t
data Chain = INPUT | OUTPUT | FORWARD | PREROUTING | POSTROUTING | ChainCustom String
deriving (Eq, Show)
-fromChain :: Chain -> String
-fromChain INPUT = "INPUT"
-fromChain OUTPUT = "OUTPUT"
-fromChain FORWARD = "FORWARD"
-fromChain PREROUTING = "PREROUTING"
-fromChain POSTROUTING = "POSTROUTING"
-fromChain (ChainCustom c) = c
+instance ConfigurableValue Chain where
+ val INPUT = "INPUT"
+ val OUTPUT = "OUTPUT"
+ val FORWARD = "FORWARD"
+ val PREROUTING = "PREROUTING"
+ val POSTROUTING = "POSTROUTING"
+ val (ChainCustom c) = c
data Proto = TCP | UDP | ICMP
deriving (Eq, Show)
@@ -159,15 +158,15 @@ data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID
data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int
deriving (Eq, Show)
-fromICMPTypeMatch :: ICMPTypeMatch -> String
-fromICMPTypeMatch (ICMPTypeName t) = t
-fromICMPTypeMatch (ICMPTypeCode c) = show c
+instance ConfigurableValue ICMPTypeMatch where
+ val (ICMPTypeName t) = t
+ val (ICMPTypeCode c) = val c
data Frequency = NumBySecond Int
deriving (Eq, Show)
-fromFrequency :: Frequency -> String
-fromFrequency (NumBySecond n) = show n ++ "/second"
+instance ConfigurableValue Frequency where
+ val (NumBySecond n) = val n ++ "/second"
type TCPFlagMask = [TCPFlag]
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index 58477468..e6ddea16 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -19,6 +19,7 @@ poudriereConfigPath = "/usr/local/etc/poudriere.conf"
newtype PoudriereConfigured = PoudriereConfigured String
deriving (Typeable, Monoid, Show)
+
instance IsInfo PoudriereConfigured where
propagateInfo _ = False
@@ -68,7 +69,7 @@ jail j@(Jail name version arch) = tightenTargets $
nx <- liftIO $ not <$> jailExists j
return $ c && nx
- (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version]
+ (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", val arch, "-v", val version]
createJail = cmdProperty cmd args
in
check chk createJail
@@ -101,9 +102,10 @@ data PoudriereZFS = PoudriereZFS ZFS.ZFS ZFS.ZFSProperties
data Jail = Jail String FBSDVersion PoudriereArch
data PoudriereArch = I386 | AMD64 deriving (Eq)
-instance Show PoudriereArch where
- show I386 = "i386"
- show AMD64 = "amd64"
+
+instance ConfigurableValue PoudriereArch where
+ val I386 = "i386"
+ val AMD64 = "amd64"
fromArchitecture :: Architecture -> PoudriereArch
fromArchitecture X86_64 = AMD64
@@ -127,7 +129,7 @@ instance ToShellConfigLines PoudriereZFS where
toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) =
[ ("NO_ZFS", "no")
, ("ZPOOL", pool)
- , ("ZROOTFS", show dataset)
+ , ("ZROOTFS", val dataset)
]
type ConfigLine = String
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index a03fc5a0..9dd5e8e1 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -69,7 +69,7 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
& File.dirExists "/boot/grub"
& "/boot/grub/menu.lst" `File.hasContent`
[ "default 1"
- , "timeout " ++ show timeout
+ , "timeout " ++ val timeout
, ""
, "title grub-xen shim"
, "root (" ++ rootdev ++ ")"
diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs
index ced9fce2..8eaf56fd 100644
--- a/src/Propellor/Property/Logcheck.hs
+++ b/src/Propellor/Property/Logcheck.hs
@@ -16,21 +16,21 @@ import qualified Propellor.Property.File as File
data ReportLevel = Workstation | Server | Paranoid
type Service = String
-instance Show ReportLevel where
- show Workstation = "workstation"
- show Server = "server"
- show Paranoid = "paranoid"
+instance ConfigurableValue ReportLevel where
+ val Workstation = "workstation"
+ val Server = "server"
+ val Paranoid = "paranoid"
-- The common prefix used by default in syslog lines.
defaultPrefix :: String
defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ "
ignoreFilePath :: ReportLevel -> Service -> FilePath
-ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n
+ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (val t) </> n
ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike
ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls
- `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")")
+ `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ val t ++ ")")
installed :: Property DebianLike
installed = Apt.installed ["logcheck"]
diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs
index dd74d91b..6dab25ef 100644
--- a/src/Propellor/Property/Munin.hs
+++ b/src/Propellor/Property/Munin.hs
@@ -46,8 +46,8 @@ hostListFragment' hs os = concatMap muninHost hs
where
muninHost :: Host -> [String]
muninHost h = [ "[" ++ (hostName h) ++ "]"
- , " address " ++ maybe (hostName h) (fromIPAddr . fst) (hOverride h)
- ] ++ (maybe [] (\x -> [" port " ++ (fromPort $ snd x)]) (hOverride h)) ++ [""]
+ , " address " ++ maybe (hostName h) (val . fst) (hOverride h)
+ ] ++ (maybe [] (\x -> [" port " ++ (val $ snd x)]) (hOverride h)) ++ [""]
hOverride :: Host -> Maybe (IPAddr, Port)
hOverride h = lookup (hostName h) os
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 5bf3ff06..66d3c08d 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -150,7 +150,7 @@ keepParam ps = "--keep=" ++ intercalate "," (map go ps)
go (KeepWeeks n) = mk n 'w'
go (KeepMonths n) = mk n 'm'
go (KeepYears n) = mk n 'y'
- mk n c = show n ++ [c]
+ mk n c = val n ++ [c]
isKeepParam :: ObnamParam -> Bool
isKeepParam p = "--keep=" `isPrefixOf` p
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index 0abf38a6..00daa57d 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -28,7 +28,7 @@ providerFor users hn mp = propertyList desc $ props
where
baseurl = hn ++ case mp of
Nothing -> ""
- Just p -> ':' : fromPort p
+ Just p -> ':' : val p
url = "http://"++baseurl++"/simpleid"
desc = "openid provider " ++ url
setbaseurl l
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 40af3357..f7ac379f 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -30,14 +30,14 @@ import Data.Char
import System.Posix.Files
class PartedVal a where
- val :: a -> String
+ pval :: a -> String
-- | Types of partition tables supported by parted.
data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN
deriving (Show)
instance PartedVal TableType where
- val = map toLower . show
+ pval = map toLower . show
-- | A disk's partition table.
data PartTable = PartTable TableType [Partition]
@@ -82,9 +82,9 @@ data PartType = Primary | Logical | Extended
deriving (Show)
instance PartedVal PartType where
- val Primary = "primary"
- val Logical = "logical"
- val Extended = "extended"
+ pval Primary = "primary"
+ pval Logical = "logical"
+ pval Extended = "extended"
-- | All partition sizing is done in megabytes, so that parted can
-- automatically lay out the partitions.
@@ -94,11 +94,11 @@ newtype PartSize = MegaBytes Integer
deriving (Show)
instance PartedVal PartSize where
- val (MegaBytes n)
- | n > 0 = show n ++ "MB"
+ pval (MegaBytes n)
+ | n > 0 = val n ++ "MB"
-- parted can't make partitions smaller than 1MB;
-- avoid failure in edge cases
- | otherwise = show "1MB"
+ | otherwise = "1MB"
-- | Rounds up to the nearest MegaByte.
toPartSize :: ByteSize -> PartSize
@@ -119,33 +119,33 @@ data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag
deriving (Show)
instance PartedVal PartFlag where
- val BootFlag = "boot"
- val RootFlag = "root"
- val SwapFlag = "swap"
- val HiddenFlag = "hidden"
- val RaidFlag = "raid"
- val LvmFlag = "lvm"
- val LbaFlag = "lba"
- val LegacyBootFlag = "legacy_boot"
- val IrstFlag = "irst"
- val EspFlag = "esp"
- val PaloFlag = "palo"
+ pval BootFlag = "boot"
+ pval RootFlag = "root"
+ pval SwapFlag = "swap"
+ pval HiddenFlag = "hidden"
+ pval RaidFlag = "raid"
+ pval LvmFlag = "lvm"
+ pval LbaFlag = "lba"
+ pval LegacyBootFlag = "legacy_boot"
+ pval IrstFlag = "irst"
+ pval EspFlag = "esp"
+ pval PaloFlag = "palo"
instance PartedVal Bool where
- val True = "on"
- val False = "off"
+ pval True = "on"
+ pval False = "off"
instance PartedVal Partition.Fs where
- val Partition.EXT2 = "ext2"
- val Partition.EXT3 = "ext3"
- val Partition.EXT4 = "ext4"
- val Partition.BTRFS = "btrfs"
- val Partition.REISERFS = "reiserfs"
- val Partition.XFS = "xfs"
- val Partition.FAT = "fat"
- val Partition.VFAT = "vfat"
- val Partition.NTFS = "ntfs"
- val Partition.LinuxSwap = "linux-swap"
+ pval Partition.EXT2 = "ext2"
+ pval Partition.EXT3 = "ext3"
+ pval Partition.EXT4 = "ext4"
+ pval Partition.BTRFS = "btrfs"
+ pval Partition.REISERFS = "reiserfs"
+ pval Partition.XFS = "xfs"
+ pval Partition.FAT = "fat"
+ pval Partition.VFAT = "vfat"
+ pval Partition.NTFS = "ntfs"
+ pval Partition.LinuxSwap = "linux-swap"
data Eep = YesReallyDeleteDiskContents
@@ -168,19 +168,19 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts []
format (p, dev) = Partition.formatted' (partMkFsOpts p)
Partition.YesReallyFormatPartition (partFs p) dev
- mklabel = ["mklabel", val tabletype]
+ mklabel = ["mklabel", pval tabletype]
mkflag partnum (f, b) =
[ "set"
, show partnum
- , val f
- , val b
+ , pval f
+ , pval b
]
mkpart partnum offset p =
[ "mkpart"
- , val (partType p)
- , val (partFs p)
- , val offset
- , val (offset <> partSize p)
+ , pval (partType p)
+ , pval (partFs p)
+ , pval offset
+ , pval (offset <> partSize p)
] ++ case partName p of
Just n -> ["name", show partnum, n]
Nothing -> []
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index db5982cd..aaa83e6f 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -111,8 +111,8 @@ type Suite = String
-- the same suite and the same architecture, so neither do we
data SbuildSchroot = SbuildSchroot Suite Architecture
-instance Show SbuildSchroot where
- show (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
+instance ConfigurableValue SbuildSchroot where
+ val (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
-- | Whether an sbuild schroot should use ccache during builds
--
@@ -151,7 +151,7 @@ built s@(SbuildSchroot suite arch) mirror cc =
where
go :: Property DebianLike
go = check (unpopulated (schrootRoot s) <||> ispartial) $
- property' ("built sbuild schroot for " ++ show s) make
+ property' ("built sbuild schroot for " ++ val s) make
make w = do
de <- liftIO standardPathEnv
let params = Param <$>
@@ -170,18 +170,18 @@ built s@(SbuildSchroot suite arch) mirror cc =
-- TODO we should kill any sessions still using the chroot
-- before destroying it (as suggested by sbuild-destroychroot)
deleted = check (not <$> unpopulated (schrootRoot s)) $
- property ("no sbuild schroot for " ++ show s) $ do
+ property ("no sbuild schroot for " ++ val s) $ do
liftIO $ removeChroot $ schrootRoot s
liftIO $ nukeFile
- ("/etc/sbuild/chroot" </> show s ++ "-sbuild")
+ ("/etc/sbuild/chroot" </> val s ++ "-sbuild")
makeChange $ nukeFile (schrootConf s)
enhancedConf =
- combineProperties ("enhanced schroot conf for " ++ show s) $ props
+ combineProperties ("enhanced schroot conf for " ++ val s) $ props
& aliasesLine
-- enable ccache and eatmydata for speed
& ConfFile.containsIniSetting (schrootConf s)
- ( show s ++ "-sbuild"
+ ( val s ++ "-sbuild"
, "command-prefix"
, intercalate "," commandPrefix
)
@@ -196,7 +196,7 @@ built s@(SbuildSchroot suite arch) mirror cc =
then ensureProperty w $
ConfFile.containsIniSetting
(schrootConf s)
- ( show s ++ "-sbuild"
+ ( val s ++ "-sbuild"
, "aliases"
, aliases
)
@@ -263,7 +263,7 @@ updatedFor system = property' ("updated sbuild schroot for " ++ show system) $
updated :: SbuildSchroot -> Property DebianLike
updated s@(SbuildSchroot suite arch) =
check (doesDirectoryExist (schrootRoot s)) $ go
- `describe` ("updated schroot for " ++ show s)
+ `describe` ("updated schroot for " ++ val s)
`requires` installed
where
go :: Property DebianLike
@@ -283,13 +283,13 @@ updated s@(SbuildSchroot suite arch) =
-- given suite and architecture, so we don't need the suffix to be random.
fixConfFile :: SbuildSchroot -> Property UnixLike
fixConfFile s@(SbuildSchroot suite arch) =
- property' ("schroot for " ++ show s ++ " config file fixed") $ \w -> do
+ property' ("schroot for " ++ val s ++ " config file fixed") $ \w -> do
confs <- liftIO $ dirContents dir
let old = concat $ filter (tempPrefix `isPrefixOf`) confs
liftIO $ moveFile old new
liftIO $ moveFile
- ("/etc/sbuild/chroot" </> show s ++ "-propellor")
- ("/etc/sbuild/chroot" </> show s ++ "-sbuild")
+ ("/etc/sbuild/chroot" </> val s ++ "-propellor")
+ ("/etc/sbuild/chroot" </> val s ++ "-sbuild")
ensureProperty w $
File.fileProperty "replace dummy suffix" (map munge) new
where
@@ -361,10 +361,10 @@ piupartsConf s@(SbuildSchroot _ arch) =
orig = "/etc/schroot/sbuild"
dir = "/etc/schroot/piuparts"
- sec = show s ++ "-piuparts"
+ sec = val s ++ "-piuparts"
f = schrootPiupartsConf s
munge = replace "-sbuild]" "-piuparts]"
- desc = "piuparts schroot conf for " ++ show s
+ desc = "piuparts schroot conf for " ++ val s
-- normally the piuparts schroot conf has no aliases, but we have to add
-- one, for dgit compatibility, if this is the default sid chroot
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 4de6c5d3..c4f0e352 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -314,9 +314,9 @@ apacheSite hn middle = Apache.siteEnabled hn $ apachecfg hn middle
apachecfg :: HostName -> Apache.ConfigFile -> Apache.ConfigFile
apachecfg hn middle =
- [ "<VirtualHost *:"++show port++">"
+ [ "<VirtualHost *:" ++ val port ++ ">"
, " ServerAdmin grue@joeyh.name"
- , " ServerName "++hn++":"++show port
+ , " ServerName "++hn++":" ++ val port
]
++ middle ++
[ ""
@@ -329,7 +329,7 @@ apachecfg hn middle =
, "</VirtualHost>"
]
where
- port = 80 :: Int
+ port = Port 80
gitAnnexDistributor :: Property (HasInfo + DebianLike)
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
@@ -405,8 +405,6 @@ githubBackup = propertyList "github-backup box" $ props
& githubKeys
& Cron.niceJob "github-backup run" (Cron.Times "30 4 * * *") (User "joey")
"/home/joey/lib/backup" backupcmd
- & Cron.niceJob "gitriddance" (Cron.Times "30 4 * * *") (User "joey")
- "/home/joey/lib/backup" gitriddancecmd
where
backupcmd = intercalate "&&" $
[ "mkdir -p github"
@@ -414,11 +412,6 @@ githubBackup = propertyList "github-backup box" $ props
, ". $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 + UnixLike)
githubKeys =
@@ -427,19 +420,6 @@ githubKeys =
`onChange` File.ownerGroup f (User "joey") (Group "joey")
--- these repos are only mirrored on github, I don't want
--- all the proprietary features
-githubMirrors :: [(String, String)]
-githubMirrors =
- [ ("ikiwiki", plzuseurl "http://ikiwiki.info/todo/")
- , ("git-annex", plzuseurl "http://git-annex.branchable.com/todo/")
- , ("myrepos", plzuseurl "http://myrepos.branchable.com/todo/")
- , ("propellor", plzuseurl "http://propellor.branchable.com/todo/")
- , ("etckeeper", plzuseurl "http://etckeeper.branchable.com/todo/")
- ]
- where
- plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess"
-
rsyncNetBackup :: [Host] -> Property DebianLike
rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *")
(User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index bce522f6..828601b8 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -69,11 +69,11 @@ setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike
setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)
setSshdConfig :: ConfigKeyword -> String -> Property DebianLike
-setSshdConfig setting val = File.fileProperty desc f sshdConfig
+setSshdConfig setting v = File.fileProperty desc f sshdConfig
`onChange` restarted
where
- desc = unwords [ "ssh config:", setting, val ]
- cfgline = setting ++ " " ++ val
+ desc = unwords [ "ssh config:", setting, v ]
+ cfgline = setting ++ " " ++ v
wantedline s
| s == cfgline = True
| (setting ++ " ") `isPrefixOf` s = False
@@ -120,7 +120,7 @@ dotFile f user = do
listenPort :: Port -> RevertableProperty DebianLike DebianLike
listenPort port = enable <!> disable
where
- portline = "Port " ++ fromPort port
+ portline = "Port " ++ val port
enable = sshdConfig `File.containsLine` portline
`describe` ("ssh listening on " ++ portline)
`onChange` restarted
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 78529f73..e1e20974 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -421,7 +421,7 @@ class Publishable a where
toPublish :: a -> String
instance Publishable Port where
- toPublish port = fromPort port
+ toPublish port = val port
instance Publishable (Bound Port) where
toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v)
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index 72bd45f5..24d5b687 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -128,7 +128,7 @@ hiddenService hn port = hiddenService' hn [port]
hiddenService' :: HiddenServiceName -> [Port] -> Property DebianLike
hiddenService' hn ports = ConfFile.adjustSection
- (unwords ["hidden service", hn, "available on ports", intercalate "," (map fromPort ports')])
+ (unwords ["hidden service", hn, "available on ports", intercalate "," (map val ports')])
(== oniondir)
(not . isPrefixOf "HiddenServicePort")
(const (oniondir : onionports))
@@ -139,7 +139,7 @@ hiddenService' hn ports = ConfFile.adjustSection
oniondir = unwords ["HiddenServiceDir", varLib </> hn]
onionports = map onionport ports'
ports' = sort ports
- onionport port = unwords ["HiddenServicePort", fromPort port, "127.0.0.1:" ++ fromPort port]
+ onionport port = unwords ["HiddenServicePort", val port, "127.0.0.1:" ++ val port]
-- | Same as `hiddenService` but also causes propellor to display
-- the onion address of the hidden service.
diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs
index 23a5b30d..470aad7e 100644
--- a/src/Propellor/Property/Unbound.hs
+++ b/src/Propellor/Property/Unbound.hs
@@ -133,10 +133,10 @@ genAddress dom ttl addr = case addr of
IPv6 _ -> genAddress' "AAAA" dom ttl addr
genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String
-genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> show ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ fromIPAddr addr
+genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> val ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ val addr
genMX :: BindDomain -> Int -> BindDomain -> String
-genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ show priority ++ " " ++ dValue dest
+genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ val priority ++ " " ++ dValue dest
genPTR :: BindDomain -> ReverseIP -> String
genPTR dom revip = revip ++ ". " ++ "PTR" ++ " " ++ dValue dom
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index c6699961f..447f8e9f 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -169,7 +169,7 @@ getSshTarget target hst
warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead."
return ip
- configips = map fromIPAddr $ mapMaybe getIPAddr $
+ configips = map val $ mapMaybe getIPAddr $
S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 23066c18..097c332d 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -36,6 +36,7 @@ module Propellor.Types (
, adjustPropertySatisfy
-- * Other included types
, module Propellor.Types.OS
+ , module Propellor.Types.ConfigurableValue
, module Propellor.Types.Dns
, module Propellor.Types.Result
, module Propellor.Types.ZFS
@@ -46,6 +47,7 @@ import Data.Monoid
import Propellor.Types.Core
import Propellor.Types.Info
import Propellor.Types.OS
+import Propellor.Types.ConfigurableValue
import Propellor.Types.Dns
import Propellor.Types.Result
import Propellor.Types.MetaTypes
diff --git a/src/Propellor/Types/ConfigurableValue.hs b/src/Propellor/Types/ConfigurableValue.hs
new file mode 100644
index 00000000..1414be5f
--- /dev/null
+++ b/src/Propellor/Types/ConfigurableValue.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+module Propellor.Types.ConfigurableValue where
+
+import Data.Word
+
+-- | A value that can be used in a configuration file, or otherwise used to
+-- configure a program.
+--
+-- Unlike Show, there should only be instances of this type class for
+-- values that have a standard serialization that is understood outside of
+-- Haskell code.
+--
+-- When converting a type alias such as "type Foo = String" or "type Foo = Int"
+-- to a newtype, it's unsafe to derive a Show instance, because there may
+-- be code that shows the type to configure a value. Instead, define a
+-- ConfigurableValue instance.
+class ConfigurableValue t where
+ val :: t -> String
+
+-- | val String does not do any quoting, unlike show String
+instance ConfigurableValue String where
+ val = id
+
+instance ConfigurableValue Int where
+ val = show
+
+instance ConfigurableValue Integer where
+ val = show
+
+instance ConfigurableValue Float where
+ val = show
+
+instance ConfigurableValue Double where
+ val = show
+
+instance ConfigurableValue Word8 where
+ val = show
+
+instance ConfigurableValue Word16 where
+ val = show
+
+instance ConfigurableValue Word32 where
+ val = show
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 8f15d156..4cb8b111 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -5,6 +5,7 @@ module Propellor.Types.Dns where
import Propellor.Types.OS (HostName)
import Propellor.Types.Empty
import Propellor.Types.Info
+import Propellor.Types.ConfigurableValue
import Data.Word
import qualified Data.Map as M
@@ -19,9 +20,9 @@ type Domain = String
data IPAddr = IPv4 String | IPv6 String
deriving (Read, Show, Eq, Ord)
-fromIPAddr :: IPAddr -> String
-fromIPAddr (IPv4 addr) = addr
-fromIPAddr (IPv6 addr) = addr
+instance ConfigurableValue IPAddr where
+ val (IPv4 addr) = addr
+ val (IPv6 addr) = addr
newtype AliasesInfo = AliasesInfo (S.Set HostName)
deriving (Show, Eq, Ord, Monoid, Typeable)
@@ -102,7 +103,7 @@ type ReverseIP = String
reverseIP :: IPAddr -> ReverseIP
reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa"
-reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ fromIPAddr $ canonicalIP addr) ++ ".ip6.arpa"
+reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa"
-- | Converts an IP address (particularly IPv6) to canonical, fully
-- expanded form.
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 696c36b0..41f839f1 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -18,10 +18,11 @@ module Propellor.Types.OS (
Group(..),
userGroup,
Port(..),
- fromPort,
systemToTargetOS,
) where
+import Propellor.Types.ConfigurableValue
+
import Network.BSD (HostName)
import Data.Typeable
import Data.String
@@ -75,10 +76,13 @@ instance IsString FBSDVersion where
fromString "9.3-RELEASE" = FBSD093
fromString _ = error "Invalid FreeBSD release"
+instance ConfigurableValue FBSDVersion where
+ val FBSD101 = "10.1-RELEASE"
+ val FBSD102 = "10.2-RELEASE"
+ val FBSD093 = "9.3-RELEASE"
+
instance Show FBSDVersion where
- show FBSD101 = "10.1-RELEASE"
- show FBSD102 = "10.2-RELEASE"
- show FBSD093 = "9.3-RELEASE"
+ show = val
isStable :: DebianSuite -> Bool
isStable (Stable _) = True
@@ -138,9 +142,15 @@ type UserName = String
newtype User = User UserName
deriving (Eq, Ord, Show)
+instance ConfigurableValue User where
+ val (User n) = n
+
newtype Group = Group String
deriving (Eq, Ord, Show)
+instance ConfigurableValue Group where
+ val (Group n) = n
+
-- | Makes a Group with the same name as the User.
userGroup :: User -> Group
userGroup (User u) = Group u
@@ -148,5 +158,5 @@ userGroup (User u) = Group u
newtype Port = Port Int
deriving (Eq, Ord, Show)
-fromPort :: Port -> String
-fromPort (Port p) = show p
+instance ConfigurableValue Port where
+ val (Port p) = show p
diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs
index 3ce4b22c..22b848fa 100644
--- a/src/Propellor/Types/ZFS.hs
+++ b/src/Propellor/Types/ZFS.hs
@@ -6,6 +6,8 @@
module Propellor.Types.ZFS where
+import Propellor.Types.ConfigurableValue
+
import Data.String
import qualified Data.Set as Set
import qualified Data.String.Utils as SU
@@ -32,24 +34,27 @@ toPropertyList = Set.foldr (\p l -> l ++ [toPair p]) []
fromPropertyList :: [(String, String)] -> ZFSProperties
fromPropertyList props =
- Set.fromList $ map fromPair props
+ Set.fromList $ map fromPair props
zfsName :: ZFS -> String
zfsName (ZFS (ZPool pool) dataset) = intercalate "/" [pool, show dataset]
+instance ConfigurableValue ZDataset where
+ val (ZDataset paths) = intercalate "/" paths
+
instance Show ZDataset where
- show (ZDataset paths) = intercalate "/" paths
+ show = val
instance IsString ZDataset where
- fromString s = ZDataset $ SU.split "/" s
+ fromString s = ZDataset $ SU.split "/" s
instance IsString ZPool where
- fromString p = ZPool p
+ fromString p = ZPool p
class Value a where
- toValue :: a -> String
- fromValue :: (IsString a) => String -> a
- fromValue = fromString
+ toValue :: a -> String
+ fromValue :: (IsString a) => String -> a
+ fromValue = fromString
data ZFSYesNo = ZFSYesNo Bool deriving (Show, Eq, Ord)
data ZFSOnOff = ZFSOnOff Bool deriving (Show, Eq, Ord)
@@ -57,57 +62,57 @@ data ZFSSize = ZFSSize Integer deriving (Show, Eq, Ord)
data ZFSString = ZFSString String deriving (Show, Eq, Ord)
instance Value ZFSYesNo where
- toValue (ZFSYesNo True) = "yes"
- toValue (ZFSYesNo False) = "no"
+ toValue (ZFSYesNo True) = "yes"
+ toValue (ZFSYesNo False) = "no"
instance Value ZFSOnOff where
- toValue (ZFSOnOff True) = "on"
- toValue (ZFSOnOff False) = "off"
+ toValue (ZFSOnOff True) = "on"
+ toValue (ZFSOnOff False) = "off"
instance Value ZFSSize where
- toValue (ZFSSize s) = show s
+ toValue (ZFSSize s) = show s
instance Value ZFSString where
- toValue (ZFSString s) = s
+ toValue (ZFSString s) = s
instance IsString ZFSString where
- fromString = ZFSString
+ fromString = ZFSString
instance IsString ZFSYesNo where
- fromString "yes" = ZFSYesNo True
- fromString "no" = ZFSYesNo False
- fromString _ = error "Not yes or no"
+ fromString "yes" = ZFSYesNo True
+ fromString "no" = ZFSYesNo False
+ fromString _ = error "Not yes or no"
instance IsString ZFSOnOff where
- fromString "on" = ZFSOnOff True
- fromString "off" = ZFSOnOff False
- fromString _ = error "Not on or off"
+ fromString "on" = ZFSOnOff True
+ fromString "off" = ZFSOnOff False
+ fromString _ = error "Not on or off"
data ZFSACLInherit = AIDiscard | AINoAllow | AISecure | AIPassthrough deriving (Show, Eq, Ord)
instance IsString ZFSACLInherit where
- fromString "discard" = AIDiscard
- fromString "noallow" = AINoAllow
- fromString "secure" = AISecure
- fromString "passthrough" = AIPassthrough
- fromString _ = error "Not valid aclpassthrough value"
+ fromString "discard" = AIDiscard
+ fromString "noallow" = AINoAllow
+ fromString "secure" = AISecure
+ fromString "passthrough" = AIPassthrough
+ fromString _ = error "Not valid aclpassthrough value"
instance Value ZFSACLInherit where
- toValue AIDiscard = "discard"
- toValue AINoAllow = "noallow"
- toValue AISecure = "secure"
- toValue AIPassthrough = "passthrough"
+ toValue AIDiscard = "discard"
+ toValue AINoAllow = "noallow"
+ toValue AISecure = "secure"
+ toValue AIPassthrough = "passthrough"
data ZFSACLMode = AMDiscard | AMGroupmask | AMPassthrough deriving (Show, Eq, Ord)
instance IsString ZFSACLMode where
- fromString "discard" = AMDiscard
- fromString "groupmask" = AMGroupmask
- fromString "passthrough" = AMPassthrough
- fromString _ = error "Invalid zfsaclmode"
+ fromString "discard" = AMDiscard
+ fromString "groupmask" = AMGroupmask
+ fromString "passthrough" = AMPassthrough
+ fromString _ = error "Invalid zfsaclmode"
instance Value ZFSACLMode where
- toValue AMDiscard = "discard"
- toValue AMGroupmask = "groupmask"
- toValue AMPassthrough = "passthrough"
+ toValue AMDiscard = "discard"
+ toValue AMGroupmask = "groupmask"
+ toValue AMPassthrough = "passthrough"
data ZFSProperty = Mounted ZFSYesNo
| Mountpoint ZFSString