summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
authorEvan Cofsky2016-02-26 10:20:21 -0600
committerEvan Cofsky2016-03-07 13:31:51 -0600
commit822694e790102efa2a5bb4a0c3d62c6fce1d4e87 (patch)
tree833ade451e379c641e9cf5de46cc81d02d8fefbc /src/Propellor/Property
parente8f36722bf23a19dcdd42a1c14ebaa40a2d73293 (diff)
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.
Diffstat (limited to 'src/Propellor/Property')
-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
8 files changed, 353 insertions, 13 deletions
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