summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore5
-rw-r--r--config-simple.hs22
-rw-r--r--doc/FreeBSD.mdwn19
-rw-r--r--propellor.cabal7
-rw-r--r--src/Propellor/Bootstrap.hs57
-rw-r--r--src/Propellor/CmdLine.hs14
-rw-r--r--src/Propellor/Property/Cron.hs8
-rw-r--r--src/Propellor/Property/Debootstrap.hs19
-rw-r--r--src/Propellor/Property/FreeBSD.hs14
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs89
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs147
-rw-r--r--src/Propellor/Property/ZFS.hs12
-rw-r--r--src/Propellor/Property/ZFS/Process.hs40
-rw-r--r--src/Propellor/Property/ZFS/Properties.hs37
-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
18 files changed, 639 insertions, 58 deletions
diff --git a/.gitignore b/.gitignore
index 431b1c4b..208339f9 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,4 @@
dist/*
-propellor
tags
privdata/local
privdata/keyring.gpg~
@@ -12,3 +11,7 @@ propellor.1
.lock
.lastchecked
.stack-work/*
+.cabal-sandbox/
+.dir-locals.el
+cabal.sandbox.config
+*~ \ No newline at end of file
diff --git a/config-simple.hs b/config-simple.hs
index 21accd18..ac1b115f 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -1,6 +1,8 @@
-- This is the main configuration file for Propellor, and is used to build
-- the propellor program.
+import Data.String (fromString)
+
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
@@ -13,6 +15,9 @@ import qualified Propellor.Property.User as User
--import qualified Propellor.Property.Hostname as Hostname
--import qualified Propellor.Property.Tor as Tor
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
@@ -21,6 +26,7 @@ main = defaultMain hosts
hosts :: [Host]
hosts =
[ mybox
+ , freebsd
]
-- An example host.
@@ -46,3 +52,19 @@ webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
& Apt.serviceInstalledRunning "apache2"
+
+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])
+ }
+
+-- An example host.
+freebsd :: Host
+freebsd = host "192.168.56.10"
+ & os (System (FreeBSD (FBSDProduction FBSD102)) "amd64")
+ & Pkg.update
+ & Pkg.upgrade
+ & Poudriere.poudriere poudriereZFS
+ & Poudriere.jail (Poudriere.Jail "formail" (fromString "10.2-RELEASE") (fromString "amd64"))
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/propellor.cabal b/propellor.cabal
index 3518a7ee..a281e277 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -83,6 +83,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
@@ -117,6 +120,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
@@ -146,6 +152,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/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index c49cb5af..2c962b12 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -15,19 +15,21 @@ 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 :: System -> ShellCommand
+bootstrapPropellorCommand sys =
+ (checkDepsCommand sys) ++
+ "&& 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"
+ [ "./propellor --check"
+ ,"cabal clean"
, buildCommand
]
@@ -40,8 +42,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 +55,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 +89,33 @@ 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 _) =
+ case distr of
+ (FreeBSD _) ->
+ "if ! git --version >/dev/null; then ASSUME_ALWAYS_YES=yes pkg update && ASSUME_ALWAYS_YES=yes pkg install git; fi"
+ _ ->
+ "if ! git --version >/dev/null; then apt-get update && DEBIAN_FRONTEND=noninteractive apt-get --no-install-recommends --no-upgrade -y install git; fi"
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/Cron.hs b/src/Propellor/Property/Cron.hs
index 74cab92a..a6ab3eca 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,5 @@ 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 = niceJob "propellor" times (User "root") localdir "true"
+-- (bootstrapPropellorCommand ++ "; ./propellor")
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 6a566853..508da5fb 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 _ = error "Not supported unless Debian or Buntish."
-- | 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..0943597f
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD.hs
@@ -0,0 +1,14 @@
+-- | FreeBSD Properties
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+--
+-- 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..7e02d99b
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -0,0 +1,89 @@
+-- | FreeBSD pkgng properties
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+
+{-# 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 = do
+ l <- isInstalled p
+ e <- exists p
+
+ return $ (not l) && e
+
+isInstalled :: Package -> IO Bool
+isInstalled p = catch (runPkg "info" [p] >> return True) (\(_ :: IOError ) -> return False)
+
+exists :: Package -> IO Bool
+exists p = catch (runPkg "search" ["--search", "name", "--exact", p] >> return True) (\(_ :: IOError ) -> return False)
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
new file mode 100644
index 00000000..217e6e5a
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -0,0 +1,147 @@
+-- | FreeBSD Poudriere properties
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+
+{-# Language GeneralizedNewtypeDeriving #-}
+
+-- | Maintainer: Evan Cofsky <evan@theunixman.com>
+
+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) =
+ let
+ 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 =
+ if isJust zfs
+ then ((setZfs $ fromJust zfs) `before` confProp)
+ else propertyList "Configuring Poudriere without ZFS" [confProp]
+ in
+ prop
+ `requires` Pkg.installed "poudriere"
+ `before` setConfigured
+
+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 = 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
+ cfgd = poudriereConfigured <$> askInfo
+
+ notExists :: IO Bool
+ notExists = not <$> jailExists j
+ chk = do
+ c <- cfgd
+ x <- liftIO notExists
+ return $ c && x
+
+ (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version]
+ createJail = cmdProperty cmd args
+ in
+ checkResult chk (\_ -> return MadeChange) createJail
+ `describe` unwords ["Create poudriere jail", name]
+
+
+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/ZFS.hs b/src/Propellor/Property/ZFS.hs
new file mode 100644
index 00000000..e42861e5
--- /dev/null
+++ b/src/Propellor/Property/ZFS.hs
@@ -0,0 +1,12 @@
+-- | ZFS properties
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+
+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..c6615252
--- /dev/null
+++ b/src/Propellor/Property/ZFS/Process.hs
@@ -0,0 +1,40 @@
+-- | Functions running zfs processes.
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+
+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
+ do
+ 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 =
+ let
+ (p, a) = zfsCommand cmd args z
+ in
+ lines <$> readProcess p a
+
+-- | 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..ba303bc3
--- /dev/null
+++ b/src/Propellor/Property/ZFS/Properties.hs
@@ -0,0 +1,37 @@
+-- | Functions defining zfs Properties.
+--
+-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
+-- License: BSD 2-clause
+
+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 =
+ let
+ (p, a) = ZP.zfsCommand "create" [Nothing] z
+ create = cmdProperty p a
+ in
+ check (not <$> ZP.zfsExists z) (create) `describe` (unwords ["Creating", zfsName z])
+
+-- | Sets the given properties. Returns True if all were successfully changed, False if not.
+zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo
+zfsSetProperties z setProperties =
+ let
+ 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
+ in
+ setall `requires` zfsExists z
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 495ebaf4..6666d089 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -1,3 +1,5 @@
+{-# Language ScopedTypeVariables #-}
+
module Propellor.Spin (
commitSpin,
spin,
@@ -41,7 +43,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"
@@ -52,7 +54,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
@@ -76,10 +78,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 o)])
=<< getprivdata
-- And now we can run it.
@@ -91,19 +95,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 sys)
, "fi"
]
-
- updatecmd = intercalate " && "
+
+ updatecmd sys = intercalate " && "
[ "cd " ++ localdir
- , bootstrapPropellorCommand
+ , bootstrapPropellorCommand sys
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
@@ -116,7 +120,7 @@ spin' mprivdata relay target hst = do
cmdline
| viarelay = Spin [target] (Just target)
| otherwise = SimpleRun target
-
+
getprivdata = case mprivdata of
Nothing
| relaying -> do
@@ -124,12 +128,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
@@ -199,7 +203,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 c302d11d..5b425f71 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,
@@ -17,6 +19,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
@@ -25,6 +28,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,
@@ -32,6 +36,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)