Lisää Guix-järjestelmäpalvelu

Valitsin --force vaikuttaa git fetch -komennon toimintaan vain kun
ylikirjoitetaan paikallisia kehityshaaroja, mitä gitPull komento ei tee.

.guix/modules/tiedote-md-service.scm

@@ -0,0 +1,112 @@
+(define-module (tiedote-md-service)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services base)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu services)
+  #:use-module (guix records)
+  #:use-module (tiedote-md-package)
+  #:use-module (gnu packages bash)
+  #:export (tiedote.md-configuration
+            tiedote.md-service-type))
+
+(define-maybe string)
+
+(define-configuration/no-serialization tiedote.md-configuration
+  (email-address
+    (string)
+    "Email address to send messages as. Mail to this address must be routed to
+the tiedote.md user on this system.")
+  (sender-name
+    (string)
+    "Name to send messages as.")
+  (remote-url
+    (string)
+    "URL of the Git repository to mirror.")
+  (remote-branch
+    maybe-string
+    "Git branch to read messages from.")
+  (sendmail-path
+    (string "/run/privileged/bin/sendmail")
+    "Path to a sendmail compatible mailing executable.")
+  (port
+    (integer 3000)
+    "Port to listen on for webhook notifications.")
+  (socket-path
+    (string "/run/tiedote.md/acid.sock")
+    "Socket on which tiedote.md should listen on.")
+  (state-directory
+    (string "/var/lib/tiedote.md")
+    "Directory for persistent storage."))
+
+(define (tiedote.md-accounts config)
+  (match-record config <tiedote.md-configuration>
+    (state-directory)
+    (list (user-group
+            (name "tiedote.md")
+            (system? #t))
+          (user-account
+            (name "tiedote.md")
+            (system? #t)
+            (group "tiedote.md")
+            (comment "Tiedote.md service user")
+            (home-directory state-directory)
+            (shell (file-append bash-minimal "/bin/bash"))))))
+
+(define (tiedote.md-shepherd-service config)
+  (match-record config <tiedote.md-configuration>
+    (state-directory socket-path email-address sender-name port sendmail-path
+     remote-branch remote-url)
+    (list (shepherd-service
+            (documentation "A simple mass email system")
+            (requirement '(networking user-processes))
+            (provision 'tiedote.md)
+            (start #~(let* ((user (getpw "tiedote.md"))
+                            (uid (passwd:uid user))
+                            (gid (passwd:gid user))
+                            (socket-directory (dirname #$socket-path))
+                            (repo-path (string-append #$state-directory "/git-repo")))
+                       (begin
+                         (mkdir-p socket-directory)
+                         (chown socket-directory uid gid)
+                         (make-forkexec-constructor
+                          `(,#$(file-append tiedote.md "/bin/tiedote.md")
+                            "--address" ,#$email-address
+                            "--sender-name" ,#$sender-name
+                            "--sendmail" ,#$sendmail-path
+                            "--socket" ,#$socket-path
+                            "--repository" ,repo-path
+                            "--port" ,#$(number->string port)
+                            "--remote-url" ,#$remote-url
+                            ,@(if #$(maybe-value-set? remote-branch)
+                                (list "--remote-branch" #$remote-branch)
+                                '())
+                            "server")
+                          #:user "tiedote.md"
+                          #:group "tiedote.md"
+                          #:directory #$state-directory))))
+            (stop #~(make-kill-destructor))))))
+
+(define (tiedote.md-activation config)
+  (match-record config <tiedote.md-configuration>
+    (state-directory)
+    (let* ((receive-exec (list (file-append tiedote.md "/bin/tiedote.md") ; file to exec
+                               (file-append tiedote.md "/bin/tiedote.md") ; arg $0
+                               "--address" email-address
+                               "--sender-name" sender-name
+                               "--sendmail" sendmail-path
+                               "--socket" socket-path))
+           (receive-script (program-file "tiedote.md-receive"
+                                         #~(apply execl #$receive-exec)))
+           (forward-file (mixed-text-file ".forward" "|" receive-script)))
+      #~(symlink #$forward-file
+                 (string-append #$state-directory "/.forward")))))
+
+(define tiedote.md-service-type
+  (service-type
+    (name 'tiedote.md)
+    (extensions
+      (list (service-extension account-service-type tiedote.md-accounts)
+            (service-extension activation-service-type tiedote.md-activation)
+            (service-extension shepherd-root-service-type tiedote.md-shepherd-service)))
+    (description "A simple mass email system")))

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" ["--force"]
+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