diff --git a/src/Main.hs b/src/Main.hs index 42445cc..61f0968 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/TiedoteMD/Git.hs b/src/TiedoteMD/Git.hs index f4231d3..897a3e6 100644 --- a/src/TiedoteMD/Git.hs +++ b/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' diff --git a/src/TiedoteMD/Read.hs b/src/TiedoteMD/Read.hs index d54ddb5..a3e92f3 100644 --- a/src/TiedoteMD/Read.hs +++ b/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 diff --git a/src/TiedoteMD/Types.hs b/src/TiedoteMD/Types.hs index 5682dab..1230606 100644 --- a/src/TiedoteMD/Types.hs +++ b/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