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.
This commit is contained in:
parent
65d730393a
commit
a700dc4208
7 changed files with 63 additions and 41 deletions
|
@ -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)
|
||||
|
|
|
@ -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) $
|
||||
|
|
|
@ -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
|
||||
let hLocal = appInstanceHost appSettings
|
||||
flip runWorker app $ runSiteDB $ do
|
||||
let hLocal = appInstanceHost appSettings
|
||||
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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue