From 822694e790102efa2a5bb4a0c3d62c6fce1d4e87 Mon Sep 17 00:00:00 2001 From: Evan Cofsky Date: Fri, 26 Feb 2016 10:20:21 -0600 Subject: FreeBSD Support including: - Propellor bootstrapping - Basic pkg - Basic ZFS datasets and properties - Simple Poudriere configuration (regular and ZFS) - Poudriere jail creation FIXME: - Cron.hs: runPropellor needs the System, but hasn't yet gotten it. Reorganizing: - Remove FreeBSD.Process - Move ZFS up to Property - Add Info for Pkg.update/Pkg.upgrade - Move FreeBSD.md to doc so it'll show up automatically. - Merge the FreeBSD config with the other sample config. - Use Info to check Pkg updated/upgraded and Poudriere configured. - Warnings clean-up, move ZFS types to Propellor.Types. - Maintainer and license statements. --- .gitignore | 5 +- config-simple.hs | 22 +++++ doc/FreeBSD.mdwn | 19 ++++ propellor.cabal | 7 ++ src/Propellor/Bootstrap.hs | 57 ++++++++--- src/Propellor/CmdLine.hs | 14 +-- src/Propellor/Property/Cron.hs | 8 +- src/Propellor/Property/Debootstrap.hs | 19 ++-- src/Propellor/Property/FreeBSD.hs | 14 +++ src/Propellor/Property/FreeBSD/Pkg.hs | 89 +++++++++++++++++ src/Propellor/Property/FreeBSD/Poudriere.hs | 147 ++++++++++++++++++++++++++++ src/Propellor/Property/ZFS.hs | 12 +++ src/Propellor/Property/ZFS/Process.hs | 40 ++++++++ src/Propellor/Property/ZFS/Properties.hs | 37 +++++++ src/Propellor/Spin.hs | 34 ++++--- src/Propellor/Types.hs | 18 ++-- src/Propellor/Types/OS.hs | 22 +++++ src/Propellor/Types/ZFS.hs | 133 +++++++++++++++++++++++++ 18 files changed, 639 insertions(+), 58 deletions(-) create mode 100644 doc/FreeBSD.mdwn create mode 100644 src/Propellor/Property/FreeBSD.hs create mode 100644 src/Propellor/Property/FreeBSD/Pkg.hs create mode 100644 src/Propellor/Property/FreeBSD/Poudriere.hs create mode 100644 src/Propellor/Property/ZFS.hs create mode 100644 src/Propellor/Property/ZFS/Process.hs create mode 100644 src/Propellor/Property/ZFS/Properties.hs create mode 100644 src/Propellor/Types/ZFS.hs 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 +-- 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 +-- 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 +-- License: BSD 2-clause + +{-# Language GeneralizedNewtypeDeriving #-} + +-- | Maintainer: Evan Cofsky + +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 +-- 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 +-- 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 +-- 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 ) + | 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 +-- 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) -- cgit v1.2.3