    {-# 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"