    {-# LANGUAGE FlexibleContexts #-}

    module Propellor.Property.Postfix where

    import Propellor.Base
    import qualified Propellor.Property.Apt as Apt
    import qualified Propellor.Property.File as File
    import qualified Propellor.Property.Service as Service
    import qualified Propellor.Property.User as User

    import qualified Data.Map as M
    import Data.List
    import Data.Char

    installed :: Property DebianLike
    installed = Apt.serviceInstalledRunning "postfix"

    restarted :: Property DebianLike
    restarted = Service.restarted "postfix"

    reloaded :: Property DebianLike
    reloaded = Service.reloaded "postfix"

    -- | Configures postfix as a satellite system, which
    -- relays all mail through a relay host, which defaults to smtp.domain,
    -- but can be changed by @mainCf "relayhost"@.
    --
    -- The smarthost may refuse to relay mail on to other domains, without
    -- further configuration/keys. But this should be enough to get cron job
    -- mail flowing to a place where it will be seen.
    satellite :: Property DebianLike
    satellite = check (not <$> mainCfIsSet "relayhost") setup
    	`requires` installed
      where
    	desc = "postfix satellite system"
    	setup :: Property DebianLike
    	setup = property' desc $ \w -> do
    		hn <- asks hostName
    		let (_, domain) = separate (== '.') hn
    		ensureProperty w $ combineProperties desc $ props
    			& Apt.reConfigure "postfix"
    				[ ("postfix/main_mailer_type", "select", "Satellite system")
    				, ("postfix/root_address", "string", "root")
    				, ("postfix/destinations", "string", "localhost")
    				, ("postfix/mailname", "string", hn)
    				]
    			& mainCf ("relayhost", "smtp." ++ domain)
    				`onChange` reloaded

    -- | Sets up a file by running a property (which the filename is passed
    -- to). If the setup property makes a change, postmap will be run on the
    -- file, and postfix will be reloaded.
    mappedFile
    	:: Combines (Property x) (Property UnixLike)
    	=> FilePath
    	-> (FilePath -> Property x)
    	-> CombinedType (Property x) (Property UnixLike)
    mappedFile f setup = setup f
    	`onChange` (cmdProperty "postmap" [f] `assume` MadeChange)

    -- | Run newaliases command, which should be done after changing
    -- @/etc/aliases@.
    newaliases :: Property UnixLike
    newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
    	(cmdProperty "newaliases" [])

    -- | The main config file for postfix.
    mainCfFile :: FilePath
    mainCfFile = "/etc/postfix/main.cf"

    -- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately.
    mainCf :: (String, String) -> Property UnixLike
    mainCf (name, value) = check notset set
    	`describe` ("postfix main.cf " ++ setting)
      where
    	setting = name ++ "=" ++ value
    	notset = (/= Just value) <$> getMainCf name
    	set = cmdProperty "postconf" ["-e", setting]

    -- | Gets a main.cf setting.
    getMainCf :: String -> IO (Maybe String)
    getMainCf name = parse . lines <$> readProcess "postconf" [name]
      where
    	parse (l:_) = Just $
    		case separate (== '=') l of
    			(_, (' ':v)) -> v
    			(_, v) -> v
    	parse [] = Nothing

    -- | Checks if a main.cf field is set. A field that is set to
    -- the empty string is considered not set.
    mainCfIsSet :: String -> IO Bool
    mainCfIsSet name = do
    	v <- getMainCf name
    	return $ v /= Nothing && v /= Just ""

    -- | Parses main.cf, and removes any initial configuration lines that are
    -- overridden to other values later in the file.
    --
    -- For example, to add some settings, removing any old settings:
    --
    -- > mainCf `File.containsLines`
    -- >	[ "# I like bars."
    -- >	, "foo = bar"
    -- >	] `onChange` dedupMainCf
    --
    -- Note that multiline configurations that continue onto the next line
    -- are not currently supported.
    dedupMainCf :: Property UnixLike
    dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile

    dedupCf :: [String] -> [String]
    dedupCf ls =
    	let parsed = map parse ls
    	in dedup [] (keycounts $ rights parsed) parsed
      where
    	parse l
    		| "#" `isPrefixOf` l = Left l
    		| "=" `isInfixOf` l =
    			let (k, v) = separate (== '=') l
    			in Right ((filter (not . isSpace) k), v)
    		| otherwise = Left l
    	fmt k v = k ++ " =" ++ v

    	keycounts = M.fromListWith (+) . map (\(k, _v) -> (k, (1 :: Integer)))

    	dedup c _ [] = reverse c
    	dedup c kc ((Left v):rest) = dedup (v:c) kc rest
    	dedup c kc ((Right (k, v)):rest) = case M.lookup k kc of
    		Just n | n > 1 -> dedup c (M.insert k (n - 1) kc) rest
    		_ -> dedup (fmt k v:c) kc rest

    -- | The master config file for postfix.
    masterCfFile :: FilePath
    masterCfFile = "/etc/postfix/master.cf"

    -- | A service that can be present in the master config file.
    data Service = Service
    	{ serviceType :: ServiceType
    	, serviceCommand :: String
    	, serviceOpts :: ServiceOpts
    	}
    	deriving (Show, Eq)

    data ServiceType
    	= InetService (Maybe HostName) ServicePort
    	| UnixService FilePath PrivateService
    	| FifoService FilePath PrivateService
    	| PassService FilePath PrivateService
    	deriving (Show, Eq)

    -- Can be a port number or service name such as "smtp".
    type ServicePort = String

    type PrivateService = Bool

    -- | Options for a service.
    data ServiceOpts = ServiceOpts
    	{ serviceUnprivileged :: Maybe Bool
    	, serviceChroot :: Maybe Bool
    	, serviceWakeupTime :: Maybe Int
    	, serviceProcessLimit :: Maybe Int
    	}
    	deriving (Show, Eq)

    defServiceOpts :: ServiceOpts
    defServiceOpts = ServiceOpts
    	{ serviceUnprivileged = Nothing
    	, serviceChroot = Nothing
    	, serviceWakeupTime = Nothing
    	, serviceProcessLimit = Nothing
    	}

    formatServiceLine :: Service -> File.Line
    formatServiceLine s = unwords $ map pad
    	[ (10, case serviceType s of
    		InetService (Just h) p -> h ++ ":" ++ p
    		InetService Nothing p -> p
    		UnixService f _ -> f
    		FifoService f _ -> f
    		PassService f _ -> f)
    	, (6, case serviceType s of
    		InetService _ _ -> "inet"
    		UnixService _ _ -> "unix"
    		FifoService _ _ -> "fifo"
    		PassService _ _ -> "pass")
    	, (8, case serviceType s of
    		InetService _ _ -> bool False
    		UnixService _ b -> bool b
    		FifoService _ b -> bool b
    		PassService _ b -> bool b)
    	, (8, v bool serviceUnprivileged)
    	, (8, v bool serviceChroot)
    	, (8, v show serviceWakeupTime)
    	, (8, v show serviceProcessLimit)
    	, (0, serviceCommand s)
    	]
      where
    	v f sel = maybe "-" f (sel (serviceOpts s))
    	bool True = "y"
    	bool False = "n"
    	pad (n, t) = t ++ replicate (n - 1 - length t) ' '

    -- | Note that this does not handle multi-line service entries,
    -- in which subsequent lines are indented. `serviceLine` does not generate
    -- such entries.
    parseServiceLine :: File.Line -> Maybe Service
    parseServiceLine ('#':_) = Nothing
    parseServiceLine (' ':_) = Nothing -- continuation of multiline entry
    parseServiceLine l = Service
    	<$> parsetype
    	<*> parsecommand
    	<*> parseopts
      where
    	parsetype = do
    		t <- getword 2
    		case t of
    			"inet" -> do
    				v <- getword 1
    				let (h,p) = separate (== ':') v
    				if null p
    					then Nothing
    					else Just $ InetService
    						(if null h then Nothing else Just h) p
    			"unix" -> UnixService <$> getword 1 <*> parseprivate
    			"fifo" -> FifoService <$> getword 1 <*> parseprivate
    			"pass" -> PassService <$> getword 1 <*> parseprivate
    			_ -> Nothing
    	parseprivate = join . bool =<< getword 3

    	parsecommand = case unwords (drop 7 ws) of
    		"" -> Nothing
    		s -> Just s

    	parseopts = ServiceOpts
    		<$> (bool =<< getword 4)
    		<*> (bool =<< getword 5)
    		<*> (int =<< getword 6)
    		<*> (int =<< getword 7)

    	bool "-" = Just Nothing
    	bool "y" = Just (Just True)
    	bool "n" = Just (Just False)
    	bool _ = Nothing

    	int "-" = Just Nothing
    	int n = maybe Nothing (Just . Just) (readish n)

    	getword n
    		| nws >= n = Just (ws !! (n -1))
    		| otherwise = Nothing
    	ws = words l
    	nws = length ws

    -- | Enables a `Service` in postfix's `masterCfFile`.
    service :: Service -> RevertableProperty DebianLike DebianLike
    service s = (enable <!> disable)
    	`describe` desc
      where
    	desc = "enabled postfix service " ++ show (serviceType s)
    	enable = masterCfFile `File.containsLine` (formatServiceLine s)
    		`onChange` reloaded
    	disable = File.fileProperty desc (filter (not . matches)) masterCfFile
    		`onChange` reloaded
    	matches l = case parseServiceLine l of
    		Just s' | s' == s -> True
    		_ -> False

    -- | Installs saslauthd and configures it for postfix, authenticating
    -- against PAM.
    --
    -- Does not configure postfix to use it; eg @smtpd_sasl_auth_enable = yes@
    -- needs to be set to enable use. See
    -- <https://wiki.debian.org/PostfixAndSASL>.
    --
    -- Password brute force attacks are possible when SASL auth is enabled.
    -- It would be wise to enable fail2ban, for example:
    --
    -- > Fail2Ban.jailEnabled "postfix-sasl"
    saslAuthdInstalled :: Property DebianLike
    saslAuthdInstalled = setupdaemon
    	`requires` Service.running "saslauthd"
    	`requires` postfixgroup
    	`requires` dirperm
    	`requires` Apt.installed ["sasl2-bin"]
    	`requires` smtpdconf
      where
    	setupdaemon = "/etc/default/saslauthd" `File.containsLines`
    		[ "START=yes"
    		, "OPTIONS=\"-c -m " ++ dir ++ "\""
    		]
    		`onChange` Service.restarted "saslauthd"
    	smtpdconf = "/etc/postfix/sasl/smtpd.conf" `File.containsLines`
    		[ "pwcheck_method: saslauthd"
    		, "mech_list: PLAIN LOGIN"
    		]
    	dirperm = check (not <$> doesDirectoryExist dir) $
    		cmdProperty "dpkg-statoverride"
    			[ "--add", "root", "sasl", "710", dir ]
    	postfixgroup = (User "postfix") `User.hasGroup` (Group "sasl")
    		`onChange` restarted
    	dir = "/var/spool/postfix/var/run/saslauthd"

    -- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file.
    --
    -- The password is taken from the privdata.
    saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike)
    saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"
      where
    	go = withPrivData src ctx $ \getpw ->
    		property desc $ getpw $ \pw -> liftIO $
    			withHandle StdinHandle createProcessSuccess p $ \h -> do
    				hPutStrLn h (privDataVal pw)
    				hClose h
    				return NoChange
    	desc = "sasl password for " ++ uatd
    	uatd = user ++ "@" ++ domain
    	ps = ["-p", "-c", "-u", domain, user]
    	p = proc "saslpasswd2" ps
    	ctx = Context "sasl"
    	src = PrivDataSource (Password uatd) "enter password"