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

Luo tallennuspisteitä tietokannalle säännöllisesti

Browse Source
This commit is contained in:
Saku Laesvuori 2023-12-22 22:01:14 +02:00
parent 8f1040efc6
commit f3a58b0bbb
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
1 changed files with 10 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Main.hs
View File

@ -4,11 +4,11 @@
module Main where module Main where
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (onException) import Control.Exception (onException)
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad (void) import Control.Monad (void, forever)
import Data.Acid (openLocalState) import Data.Acid (openLocalState, createCheckpoint)
import Data.Acid.Remote (skipAuthenticationCheck, acidServerSockAddr, openRemoteStateSockAddr, skipAuthenticationPerform) import Data.Acid.Remote (skipAuthenticationCheck, acidServerSockAddr, openRemoteStateSockAddr, skipAuthenticationPerform)
import Data.IMF (Mailbox, parse, mailbox) import Data.IMF (Mailbox, parse, mailbox)
import Data.MIME.Charset (defaultCharsets) import Data.MIME.Charset (defaultCharsets)
@ -32,8 +32,8 @@ import TiedoteMD.State
import TiedoteMD.Types import TiedoteMD.Types
import TiedoteMD.Debug import TiedoteMD.Debug
serverMain :: SockAddr -> Mailbox -> FilePath -> FilePath -> Int -> IO () serverMain :: SockAddr -> Mailbox -> FilePath -> FilePath -> Int -> Int -> IO ()
serverMain socket mail repoPath sendmailPath port = do serverMain socket mail repoPath sendmailPath checkpointDelay port = do
acid <- openLocalState $ emptyState acid <- openLocalState $ emptyState
_ <- forkIO $ acidServerSockAddr skipAuthenticationCheck socket acid _ <- forkIO $ acidServerSockAddr skipAuthenticationCheck socket acid
queueMessages acid queueMessages acid
@ -43,7 +43,8 @@ serverMain socket mail repoPath sendmailPath port = do
updateMessages acid repoPath updateMessages acid repoPath
_ <- forkIO $ manageQueueingMessages acid _ <- forkIO $ manageQueueingMessages acid
_ <- forkIO $ managePreviews acid mail sendmailPath _ <- forkIO $ managePreviews acid mail sendmailPath
manageQueue acid mail sendmailPath _ <- forkIO $ manageQueue acid mail sendmailPath
forever $ threadDelay (1000 * 1000 * 60 * checkpointDelay) >> createCheckpoint acid
clientMain :: SockAddr -> Mailbox -> FilePath -> IO () clientMain :: SockAddr -> Mailbox -> FilePath -> IO ()
clientMain socket mail sendmailPath = do clientMain socket mail sendmailPath = do
@ -59,7 +60,7 @@ printStateMain socket = do
printState acid printState acid
data Config = Config { socketPath :: FilePath, mail :: Mailbox, sendmailCommand :: String, runMode :: RunMode } deriving Show data Config = Config { socketPath :: FilePath, mail :: Mailbox, sendmailCommand :: String, runMode :: RunMode } deriving Show
data RunMode = Server { repoPath :: FilePath, portNumber :: Int } | Receive | Print deriving Show data RunMode = Server { repoPath :: FilePath, portNumber :: Int, checkpointDelay :: Int } | Receive | Print deriving Show
config :: Maybe Mailbox -> Parser Config config :: Maybe Mailbox -> Parser Config
config mail = Config config mail = Config
@ -74,6 +75,7 @@ serverCommand :: Parser RunMode
serverCommand = Server serverCommand = Server
<$> strOption (long "repository" <> short 'r' <> metavar "DIRECTORY" <> value "/var/lib/tiedote.md/git-repo" <> showDefault <> help "Path to git repository") <$> 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 "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 :: ReadM Mailbox
readMailbox = eitherReader $ parse (mailbox defaultCharsets) . encodeUtf8 . T.pack readMailbox = eitherReader $ parse (mailbox defaultCharsets) . encodeUtf8 . T.pack
@ -90,4 +92,4 @@ main = do
case args of case args of
Config {runMode = Receive, ..} -> clientMain (SockAddrUnix socketPath) mail sendmailPath Config {runMode = Receive, ..} -> clientMain (SockAddrUnix socketPath) mail sendmailPath
Config {runMode = Print, ..} -> printStateMain (SockAddrUnix socketPath) Config {runMode = Print, ..} -> printStateMain (SockAddrUnix socketPath)
Config {runMode = Server {..}, ..} -> serverMain (SockAddrUnix socketPath) mail repoPath sendmailPath portNumber Config {runMode = Server {..}, ..} -> serverMain (SockAddrUnix socketPath) mail repoPath sendmailPath checkpointDelay portNumber