{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import Control.Applicative (optional)
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (onException, catch)
import Control.Exception (throwIO)
import Control.Monad (void, forever)
import Data.Acid (AcidState(..), openLocalState, createCheckpoint, createArchive)
import Data.Acid.Remote (skipAuthenticationCheck, acidServerSockAddr, openRemoteStateSockAddr, skipAuthenticationPerform)
import Data.FileStore (gitFileStore, initialize, FileStoreError(RepositoryExists))
import Data.IMF (Mailbox(..), parse, mailbox)
import Data.MIME.Charset (defaultCharsets)
import Data.Text.Encoding (encodeUtf8)
import Network.HostName (getHostName)
import Network.Socket (SockAddr(SockAddrUnix))
import Options.Applicative (Parser, ReadM, auto, eitherReader, execParser, strOption, option, hsubparser, command, info, progDesc, long, short, metavar, value, showDefault, help, header, fullDesc, helper, (<**>))
import System.Directory (findExecutable)
import System.Exit (exitWith)
import System.Exit.Codes (codeTempFail)
import System.Posix.User (getRealUserID, userName, getUserEntryForID)
import Web.Scotty (scotty, post, liftAndCatchIO, defaultHandler)

import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as LT

import TiedoteMD.Read (updateMessages)
import TiedoteMD.Review
import TiedoteMD.Send
import TiedoteMD.State
import TiedoteMD.Types
import TiedoteMD.Debug

serverMain :: SockAddr -> Mailbox -> FilePath -> GitOrigin -> FilePath -> Int -> Int -> IO ()
serverMain socket mail repoPath origin sendmailPath checkpointDelay port = do
    initialize (gitFileStore repoPath) `catch` \RepositoryExists -> pure ()
    acid <- openLocalState $ emptyState
    _ <- forkIO $ acidServerSockAddr skipAuthenticationCheck socket acid
    queueMessages acid
    _ <- forkIO $ scotty port $ do
        defaultHandler $ liftAndCatchIO . LT.putStrLn -- Don't return exceptions to clients
        post "/" $ liftAndCatchIO $ void $ forkIO $ updateMessages acid repoPath origin
    updateMessages acid repoPath origin
    _ <- forkIO $ manageQueueingMessages acid
    _ <- forkIO $ managePreviews acid mail sendmailPath
    _ <- forkIO $ manageQueue acid mail sendmailPath
    forever $ threadDelay (1000 * 1000 * 60 * checkpointDelay) >> createCheckpoint acid

clientMain :: SockAddr -> Mailbox -> FilePath -> IO ()
clientMain socket mail sendmailPath = do
    acid <- openRemoteStateSockAddr skipAuthenticationPerform socket
        `onException` exitWith codeTempFail
    manageIncomingEmail acid mail sendmailPath

printStateMain :: SockAddr -> IO ()
printStateMain socket = do
    acid <- openRemoteStateSockAddr skipAuthenticationPerform socket
        `onException` openLocalState emptyState
        `onException` exitWith codeTempFail
    printState acid

archiveMain :: SockAddr -> IO ()
archiveMain socket = do
    acid <- openRemoteStateSockAddr skipAuthenticationPerform socket
        `onException` openLocalState emptyState
        `onException` exitWith codeTempFail
    createCheckpoint (acid :: AcidState State)
    createArchive acid

data Config = Config { socketPath :: FilePath, mail :: Mailbox, sendmailCommand :: String, runMode :: RunMode } deriving Show
data RunMode = Server { repoPath :: FilePath, origin :: GitOrigin, portNumber :: Int, checkpointDelay :: Int } | Receive | Print | Archive deriving Show

config :: Maybe Mailbox -> Parser Config
config mail = Config
    <$> strOption (long "socket" <> short 's' <> metavar "FILE" <> value "/run/tiedote.md/acid.socket" <> showDefault <> help "Path for database socket")
    <*> mailboxOption mail
    <*> strOption (long "sendmail" <> short 'm' <> metavar "FILE" <> value "sendmail" <> help "Sendmail command")
    <*> hsubparser (command "server" (info serverCommand (progDesc "Run the server"))
        <> command "receive" (info (pure Receive) (progDesc "Receive an email"))
        <> command "state" (info (pure Print) (progDesc "Print the server's current state"))
        <> command "archive" (info (pure Archive) (progDesc "Archive old versions of the database")))

serverCommand :: Parser RunMode
serverCommand = Server
    <$> strOption (long "repository" <> short 'r' <> metavar "DIRECTORY" <> value "/var/lib/tiedote.md/git-repo" <> showDefault <> help "Path to git repository")
    <*> (GitOrigin
        <$> strOption (long "remote-url" <> short 'u' <> metavar "URL" <> help "Url to fetch updated messages from")
        <*> optional (strOption (long "remote-branch" <> short 'b' <> metavar "NAME" <> help "Branch to fetch updated messages from")))
    <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> showDefault <> help "TCP port number to listen on for webhook notifications")
    <*> option auto (long "checkpoint-delay" <> metavar "MINUTES" <> value (60 * 24 * 7) <> help "Number of minutes to wait between creating snapshots.")

mailboxOption :: Maybe Mailbox -> Parser Mailbox
mailboxOption mail = Mailbox
    <$> optional (strOption (long "sender-name" <> metavar "NAME" <> help "Name to display as the mail's sender"))
    -- XXX Data.IMF (as of purebred-email-0.6.0.2, 2023-10) doesn't expose the
    -- addrSpec parser so we have to use this workaround
    <*> ((\(Mailbox _ addrSpec) -> addrSpec) <$>
        option readMailbox (long "address" <> short 'a' <> metavar "EMAIL" <> maybe mempty value mail <> help "Email address to send and receive mail"))

readMailbox :: ReadM Mailbox
readMailbox = eitherReader $ parse (mailbox defaultCharsets) . encodeUtf8 . T.pack

main :: IO ()
main = do
    hostname <- getHostName
    username <- getRealUserID >>= fmap userName . getUserEntryForID
    let defaultMailbox = either (const Nothing) Just $ parse (mailbox defaultCharsets) $
            encodeUtf8 $ T.pack $ username <> "@" <> hostname
    args <- execParser $ info (config defaultMailbox <**> helper) (fullDesc <> header "TiedoteMD mass mailing system")
    sendmailPath <- maybe (throwIO $ FileNotFoundError $ sendmailCommand args) pure =<<
        findExecutable (sendmailCommand args)
    case args of
      Config {runMode = Receive, ..} -> clientMain (SockAddrUnix socketPath) mail sendmailPath
      Config {runMode = Print, ..} -> printStateMain (SockAddrUnix socketPath)
      Config {runMode = Archive, ..} -> archiveMain (SockAddrUnix socketPath)
      Config {runMode = Server {..}, ..} -> serverMain (SockAddrUnix socketPath) mail repoPath origin sendmailPath checkpointDelay portNumber