120 lines
6.4 KiB
Haskell
120 lines
6.4 KiB
Haskell
{-# 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
|