module Network.Mail.Postie.Settings
  ( Settings (..),
    TLSSettings (..),
    StartTLSPolicy (..),
    settingsStartTLSPolicy,
    defaultExceptionHandler,
    mkServerParams,
    def,
    -- | reexport from Default class
  )
where

import Control.Applicative
import Control.Exception
import Data.ByteString (ByteString)
import Data.Default.Class
import GHC.IO.Exception (IOErrorType (..))
import Network.Socket (HostName, PortNumber, SockAddr)
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra.Cipher as TLS
import System.IO (hPrint, stderr)
import System.IO.Error (ioeGetErrorType)
import Network.Mail.Postie.Address
import Network.Mail.Postie.SessionID
import Network.Mail.Postie.Types
import Prelude

-- | Settings to configure posties behaviour.
data Settings
  = Settings
      { -- | Port postie will run on.
        Settings -> PortNumber
settingsPort :: PortNumber,
        -- | Timeout for connections in seconds
        Settings -> Int
settingsTimeout :: Int,
        -- | Maximal size of incoming mail data
        Settings -> Int
settingsMaxDataSize :: Int,
        -- | Hostname which is shown in posties greeting.
        Settings -> Maybe HostName
settingsHost :: Maybe HostName,
        -- | TLS settings if you wish to secure connections.
        Settings -> Maybe TLSSettings
settingsTLS :: Maybe TLSSettings,
        -- | Whether authentication is required
        Settings -> Bool
settingsRequireAuth :: Bool,
        -- | Exception handler (default is defaultExceptionHandler)
        Settings -> Maybe SessionID -> SomeException -> IO ()
settingsOnException :: Maybe SessionID -> SomeException -> IO (),
        -- | Action will be performed before main processing begins.
        Settings -> IO ()
settingsBeforeMainLoop :: IO (),
        -- | Action will be performed when connection has been opened.
        Settings -> SessionID -> SockAddr -> IO ()
settingsOnOpen :: SessionID -> SockAddr -> IO (),
        -- | Action will be performed when connection has been closed.
        Settings -> SessionID -> IO ()
settingsOnClose :: SessionID -> IO (),
        -- | Action will be performend on STARTTLS command.
        Settings -> SessionID -> IO ()
settingsOnStartTLS :: SessionID -> IO (),
        -- | Performed when client says hello
        Settings -> SessionID -> ByteString -> IO HandlerResponse
settingsOnHello :: SessionID -> ByteString -> IO HandlerResponse,
        -- | Performed when client authenticates
        Settings -> SessionID -> ByteString -> IO HandlerResponse
settingsOnAuth :: SessionID -> ByteString -> IO HandlerResponse,
        -- | Performed when client starts mail transaction
        Settings -> SessionID -> Address -> IO HandlerResponse
settingsOnMailFrom :: SessionID -> Address -> IO HandlerResponse,
        -- | Performed when client adds recipient to mail transaction.
        Settings -> SessionID -> Address -> IO HandlerResponse
settingsOnRecipient :: SessionID -> Address -> IO HandlerResponse
      }

instance Default Settings where
  def :: Settings
def = Settings
defaultSettings

-- | Default settings for postie
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings =
  Settings :: PortNumber
-> Int
-> Int
-> Maybe HostName
-> Maybe TLSSettings
-> Bool
-> (Maybe SessionID -> SomeException -> IO ())
-> IO ()
-> (SessionID -> SockAddr -> IO ())
-> (SessionID -> IO ())
-> (SessionID -> IO ())
-> (SessionID -> ByteString -> IO HandlerResponse)
-> (SessionID -> ByteString -> IO HandlerResponse)
-> (SessionID -> Address -> IO HandlerResponse)
-> (SessionID -> Address -> IO HandlerResponse)
-> Settings
Settings
    { settingsPort :: PortNumber
settingsPort = 3001,
      settingsTimeout :: Int
settingsTimeout = 1800,
      settingsMaxDataSize :: Int
settingsMaxDataSize = 32000,
      settingsHost :: Maybe HostName
settingsHost = Maybe HostName
forall a. Maybe a
Nothing,
      settingsTLS :: Maybe TLSSettings
settingsTLS = Maybe TLSSettings
forall a. Maybe a
Nothing,
      settingsRequireAuth :: Bool
settingsRequireAuth = Bool
False,
      settingsOnException :: Maybe SessionID -> SomeException -> IO ()
settingsOnException = Maybe SessionID -> SomeException -> IO ()
defaultExceptionHandler,
      settingsBeforeMainLoop :: IO ()
settingsBeforeMainLoop = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
      settingsOnOpen :: SessionID -> SockAddr -> IO ()
settingsOnOpen = \_ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
      settingsOnClose :: SessionID -> IO ()
settingsOnClose = IO () -> SessionID -> IO ()
forall a b. a -> b -> a
const (IO () -> SessionID -> IO ()) -> IO () -> SessionID -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
      settingsOnStartTLS :: SessionID -> IO ()
settingsOnStartTLS = IO () -> SessionID -> IO ()
forall a b. a -> b -> a
const (IO () -> SessionID -> IO ()) -> IO () -> SessionID -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
      settingsOnAuth :: SessionID -> ByteString -> IO HandlerResponse
settingsOnAuth = SessionID -> ByteString -> IO HandlerResponse
forall (m :: * -> *) p p. Monad m => p -> p -> m HandlerResponse
void,
      settingsOnHello :: SessionID -> ByteString -> IO HandlerResponse
settingsOnHello = SessionID -> ByteString -> IO HandlerResponse
forall (m :: * -> *) p p. Monad m => p -> p -> m HandlerResponse
void,
      settingsOnMailFrom :: SessionID -> Address -> IO HandlerResponse
settingsOnMailFrom = SessionID -> Address -> IO HandlerResponse
forall (m :: * -> *) p p. Monad m => p -> p -> m HandlerResponse
void,
      settingsOnRecipient :: SessionID -> Address -> IO HandlerResponse
settingsOnRecipient = SessionID -> Address -> IO HandlerResponse
forall (m :: * -> *) p p. Monad m => p -> p -> m HandlerResponse
void
    }
  where
    void :: p -> p -> m HandlerResponse
void _ _ = HandlerResponse -> m HandlerResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerResponse
Accepted

-- | Settings for TLS handling
data TLSSettings
  = TLSSettings
      { -- | Path to certificate file
        TLSSettings -> HostName
certFile :: FilePath,
        -- | Path to private key file belonging to certificate
        TLSSettings -> HostName
keyFile :: FilePath,
        -- | Connection security mode, default is DemandStartTLS
        TLSSettings -> StartTLSPolicy
security :: StartTLSPolicy,
        -- | Logging for TLS
        TLSSettings -> Logging
tlsLogging :: TLS.Logging,
        -- | Supported TLS versions
        TLSSettings -> [Version]
tlsAllowedVersions :: [TLS.Version],
        -- | Supported ciphers
        TLSSettings -> [Cipher]
tlsCiphers :: [TLS.Cipher]
      }

instance Default TLSSettings where
  def :: TLSSettings
def = TLSSettings
defaultTLSSettings

-- | Connection security policy, either via STARTTLS command or on connection initiation.
data StartTLSPolicy
  = -- | Allows clients to use STARTTLS command
    AllowStartTLS
  | -- | Client needs to send STARTTLS command before issuing a mail transaction
    DemandStartTLS
  | -- | Negotiates a TSL context on connection startup.
    ConnectWithTLS
  deriving (StartTLSPolicy -> StartTLSPolicy -> Bool
(StartTLSPolicy -> StartTLSPolicy -> Bool)
-> (StartTLSPolicy -> StartTLSPolicy -> Bool) -> Eq StartTLSPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StartTLSPolicy -> StartTLSPolicy -> Bool
$c/= :: StartTLSPolicy -> StartTLSPolicy -> Bool
== :: StartTLSPolicy -> StartTLSPolicy -> Bool
$c== :: StartTLSPolicy -> StartTLSPolicy -> Bool
Eq, Int -> StartTLSPolicy -> ShowS
[StartTLSPolicy] -> ShowS
StartTLSPolicy -> HostName
(Int -> StartTLSPolicy -> ShowS)
-> (StartTLSPolicy -> HostName)
-> ([StartTLSPolicy] -> ShowS)
-> Show StartTLSPolicy
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [StartTLSPolicy] -> ShowS
$cshowList :: [StartTLSPolicy] -> ShowS
show :: StartTLSPolicy -> HostName
$cshow :: StartTLSPolicy -> HostName
showsPrec :: Int -> StartTLSPolicy -> ShowS
$cshowsPrec :: Int -> StartTLSPolicy -> ShowS
Show)

defaultTLSSettings :: TLSSettings
defaultTLSSettings :: TLSSettings
defaultTLSSettings =
  TLSSettings :: HostName
-> HostName
-> StartTLSPolicy
-> Logging
-> [Version]
-> [Cipher]
-> TLSSettings
TLSSettings
    { certFile :: HostName
certFile = "certificate.pem",
      keyFile :: HostName
keyFile = "key.pem",
      security :: StartTLSPolicy
security = StartTLSPolicy
DemandStartTLS,
      tlsLogging :: Logging
tlsLogging = Logging
forall a. Default a => a
def,
      tlsAllowedVersions :: [Version]
tlsAllowedVersions = [Version
TLS.SSL3, Version
TLS.TLS10, Version
TLS.TLS11, Version
TLS.TLS12],
      tlsCiphers :: [Cipher]
tlsCiphers = [Cipher]
TLS.ciphersuite_default
    }

settingsStartTLSPolicy :: Settings -> Maybe StartTLSPolicy
settingsStartTLSPolicy :: Settings -> Maybe StartTLSPolicy
settingsStartTLSPolicy settings :: Settings
settings = TLSSettings -> StartTLSPolicy
security (TLSSettings -> StartTLSPolicy)
-> Maybe TLSSettings -> Maybe StartTLSPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Settings -> Maybe TLSSettings
settingsTLS Settings
settings

mkServerParams :: TLSSettings -> IO TLS.ServerParams
mkServerParams :: TLSSettings -> IO ServerParams
mkServerParams tlsSettings :: TLSSettings
tlsSettings = do
  Credential
credentials <- IO Credential
loadCredentials
  ServerParams -> IO ServerParams
forall (m :: * -> *) a. Monad m => a -> m a
return
    ServerParams
forall a. Default a => a
def
      { serverShared :: Shared
TLS.serverShared =
          Shared
forall a. Default a => a
def
            { sharedCredentials :: Credentials
TLS.sharedCredentials = [Credential] -> Credentials
TLS.Credentials [Credential
credentials]
            },
        serverSupported :: Supported
TLS.serverSupported =
          Supported
forall a. Default a => a
def
            { supportedCiphers :: [Cipher]
TLS.supportedCiphers = TLSSettings -> [Cipher]
tlsCiphers TLSSettings
tlsSettings,
              supportedVersions :: [Version]
TLS.supportedVersions = TLSSettings -> [Version]
tlsAllowedVersions TLSSettings
tlsSettings
            }
      }
  where
    loadCredentials :: IO Credential
loadCredentials =
      (HostName -> Credential)
-> (Credential -> Credential)
-> Either HostName Credential
-> Credential
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TLSError -> Credential
forall a e. Exception e => e -> a
throw (TLSError -> Credential)
-> (HostName -> TLSError) -> HostName -> Credential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> TLSError
TLS.Error_Certificate) Credential -> Credential
forall a. a -> a
id
        (Either HostName Credential -> Credential)
-> IO (Either HostName Credential) -> IO Credential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> HostName -> IO (Either HostName Credential)
TLS.credentialLoadX509 (TLSSettings -> HostName
certFile TLSSettings
tlsSettings) (TLSSettings -> HostName
keyFile TLSSettings
tlsSettings)

defaultExceptionHandler :: Maybe SessionID -> SomeException -> IO ()
defaultExceptionHandler :: Maybe SessionID -> SomeException -> IO ()
defaultExceptionHandler _ e :: SomeException
e = SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` [Handler ()]
handlers
  where
    handlers :: [Handler ()]
handlers = [(AsyncException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler AsyncException -> IO ()
ah, (IOException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler IOException -> IO ()
oh, (TLSException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler TLSException -> IO ()
tlsh, (TLSError -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler TLSError -> IO ()
th, (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SomeException -> IO ()
sh]
    ah :: AsyncException -> IO ()
    ah :: AsyncException -> IO ()
ah ThreadKilled = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ah x :: AsyncException
x = Handle -> AsyncException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr AsyncException
x
    oh :: IOException -> IO ()
    oh :: IOException -> IO ()
oh x :: IOException
x
      | IOErrorType
et IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished Bool -> Bool -> Bool
|| IOErrorType
et IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = Handle -> IOException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr IOException
x
      where
        et :: IOErrorType
et = IOException -> IOErrorType
ioeGetErrorType IOException
x
    tlsh :: TLS.TLSException -> IO ()
    tlsh :: TLSException -> IO ()
tlsh TLS.Terminated {} = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    tlsh TLS.HandshakeFailed {} = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    tlsh x :: TLSException
x = Handle -> TLSException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr TLSException
x
    th :: TLS.TLSError -> IO ()
    th :: TLSError -> IO ()
th TLS.Error_EOF = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    th (TLS.Error_Packet_Parsing _) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    th (TLS.Error_Packet _) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    th (TLS.Error_Protocol _) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    th x :: TLSError
x = Handle -> TLSError -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr TLSError
x
    sh :: SomeException -> IO ()
    sh :: SomeException -> IO ()
sh = Handle -> SomeException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr