summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore6
-rw-r--r--config-freebsd.hs66
l---------config.hs2
-rw-r--r--debian/changelog4
-rwxr-xr-xdebian/rules2
-rw-r--r--doc/FreeBSD.mdwn19
-rw-r--r--privdata/relocate1
-rw-r--r--propellor.cabal8
-rw-r--r--src/Propellor.hs1
-rw-r--r--src/Propellor/Bootstrap.hs58
-rw-r--r--src/Propellor/CmdLine.hs14
-rw-r--r--src/Propellor/Property/Chroot.hs15
-rw-r--r--src/Propellor/Property/Cron.hs10
-rw-r--r--src/Propellor/Property/Debootstrap.hs19
-rw-r--r--src/Propellor/Property/FreeBSD.hs13
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs85
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs141
-rw-r--r--src/Propellor/Property/Systemd.hs16
-rw-r--r--src/Propellor/Property/ZFS.hs11
-rw-r--r--src/Propellor/Property/ZFS/Process.hs32
-rw-r--r--src/Propellor/Property/ZFS/Properties.hs36
-rw-r--r--src/Propellor/Spin.hs34
-rw-r--r--src/Propellor/Types.hs18
-rw-r--r--src/Propellor/Types/OS.hs22
-rw-r--r--src/Propellor/Types/ZFS.hs133
25 files changed, 690 insertions, 76 deletions
diff --git a/.gitignore b/.gitignore
index 431b1c4b..d9285db3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,5 @@
+/propellor
dist/*
-propellor
tags
privdata/local
privdata/keyring.gpg~
@@ -12,3 +12,7 @@ propellor.1
.lock
.lastchecked
.stack-work/*
+.cabal-sandbox/
+.dir-locals.el
+cabal.sandbox.config
+*~
diff --git a/config-freebsd.hs b/config-freebsd.hs
new file mode 100644
index 00000000..02a0fdf9
--- /dev/null
+++ b/config-freebsd.hs
@@ -0,0 +1,66 @@
+-- This is the main configuration file for Propellor, and is used to build
+-- the propellor program.
+--
+-- This shows how to as a FreeBSD, as well as a Linux host.
+
+import Propellor
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Network as Network
+import qualified Propellor.Property.Cron as Cron
+import Propellor.Property.Scheduled
+import qualified Propellor.Property.User as User
+import qualified Propellor.Property.Docker as Docker
+import qualified Propellor.Property.FreeBSD.Pkg as Pkg
+import qualified Propellor.Property.ZFS as ZFS
+import qualified Propellor.Property.FreeBSD.Poudriere as Poudriere
+
+main :: IO ()
+main = defaultMain hosts
+
+-- The hosts propellor knows about.
+hosts :: [Host]
+hosts =
+ [ mybox
+ , freebsd
+ ]
+
+-- An example linux host.
+mybox :: Host
+mybox = host "mybox.example.com"
+ & os (System (Debian Unstable) "amd64")
+ & Apt.stdSourcesList
+ & Apt.unattendedUpgrades
+ & Apt.installed ["etckeeper"]
+ & Apt.installed ["ssh"]
+ & User.hasSomePassword (User "root")
+ & Network.ipv6to4
+ & File.dirExists "/var/www"
+ & Docker.docked webserverContainer
+ & Docker.garbageCollected `period` Daily
+ & Cron.runPropellor (Cron.Times "30 * * * *")
+
+-- A generic webserver in a Docker container.
+webserverContainer :: Docker.Container
+webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
+ & os (System (Debian (Stable "jessie")) "amd64")
+ & Apt.stdSourcesList
+ & Docker.publish "80:80"
+ & Docker.volume "/var/www:/var/www"
+ & Apt.serviceInstalledRunning "apache2"
+
+-- An example freebsd host.
+freebsd :: Host
+freebsd = host "freebsd.example.com"
+ & os (System (FreeBSD (FBSDProduction FBSD102)) "amd64")
+ & Pkg.update
+ & Pkg.upgrade
+ & Poudriere.poudriere poudriereZFS
+ & Poudriere.jail (Poudriere.Jail "formail" (fromString "10.2-RELEASE") (fromString "amd64"))
+
+poudriereZFS :: Poudriere.Poudriere
+poudriereZFS = Poudriere.defaultConfig
+ { Poudriere._zfs = Just $ Poudriere.PoudriereZFS
+ (ZFS.ZFS (fromString "zroot") (fromString "poudriere"))
+ (ZFS.fromList [ZFS.Mountpoint (fromString "/poudriere"), ZFS.ACLInherit ZFS.AIPassthrough])
+ }
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 74911c24..462cad65 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -19,6 +19,10 @@ propellor (2.17.0) UNRELEASED; urgency=medium
Thanks, Félix Sipma.
* Ssh: hange type of listenPort from Int to Port (API change)
Thanks, Félix Sipma.
+ * Added initial support for FreeBSD.
+ Thanks, Evan Cofsky.
+ * Added Propellor.Property.ZFS.
+ Thanks, Evan Cofsky.
-- Joey Hess <id@joeyh.name> Mon, 29 Feb 2016 17:58:08 -0400
diff --git a/debian/rules b/debian/rules
index a71212db..c88cc004 100755
--- a/debian/rules
+++ b/debian/rules
@@ -1,4 +1,4 @@
-#!/usr/bin/make -f
+#!/bin/false
# Avoid using cabal, as it writes to $HOME
export CABAL=./Setup
diff --git a/doc/FreeBSD.mdwn b/doc/FreeBSD.mdwn
new file mode 100644
index 00000000..1cac527e
--- /dev/null
+++ b/doc/FreeBSD.mdwn
@@ -0,0 +1,19 @@
+# FreeBSD Support for Propellor
+
+This branch is to add FreeBSD support to Propellor. The first steps
+will focus around package management with pkg-ng.
+
+# Bootstrapping
+
+The current Bootstrap process is very apt-centric, so current efforts
+are focusing on passing the System information down into Bootstrap.
+
+Affected functions are:
+
+* `installGitCommand`, which has to install pkg itself, then install
+ git. The `ASSUME_ALWAYS_YES` environment variable must be set so pkg
+ will just do its thing.
+
+* `depsCommand`, which installs as many Haskell dependencies from the
+ system package manager. We also install gmake, but I'm not sure
+ where this is used yet.
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 1366d89e..4e0e1db2 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -16,6 +16,7 @@ Extra-Source-Files:
CHANGELOG
Makefile
config-simple.hs
+ config-freebsd.hs
joeyconfig.hs
config.hs
contrib/post-checkout-hook
@@ -84,6 +85,9 @@ Library
Propellor.Property.Fail2Ban
Propellor.Property.File
Propellor.Property.Firewall
+ Propellor.Property.FreeBSD
+ Propellor.Property.FreeBSD.Pkg
+ Propellor.Property.FreeBSD.Poudriere
Propellor.Property.Git
Propellor.Property.Gpg
Propellor.Property.Group
@@ -118,6 +122,9 @@ Library
Propellor.Property.Unbound
Propellor.Property.User
Propellor.Property.Uwsgi
+ Propellor.Property.ZFS
+ Propellor.Property.ZFS.Process
+ Propellor.Property.ZFS.Properties
Propellor.Property.HostingProvider.CloudAtCost
Propellor.Property.HostingProvider.DigitalOcean
Propellor.Property.HostingProvider.Linode
@@ -147,6 +154,7 @@ Library
Propellor.Types.Result
Propellor.Types.ResultCheck
Propellor.Types.CmdLine
+ Propellor.Types.ZFS
Other-Modules:
Propellor.Bootstrap
Propellor.Git
diff --git a/src/Propellor.hs b/src/Propellor.hs
index 53b209ca..9c5a85a9 100644
--- a/src/Propellor.hs
+++ b/src/Propellor.hs
@@ -72,3 +72,4 @@ import Propellor.Info
import Propellor.PropAccum
import Data.Monoid as X
+import Data.String as X (fromString)
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index c49cb5af..633a2ff4 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -15,16 +15,16 @@ type ShellCommand = String
-- Shell command line to ensure propellor is bootstrapped and ready to run.
-- Should be run inside the propellor config dir, and will install
-- all necessary build dependencies and build propellor.
-bootstrapPropellorCommand :: ShellCommand
-bootstrapPropellorCommand = checkDepsCommand ++
- "&& if ! test -x ./propellor; then "
- ++ buildCommand ++
+bootstrapPropellorCommand :: Maybe System -> ShellCommand
+bootstrapPropellorCommand msys = maybe "true" checkDepsCommand msys ++
+ "&& if ! test -x ./propellor; then "
+ ++ buildCommand ++
"; fi;" ++ checkBinaryCommand
-- Use propellor --check to detect if the local propellor binary has
-- stopped working (eg due to library changes), and must be rebuilt.
checkBinaryCommand :: ShellCommand
-checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check 2>/dev/null; then " ++ go ++ "; fi"
+checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi"
where
go = intercalate " && "
[ "cabal clean"
@@ -40,8 +40,8 @@ buildCommand = intercalate " && "
-- Run cabal configure to check if all dependencies are installed;
-- if not, run the depsCommand.
-checkDepsCommand :: ShellCommand
-checkDepsCommand = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand ++ "; fi"
+checkDepsCommand :: System -> ShellCommand
+checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi"
-- Install build dependencies of propellor.
--
@@ -53,17 +53,20 @@ checkDepsCommand = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand
-- So, as a second step, cabal is used to install all dependencies.
--
-- Note: May succeed and leave some deps not installed.
-depsCommand :: ShellCommand
-depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true"
+depsCommand :: System -> ShellCommand
+depsCommand (System distr _) = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true"
where
- osinstall = "apt-get update" : map aptinstall debdeps
+ osinstall = case distr of
+ (FreeBSD _) -> map pkginstall fbsddeps
+ _ -> "apt-get update" : map aptinstall debdeps
- cabalinstall =
+ cabalinstall =
[ "cabal update"
, "cabal install --only-dependencies"
]
aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get --no-upgrade --no-install-recommends -y install " ++ p
+ pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p
-- This is the same deps listed in debian/control.
debdeps =
@@ -84,9 +87,38 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ "
, "libghc-text-dev"
, "make"
]
+ fbsddeps =
+ [ "gnupg"
+ , "ghc"
+ , "hs-cabal-install"
+ , "hs-async"
+ , "hs-MissingH"
+ , "hs-hslogger"
+ , "hs-unix-compat"
+ , "hs-ansi-terminal"
+ , "hs-IfElse"
+ , "hs-network"
+ , "hs-mtl"
+ , "hs-transformers-base"
+ , "hs-exceptions"
+ , "hs-stm"
+ , "hs-text"
+ , "gmake"
+ ]
-installGitCommand :: ShellCommand
-installGitCommand = "if ! git --version >/dev/null; then apt-get update && DEBIAN_FRONTEND=noninteractive apt-get --no-install-recommends --no-upgrade -y install git; fi"
+installGitCommand :: System -> ShellCommand
+installGitCommand (System distr _) =
+ "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi"
+ where
+ cmds = case distr of
+ (FreeBSD _) ->
+ [ "ASSUME_ALWAYS_YES=yes pkg update"
+ , "ASSUME_ALWAYS_YES=yes pkg install git"
+ ]
+ _ ->
+ [ "apt-get update"
+ , "DEBIAN_FRONTEND=noninteractive apt-get --no-install-recommends --no-upgrade -y install git"
+ ]
buildPropellor :: IO ()
buildPropellor = unlessM (actionMessage "Propellor build" build) $
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 5dbc5836..1761a11e 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -21,7 +21,7 @@ import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
usage :: Handle -> IO ()
-usage h = hPutStrLn h $ unlines
+usage h = hPutStrLn h $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
@@ -47,10 +47,10 @@ usageError ps = do
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
- go ("--check":_) = return Check
+ go ("--check":_) = return Check
go ("--spin":ps) = case reverse ps of
- (r:"--via":hs) -> Spin
- <$> mapM hostname (reverse hs)
+ (r:"--via":hs) -> Spin
+ <$> mapM hostname (reverse hs)
<*> pure (Just r)
_ -> Spin <$> mapM hostname ps <*> pure Nothing
go ("--add-key":k:[]) = return $ AddKey k
@@ -62,7 +62,7 @@ processCmdLine = go =<< getArgs
go ("--edit":f:c:[]) = withprivfield f c Edit
go ("--list-fields":[]) = return ListFields
go ("--merge":[]) = return Merge
- go ("--help":_) = do
+ go ("--help":_) = do
usage stdout
exitFailure
go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
@@ -134,7 +134,7 @@ defaultMain hostlist = withConcurrentOutput $ do
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
-
+
runhost hn = onlyprocess $ withhost hn mainProperties
onlyprocess = onlyProcess (localdir </> ".lock")
@@ -205,5 +205,5 @@ hostname s = go =<< catchDefaultIO [] dnslookup
go (AddrInfo { addrCanonName = Just v } : _) = pure v
go _
| "." `isInfixOf` s = pure s -- assume it's a fqdn
- | otherwise =
+ | otherwise =
error $ "cannot find host " ++ s ++ " in the DNS"
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index e0ff477d..378836e8 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -55,7 +55,7 @@ instance PropAccum Chroot where
-- System in a chroot.
class ChrootBootstrapper b where
-- | Do initial bootstrapping of an operating system in a chroot.
- -- If the operating System is not supported, return
+ -- If the operating System is not supported, return
-- Left error message.
buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
@@ -91,6 +91,7 @@ instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
(Just s@(System (Debian _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
+ (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; `os` property not specified"
where
debootstrap s = Debootstrap.built loc s cf
@@ -102,8 +103,8 @@ instance ChrootBootstrapper Debootstrapped where
--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
-- > & os (System (Debian Unstable) "amd64")
--- > & Apt.installed ["ghc", "haskell-platform"]
--- > & ...
+-- > & Apt.installed ["ghc", "haskell-platform"]
+-- > & ...
debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
debootstrapped conf = bootstrapped (Debootstrapped conf)
@@ -131,7 +132,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
where
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
`requires` toProp built
-
+
built = case buildchroot bootstrapper (chrootSystem c) loc of
Right p -> p
Left e -> cantbuild e
@@ -152,7 +153,7 @@ propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
(propertyChildren p)
chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ h) = mempty `addInfo`
+chrootInfo (Chroot loc _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
@@ -201,7 +202,7 @@ toChain parenthost (Chroot loc _ _) systemdonly = do
return $ ChrootChain parenthost loc systemdonly onconsole
chain :: [Host] -> CmdLine -> IO ()
-chain hostlist (ChrootChain hn loc systemdonly onconsole) =
+chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
@@ -230,7 +231,7 @@ inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
-- /proc/self/exe which is necessary for some commands to work
mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
void $ mount "proc" "proc" procloc mempty
-
+
procloc = loc </> "proc"
cleanup
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 74cab92a..365e2903 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -21,7 +21,7 @@ data Times
-- | Installs a cron job, that will run as a specified user in a particular
-- directory. Note that the Desc must be unique, as it is used for the
-- cron job filename.
---
+--
-- Only one instance of the cron job is allowed to run at a time, no matter
-- how long it runs. This is accomplished using flock locking of the cron
-- job file.
@@ -47,7 +47,7 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
, case times of
Times _ -> doNothing
_ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes)
- -- Use a separate script because it makes the cron job name
+ -- Use a separate script because it makes the cron job name
-- prettier in emails, and also allows running the job manually.
, scriptfile `File.hasContent`
[ "#!/bin/sh"
@@ -81,5 +81,7 @@ niceJob desc times user cddir command = job desc times user cddir
-- | Installs a cron job to run propellor.
runPropellor :: Times -> Property NoInfo
-runPropellor times = niceJob "propellor" times (User "root") localdir
- (bootstrapPropellorCommand ++ "; ./propellor")
+runPropellor times = withOS "propellor cron job" $ \o ->
+ ensureProperty $
+ niceJob "propellor" times (User "root") localdir
+ (bootstrapPropellorCommand o ++ "; ./propellor")
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 6a566853..5716be38 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -23,7 +23,7 @@ import System.Posix.Files
type Url = String
--- | A monoid for debootstrap configuration.
+-- | A monoid for debootstrap configuration.
-- mempty is a default debootstrapped system.
data DebootstrapConfig
= DefaultConfig
@@ -34,8 +34,8 @@ data DebootstrapConfig
deriving (Show)
instance Monoid DebootstrapConfig where
- mempty = DefaultConfig
- mappend = (:+)
+ mempty = DefaultConfig
+ mappend = (:+)
toParams :: DebootstrapConfig -> [CommandParam]
toParams DefaultConfig = []
@@ -52,7 +52,7 @@ built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo
built target system config = built' (toProp installed) target system config
built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
-built' installprop target system@(System _ arch) config =
+built' installprop target system@(System _ arch) config =
check (unpopulated target <||> ispartial) setupprop
`requires` installprop
where
@@ -88,10 +88,11 @@ built' installprop target system@(System _ arch) config =
return True
, return False
)
-
+
extractSuite :: System -> Maybe String
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
+extractSuite (System (FreeBSD _) _) = Nothing
-- | Ensures debootstrap is installed.
--
@@ -101,7 +102,7 @@ extractSuite (System (Buntish r) _) = Just r
installed :: RevertableProperty NoInfo
installed = install <!> remove
where
- install = withOS "debootstrap installed" $ \o ->
+ install = withOS "debootstrap installed" $ \o ->
ifM (liftIO $ isJust <$> programPath)
( return NoChange
, ensureProperty (installon o)
@@ -115,7 +116,7 @@ installed = install <!> remove
removefrom (Just (System (Debian _) _)) = aptremove
removefrom (Just (System (Buntish _) _)) = aptremove
removefrom _ = sourceRemove
-
+
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
@@ -273,9 +274,9 @@ extractUrls base = collect [] . map toLower
_ -> findend l r
collect l (_:cs) = collect l cs
- findend l s =
+ findend l s =
let (u, r) = break (== '"') s
u' = if "http" `isPrefixOf` u
- then u
+ then u
else base </> u
in collect (u':l) r
diff --git a/src/Propellor/Property/FreeBSD.hs b/src/Propellor/Property/FreeBSD.hs
new file mode 100644
index 00000000..af83fa8c
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD.hs
@@ -0,0 +1,13 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- FreeBSD Properties
+--
+-- This module is designed to be imported unqualified.
+
+module Propellor.Property.FreeBSD (
+ module Propellor.Property.FreeBSD.Pkg,
+ module Propellor.Property.FreeBSD.Poudriere
+) where
+
+import Propellor.Property.FreeBSD.Pkg
+import Propellor.Property.FreeBSD.Poudriere
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
new file mode 100644
index 00000000..913710f7
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -0,0 +1,85 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- FreeBSD pkgng properties
+
+{-# Language ScopedTypeVariables, GeneralizedNewtypeDeriving #-}
+
+module Propellor.Property.FreeBSD.Pkg where
+
+import Propellor.Base
+import Propellor.Types.Info
+
+noninteractiveEnv :: [([Char], [Char])]
+noninteractiveEnv = [("ASSUME_ALWAYS_YES", "yes")]
+
+pkgCommand :: String -> [String] -> (String, [String])
+pkgCommand cmd args = ("pkg", (cmd:args))
+
+runPkg :: String -> [String] -> IO [String]
+runPkg cmd args =
+ let
+ (p, a) = pkgCommand cmd args
+ in
+ lines <$> readProcess p a
+
+pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo
+pkgCmdProperty cmd args =
+ let
+ (p, a) = pkgCommand cmd args
+ in
+ cmdPropertyEnv p a noninteractiveEnv
+
+pkgCmd :: String -> [String] -> IO [String]
+pkgCmd cmd args =
+ let
+ (p, a) = pkgCommand cmd args
+ in
+ lines <$> readProcessEnv p a (Just noninteractiveEnv)
+
+newtype PkgUpdate = PkgUpdate String
+ deriving (Typeable, Monoid, Show)
+instance IsInfo PkgUpdate where
+ propagateInfo _ = False
+
+pkgUpdated :: PkgUpdate -> Bool
+pkgUpdated (PkgUpdate _) = True
+
+update :: Property HasInfo
+update =
+ let
+ upd = pkgCmd "update" []
+ go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
+ in
+ infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) []
+
+newtype PkgUpgrade = PkgUpgrade String
+ deriving (Typeable, Monoid, Show)
+instance IsInfo PkgUpgrade where
+ propagateInfo _ = False
+
+pkgUpgraded :: PkgUpgrade -> Bool
+pkgUpgraded (PkgUpgrade _) = True
+
+upgrade :: Property HasInfo
+upgrade =
+ let
+ upd = pkgCmd "upgrade" []
+ go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
+ in
+ infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update
+
+type Package = String
+
+installed :: Package -> Property NoInfo
+installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg]
+
+isInstallable :: Package -> IO Bool
+isInstallable p = (not <$> isInstalled p) <&&> exists p
+
+isInstalled :: Package -> IO Bool
+isInstalled p = (runPkg "info" [p] >> return True)
+ `catchIO` (\_ -> return False)
+
+exists :: Package -> IO Bool
+exists p = (runPkg "search" ["--search", "name", "--exact", p] >> return True)
+ `catchIO` (\_ -> return False)
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
new file mode 100644
index 00000000..7ed7f59e
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -0,0 +1,141 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- FreeBSD Poudriere properties
+
+{-# Language GeneralizedNewtypeDeriving #-}
+
+module Propellor.Property.FreeBSD.Poudriere where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Data.List
+import Data.String (IsString(..))
+
+import qualified Propellor.Property.FreeBSD.Pkg as Pkg
+import qualified Propellor.Property.ZFS as ZFS
+import qualified Propellor.Property.File as File
+
+poudriereConfigPath :: FilePath
+poudriereConfigPath = "/usr/local/etc/poudriere.conf"
+
+newtype PoudriereConfigured = PoudriereConfigured String
+ deriving (Typeable, Monoid, Show)
+instance IsInfo PoudriereConfigured where
+ propagateInfo _ = False
+
+poudriereConfigured :: PoudriereConfigured -> Bool
+poudriereConfigured (PoudriereConfigured _) = True
+
+setConfigured :: Property HasInfo
+setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
+
+poudriere :: Poudriere -> Property HasInfo
+poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop
+ `requires` Pkg.installed "poudriere"
+ `before` setConfigured
+ where
+ confProp = File.containsLines poudriereConfigPath (toLines conf)
+ setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS"
+ prop :: CombinedType (Property NoInfo) (Property NoInfo)
+ prop
+ | isJust zfs = ((setZfs $ fromJust zfs) `before` confProp)
+ | otherwise = propertyList "Configuring Poudriere without ZFS" [confProp]
+
+poudriereCommand :: String -> [String] -> (String, [String])
+poudriereCommand cmd args = ("poudriere", cmd:args)
+
+runPoudriere :: String -> [String] -> IO [String]
+runPoudriere cmd args =
+ let
+ (p, a) = poudriereCommand cmd args
+ in
+ lines <$> readProcess p a
+
+listJails :: IO [String]
+listJails = mapMaybe (headMaybe . take 1 . words)
+ <$> runPoudriere "jail" ["-l", "-q"]
+
+jailExists :: Jail -> IO Bool
+jailExists (Jail name _ _) = isInfixOf [name] <$> listJails
+
+jail :: Jail -> Property NoInfo
+jail j@(Jail name version arch) =
+ let
+ chk = do
+ c <- poudriereConfigured <$> askInfo
+ nx <- liftIO $ not <$> jailExists j
+ return $ c && nx
+
+ (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version]
+ createJail = cmdProperty cmd args
+ in
+ check chk createJail
+ `describe` unwords ["Create poudriere jail", name]
+
+data JailInfo = JailInfo String
+
+data Poudriere = Poudriere
+ { _resolvConf :: String
+ , _freebsdHost :: String
+ , _baseFs :: String
+ , _usePortLint :: Bool
+ , _distFilesCache :: FilePath
+ , _svnHost :: String
+ , _zfs :: Maybe PoudriereZFS
+ }
+
+defaultConfig :: Poudriere
+defaultConfig = Poudriere
+ "/etc/resolv.conf"
+ "ftp://ftp5.us.FreeBSD.org"
+ "/usr/local/poudriere"
+ True
+ "/usr/ports/distfiles"
+ "svn.freebsd.org"
+ Nothing
+
+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 IsString PoudriereArch where
+ fromString "i386" = I386
+ fromString "amd64" = AMD64
+ fromString _ = error "Not a valid Poudriere architecture."
+
+yesNoProp :: Bool -> String
+yesNoProp b = if b then "yes" else "no"
+
+instance ToShellConfigLines Poudriere where
+ toAssoc c = map (\(k, f) -> (k, f c))
+ [ ("RESOLV_CONF", _resolvConf)
+ , ("FREEBSD_HOST", _freebsdHost)
+ , ("BASEFS", _baseFs)
+ , ("USE_PORTLINT", yesNoProp . _usePortLint)
+ , ("DISTFILES_CACHE", _distFilesCache)
+ , ("SVN_HOST", _svnHost)
+ ] ++ maybe [ ("NO_ZFS", "yes") ] toAssoc (_zfs c)
+
+instance ToShellConfigLines PoudriereZFS where
+ toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) =
+ [ ("NO_ZFS", "no")
+ , ("ZPOOL", pool)
+ , ("ZROOTFS", show dataset)
+ ]
+
+type ConfigLine = String
+type ConfigFile = [ConfigLine]
+
+class ToShellConfigLines a where
+ toAssoc :: a -> [(String, String)]
+
+ toLines :: a -> [ConfigLine]
+ toLines c = map (\(k, v) -> intercalate "=" [k, v]) (toAssoc c)
+
+confFile :: FilePath
+confFile = "/usr/local/etc/poudriere.conf"
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 0ad2186e..2234ad5c 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -174,15 +174,13 @@ journaldConfigured option value =
-- | Ensures machined and machinectl are installed
machined :: Property NoInfo
-machined = go `describe` "machined installed"
- where
- go = withOS ("standard sources.list") $ \o ->
- case o of
- -- Split into separate debian package since systemd 225.
- (Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
- Apt.installed ["systemd-container"]
- _ -> noChange
+machined = withOS "machined installed" $ \o ->
+ case o of
+ -- Split into separate debian package since systemd 225.
+ (Just (System (Debian suite) _))
+ | not (isStable suite) -> ensureProperty $
+ Apt.installed ["systemd-container"]
+ _ -> noChange
-- | Defines a container with a given machine name, and operating system,
-- and how to create its chroot if not already present.
diff --git a/src/Propellor/Property/ZFS.hs b/src/Propellor/Property/ZFS.hs
new file mode 100644
index 00000000..7118a515
--- /dev/null
+++ b/src/Propellor/Property/ZFS.hs
@@ -0,0 +1,11 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- ZFS properties
+
+module Propellor.Property.ZFS (
+ module Propellor.Property.ZFS.Properties,
+ module Propellor.Types.ZFS
+) where
+
+import Propellor.Property.ZFS.Properties
+import Propellor.Types.ZFS
diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs
new file mode 100644
index 00000000..372bac6d
--- /dev/null
+++ b/src/Propellor/Property/ZFS/Process.hs
@@ -0,0 +1,32 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- Functions running zfs processes.
+
+module Propellor.Property.ZFS.Process where
+
+import Propellor.Base
+import Data.String.Utils (split)
+import Data.List
+
+-- | Gets the properties of a ZFS volume.
+zfsGetProperties :: ZFS -> IO ZFSProperties
+zfsGetProperties z =
+ let plist = fromPropertyList . map (\(_:k:v:_) -> (k, v)) . (map (split "\t"))
+ in plist <$> runZfs "get" [Just "-H", Just "-p", Just "all"] z
+
+zfsExists :: ZFS -> IO Bool
+zfsExists z = any id . map (isInfixOf (zfsName z))
+ <$> runZfs "list" [Just "-H"] z
+
+-- | Runs the zfs command with the arguments.
+--
+-- Runs the command with -H which will skip the header line and
+-- separate all fields with tabs.
+--
+-- Replaces Nothing in the argument list with the ZFS pool/dataset.
+runZfs :: String -> [Maybe String] -> ZFS -> IO [String]
+runZfs cmd args z = lines <$> uncurry readProcess (zfsCommand cmd args z)
+
+-- | Return the ZFS command line suitable for readProcess or cmdProperty.
+zfsCommand :: String -> [Maybe String] -> ZFS -> (String, [String])
+zfsCommand cmd args z = ("zfs", cmd:(map (maybe (zfsName z) id) args))
diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs
new file mode 100644
index 00000000..5ceaf9ba
--- /dev/null
+++ b/src/Propellor/Property/ZFS/Properties.hs
@@ -0,0 +1,36 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- Functions defining zfs Properties.
+
+module Propellor.Property.ZFS.Properties (
+ zfsExists,
+ zfsSetProperties
+) where
+
+import Propellor.Base
+import Data.List (intercalate)
+import qualified Propellor.Property.ZFS.Process as ZP
+
+-- | Will ensure that a ZFS volume exists with the specified mount point.
+-- This requires the pool to exist as well, but we don't create pools yet.
+zfsExists :: ZFS -> Property NoInfo
+zfsExists z = check (not <$> ZP.zfsExists z) create
+ `describe` unwords ["Creating", zfsName z]
+ where
+ (p, a) = ZP.zfsCommand "create" [Nothing] z
+ create = cmdProperty p a
+
+-- | Sets the given properties. Returns True if all were successfully changed, False if not.
+zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo
+zfsSetProperties z setProperties = setall
+ `requires` zfsExists z
+ where
+ spcmd :: String -> String -> (String, [String])
+ spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z
+
+ setprop :: (String, String) -> Property NoInfo
+ setprop (p, v) = check (ZP.zfsExists z) $
+ cmdProperty (fst (spcmd p v)) (snd (spcmd p v))
+
+ setall = combineProperties (unwords ["Setting properties on", zfsName z]) $
+ map setprop $ toPropertyList setProperties
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 83654105..2c57f57d 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -1,3 +1,5 @@
+{-# Language ScopedTypeVariables #-}
+
module Propellor.Spin (
commitSpin,
spin,
@@ -42,7 +44,7 @@ commitSpin = do
currentBranch <- getCurrentBranch
when (b /= currentBranch) $
error ("spin aborted: check out "
- ++ b ++ " branch first")
+ ++ b ++ " branch first")
-- safety check #2: check we can commit with a dirty tree
noDirtySpin <- getGitConfigBool "propellor.forbid-dirty-spin"
@@ -53,7 +55,7 @@ commitSpin = do
error "spin aborted: commit changes first"
void $ actionMessage "Git commit" $
- gitCommit (Just spinCommitMessage)
+ gitCommit (Just spinCommitMessage)
[Param "--allow-empty", Param "-a"]
-- Push to central origin repo first, if possible.
-- The remote propellor will pull from there, which avoids
@@ -77,10 +79,12 @@ spin' mprivdata relay target hst = do
Just r -> pure r
Nothing -> getSshTarget target hst
+ let (InfoVal o) = (getInfo $ hostInfo hst) :: InfoVal System
+
-- Install, or update the remote propellor.
updateServer target relay hst
- (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
- (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
+ (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap (probecmd o)])
+ (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap (updatecmd (Just o))])
=<< getprivdata
-- And now we can run it.
@@ -92,19 +96,19 @@ spin' mprivdata relay target hst = do
relaying = relay == Just target
viarelay = isJust relay && not relaying
- probecmd = intercalate " ; "
- [ "if [ ! -d " ++ localdir ++ "/.git ]"
+ probecmd sys = intercalate " ; "
+ ["if [ ! -d " ++ localdir ++ "/.git ]"
, "then (" ++ intercalate " && "
- [ installGitCommand
+ [ installGitCommand sys
, "echo " ++ toMarked statusMarker (show NeedGitClone)
] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
- , "else " ++ updatecmd
+ , "else " ++ (updatecmd (Just sys))
, "fi"
]
-
- updatecmd = intercalate " && "
+
+ updatecmd sys = intercalate " && "
[ "cd " ++ localdir
- , bootstrapPropellorCommand
+ , bootstrapPropellorCommand sys
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
@@ -117,7 +121,7 @@ spin' mprivdata relay target hst = do
cmdline
| viarelay = Spin [target] (Just target)
| otherwise = SimpleRun target
-
+
getprivdata = case mprivdata of
Nothing
| relaying -> do
@@ -125,12 +129,12 @@ spin' mprivdata relay target hst = do
d <- readPrivDataFile f
nukeFile f
return d
- | otherwise ->
+ | otherwise ->
filterPrivData hst <$> decryptPrivData
Just pd -> pure pd
-- Check if the Host contains an IP address that matches one of the IPs
--- in the DNS for the HostName. If so, the HostName is used as-is,
+-- in the DNS for the HostName. If so, the HostName is used as-is,
-- but if the DNS is out of sync with the Host config, or doesn't have
-- the host in it at all, use one of the Host's IPs instead.
getSshTarget :: HostName -> Host -> IO String
@@ -200,7 +204,7 @@ update forhost = do
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
, Param "."
]
-
+
-- When --spin --relay is run, get a privdata file
-- to be relayed to the target host.
privfile = maybe privDataLocal privDataRelay forhost
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index f224c8ba..542a1f66 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -34,6 +34,7 @@ module Propellor.Types
, module Propellor.Types.OS
, module Propellor.Types.Dns
, module Propellor.Types.Result
+ , module Propellor.Types.ZFS
, propertySatisfy
, ignoreInfo
) where
@@ -49,6 +50,7 @@ import Propellor.Types.Info
import Propellor.Types.OS
import Propellor.Types.Dns
import Propellor.Types.Result
+import Propellor.Types.ZFS
-- | Everything Propellor knows about a system: Its hostname,
-- properties and their collected info.
@@ -126,7 +128,7 @@ type instance CInfo NoInfo HasInfo = HasInfo
type instance CInfo NoInfo NoInfo = NoInfo
-- | Constructs a Property with associated Info.
-infoProperty
+infoProperty
:: Desc -- ^ description of the property
-> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
-> Info -- ^ info associated with the property
@@ -158,7 +160,7 @@ propertySatisfy :: Property i -> Propellor Result
propertySatisfy (IProperty _ a _ _) = a
propertySatisfy (SProperty _ a _) = a
--- | Changes the action that is performed to satisfy a property.
+-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs
@@ -172,7 +174,7 @@ propertyDesc (IProperty d _ _ _) = d
propertyDesc (SProperty d _ _) = d
instance Show (Property i) where
- show p = "property " ++ show (propertyDesc p)
+ show p = "property " ++ show (propertyDesc p)
-- | A Property can include a list of child properties that it also
-- satisfies. This allows them to be introspected to collect their info, etc.
@@ -188,7 +190,7 @@ data RevertableProperty i = RevertableProperty
}
instance Show (RevertableProperty i) where
- show (RevertableProperty p _) = show p
+ show (RevertableProperty p _) = show p
class MkRevertableProperty i1 i2 where
-- | Shorthand to construct a revertable property.
@@ -216,7 +218,7 @@ instance IsProp (Property HasInfo) where
setDesc (IProperty _ a i cs) d = IProperty d a i cs
toProp = id
getDesc = propertyDesc
- getInfoRecursive (IProperty _ _ i cs) =
+ getInfoRecursive (IProperty _ _ i cs) =
i <> mconcat (map getInfoRecursive cs)
instance IsProp (Property NoInfo) where
setDesc (SProperty _ a cs) d = SProperty d a cs
@@ -256,8 +258,8 @@ type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result
class Combines x y where
-- | Combines together two properties, yielding a property that
-- has the description and info of the first, and that has the second
- -- property as a child.
- combineWith
+ -- property as a child.
+ combineWith
:: ResultCombiner
-- ^ How to combine the actions to satisfy the properties.
-> ResultCombiner
@@ -308,7 +310,7 @@ instance Combines (Property HasInfo) (RevertableProperty HasInfo) where
instance Combines (Property NoInfo) (RevertableProperty HasInfo) where
combineWith = combineWithPR
-combineWithRR
+combineWithRR
:: Combines (Property x) (Property y)
=> ResultCombiner
-> ResultCombiner
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 0abc76ac..a1ba14d4 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -4,6 +4,8 @@ module Propellor.Types.OS (
System(..),
Distribution(..),
DebianSuite(..),
+ FreeBSDRelease(..),
+ FBSDVersion(..),
isStable,
Release,
Architecture,
@@ -18,6 +20,7 @@ module Propellor.Types.OS (
import Network.BSD (HostName)
import Data.Typeable
+import Data.String
-- | High level description of a operating system.
data System = System Distribution Architecture
@@ -26,6 +29,7 @@ data System = System Distribution Architecture
data Distribution
= Debian DebianSuite
| Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/>)
+ | FreeBSD FreeBSDRelease
deriving (Show, Eq)
-- | Debian has several rolling suites, and a number of stable releases,
@@ -33,6 +37,24 @@ data Distribution
data DebianSuite = Experimental | Unstable | Testing | Stable Release
deriving (Show, Eq)
+-- | FreeBSD breaks their releases into "Production" and "Legacy".
+data FreeBSDRelease = FBSDProduction FBSDVersion | FBSDLegacy FBSDVersion
+ deriving (Show, Eq)
+
+data FBSDVersion = FBSD101 | FBSD102 | FBSD093
+ deriving (Eq)
+
+instance IsString FBSDVersion where
+ fromString "10.1-RELEASE" = FBSD101
+ fromString "10.2-RELEASE" = FBSD102
+ fromString "9.3-RELEASE" = FBSD093
+ fromString _ = error "Invalid FreeBSD release"
+
+instance Show FBSDVersion where
+ show FBSD101 = "10.1-RELEASE"
+ show FBSD102 = "10.2-RELEASE"
+ show FBSD093 = "9.3-RELEASE"
+
isStable :: DebianSuite -> Bool
isStable (Stable _) = True
isStable _ = False
diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs
new file mode 100644
index 00000000..8784c641
--- /dev/null
+++ b/src/Propellor/Types/ZFS.hs
@@ -0,0 +1,133 @@
+-- | Types for ZFS Properties.
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+
+module Propellor.Types.ZFS where
+
+import Data.String
+import qualified Data.Set as Set
+import qualified Data.String.Utils as SU
+import Data.List
+
+-- | A single ZFS filesystem.
+data ZFS = ZFS ZPool ZDataset deriving (Show, Eq, Ord)
+
+-- | Represents a zpool.
+data ZPool = ZPool String deriving (Show, Eq, Ord)
+
+-- | Represents a dataset in a zpool.
+--
+-- Can be constructed from a / separated string.
+data ZDataset = ZDataset [String] deriving (Eq, Ord)
+
+type ZFSProperties = Set.Set ZFSProperty
+
+fromList :: [ZFSProperty] -> ZFSProperties
+fromList = Set.fromList
+
+toPropertyList :: ZFSProperties -> [(String, String)]
+toPropertyList = Set.foldr (\p l -> l ++ [toPair p]) []
+
+fromPropertyList :: [(String, String)] -> ZFSProperties
+fromPropertyList props =
+ Set.fromList $ map fromPair props
+
+zfsName :: ZFS -> String
+zfsName (ZFS (ZPool pool) dataset) = intercalate "/" [pool, show dataset]
+
+instance Show ZDataset where
+ show (ZDataset paths) = intercalate "/" paths
+
+instance IsString ZDataset where
+ fromString s = ZDataset $ SU.split "/" s
+
+instance IsString ZPool where
+ fromString p = ZPool p
+
+class Value a where
+ 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)
+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"
+
+instance Value ZFSOnOff where
+ toValue (ZFSOnOff True) = "on"
+ toValue (ZFSOnOff False) = "off"
+
+instance Value ZFSSize where
+ toValue (ZFSSize s) = show s
+
+instance Value ZFSString where
+ toValue (ZFSString s) = s
+
+instance IsString ZFSString where
+ fromString = ZFSString
+
+instance IsString ZFSYesNo where
+ 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"
+
+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"
+
+instance Value ZFSACLInherit where
+ 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"
+
+instance Value ZFSACLMode where
+ toValue AMDiscard = "discard"
+ toValue AMGroupmask = "groupmask"
+ toValue AMPassthrough = "passthrough"
+
+data ZFSProperty = Mounted ZFSYesNo
+ | Mountpoint ZFSString
+ | ReadOnly ZFSYesNo
+ | ACLInherit ZFSACLInherit
+ | ACLMode ZFSACLMode
+ | StringProperty String ZFSString
+ deriving (Show, Eq, Ord)
+
+toPair :: ZFSProperty -> (String, String)
+toPair (Mounted v) = ("mounted", toValue v)
+toPair (Mountpoint v) = ("mountpoint", toValue v)
+toPair (ReadOnly v) = ("readonly", toValue v)
+toPair (ACLInherit v) = ("aclinherit", toValue v)
+toPair (ACLMode v) = ("aclmode", toValue v)
+toPair (StringProperty s v) = (s, toValue v)
+
+fromPair :: (String, String) -> ZFSProperty
+fromPair ("mounted", v) = Mounted (fromString v)
+fromPair ("mountpoint", v) = Mountpoint (fromString v)
+fromPair ("readonly", v) = ReadOnly (fromString v)
+fromPair ("aclinherit", v) = ACLInherit (fromString v)
+fromPair ("aclmode", v) = ACLMode (fromString v)
+fromPair (s, v) = StringProperty s (fromString v)