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