Lisää komento tietokantaversioiden arkistointiin

src/Main.hs

@@ -4,11 +4,11 @@
 
 module Main where
 
-import Control.Concurrent (forkIO)
+import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (onException)
 import Control.Exception (throwIO)
-import Control.Monad (void)
+import Control.Monad (void, forever)
-import Data.Acid (openLocalState)
+import Data.Acid (AcidState(..), openLocalState, createCheckpoint, createArchive)
 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 -> 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
     _ <- forkIO $ acidServerSockAddr skipAuthenticationCheck socket acid
     queueMessages acid
@@ -43,7 +43,8 @@ serverMain socket mail repoPath sendmailPath port = do
     updateMessages acid repoPath
     _ <- forkIO $ manageQueueingMessages acid
     _ <- 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 socket mail sendmailPath = do
@@ -58,8 +59,16 @@ 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 } | Receive | Print deriving Show
+data RunMode = Server { repoPath :: FilePath, portNumber :: Int, checkpointDelay :: Int } | Receive | Print | Archive deriving Show
 
 config :: Maybe Mailbox -> Parser Config
 config mail = Config
@@ -68,12 +77,14 @@ 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 "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")
     <*> 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
@@ -90,4 +101,5 @@ main = do
     case args of
       Config {runMode = Receive, ..} -> clientMain (SockAddrUnix socketPath) mail sendmailPath
       Config {runMode = Print, ..} -> printStateMain (SockAddrUnix socketPath)
-      Config {runMode = Server {..}, ..} -> serverMain (SockAddrUnix socketPath) mail repoPath sendmailPath portNumber
+      Config {runMode = Archive, ..} -> archiveMain (SockAddrUnix socketPath)
+      Config {runMode = Server {..}, ..} -> serverMain (SockAddrUnix socketPath) mail repoPath sendmailPath checkpointDelay portNumber