From 4e4fb9ab7ca13f5148c6d4b08f53f518429530a8 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 18 Apr 2014 03:59:06 -0400
Subject: get rid of AttrProperty

Now both Property and RevertableProperty can influence Attr on their own.
---
 Propellor/Types.hs | 37 +++++++++++++++++++------------------
 1 file changed, 19 insertions(+), 18 deletions(-)

(limited to 'Propellor/Types.hs')

diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index fc767cd2..01be9a5a 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -8,8 +8,8 @@ module Propellor.Types
 	, HostName
 	, Propellor(..)
 	, Property(..)
+	, property
 	, RevertableProperty(..)
-	, AttrProperty(..)
 	, IsProp
 	, describe
 	, toProp
@@ -53,16 +53,18 @@ newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
 -- property.
 data Property = Property
 	{ propertyDesc :: Desc
-	-- | must be idempotent; may run repeatedly
 	, propertySatisfy :: Propellor Result
+	-- ^ must be idempotent; may run repeatedly
+	, propertyAttr :: Attr -> Attr
+	-- ^ a property can affect the overall Attr
 	}
 
+property :: Desc -> Propellor Result -> Property
+property d s = Property d s id
+
 -- | A property that can be reverted.
 data RevertableProperty = RevertableProperty Property Property
 
--- | A property that affects the Attr.
-data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
-
 class IsProp p where
 	-- | Sets description.
 	describe :: p -> Desc -> p
@@ -75,12 +77,16 @@ class IsProp p where
 instance IsProp Property where
 	describe p d = p { propertyDesc = d }
 	toProp p = p
-	x `requires` y = Property (propertyDesc x) $ do
-		r <- propertySatisfy y
-		case r of
-			FailedChange -> return FailedChange
-			_ -> propertySatisfy x
-	getAttr _ = id
+	getAttr = propertyAttr
+	x `requires` y = Property (propertyDesc x) satisfy attr
+	  where
+	  	attr = propertyAttr x . propertyAttr y
+		satisfy = do
+			r <- propertySatisfy y
+			case r of
+				FailedChange -> return FailedChange
+				_ -> propertySatisfy x
+			
 
 instance IsProp RevertableProperty where
 	-- | Sets the description of both sides.
@@ -89,13 +95,8 @@ instance IsProp RevertableProperty where
 	toProp (RevertableProperty p1 _) = p1
 	(RevertableProperty p1 p2) `requires` y =
 		RevertableProperty (p1 `requires` y) p2
-	getAttr _ = id
-
-instance IsProp AttrProperty where
-	describe (AttrProperty p a) d = AttrProperty (describe p d) a
-	toProp (AttrProperty p _) = toProp p
-	(AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
-	getAttr (AttrProperty _ a) = a
+	-- | Gets the Attr of the currently active side.
+	getAttr (RevertableProperty p1 _p2) = getAttr p1
 
 type Desc = String
 
-- 
cgit v1.3-2-g0d8e


From 5f6c3ad56490a8c3063f8daa1cd8b0a302b63ddd Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 18 Apr 2014 04:48:49 -0400
Subject: All Property combinators now combine together their Attr settings.

So Attr settings can be made inside a propertyList, for example.
---
 Propellor/Attr.hs               |  4 +--
 Propellor/Engine.hs             |  2 +-
 Propellor/Property.hs           | 79 ++++++++++++++++++++++++-----------------
 Propellor/Property/Apt.hs       |  4 +--
 Propellor/Property/Cmd.hs       |  1 +
 Propellor/Property/Scheduled.hs |  4 +--
 Propellor/Types.hs              | 18 ++++------
 Propellor/Types/Attr.hs         |  2 ++
 TODO                            |  6 ++--
 debian/changelog                |  5 ++-
 10 files changed, 70 insertions(+), 55 deletions(-)

(limited to 'Propellor/Types.hs')

diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index d4fb25d2..03c882cc 100644
--- a/Propellor/Attr.hs
+++ b/Propellor/Attr.hs
@@ -10,7 +10,7 @@ import qualified Data.Set as S
 import qualified Data.Map as M
 import Control.Applicative
 
-pureAttrProperty :: Desc -> (Attr -> Attr) -> Property 
+pureAttrProperty :: Desc -> SetAttr -> Property 
 pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)
 
 hostname :: HostName -> Property
@@ -35,7 +35,7 @@ cnameFor domain mkp =
 	let p = mkp domain
 	in p { propertyAttr = propertyAttr p . addCName domain }
 
-addCName :: HostName -> Attr -> Attr
+addCName :: HostName -> SetAttr
 addCName domain d = d { _cnames = S.insert domain (_cnames d) }
 
 sshPubKey :: String -> Property
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
index c697d853..55ce7f77 100644
--- a/Propellor/Engine.hs
+++ b/Propellor/Engine.hs
@@ -18,7 +18,7 @@ runPropellor attr a = runReaderT (runWithAttr a) attr
 mainProperties :: Attr -> [Property] -> IO ()
 mainProperties attr ps = do
 	r <- runPropellor attr $
-		ensureProperties [property "overall" $ ensureProperties ps]
+		ensureProperties [Property "overall" (ensureProperties ps) id]
 	setTitle "propellor: done"
 	hFlush stdout
 	case r of
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index aa419069..24494654 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -5,6 +5,7 @@ module Propellor.Property where
 import System.Directory
 import Control.Monad
 import Data.Monoid
+import Data.List
 import Control.Monad.IfElse
 import "mtl" Control.Monad.Reader
 
@@ -15,23 +16,21 @@ import Propellor.Engine
 import Utility.Monad
 import System.FilePath
 
-makeChange :: IO () -> Propellor Result
-makeChange a = liftIO a >> return MadeChange
-
-noChange :: Propellor Result
-noChange = return NoChange
+-- Constructs a Property.
+property :: Desc -> Propellor Result -> Property
+property d s = Property d s id
 
 -- | Combines a list of properties, resulting in a single property
 -- that when run will run each property in the list in turn,
 -- and print out the description of each as it's run. Does not stop
 -- on failure; does propigate overall success/failure.
 propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = property desc $ ensureProperties ps
+propertyList desc ps = Property desc (ensureProperties ps) (combineSetAttrs ps)
 
 -- | Combines a list of properties, resulting in one property that
 -- ensures each in turn, stopping on failure.
 combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = property desc $ go ps NoChange
+combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)
   where
   	go [] rs = return rs
 	go (l:ls) rs = do
@@ -44,11 +43,8 @@ combineProperties desc ps = property desc $ go ps NoChange
 -- that ensures the first, and if the first succeeds, ensures the second.
 -- The property uses the description of the first property.
 before :: Property -> Property -> Property
-p1 `before` p2 = property (propertyDesc p1) $ do
-	r <- ensureProperty p1
-	case r of
-		FailedChange -> return FailedChange
-		_ -> ensureProperty p2
+p1 `before` p2 = p2 `requires` p1
+	`describe` (propertyDesc p1)
 
 -- | Makes a perhaps non-idempotent Property be idempotent by using a flag
 -- file to indicate whether it has run before.
@@ -57,13 +53,13 @@ flagFile :: Property -> FilePath -> Property
 flagFile p = flagFile' p . return
 
 flagFile' :: Property -> IO FilePath -> Property
-flagFile' p getflagfile = property (propertyDesc p) $ do
+flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
 	flagfile <- liftIO getflagfile
-	go flagfile =<< liftIO (doesFileExist flagfile)
+	go satisfy flagfile =<< liftIO (doesFileExist flagfile)
   where
-	go _ True = return NoChange
-	go flagfile False = do
-		r <- ensureProperty p
+	go _ _ True = return NoChange
+	go satisfy flagfile False = do
+		r <- satisfy
 		when (r == MadeChange) $ liftIO $ 
 			unlessM (doesFileExist flagfile) $ do
 				createDirectoryIfMissing True (takeDirectory flagfile)
@@ -73,22 +69,24 @@ flagFile' p getflagfile = property (propertyDesc p) $ do
 --- | Whenever a change has to be made for a Property, causes a hook
 -- Property to also be run, but not otherwise.
 onChange :: Property -> Property -> Property
-p `onChange` hook = property (propertyDesc p) $ do
-	r <- ensureProperty p
-	case r of
-		MadeChange -> do
-			r' <- ensureProperty hook
-			return $ r <> r'
-		_ -> return r
+p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)
+  where
+	satisfy = do
+		r <- ensureProperty p
+		case r of
+			MadeChange -> do
+				r' <- ensureProperty hook
+				return $ r <> r'
+			_ -> return r
 
 (==>) :: Desc -> Property -> Property
 (==>) = flip describe
 infixl 1 ==>
 
--- | Makes a Property only be performed when a test succeeds.
+-- | Makes a Property only need to do anything when a test succeeds.
 check :: IO Bool -> Property -> Property
-check c p = property (propertyDesc p) $ ifM (liftIO c)
-	( ensureProperty p
+check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
+	( satisfy
 	, return NoChange
 	)
 
@@ -99,8 +97,8 @@ check c p = property (propertyDesc p) $ ifM (liftIO c)
 -- to be made as it is to just idempotently assure the property is
 -- satisfied. For example, chmodding a file.
 trivial :: Property -> Property
-trivial p = property (propertyDesc p) $ do
-	r <- ensureProperty p
+trivial p = adjustProperty p $ \satisfy -> do
+	r <- satisfy
 	if r == MadeChange
 		then return NoChange
 		else return r
@@ -133,16 +131,33 @@ host hn = Host [] (\_ -> newAttr hn)
 
 -- | Adds a property to a Host
 --
--- Can add Properties, RevertableProperties, and AttrProperties
+-- Can add Properties and RevertableProperties
 (&) :: IsProp p => Host -> p -> Host
-(Host ps as) & p = Host (ps ++ [toProp p]) (getAttr p . as)
+(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as)
 
 infixl 1 &
 
 -- | Adds a property to the Host in reverted form.
 (!) :: Host -> RevertableProperty -> Host
-(Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as)
+(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as)
   where
 	q = revert p
 
 infixl 1 !
+
+-- Changes the action that is performed to satisfy a property. 
+adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
+adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
+
+-- Combines the Attr settings of two properties.
+combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr
+combineSetAttr p q = setAttr p . setAttr q
+
+combineSetAttrs :: IsProp p => [p] -> SetAttr
+combineSetAttrs = foldl' (.) id . map setAttr
+
+makeChange :: IO () -> Propellor Result
+makeChange a = liftIO a >> return MadeChange
+
+noChange :: Propellor Result
+noChange = return NoChange
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 2115dc50..9234cbbf 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -157,8 +157,8 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
 -- | Package installation may fail becuse the archive has changed.
 -- Run an update in that case and retry.
 robustly :: Property -> Property
-robustly p = property (propertyDesc p) $ do
-	r <- ensureProperty p
+robustly p = adjustProperty p $ \satisfy -> do
+	r <- satisfy
 	if r == FailedChange
 		then ensureProperty $ p `requires` update
 		else return r
diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs
index 5b7494ee..bcd08246 100644
--- a/Propellor/Property/Cmd.hs
+++ b/Propellor/Property/Cmd.hs
@@ -12,6 +12,7 @@ import Data.List
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
+import Propellor.Property
 import Utility.Monad
 import Utility.SafeCommand
 import Utility.Env
diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs
index 0e639129..f2911e50 100644
--- a/Propellor/Property/Scheduled.hs
+++ b/Propellor/Property/Scheduled.hs
@@ -19,13 +19,13 @@ import qualified Data.Map as M
 -- This uses the description of the Property to keep track of when it was
 -- last run.
 period :: Property -> Recurrance -> Property
-period prop recurrance = property desc $ do
+period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do
 	lasttime <- liftIO $ getLastChecked (propertyDesc prop)
 	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
 	t <- liftIO localNow
 	if Just t >= nexttime
 		then do
-			r <- ensureProperty prop
+			r <- satisfy
 			liftIO $ setLastChecked t (propertyDesc prop)
 			return r
 		else noChange
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 01be9a5a..42401d12 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -8,12 +8,11 @@ module Propellor.Types
 	, HostName
 	, Propellor(..)
 	, Property(..)
-	, property
 	, RevertableProperty(..)
 	, IsProp
 	, describe
 	, toProp
-	, getAttr
+	, setAttr
 	, requires
 	, Desc
 	, Result(..)
@@ -34,7 +33,7 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO
 import Propellor.Types.Attr
 import Propellor.Types.OS
 
-data Host = Host [Property] (Attr -> Attr)
+data Host = Host [Property] SetAttr
 
 -- | Propellor's monad provides read-only access to attributes of the
 -- system.
@@ -55,13 +54,10 @@ data Property = Property
 	{ propertyDesc :: Desc
 	, propertySatisfy :: Propellor Result
 	-- ^ must be idempotent; may run repeatedly
-	, propertyAttr :: Attr -> Attr
+	, propertyAttr :: SetAttr
 	-- ^ a property can affect the overall Attr
 	}
 
-property :: Desc -> Propellor Result -> Property
-property d s = Property d s id
-
 -- | A property that can be reverted.
 data RevertableProperty = RevertableProperty Property Property
 
@@ -72,12 +68,12 @@ class IsProp p where
 	-- | Indicates that the first property can only be satisfied
 	-- once the second one is.
 	requires :: p -> Property -> p
-	getAttr :: p -> (Attr -> Attr)
+	setAttr :: p -> SetAttr
 
 instance IsProp Property where
 	describe p d = p { propertyDesc = d }
 	toProp p = p
-	getAttr = propertyAttr
+	setAttr = propertyAttr
 	x `requires` y = Property (propertyDesc x) satisfy attr
 	  where
 	  	attr = propertyAttr x . propertyAttr y
@@ -95,8 +91,8 @@ instance IsProp RevertableProperty where
 	toProp (RevertableProperty p1 _) = p1
 	(RevertableProperty p1 p2) `requires` y =
 		RevertableProperty (p1 `requires` y) p2
-	-- | Gets the Attr of the currently active side.
-	getAttr (RevertableProperty p1 _p2) = getAttr p1
+	-- | Return the SetAttr of the currently active side.
+	setAttr (RevertableProperty p1 _p2) = setAttr p1
 
 type Desc = String
 
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
index 1ff58148..00611775 100644
--- a/Propellor/Types/Attr.hs
+++ b/Propellor/Types/Attr.hs
@@ -42,3 +42,5 @@ newAttr hn = Attr hn S.empty Nothing Nothing Nothing []
 
 type HostName = String
 type Domain = String
+
+type SetAttr = Attr -> Attr
diff --git a/TODO b/TODO
index 93dcf0d4..96324ad5 100644
--- a/TODO
+++ b/TODO
@@ -15,7 +15,5 @@
 * There is no way for a property of a docker container to require
   some property be met outside the container. For example, some servers
   need ntp installed for a good date source.
-* Attributes can only be set in the top level property list for a Host.
-  If an attribute is set inside a propertyList, it won't propigate out.
-  Fix this. Probably the fix involves combining AttrProperty into Property.
-  Then propertyList can gather the attributes from its list.
+* Docking a container in a host should add to the host any cnames that
+  are assigned to the container.
diff --git a/debian/changelog b/debian/changelog
index 3cef12dc..ee7df1e8 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,7 +1,10 @@
 propellor (0.4.0) UNRELEASED; urgency=medium
 
   * Constructor of Property has changed (use property function instead).
-  * Run all cron jobs under chronic from moreutils to avoid unnecessary mails.
+  * All Property combinators now combine together their Attr settings.
+    So Attr settings can be made inside a propertyList, for example.
+  * Run all cron jobs under chronic from moreutils to avoid unnecessary
+    mails.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 17 Apr 2014 21:00:43 -0400
 
-- 
cgit v1.3-2-g0d8e


From 39d697ca789c04da07bb14cc7476899e717d9413 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 18 Apr 2014 17:19:28 -0400
Subject: add dns records to Attr

---
 Propellor/Attr.hs         |  10 ++--
 Propellor/Property/Dns.hs | 121 +++++++++++++---------------------------------
 Propellor/Types.hs        |   1 -
 Propellor/Types/Attr.hs   |  12 ++---
 Propellor/Types/Dns.hs    |  73 ++++++++++++++++++++++++++++
 Propellor/Types/OS.hs     |   1 +
 config-joey.hs            |   6 +--
 propellor.cabal           |   1 +
 8 files changed, 122 insertions(+), 103 deletions(-)
 create mode 100644 Propellor/Types/Dns.hs

(limited to 'Propellor/Types.hs')

diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index 03c882cc..21736588 100644
--- a/Propellor/Attr.hs
+++ b/Propellor/Attr.hs
@@ -4,6 +4,7 @@ module Propellor.Attr where
 
 import Propellor.Types
 import Propellor.Types.Attr
+import Propellor.Types.Dns
 
 import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
@@ -28,15 +29,16 @@ getOS :: Propellor (Maybe System)
 getOS = asks _os
 
 cname :: Domain -> Property
-cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
+cname domain = pureAttrProperty ("cname " ++ domain)
+	(addDNS $ CNAME $ AbsDomain domain)
 
 cnameFor :: Domain -> (Domain -> Property) -> Property
 cnameFor domain mkp =
 	let p = mkp domain
-	in p { propertyAttr = propertyAttr p . addCName domain }
+	in p { propertyAttr = propertyAttr p . addDNS (CNAME $ AbsDomain domain) }
 
-addCName :: HostName -> SetAttr
-addCName domain d = d { _cnames = S.insert domain (_cnames d) }
+addDNS :: Record -> SetAttr
+addDNS record d = d { _dns = S.insert record (_dns d) }
 
 sshPubKey :: String -> Property
 sshPubKey k = pureAttrProperty ("ssh pubkey known") $
diff --git a/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs
index 1d4a8e49..99a60145 100644
--- a/Propellor/Property/Dns.hs
+++ b/Propellor/Property/Dns.hs
@@ -1,6 +1,18 @@
-module Propellor.Property.Dns where
+module Propellor.Property.Dns (
+	module Propellor.Types.Dns,
+	secondary,
+	servingZones,
+	mkSOA,
+	nextSerialNumber,
+	incrSerialNumber,
+	currentSerialNumber,
+	writeZoneFile,
+	genZoneFile,
+	genSOA,
+) where
 
 import Propellor
+import Propellor.Types.Dns
 import Propellor.Property.File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Service as Service
@@ -8,48 +20,31 @@ import Utility.Applicative
 
 import Data.List
 import Data.Time.Clock.POSIX
-import Data.Time.Format
-import Foreign.C.Types
 
 namedconf :: FilePath
 namedconf = "/etc/bind/named.conf.local"
 
-data NamedConf = NamedConf
-	{ zdomain :: Domain
-	, ztype :: Type
-	, zfile :: FilePath
-	, zmasters :: [IPAddr]
-	, zconfiglines :: [String]
-	}
-
 zoneDesc :: NamedConf -> String
-zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"
-
-type IPAddr = String
-
-type Domain = String
-
-data Type = Master | Secondary
-	deriving (Show, Eq)
+zoneDesc z = confDomain z ++ " (" ++ show (confType z) ++ ")"
 
 secondary :: Domain -> [IPAddr] -> NamedConf
 secondary domain masters = NamedConf
-	{ zdomain = domain
-	, ztype = Secondary
-	, zfile = "db." ++ domain
-	, zmasters = masters
-	, zconfiglines = ["allow-transfer { }"]
+	{ confDomain = domain
+	, confType = Secondary
+	, confFile = "db." ++ domain
+	, confMasters = masters
+	, confLines = ["allow-transfer { }"]
 	}
 
-zoneStanza :: NamedConf -> [Line]
-zoneStanza z =
+confStanza :: NamedConf -> [Line]
+confStanza c =
 	[ "// automatically generated by propellor"
-	, "zone \"" ++ zdomain z ++ "\" {"
-	, cfgline "type" (if ztype z == Master then "master" else "slave")
-	, cfgline "file" ("\"" ++ zfile z ++ "\"")
+	, "zone \"" ++ confDomain c ++ "\" {"
+	, cfgline "type" (if confType c == Master then "master" else "slave")
+	, cfgline "file" ("\"" ++ confFile c ++ "\"")
 	] ++
-	(if null (zmasters z) then [] else mastersblock) ++
-	(map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) ++
+	(if null (confMasters c) then [] else mastersblock) ++
+	(map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
 	[ "};"
 	, ""
 	]
@@ -57,40 +52,17 @@ zoneStanza z =
 	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
 	mastersblock =
 		[ "\tmasters {" ] ++
-		(map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) ++
+		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") (confMasters c)) ++
 		[ "\t};" ]
 
 -- | Rewrites the whole named.conf.local file to serve the specificed
 -- zones.
-zones :: [NamedConf] -> Property
-zones zs = hasContent namedconf (concatMap zoneStanza zs)
+servingZones :: [NamedConf] -> Property
+servingZones zs = hasContent namedconf (concatMap confStanza zs)
 	`describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))
 	`requires` Apt.serviceInstalledRunning "bind9"
 	`onChange` Service.reloaded "bind9"
 
--- | Represents a bind 9 zone file.
-data Zone = Zone
-	{ zSOA :: SOA
-	, zHosts :: [(HostName, Record)]
-	}
-	deriving (Read, Show, Eq)
-
--- | Every domain has a SOA record, which is big and complicated.
-data SOA = SOA
-	{ sDomain :: BindDomain
-	-- ^ Typically ns1.your.domain
-	, sSerial :: SerialNumber
-	-- ^ The most important parameter is the serial number,
-	-- which must increase after each change.
-	, sRefresh :: Integer
-	, sRetry :: Integer
-	, sExpire :: Integer
-	, sTTL :: Integer
-	, sRecord :: [Record]
-	-- ^ Records for the root of the domain. Typically NS, A, TXT
-	}
-	deriving (Read, Show, Eq)
-
 -- |  Generates a SOA with some fairly sane numbers in it.
 mkSOA :: Domain -> [Record] -> SOA
 mkSOA d rs = SOA
@@ -105,49 +77,22 @@ mkSOA d rs = SOA
   where
 	hours n = n * 60 * 60
 
--- | Types of DNS records.
---
--- This is not a complete list, more can be added.
-data Record
-	= A Ipv4
-	| AAAA Ipv6
-	| CNAME BindDomain
-	| MX Int BindDomain
-	| NS BindDomain
-	| TXT String
-	deriving (Read, Show, Eq)
-
-type Ipv4 = String
-type Ipv6 = String
-
--- | Bind serial numbers are unsigned, 32 bit integers.
-type SerialNumber = CInt
-
--- | Domains in the zone file must end with a period if they are absolute.
---
--- Let's use a type to keep absolute domains straight from relative
--- domains.
---
--- The SOADomain refers to the root SOA record.
-data BindDomain = RelDomain Domain | AbsDomain Domain | SOADomain
-	deriving (Read, Show, Eq)
-
 dValue :: BindDomain -> String
 dValue (RelDomain d) = d
 dValue (AbsDomain d) = d ++ "."
 dValue (SOADomain) = "@"
 
 rField :: Record -> String
-rField (A _) = "A"
-rField (AAAA _) = "AAAA"
+rField (Address (IPv4 _)) = "A"
+rField (Address (IPv6 _)) = "AAAA"
 rField (CNAME _) = "CNAME"
 rField (MX _ _) = "MX"
 rField (NS _) = "NS"
 rField (TXT _) = "TXT"
 
 rValue :: Record -> String
-rValue (A addr) = addr
-rValue (AAAA addr) = addr
+rValue (Address (IPv4 addr)) = addr
+rValue (Address (IPv6 addr)) = addr
 rValue (CNAME d) = dValue d
 rValue (MX pri d) = show pri ++ " " ++ dValue d
 rValue (NS d) = dValue d
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 42401d12..ad822a8b 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -5,7 +5,6 @@
 module Propellor.Types
 	( Host(..)
 	, Attr
-	, HostName
 	, Propellor(..)
 	, Property(..)
 	, RevertableProperty(..)
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
index 00611775..cf8bdf1a 100644
--- a/Propellor/Types/Attr.hs
+++ b/Propellor/Types/Attr.hs
@@ -1,14 +1,15 @@
 module Propellor.Types.Attr where
 
 import Propellor.Types.OS
+import qualified Propellor.Types.Dns as Dns
 
 import qualified Data.Set as S
 
 -- | The attributes of a host. For example, its hostname.
 data Attr = Attr
 	{ _hostname :: HostName
-	, _cnames :: S.Set Domain
 	, _os :: Maybe System
+	, _dns :: S.Set Dns.Record
 	, _sshPubKey :: Maybe String
 
 	, _dockerImage :: Maybe String
@@ -18,8 +19,8 @@ data Attr = Attr
 instance Eq Attr where
 	x == y = and
 		[ _hostname x == _hostname y
-		, _cnames x == _cnames y
 		, _os x == _os y
+		, _dns x == _dns y
 		, _sshPubKey x == _sshPubKey y
 
 		, _dockerImage x == _dockerImage y
@@ -30,17 +31,14 @@ instance Eq Attr where
 instance Show Attr where
 	show a = unlines
 		[ "hostname " ++ _hostname a
-		, "cnames " ++ show (_cnames a)
 		, "OS " ++ show (_os a)
+		, "dns " ++ show (_dns a)
 		, "sshPubKey " ++ show (_sshPubKey a)
 		, "docker image " ++ show (_dockerImage a)
 		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
 		]
 
 newAttr :: HostName -> Attr
-newAttr hn = Attr hn S.empty Nothing Nothing Nothing []
-
-type HostName = String
-type Domain = String
+newAttr hn = Attr hn Nothing S.empty Nothing Nothing []
 
 type SetAttr = Attr -> Attr
diff --git a/Propellor/Types/Dns.hs b/Propellor/Types/Dns.hs
new file mode 100644
index 00000000..4b5925c1
--- /dev/null
+++ b/Propellor/Types/Dns.hs
@@ -0,0 +1,73 @@
+module Propellor.Types.Dns where
+
+import Propellor.Types.OS (HostName)
+
+import Foreign.C.Types
+
+type Domain = String
+
+data IPAddr = IPv4 String | IPv6 String
+	deriving (Read, Show, Eq, Ord)
+
+fromIPAddr :: IPAddr -> String
+fromIPAddr (IPv4 addr) = addr
+fromIPAddr (IPv6 addr) = addr
+
+-- | Represents a bind 9 named.conf file.
+data NamedConf = NamedConf
+	{ confDomain :: Domain
+	, confType :: Type
+	, confFile :: FilePath
+	, confMasters :: [IPAddr]
+	, confLines :: [String]
+	}
+	deriving (Show, Eq)
+
+data Type = Master | Secondary
+	deriving (Show, Eq)
+
+-- | Represents a bind 9 zone file.
+data Zone = Zone
+	{ zSOA :: SOA
+	, zHosts :: [(HostName, Record)]
+	}
+	deriving (Read, Show, Eq)
+
+-- | Every domain has a SOA record, which is big and complicated.
+data SOA = SOA
+	{ sDomain :: BindDomain
+	-- ^ Typically ns1.your.domain
+	, sSerial :: SerialNumber
+	-- ^ The most important parameter is the serial number,
+	-- which must increase after each change.
+	, sRefresh :: Integer
+	, sRetry :: Integer
+	, sExpire :: Integer
+	, sTTL :: Integer
+	, sRecord :: [Record]
+	-- ^ Records for the root of the domain. Typically NS, A, TXT
+	}
+	deriving (Read, Show, Eq)
+
+-- | Types of DNS records.
+--
+-- This is not a complete list, more can be added.
+data Record
+	= Address IPAddr
+	| CNAME BindDomain
+	| MX Int BindDomain
+	| NS BindDomain
+	| TXT String
+	deriving (Read, Show, Eq, Ord)
+
+-- | Bind serial numbers are unsigned, 32 bit integers.
+type SerialNumber = CInt
+
+-- | Domains in the zone file must end with a period if they are absolute.
+--
+-- Let's use a type to keep absolute domains straight from relative
+-- domains.
+--
+-- The SOADomain refers to the root SOA record.
+data BindDomain = RelDomain Domain | AbsDomain Domain | SOADomain
+	deriving (Read, Show, Eq, Ord)
diff --git a/Propellor/Types/OS.hs b/Propellor/Types/OS.hs
index 0635b271..23cc8a29 100644
--- a/Propellor/Types/OS.hs
+++ b/Propellor/Types/OS.hs
@@ -1,5 +1,6 @@
 module Propellor.Types.OS where
 
+type HostName = String
 type UserName = String
 type GroupName = String
 
diff --git a/config-joey.hs b/config-joey.hs
index b6d1664d..48b43266 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -82,7 +82,7 @@ hosts =               --                  (o)  `
 		& Ssh.hostKey SshEcdsa
 		& Apt.unattendedUpgrades
 		& Apt.serviceInstalledRunning "ntp"
-		& Dns.zones myDnsSecondary
+		& Dns.servingZones myDnsSecondary
 		& Postfix.satellite
 	
 		& Apt.serviceInstalledRunning "apache2"
@@ -234,8 +234,8 @@ myDnsSecondary =
 	, Dns.secondary "branchable.com" branchablemaster
 	]
   where
-	master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren
-	branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]
+	master = [Dns.IPv4 "80.68.85.49", Dns.IPv6 "2001:41c8:125:49::10"] -- wren
+	branchablemaster = [Dns.IPv4 "66.228.46.55", Dns.IPv6 "2600:3c03::f03c:91ff:fedf:c0e5"]
 
 main :: IO ()
 main = defaultMain hosts
diff --git a/propellor.cabal b/propellor.cabal
index 677b9a89..68d7fb70 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -99,6 +99,7 @@ Library
     Propellor.Exception
     Propellor.Types
     Propellor.Types.OS
+    Propellor.Types.Dns
   Other-Modules:
     Propellor.Types.Attr
     Propellor.CmdLine
-- 
cgit v1.3-2-g0d8e


From 395d3f206af48dcac5980fc70f7189a77e43fcc8 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 18 Apr 2014 21:58:23 -0400
Subject: Dns.primary wrote, not quite ready

---
 Propellor/Attr.hs         |  1 -
 Propellor/Property/Dns.hs | 37 ++++++++++++++++++++++++++++++++-----
 Propellor/Types.hs        |  2 ++
 config-joey.hs            | 18 ++++++++++++++++--
 4 files changed, 50 insertions(+), 8 deletions(-)

(limited to 'Propellor/Types.hs')

diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index 37ed1bad..a4d7a958 100644
--- a/Propellor/Attr.hs
+++ b/Propellor/Attr.hs
@@ -4,7 +4,6 @@ module Propellor.Attr where
 
 import Propellor.Types
 import Propellor.Types.Attr
-import Propellor.Types.Dns
 
 import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
diff --git a/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs
index 131079ea..a9a8619c 100644
--- a/Propellor/Property/Dns.hs
+++ b/Propellor/Property/Dns.hs
@@ -1,8 +1,10 @@
 module Propellor.Property.Dns (
 	module Propellor.Types.Dns,
+	primary,
 	secondary,
 	servingZones,
 	mkSOA,
+	rootAddressesFrom,
 	writeZoneFile,
 	nextSerialNumber,
 	adjustSerialNumber,
@@ -22,6 +24,23 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.List
 
+-- | Primary dns server for a domain.
+--
+-- TODO: Does not yet add it to named.conf.local.
+primary :: [Host] -> Domain -> SOA -> Property
+primary hosts domain soa = withwarnings (check needupdate baseprop)
+	`requires` Apt.serviceInstalledRunning "bind9"
+	`onChange` Service.reloaded "bind9"
+  where
+	(zone, warnings) = genZone hosts domain soa
+	zonefile = "/etc/bind/propellor/db." ++ domain
+	needupdate = (/= Just zone) <$> readZonePropellorFile zonefile
+	baseprop = property ("dns primary for " ++ domain) $ makeChange $ do
+		writeZoneFile zone zonefile
+	withwarnings p = adjustProperty p $ \satisfy -> do
+		mapM_ warningMessage warnings
+		satisfy
+
 namedconf :: FilePath
 namedconf = "/etc/bind/named.conf.local"
 
@@ -56,7 +75,7 @@ confStanza c =
 		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") (confMasters c)) ++
 		[ "\t};" ]
 
--- | Rewrites the whole named.conf.local file to serve the specificed
+-- | Rewrites the whole named.conf.local file to serve the specified
 -- zones.
 servingZones :: [NamedConf] -> Property
 servingZones zs = hasContent namedconf (concatMap confStanza zs)
@@ -66,6 +85,10 @@ servingZones zs = hasContent namedconf (concatMap confStanza zs)
 
 -- | Generates a SOA with some fairly sane numbers in it.
 --
+-- The Domain is the domain to use in the SOA record. Typically
+-- something like ns1.example.com. Not the domain that this is the SOA
+-- record for.
+--
 -- The SerialNumber can be whatever serial number was used by the domain
 -- before propellor started managing it. Or 0 if the domain has only ever
 -- been managed by propellor.
@@ -73,19 +96,22 @@ servingZones zs = hasContent namedconf (concatMap confStanza zs)
 -- You do not need to increment the SerialNumber when making changes!
 -- Propellor will automatically add the number of commits in the git
 -- repository to the SerialNumber.
-mkSOA :: Domain -> SerialNumber -> [Record] -> SOA
-mkSOA d sn rs = SOA
+mkSOA :: Domain -> SerialNumber -> [Record] -> [Record] -> SOA
+mkSOA d sn rs1 rs2 = SOA
 	{ sDomain = AbsDomain d
 	, sSerial = sn
 	, sRefresh = hours 4
 	, sRetry = hours 1
 	, sExpire = 2419200 -- 4 weeks
 	, sTTL = hours 8
-	, sRecord = rs
+	, sRecord = rs1 ++ rs2
 	}
   where
 	hours n = n * 60 * 60
 
+rootAddressesFrom :: [Host] -> HostName -> [Record]
+rootAddressesFrom hosts hn = map Address (hostAddresses hn hosts)
+
 dValue :: BindDomain -> String
 dValue (RelDomain d) = d
 dValue (AbsDomain d) = d ++ "."
@@ -137,7 +163,8 @@ writeZoneFile z f = do
 	offset <- serialNumberOffset
 	let z' = nextSerialNumber
 		(adjustSerialNumber z (+ offset))
-		(succ oldserial)
+		oldserial
+	createDirectoryIfMissing True (takeDirectory f)
 	writeFile f (genZoneFile z')
 	writeZonePropellorFile f z'
 
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index ad822a8b..0e412e82 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -21,6 +21,7 @@ module Propellor.Types
 	, GpgKeyId
 	, SshKeyType(..)
 	, module Propellor.Types.OS
+	, module Propellor.Types.Dns
 	) where
 
 import Data.Monoid
@@ -31,6 +32,7 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO
 
 import Propellor.Types.Attr
 import Propellor.Types.OS
+import Propellor.Types.Dns
 
 data Host = Host [Property] SetAttr
 
diff --git a/config-joey.hs b/config-joey.hs
index 289d3240..e4eed9f1 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -39,6 +39,16 @@ hosts =               --                  (o)  `
 	, standardSystem "clam.kitenet.net" Unstable "amd64"
 		& ipv4 "162.248.143.249"
 		& ipv6 "2002:5044:5531::1"
+		
+		& Dns.primary hosts "olduse.net" $
+			Dns.mkSOA "ns1.kitenet.net" 100
+				(Dns.rootAddressesFrom hosts "branchable.com")
+				[ NS "ns1.kitenet.net"
+				, NS "ns6.gandi.net"
+				, NS "ns2.kitenet.net"
+				, MX 0 "kitenet.net"
+				, TXT "v=spf1 a -all"
+				] 
 
 		& cleanCloudAtCost
 		& Apt.unattendedUpgrades
@@ -242,7 +252,7 @@ myDnsSecondary =
 	]
   where
 	master = hostAddresses "wren.kitenet.net" hosts
-	branchablemaster = hostAddresses "pell.branchable.com" hosts
+	branchablemaster = hostAddresses "branchable.com" hosts
 
 main :: IO ()
 main = defaultMain hosts
@@ -274,7 +284,11 @@ monsters =	      -- but do want to track their public keys etc.
 		& ipv4 "80.68.85.49"
 		& ipv6 "2001:41c8:125:49::10"
 		& cname "kite.kitenet.net"
-	, host "pell.branchable.com"
+	, host "branchable.com"
 		& ipv4 "66.228.46.55"
 		& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
+		& cname "www.olduse.net"
+		& cname "git.olduse.net"
+	, host "virgil.koldfront.dk"
+		& cname "article.olduse.net"
 	]
-- 
cgit v1.3-2-g0d8e