Alusta Git-tietovaranto automaattisesti

src/Main.hs

@@ -11,6 +11,7 @@ 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)
 import Data.IMF (Mailbox(..), parse, mailbox)
 import Data.MIME.Charset (defaultCharsets)
 import Data.Text.Encoding (encodeUtf8)
@@ -33,15 +34,16 @@ 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 -> GitOrigin -> FilePath -> Int -> Int -> IO ()
+serverMain socket mail repoPath origin sendmailPath checkpointDelay port = do
+    initialize $ gitFileStore repoPath
     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
-    updateMessages acid repoPath
+        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
@@ -69,7 +71,7 @@ archiveMain socket = do
     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, origin :: GitOrigin, portNumber :: Int, checkpointDelay :: Int } | Receive | Print | Archive deriving Show
 
 config :: Maybe Mailbox -> Parser Config
 config mail = Config
@@ -84,6 +86,9 @@ config mail = Config
 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.")
 
@@ -111,4 +116,4 @@ main = do
       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 origin sendmailPath checkpointDelay portNumber

src/TiedoteMD/Git.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module TiedoteMD.Git where
 
@@ -9,6 +10,7 @@ import Control.Exception (throwIO)
 import Control.Monad (liftM2, unless)
 import Data.ByteString.Lazy.UTF8 (toString)
 import Data.FileStore.Types (FileStoreError(..))
+import Data.List (singleton)
 import System.Directory (getTemporaryDirectory, removeFile)
 import System.Environment (getEnvironment)
 import System.Exit (ExitCode(..))
@@ -19,9 +21,11 @@ import qualified Control.Exception as E
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as B
 
-gitPull :: FilePath -> IO ()
-gitPull repo = do
-    (exit, err, _) <- runGitCommand repo "fetch" []
+import TiedoteMD.Types (GitOrigin(..))
+
+gitPull :: FilePath -> GitOrigin -> IO ()
+gitPull repo GitOrigin {url, branch} = do
+    (exit, err, _) <- runGitCommand repo "fetch" (url : (maybe [] singleton branch))
     unless (exit == ExitSuccess) $ throwIO $ UnknownError $ "git-fetch failed: " <> err
     (exit', err', _) <- runGitCommand repo "reset" ["--hard","FETCH_HEAD"]
     unless (exit' == ExitSuccess) $ throwIO $ UnknownError $ "git-reset failed: " <> err'

src/TiedoteMD/Read.hs

@@ -52,9 +52,9 @@ import TiedoteMD.State
 import TiedoteMD.Templates
 import TiedoteMD.Types
 
-updateMessages :: AcidState State -> FilePath -> IO ()
-updateMessages acid repoPath =
-    gitPull repoPath >> readMessageFiles (gitFileStore repoPath) >>= update acid . UpdateState
+updateMessages :: AcidState State -> FilePath -> GitOrigin -> IO ()
+updateMessages acid repoPath origin =
+    gitPull repoPath origin >> readMessageFiles (gitFileStore repoPath) >>= update acid . UpdateState
 
 readMessageFiles :: FileStore -> IO [Message]
 readMessageFiles store = do

src/TiedoteMD/Types.hs

@@ -7,6 +7,7 @@
 module TiedoteMD.Types
     ( Email(..)
     , Error(..)
+    , GitOrigin(..)
     , MailID
     , MediaPart(..)
     , Message(..)
@@ -141,6 +142,9 @@ messageIDToMailID = MailID . renderMessageID
 renderMailID :: MailID -> ByteString
 renderMailID = renderMessageID . mailIDToMessageID
 
+data GitOrigin = GitOrigin { url :: String, branch :: Maybe String }
+    deriving (Show)
+
 data Error = PandocError PandocError
            | NoMeta Text
            | InvalidTime Text