From 69229fb80e802c3158612e5a3c439b158b0823cc Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 4 May 2016 11:44:06 +0000 Subject: [PATCH] Enable Darcs repo creation using the executable Darcs does export most of its module tree, but there's a problem: Darcs relies on the current directory. It changes the current directory of the process to the repo, and then proceeds using paths relative to the repo dir. This is bad for my case here. If some other thread uses a relative path (e.g. currently any repo path is relative by default) in parallel, it will fail. For now, the quick path around this problem is to use the `darcs` program. --- src/Darcs/Local.hs | 65 ++++++++++++++++++++++++++++++++++++++ src/Vervis/Handler/Repo.hs | 32 ++++++++++--------- vervis.cabal | 3 +- 3 files changed, 84 insertions(+), 16 deletions(-) create mode 100644 src/Darcs/Local.hs diff --git a/src/Darcs/Local.hs b/src/Darcs/Local.hs new file mode 100644 index 0000000..13a9d4f --- /dev/null +++ b/src/Darcs/Local.hs @@ -0,0 +1,65 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Darcs.Local + ( initRepo + ) +where + +import Prelude + +import System.Directory (createDirectory) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.Process (createProcess, proc, waitForProcess) + +{- +initialRepoTree :: FileName -> DirTree B.ByteString +initialRepoTree repo = + Dir repo + [ Dir "_darcs" + --[ File "format" + -- "hashed|no-working-dir\n\ + -- \darcs-2" + --, File "hashed_inventory" "" + --, File "index" ??? + , Dir "inventories" [] + , Dir "patches" [] + , Dir "prefs" [] + -- [ File "binaries" "" + -- , File "boring" "" + -- , File "motd" "" + -- ] + , Dir "pristine.hashed" [] + ] + ] +-} + +-- | initialize a new bare repository at a specific location. +initRepo + :: FilePath + -- ^ Parent directory which already exists + -> String + -- ^ Name of new repo, i.e. new directory to create under the parent + -> IO () +initRepo parent name = do + let path = parent name + createDirectory path + let settings = proc "darcs" ["init", "--no-working-dir", path] + (_, _, _, ph) <- createProcess settings + ec <- waitForProcess ph + case ec of + ExitSuccess -> return () + ExitFailure n -> error $ "darcs init failed with exit code " ++ show n diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 5dd5107..8886a6e 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -44,7 +44,7 @@ import Data.Git.Graph import Data.Git.Harder import Data.Git.Named (RefName (..)) import Data.Git.Ref (toHex) -import Data.Git.Repository hiding (initRepo) +import Data.Git.Repository import Data.Git.Storage (withRepo, getObject_) import Data.Git.Storage.Object (Object (..)) import Data.Git.Types (Blob (..), Commit (..), Person (..), entName) @@ -64,7 +64,6 @@ import qualified Data.Set as S (member) import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import Data.ByteString.Char8.Local (takeLine) -import Data.Git.Local (initRepo) import Text.FilePath.Local (breakExt) import Vervis.Form.Repo import Vervis.Foundation @@ -78,6 +77,9 @@ import Vervis.Render import Vervis.Settings import Vervis.Style +import qualified Darcs.Local as D (initRepo) +import qualified Data.Git.Local as G (initRepo) + getReposR :: Text -> Handler Html getReposR user = do repos <- runDB $ select $ from $ \ (sharer, repo) -> do @@ -97,22 +99,22 @@ postReposR user = do let sid = personIdent person ((result, widget), enctype) <- runFormPost $ newRepoForm sid case result of - FormSuccess repo -> - case repoVcs repo of - VCSDarcs -> error "Darcs not supported yet" - VCSGit -> do - parent <- askSharerDir user - liftIO $ do - createDirectoryIfMissing True parent - initRepo parent (unpack $ repoIdent repo) - runDB $ insert_ repo - setMessage "Repo added." - redirect $ ReposR user + FormSuccess repo -> do + parent <- askSharerDir user + liftIO $ do + createDirectoryIfMissing True parent + let repoName = unpack $ repoIdent repo + case repoVcs repo of + VCSDarcs -> D.initRepo parent repoName + VCSGit -> G.initRepo parent repoName + runDB $ insert_ repo + setMessage "Repo added." + redirect $ ReposR user FormMissing -> do setMessage "Field(s) missing" defaultLayout $(widgetFile "repo/repo-new") - FormFailure l -> do - setMessage $ toHtml $ intercalate "; " l + FormFailure _l -> do + setMessage "Repo creation failed, see errors below" defaultLayout $(widgetFile "repo/repo-new") getRepoNewR :: Text -> Handler Html diff --git a/vervis.cabal b/vervis.cabal index fb4fafc..dae045e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -34,7 +34,8 @@ flag library-only default: False library - exposed-modules: Data.Binary.Local + exposed-modules: Darcs.Local + Data.Binary.Local Data.ByteString.Char8.Local Data.ByteString.Local Data.Char.Local