diff options
39 files changed, 321 insertions, 244 deletions
@@ -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 |