Make the hook config file path include the instance host

Before this patch, if you ran more than 1 instance as the same OS user, they'd
use the same config file path and overwrite it and cause post hooks to have
errors due to wrong config being used.

src/Darcs/Local/Repository.hs

@@ -34,15 +34,18 @@ import qualified Data.ByteString as B
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 
-writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> IO ()
-writeDefaultsFile path cmd sharer repo = do
+writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> Text -> IO ()
+writeDefaultsFile path cmd authority sharer repo = do
     let file = path </> "_darcs" </> "prefs" </> "defaults"
-    TIO.writeFile file $ defaultsContent cmd sharer repo
+    TIO.writeFile file $ defaultsContent cmd authority sharer repo
     setFileMode file $ ownerReadMode .|. ownerWriteMode
     where
-    defaultsContent :: FilePath -> Text -> Text -> Text
-    defaultsContent hook sharer repo =
-        T.concat ["apply posthook ", T.pack hook, " ", sharer, " ", repo]
+    defaultsContent :: FilePath -> Text -> Text -> Text -> Text
+    defaultsContent hook authority sharer repo =
+        T.concat
+            [ "apply posthook "
+            , T.pack hook, " ", authority, " ", sharer, " ", repo
+            ]
 
 {-
 initialRepoTree :: FileName -> DirTree B.ByteString
@@ -75,18 +78,20 @@ createRepo
     -> FilePath
     -- ^ Path of Vervis hook program
     -> Text
+    -- ^ Instance HTTP authority
+    -> Text
     -- ^ Repo sharer textual ID
     -> Text
     -- ^ Repo textual ID
     -> IO ()
-createRepo parent name cmd sharer repo = do
+createRepo parent name cmd authority sharer repo = do
     let path = parent </> name
     createDirectory path
     let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path]
     (_, _, _, ph) <- createProcess settings
     ec <- waitForProcess ph
     case ec of
-        ExitSuccess   -> writeDefaultsFile path cmd sharer repo
+        ExitSuccess   -> writeDefaultsFile path cmd authority sharer repo
         ExitFailure n -> error $ "darcs init failed with exit code " ++ show n
 
 readPristineRoot :: FilePath -> IO (Maybe Int, Hash)

src/Data/Git/Local.hs

@@ -54,18 +54,21 @@ instance SpecToEventTime GitTime where
     specToEventTime = specToEventTime . gitTimeUTC
     specsToEventTimes = specsToEventTimes . fmap gitTimeUTC
 
-hookContent :: FilePath -> Text -> Text -> Text
-hookContent hook sharer repo =
-    T.concat ["#!/bin/sh\nexec ", T.pack hook, " ", sharer, " ", repo]
+hookContent :: FilePath -> Text -> Text -> Text -> Text
+hookContent hook authority sharer repo =
+    T.concat
+        [ "#!/bin/sh\nexec ", T.pack hook
+        , " ", authority, " ", sharer, " ", repo
+        ]
 
-writeHookFile :: FilePath -> FilePath -> Text -> Text -> IO ()
-writeHookFile path cmd sharer repo = do
+writeHookFile :: FilePath -> FilePath -> Text -> Text -> Text -> IO ()
+writeHookFile path cmd authority sharer repo = do
     let file = path </> "hooks" </> "post-receive"
-    TIO.writeFile file $ hookContent cmd sharer repo
+    TIO.writeFile file $ hookContent cmd authority sharer repo
     setFileMode file ownerModes
 
-initialRepoTree :: FilePath -> Text -> Text -> FileName -> DirTree Text
-initialRepoTree hook sharer repo dir =
+initialRepoTree :: FilePath -> Text -> Text -> Text -> FileName -> DirTree Text
+initialRepoTree hook authority sharer repo dir =
     Dir dir
         [ Dir "branches" []
         , File "config"
@@ -77,7 +80,7 @@ initialRepoTree hook sharer repo dir =
             "Unnamed repository; edit this file to name the repository."
         , File "HEAD" "ref: refs/heads/master"
         , Dir "hooks"
-            [ File "post-receive" $ hookContent hook sharer repo
+            [ File "post-receive" $ hookContent hook authority sharer repo
             ]
         , Dir "info"
             [ File "exclude" ""
@@ -105,12 +108,14 @@ createRepo
     -> FilePath
     -- ^ Path of Vervis hook program
     -> Text
+    -- ^ Instance HTTP authority
+    -> Text
     -- ^ Repo sharer textual ID
     -> Text
     -- ^ Repo textual ID
     -> IO ()
-createRepo path name cmd sharer repo = do
-    let tree = path :/ initialRepoTree cmd sharer repo name
+createRepo path name cmd authority sharer repo = do
+    let tree = path :/ initialRepoTree cmd authority sharer repo name
     result <- writeDirectoryWith TIO.writeFile tree
     let errs = failures $ dirTree result
     when (not . null $ errs) $

src/Vervis/Application.hs

@@ -61,13 +61,13 @@ import Yesod.Persist.Core
 import Yesod.Static
 
 import qualified Data.Text as T (unpack)
-import qualified Data.HashMap.Strict as M (empty)
 
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Yesod.Mail.Send (runMailer)
 
 import Control.Concurrent.ResultShare
 import Data.KeyFile
+import Network.FedURI
 import Yesod.MonadSite
 
 import Control.Concurrent.Local
@@ -187,8 +187,8 @@ makeFoundation appSettings = do
 
     -- Perform database migration using our application's logging settings.
     --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-    flip runWorker app $ runSiteDB $ do
     let hLocal = appInstanceHost appSettings
+    flip runWorker app $ runSiteDB $ do
         r <- migrateDB hLocal hashidsCtx
         case r of
             Left err -> do
@@ -202,7 +202,8 @@ makeFoundation appSettings = do
                 writePostReceiveHooks
                 writePostApplyHooks
 
-    writeHookConfig Config
+    let hostString = T.unpack $ renderAuthority hLocal
+    writeHookConfig hostString Config
         { configSecret     = hookSecretText appHookSecret
         , configPort       = fromIntegral $ appPort appSettings
         , configMaxCommits = 20

src/Vervis/Darcs.hs

@@ -63,6 +63,8 @@ import qualified Database.Esqueleto as E
 
 import qualified Development.Darcs.Internal.Patch.Parser as P
 
+import Network.FedURI
+import Yesod.ActivityPub
 import Yesod.MonadSite
 
 import Darcs.Local.Repository
@@ -334,6 +336,8 @@ writePostApplyHooks = do
         E.where_ $ r E.^. RepoVcs E.==. E.val VCSDarcs
         return (s E.^. SharerIdent, r E.^. RepoIdent)
     hook <- asksSite $ appPostApplyHookFile . appSettings
+    authority <- asksSite $ renderAuthority . siteInstanceHost
     for_ repos $ \ (E.Value shr, E.Value rp) -> do
         path <- askRepoDir shr rp
-        liftIO $ writeDefaultsFile path hook (shr2text shr) (rp2text rp)
+        liftIO $
+            writeDefaultsFile path hook authority (shr2text shr) (rp2text rp)

src/Vervis/Git.hs

@@ -67,6 +67,8 @@ import qualified Data.Text.Encoding.Error as TE (lenientDecode)
 import qualified Data.Vector as V (fromList)
 import qualified Database.Esqueleto as E
 
+import Network.FedURI
+import Yesod.ActivityPub
 import Yesod.MonadSite
 
 import Data.ByteString.Char8.Local (takeLine)
@@ -339,6 +341,7 @@ writePostReceiveHooks = do
         E.where_ $ r E.^. RepoVcs E.==. E.val VCSGit
         return (s E.^. SharerIdent, r E.^. RepoIdent)
     hook <- asksSite $ appPostReceiveHookFile . appSettings
+    authority <- asksSite $ renderAuthority . siteInstanceHost
     for_ repos $ \ (E.Value shr, E.Value rp) -> do
         path <- askRepoDir shr rp
-        liftIO $ writeHookFile path hook (shr2text shr) (rp2text rp)
+        liftIO $ writeHookFile path hook authority (shr2text shr) (rp2text rp)

src/Vervis/Handler/Repo.hs

@@ -86,6 +86,7 @@ import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
 import qualified Database.Esqueleto as E
 
 import Data.MediaType
+import Network.FedURI
 import Web.ActivityPub hiding (Repo)
 import Yesod.ActivityPub
 import Yesod.FedURI
@@ -145,6 +146,7 @@ postReposR user = do
             liftIO $ createDirectoryIfMissing True parent
             let repoName =
                     unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
+            host <- asksSite siteInstanceHost
             case nrpVcs nrp of
                 VCSDarcs -> do
                     hook <- getsYesod $ appPostApplyHookFile . appSettings
@@ -153,6 +155,7 @@ postReposR user = do
                             parent
                             repoName
                             hook
+                            (renderAuthority host)
                             (shr2text user)
                             (rp2text $ nrpIdent nrp)
                 VCSGit -> do
@@ -162,6 +165,7 @@ postReposR user = do
                             parent
                             repoName
                             hook
+                            (renderAuthority host)
                             (shr2text user)
                             (rp2text $ nrpIdent nrp)
             pid <- requireAuthId

src/Vervis/Hook.hs

@@ -149,15 +149,15 @@ instance FromJSON Push
 
 instance ToJSON Push
 
-getVervisCachePath :: IO FilePath
-getVervisCachePath = getXdgDirectory XdgCache "vervis"
+getVervisCachePath :: String -> IO FilePath
+getVervisCachePath host = (</> host) <$> getXdgDirectory XdgCache "vervis"
 
 hookConfigFileName :: String
 hookConfigFileName = "hook-config.json"
 
-writeHookConfig :: Config -> IO ()
-writeHookConfig config = do
-    cachePath <- getVervisCachePath
+writeHookConfig :: String -> Config -> IO ()
+writeHookConfig host config = do
+    cachePath <- getVervisCachePath host
     createDirectoryIfMissing True cachePath
     encodeFile (cachePath </> hookConfigFileName) config
 
@@ -306,17 +306,17 @@ reportNewCommits config sharer repo = do
 
 postReceive :: IO ()
 postReceive = do
-    cachePath <- getVervisCachePath
+    (host, sharer, repo) <- do
+        args <- getArgs
+        case args of
+            [h, s, r] -> return (h, T.pack s, T.pack r)
+            _ -> die "Unexpected number of arguments"
+    cachePath <- getVervisCachePath host
     config <- do
         mc <- decodeFileStrict' $ cachePath </> hookConfigFileName
         case mc of
             Nothing -> die "Parsing hook config failed"
             Just c -> return c
-    args <- getArgs
-    (sharer, repo) <-
-        case args of
-            [s, r] -> return (T.pack s, T.pack r)
-            _ -> die "Unexpected number of arguments"
     reportNewCommits config sharer repo
 
 reportNewPatches :: Config -> Text -> Text -> IO ()
@@ -416,15 +416,15 @@ reportNewPatches config sharer repo = do
 
 postApply :: IO ()
 postApply = do
-    cachePath <- getVervisCachePath
+    (host, sharer, repo) <- do
+        args <- getArgs
+        case args of
+            [h, s, r] -> return (h, T.pack s, T.pack r)
+            _ -> die "Unexpected number of arguments"
+    cachePath <- getVervisCachePath host
     config <- do
         mc <- decodeFileStrict' $ cachePath </> hookConfigFileName
         case mc of
             Nothing -> die "Parsing hook config failed"
             Just c -> return c
-    args <- getArgs
-    (sharer, repo) <-
-        case args of
-            [s, r] -> return (T.pack s, T.pack r)
-            _ -> die "Unexpected number of arguments"
     reportNewPatches config sharer repo