summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Chroot.hs15
-rw-r--r--src/Propellor/Property/Cron.hs10
-rw-r--r--src/Propellor/Property/Debootstrap.hs19
-rw-r--r--src/Propellor/Property/FreeBSD.hs13
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs85
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs141
-rw-r--r--src/Propellor/Property/Systemd.hs16
-rw-r--r--src/Propellor/Property/ZFS.hs11
-rw-r--r--src/Propellor/Property/ZFS/Process.hs32
-rw-r--r--src/Propellor/Property/ZFS/Properties.hs36
10 files changed, 349 insertions, 29 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index e0ff477d..378836e8 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -55,7 +55,7 @@ instance PropAccum Chroot where
-- System in a chroot.
class ChrootBootstrapper b where
-- | Do initial bootstrapping of an operating system in a chroot.
- -- If the operating System is not supported, return
+ -- If the operating System is not supported, return
-- Left error message.
buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
@@ -91,6 +91,7 @@ instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
(Just s@(System (Debian _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
+ (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; `os` property not specified"
where
debootstrap s = Debootstrap.built loc s cf
@@ -102,8 +103,8 @@ instance ChrootBootstrapper Debootstrapped where
--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
-- > & os (System (Debian Unstable) "amd64")
--- > & Apt.installed ["ghc", "haskell-platform"]
--- > & ...
+-- > & Apt.installed ["ghc", "haskell-platform"]
+-- > & ...
debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
debootstrapped conf = bootstrapped (Debootstrapped conf)
@@ -131,7 +132,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
where
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
`requires` toProp built
-
+
built = case buildchroot bootstrapper (chrootSystem c) loc of
Right p -> p
Left e -> cantbuild e
@@ -152,7 +153,7 @@ propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
(propertyChildren p)
chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ h) = mempty `addInfo`
+chrootInfo (Chroot loc _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
@@ -201,7 +202,7 @@ toChain parenthost (Chroot loc _ _) systemdonly = do
return $ ChrootChain parenthost loc systemdonly onconsole
chain :: [Host] -> CmdLine -> IO ()
-chain hostlist (ChrootChain hn loc systemdonly onconsole) =
+chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
@@ -230,7 +231,7 @@ inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
-- /proc/self/exe which is necessary for some commands to work
mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
void $ mount "proc" "proc" procloc mempty
-
+
procloc = loc </> "proc"
cleanup
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 74cab92a..365e2903 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -21,7 +21,7 @@ data Times
-- | Installs a cron job, that will run as a specified user in a particular
-- directory. Note that the Desc must be unique, as it is used for the
-- cron job filename.
---
+--
-- Only one instance of the cron job is allowed to run at a time, no matter
-- how long it runs. This is accomplished using flock locking of the cron
-- job file.
@@ -47,7 +47,7 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
, case times of
Times _ -> doNothing
_ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes)
- -- Use a separate script because it makes the cron job name
+ -- Use a separate script because it makes the cron job name
-- prettier in emails, and also allows running the job manually.
, scriptfile `File.hasContent`
[ "#!/bin/sh"
@@ -81,5 +81,7 @@ niceJob desc times user cddir command = job desc times user cddir
-- | Installs a cron job to run propellor.
runPropellor :: Times -> Property NoInfo
-runPropellor times = niceJob "propellor" times (User "root") localdir
- (bootstrapPropellorCommand ++ "; ./propellor")
+runPropellor times = withOS "propellor cron job" $ \o ->
+ ensureProperty $
+ niceJob "propellor" times (User "root") localdir
+ (bootstrapPropellorCommand o ++ "; ./propellor")
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 6a566853..5716be38 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -23,7 +23,7 @@ import System.Posix.Files
type Url = String
--- | A monoid for debootstrap configuration.
+-- | A monoid for debootstrap configuration.
-- mempty is a default debootstrapped system.
data DebootstrapConfig
= DefaultConfig
@@ -34,8 +34,8 @@ data DebootstrapConfig
deriving (Show)
instance Monoid DebootstrapConfig where
- mempty = DefaultConfig
- mappend = (:+)
+ mempty = DefaultConfig
+ mappend = (:+)
toParams :: DebootstrapConfig -> [CommandParam]
toParams DefaultConfig = []
@@ -52,7 +52,7 @@ built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo
built target system config = built' (toProp installed) target system config
built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
-built' installprop target system@(System _ arch) config =
+built' installprop target system@(System _ arch) config =
check (unpopulated target <||> ispartial) setupprop
`requires` installprop
where
@@ -88,10 +88,11 @@ built' installprop target system@(System _ arch) config =
return True
, return False
)
-
+
extractSuite :: System -> Maybe String
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
+extractSuite (System (FreeBSD _) _) = Nothing
-- | Ensures debootstrap is installed.
--
@@ -101,7 +102,7 @@ extractSuite (System (Buntish r) _) = Just r
installed :: RevertableProperty NoInfo
installed = install <!> remove
where
- install = withOS "debootstrap installed" $ \o ->
+ install = withOS "debootstrap installed" $ \o ->
ifM (liftIO $ isJust <$> programPath)
( return NoChange
, ensureProperty (installon o)
@@ -115,7 +116,7 @@ installed = install <!> remove
removefrom (Just (System (Debian _) _)) = aptremove
removefrom (Just (System (Buntish _) _)) = aptremove
removefrom _ = sourceRemove
-
+
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
@@ -273,9 +274,9 @@ extractUrls base = collect [] . map toLower
_ -> findend l r
collect l (_:cs) = collect l cs
- findend l s =
+ findend l s =
let (u, r) = break (== '"') s
u' = if "http" `isPrefixOf` u
- then u
+ then u
else base </> u
in collect (u':l) r
diff --git a/src/Propellor/Property/FreeBSD.hs b/src/Propellor/Property/FreeBSD.hs
new file mode 100644
index 00000000..af83fa8c
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD.hs
@@ -0,0 +1,13 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- FreeBSD Properties
+--
+-- This module is designed to be imported unqualified.
+
+module Propellor.Property.FreeBSD (
+ module Propellor.Property.FreeBSD.Pkg,
+ module Propellor.Property.FreeBSD.Poudriere
+) where
+
+import Propellor.Property.FreeBSD.Pkg
+import Propellor.Property.FreeBSD.Poudriere
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
new file mode 100644
index 00000000..913710f7
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -0,0 +1,85 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- FreeBSD pkgng properties
+
+{-# Language ScopedTypeVariables, GeneralizedNewtypeDeriving #-}
+
+module Propellor.Property.FreeBSD.Pkg where
+
+import Propellor.Base
+import Propellor.Types.Info
+
+noninteractiveEnv :: [([Char], [Char])]
+noninteractiveEnv = [("ASSUME_ALWAYS_YES", "yes")]
+
+pkgCommand :: String -> [String] -> (String, [String])
+pkgCommand cmd args = ("pkg", (cmd:args))
+
+runPkg :: String -> [String] -> IO [String]
+runPkg cmd args =
+ let
+ (p, a) = pkgCommand cmd args
+ in
+ lines <$> readProcess p a
+
+pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo
+pkgCmdProperty cmd args =
+ let
+ (p, a) = pkgCommand cmd args
+ in
+ cmdPropertyEnv p a noninteractiveEnv
+
+pkgCmd :: String -> [String] -> IO [String]
+pkgCmd cmd args =
+ let
+ (p, a) = pkgCommand cmd args
+ in
+ lines <$> readProcessEnv p a (Just noninteractiveEnv)
+
+newtype PkgUpdate = PkgUpdate String
+ deriving (Typeable, Monoid, Show)
+instance IsInfo PkgUpdate where
+ propagateInfo _ = False
+
+pkgUpdated :: PkgUpdate -> Bool
+pkgUpdated (PkgUpdate _) = True
+
+update :: Property HasInfo
+update =
+ let
+ upd = pkgCmd "update" []
+ go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
+ in
+ infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) []
+
+newtype PkgUpgrade = PkgUpgrade String
+ deriving (Typeable, Monoid, Show)
+instance IsInfo PkgUpgrade where
+ propagateInfo _ = False
+
+pkgUpgraded :: PkgUpgrade -> Bool
+pkgUpgraded (PkgUpgrade _) = True
+
+upgrade :: Property HasInfo
+upgrade =
+ let
+ upd = pkgCmd "upgrade" []
+ go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
+ in
+ infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update
+
+type Package = String
+
+installed :: Package -> Property NoInfo
+installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg]
+
+isInstallable :: Package -> IO Bool
+isInstallable p = (not <$> isInstalled p) <&&> exists p
+
+isInstalled :: Package -> IO Bool
+isInstalled p = (runPkg "info" [p] >> return True)
+ `catchIO` (\_ -> return False)
+
+exists :: Package -> IO Bool
+exists p = (runPkg "search" ["--search", "name", "--exact", p] >> return True)
+ `catchIO` (\_ -> return False)
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
new file mode 100644
index 00000000..7ed7f59e
--- /dev/null
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -0,0 +1,141 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- FreeBSD Poudriere properties
+
+{-# Language GeneralizedNewtypeDeriving #-}
+
+module Propellor.Property.FreeBSD.Poudriere where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Data.List
+import Data.String (IsString(..))
+
+import qualified Propellor.Property.FreeBSD.Pkg as Pkg
+import qualified Propellor.Property.ZFS as ZFS
+import qualified Propellor.Property.File as File
+
+poudriereConfigPath :: FilePath
+poudriereConfigPath = "/usr/local/etc/poudriere.conf"
+
+newtype PoudriereConfigured = PoudriereConfigured String
+ deriving (Typeable, Monoid, Show)
+instance IsInfo PoudriereConfigured where
+ propagateInfo _ = False
+
+poudriereConfigured :: PoudriereConfigured -> Bool
+poudriereConfigured (PoudriereConfigured _) = True
+
+setConfigured :: Property HasInfo
+setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
+
+poudriere :: Poudriere -> Property HasInfo
+poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop
+ `requires` Pkg.installed "poudriere"
+ `before` setConfigured
+ where
+ confProp = File.containsLines poudriereConfigPath (toLines conf)
+ setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS"
+ prop :: CombinedType (Property NoInfo) (Property NoInfo)
+ prop
+ | isJust zfs = ((setZfs $ fromJust zfs) `before` confProp)
+ | otherwise = propertyList "Configuring Poudriere without ZFS" [confProp]
+
+poudriereCommand :: String -> [String] -> (String, [String])
+poudriereCommand cmd args = ("poudriere", cmd:args)
+
+runPoudriere :: String -> [String] -> IO [String]
+runPoudriere cmd args =
+ let
+ (p, a) = poudriereCommand cmd args
+ in
+ lines <$> readProcess p a
+
+listJails :: IO [String]
+listJails = mapMaybe (headMaybe . take 1 . words)
+ <$> runPoudriere "jail" ["-l", "-q"]
+
+jailExists :: Jail -> IO Bool
+jailExists (Jail name _ _) = isInfixOf [name] <$> listJails
+
+jail :: Jail -> Property NoInfo
+jail j@(Jail name version arch) =
+ let
+ chk = do
+ c <- poudriereConfigured <$> askInfo
+ nx <- liftIO $ not <$> jailExists j
+ return $ c && nx
+
+ (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version]
+ createJail = cmdProperty cmd args
+ in
+ check chk createJail
+ `describe` unwords ["Create poudriere jail", name]
+
+data JailInfo = JailInfo String
+
+data Poudriere = Poudriere
+ { _resolvConf :: String
+ , _freebsdHost :: String
+ , _baseFs :: String
+ , _usePortLint :: Bool
+ , _distFilesCache :: FilePath
+ , _svnHost :: String
+ , _zfs :: Maybe PoudriereZFS
+ }
+
+defaultConfig :: Poudriere
+defaultConfig = Poudriere
+ "/etc/resolv.conf"
+ "ftp://ftp5.us.FreeBSD.org"
+ "/usr/local/poudriere"
+ True
+ "/usr/ports/distfiles"
+ "svn.freebsd.org"
+ Nothing
+
+data PoudriereZFS = PoudriereZFS ZFS.ZFS ZFS.ZFSProperties
+
+data Jail = Jail String FBSDVersion PoudriereArch
+
+data PoudriereArch = I386 | AMD64 deriving (Eq)
+instance Show PoudriereArch where
+ show I386 = "i386"
+ show AMD64 = "amd64"
+
+instance IsString PoudriereArch where
+ fromString "i386" = I386
+ fromString "amd64" = AMD64
+ fromString _ = error "Not a valid Poudriere architecture."
+
+yesNoProp :: Bool -> String
+yesNoProp b = if b then "yes" else "no"
+
+instance ToShellConfigLines Poudriere where
+ toAssoc c = map (\(k, f) -> (k, f c))
+ [ ("RESOLV_CONF", _resolvConf)
+ , ("FREEBSD_HOST", _freebsdHost)
+ , ("BASEFS", _baseFs)
+ , ("USE_PORTLINT", yesNoProp . _usePortLint)
+ , ("DISTFILES_CACHE", _distFilesCache)
+ , ("SVN_HOST", _svnHost)
+ ] ++ maybe [ ("NO_ZFS", "yes") ] toAssoc (_zfs c)
+
+instance ToShellConfigLines PoudriereZFS where
+ toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) =
+ [ ("NO_ZFS", "no")
+ , ("ZPOOL", pool)
+ , ("ZROOTFS", show dataset)
+ ]
+
+type ConfigLine = String
+type ConfigFile = [ConfigLine]
+
+class ToShellConfigLines a where
+ toAssoc :: a -> [(String, String)]
+
+ toLines :: a -> [ConfigLine]
+ toLines c = map (\(k, v) -> intercalate "=" [k, v]) (toAssoc c)
+
+confFile :: FilePath
+confFile = "/usr/local/etc/poudriere.conf"
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 0ad2186e..2234ad5c 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -174,15 +174,13 @@ journaldConfigured option value =
-- | Ensures machined and machinectl are installed
machined :: Property NoInfo
-machined = go `describe` "machined installed"
- where
- go = withOS ("standard sources.list") $ \o ->
- case o of
- -- Split into separate debian package since systemd 225.
- (Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
- Apt.installed ["systemd-container"]
- _ -> noChange
+machined = withOS "machined installed" $ \o ->
+ case o of
+ -- Split into separate debian package since systemd 225.
+ (Just (System (Debian suite) _))
+ | not (isStable suite) -> ensureProperty $
+ Apt.installed ["systemd-container"]
+ _ -> noChange
-- | Defines a container with a given machine name, and operating system,
-- and how to create its chroot if not already present.
diff --git a/src/Propellor/Property/ZFS.hs b/src/Propellor/Property/ZFS.hs
new file mode 100644
index 00000000..7118a515
--- /dev/null
+++ b/src/Propellor/Property/ZFS.hs
@@ -0,0 +1,11 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- ZFS properties
+
+module Propellor.Property.ZFS (
+ module Propellor.Property.ZFS.Properties,
+ module Propellor.Types.ZFS
+) where
+
+import Propellor.Property.ZFS.Properties
+import Propellor.Types.ZFS
diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs
new file mode 100644
index 00000000..372bac6d
--- /dev/null
+++ b/src/Propellor/Property/ZFS/Process.hs
@@ -0,0 +1,32 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- Functions running zfs processes.
+
+module Propellor.Property.ZFS.Process where
+
+import Propellor.Base
+import Data.String.Utils (split)
+import Data.List
+
+-- | Gets the properties of a ZFS volume.
+zfsGetProperties :: ZFS -> IO ZFSProperties
+zfsGetProperties z =
+ let plist = fromPropertyList . map (\(_:k:v:_) -> (k, v)) . (map (split "\t"))
+ in plist <$> runZfs "get" [Just "-H", Just "-p", Just "all"] z
+
+zfsExists :: ZFS -> IO Bool
+zfsExists z = any id . map (isInfixOf (zfsName z))
+ <$> runZfs "list" [Just "-H"] z
+
+-- | Runs the zfs command with the arguments.
+--
+-- Runs the command with -H which will skip the header line and
+-- separate all fields with tabs.
+--
+-- Replaces Nothing in the argument list with the ZFS pool/dataset.
+runZfs :: String -> [Maybe String] -> ZFS -> IO [String]
+runZfs cmd args z = lines <$> uncurry readProcess (zfsCommand cmd args z)
+
+-- | Return the ZFS command line suitable for readProcess or cmdProperty.
+zfsCommand :: String -> [Maybe String] -> ZFS -> (String, [String])
+zfsCommand cmd args z = ("zfs", cmd:(map (maybe (zfsName z) id) args))
diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs
new file mode 100644
index 00000000..5ceaf9ba
--- /dev/null
+++ b/src/Propellor/Property/ZFS/Properties.hs
@@ -0,0 +1,36 @@
+-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com>
+--
+-- Functions defining zfs Properties.
+
+module Propellor.Property.ZFS.Properties (
+ zfsExists,
+ zfsSetProperties
+) where
+
+import Propellor.Base
+import Data.List (intercalate)
+import qualified Propellor.Property.ZFS.Process as ZP
+
+-- | Will ensure that a ZFS volume exists with the specified mount point.
+-- This requires the pool to exist as well, but we don't create pools yet.
+zfsExists :: ZFS -> Property NoInfo
+zfsExists z = check (not <$> ZP.zfsExists z) create
+ `describe` unwords ["Creating", zfsName z]
+ where
+ (p, a) = ZP.zfsCommand "create" [Nothing] z
+ create = cmdProperty p a
+
+-- | Sets the given properties. Returns True if all were successfully changed, False if not.
+zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo
+zfsSetProperties z setProperties = setall
+ `requires` zfsExists z
+ where
+ spcmd :: String -> String -> (String, [String])
+ spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z
+
+ setprop :: (String, String) -> Property NoInfo
+ setprop (p, v) = check (ZP.zfsExists z) $
+ cmdProperty (fst (spcmd p v)) (snd (spcmd p v))
+
+ setall = combineProperties (unwords ["Setting properties on", zfsName z]) $
+ map setprop $ toPropertyList setProperties