HostName: Improve domain extraction code.

2 files changed, 36 insertions, 5 deletions

diff --git a/debian/changelog b/debian/changelog
index 487826e1..0fd2cb1d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -5,6 +5,7 @@ propellor (2.11.1) UNRELEASED; urgency=medium
     as chroots. Thanks, Ben Boeckel.
   * Added Mount.fstabbed property to generate /etc/fstab to replicate
     current mounts.
+  * HostName: Improve domain extraction code.
 
  -- Joey Hess <id@joeyh.name>  Thu, 22 Oct 2015 20:24:18 -0400
 
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 7766d497..78ec872f 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -4,6 +4,7 @@ import Propellor.Base
 import qualified Propellor.Property.File as File
 
 import Data.List
+import Data.List.Utils
 
 -- | Ensures that the hostname is set using best practices.
 --
@@ -18,13 +19,21 @@ import Data.List
 -- other hostnames there is not best practices and can lead to annoying
 -- messages from eg, apache.
 sane :: Property NoInfo
-sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
+sane = sane' extractDomain
+
+sane' :: ExtractDomain -> Property NoInfo
+sane' extractdomain = property ("sane hostname") $
+	ensureProperty . setTo' extractdomain =<< asks hostName
 
 setTo :: HostName -> Property NoInfo
-setTo hn = combineProperties desc go
+setTo = setTo' extractDomain
+
+setTo' :: ExtractDomain -> HostName -> Property NoInfo
+setTo' extractdomain hn = combineProperties desc go
   where
 	desc = "hostname " ++ hn
-	(basehost, domain) = separate (== '.') hn
+	basehost = takeWhile (/= '.') hn
+	domain = extractdomain hn
 
 	go = catMaybes
 		[ Just $ "/etc/hostname" `File.hasContent` [basehost]
@@ -47,11 +56,14 @@ setTo hn = combineProperties desc go
 -- | Makes </etc/resolv.conf> contain search and domain lines for 
 -- the domain that the hostname is in.
 searchDomain :: Property NoInfo
-searchDomain = property desc (ensureProperty . go =<< asks hostName)
+searchDomain = searchDomain' extractDomain
+
+searchDomain' :: ExtractDomain -> Property NoInfo
+searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)
   where
 	desc = "resolv.conf search and domain configured"
 	go hn =
-		let (_basehost, domain) = separate (== '.') hn
+		let domain = extractdomain hn
 		in  File.fileProperty desc (use domain) "/etc/resolv.conf"
 	use domain ls = filter wanted $ nub (ls ++ cfgs)
 	  where
@@ -61,3 +73,21 @@ searchDomain = property desc (ensureProperty . go =<< asks hostName)
 			| "domain " `isPrefixOf` l = False
 			| "search " `isPrefixOf` l = False
 			| otherwise = True
+
+-- | Function to extract the domain name from a HostName.
+type ExtractDomain = HostName -> String
+
+-- | hostname of foo.example.com has a domain of example.com.
+-- But, when the hostname is example.com, the domain is
+-- example.com too.
+--
+-- This doesn't work for eg, foo.co.uk, or when foo.sci.uni.edu
+-- is in a sci.uni.edu subdomain. If you are in such a network,
+-- provide your own ExtractDomain function to the properties above.
+extractDomain :: ExtractDomain
+extractDomain hn = 
+	let bits = split "." hn
+	in intercalate "." $
+		if length bits > 2
+			then drop 1 bits
+			else bits