OMS/tiedote.md
3
0
Fork 0
Code Issues 14 Pull Requests Projects Releases Wiki Activity

Compare commits

base: OMS:4b902e9e5a1242b2844a3449a21c85f13b8860bd
Branches Tags
OMS:main
OMS:keyring
..
compare: OMS:8f1040efc6df12d0531406c0827940b419f43d6b
Branches Tags
OMS:main
OMS:keyring

No commits in common. "4b902e9e5a1242b2844a3449a21c85f13b8860bd" and "8f1040efc6df12d0531406c0827940b419f43d6b" have entirely different histories.
4b902e9e5a ... 8f1040efc6

1 changed files with 9 additions and 21 deletions
Show Stats Expand all files Collapse all files

30
src/Main.hs
View File

@ -4,11 +4,11 @@
module Main where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent (forkIO)
import Control.Exception (onException)
import Control.Exception (throwIO)
import Control.Monad (void, forever)
import Data.Acid (AcidState(..), openLocalState, createCheckpoint, createArchive)
import Control.Monad (void)
import Data.Acid (openLocalState)
import Data.Acid.Remote (skipAuthenticationCheck, acidServerSockAddr, openRemoteStateSockAddr, skipAuthenticationPerform)
import Data.IMF (Mailbox, parse, mailbox)
import Data.MIME.Charset (defaultCharsets)
@ -32,8 +32,8 @@ import TiedoteMD.State
import TiedoteMD.Types
import TiedoteMD.Debug
serverMain :: SockAddr -> Mailbox -> FilePath -> FilePath -> Int -> Int -> IO ()
serverMain socket mail repoPath sendmailPath checkpointDelay port = do
serverMain :: SockAddr -> Mailbox -> FilePath -> FilePath -> Int -> IO ()
serverMain socket mail repoPath sendmailPath port = do
acid <- openLocalState $ emptyState
_ <- forkIO $ acidServerSockAddr skipAuthenticationCheck socket acid
queueMessages acid
@ -43,8 +43,7 @@ serverMain socket mail repoPath sendmailPath checkpointDelay port = do
updateMessages acid repoPath
_ <- forkIO $ manageQueueingMessages acid
_ <- forkIO $ managePreviews acid mail sendmailPath
_ <- forkIO $ manageQueue acid mail sendmailPath
forever $ threadDelay (1000 * 1000 * 60 * checkpointDelay) >> createCheckpoint acid
manageQueue acid mail sendmailPath
clientMain :: SockAddr -> Mailbox -> FilePath -> IO ()
clientMain socket mail sendmailPath = do
@ -59,16 +58,8 @@ printStateMain socket = do
`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, portNumber :: Int, checkpointDelay :: Int } | Receive | Print | Archive deriving Show
data RunMode = Server { repoPath :: FilePath, portNumber :: Int } | Receive | Print deriving Show
config :: Maybe Mailbox -> Parser Config
config mail = Config
@ -77,14 +68,12 @@ config mail = Config
<*> 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")))
<> command "state" (info (pure Print) (progDesc "Print the server's current state")))
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")
<*> 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.")
readMailbox :: ReadM Mailbox
readMailbox = eitherReader $ parse (mailbox defaultCharsets) . encodeUtf8 . T.pack
@ -101,5 +90,4 @@ main = do
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 sendmailPath checkpointDelay portNumber
Config {runMode = Server {..}, ..} -> serverMain (SockAddrUnix socketPath) mail repoPath sendmailPath portNumber