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.
This commit is contained in:
parent
8448355f98
commit
69229fb80e
3 changed files with 84 additions and 16 deletions
65
src/Darcs/Local.hs
Normal file
65
src/Darcs/Local.hs
Normal file
|
@ -0,0 +1,65 @@
|
||||||
|
{- This file is part of Vervis.
|
||||||
|
-
|
||||||
|
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
|
-
|
||||||
|
- ♡ 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
|
||||||
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
-}
|
||||||
|
|
||||||
|
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
|
|
@ -44,7 +44,7 @@ import Data.Git.Graph
|
||||||
import Data.Git.Harder
|
import Data.Git.Harder
|
||||||
import Data.Git.Named (RefName (..))
|
import Data.Git.Named (RefName (..))
|
||||||
import Data.Git.Ref (toHex)
|
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 (withRepo, getObject_)
|
||||||
import Data.Git.Storage.Object (Object (..))
|
import Data.Git.Storage.Object (Object (..))
|
||||||
import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
|
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 qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
||||||
|
|
||||||
import Data.ByteString.Char8.Local (takeLine)
|
import Data.ByteString.Char8.Local (takeLine)
|
||||||
import Data.Git.Local (initRepo)
|
|
||||||
import Text.FilePath.Local (breakExt)
|
import Text.FilePath.Local (breakExt)
|
||||||
import Vervis.Form.Repo
|
import Vervis.Form.Repo
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
@ -78,6 +77,9 @@ import Vervis.Render
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
import Vervis.Style
|
import Vervis.Style
|
||||||
|
|
||||||
|
import qualified Darcs.Local as D (initRepo)
|
||||||
|
import qualified Data.Git.Local as G (initRepo)
|
||||||
|
|
||||||
getReposR :: Text -> Handler Html
|
getReposR :: Text -> Handler Html
|
||||||
getReposR user = do
|
getReposR user = do
|
||||||
repos <- runDB $ select $ from $ \ (sharer, repo) -> do
|
repos <- runDB $ select $ from $ \ (sharer, repo) -> do
|
||||||
|
@ -97,22 +99,22 @@ postReposR user = do
|
||||||
let sid = personIdent person
|
let sid = personIdent person
|
||||||
((result, widget), enctype) <- runFormPost $ newRepoForm sid
|
((result, widget), enctype) <- runFormPost $ newRepoForm sid
|
||||||
case result of
|
case result of
|
||||||
FormSuccess repo ->
|
FormSuccess repo -> do
|
||||||
case repoVcs repo of
|
parent <- askSharerDir user
|
||||||
VCSDarcs -> error "Darcs not supported yet"
|
liftIO $ do
|
||||||
VCSGit -> do
|
createDirectoryIfMissing True parent
|
||||||
parent <- askSharerDir user
|
let repoName = unpack $ repoIdent repo
|
||||||
liftIO $ do
|
case repoVcs repo of
|
||||||
createDirectoryIfMissing True parent
|
VCSDarcs -> D.initRepo parent repoName
|
||||||
initRepo parent (unpack $ repoIdent repo)
|
VCSGit -> G.initRepo parent repoName
|
||||||
runDB $ insert_ repo
|
runDB $ insert_ repo
|
||||||
setMessage "Repo added."
|
setMessage "Repo added."
|
||||||
redirect $ ReposR user
|
redirect $ ReposR user
|
||||||
FormMissing -> do
|
FormMissing -> do
|
||||||
setMessage "Field(s) missing"
|
setMessage "Field(s) missing"
|
||||||
defaultLayout $(widgetFile "repo/repo-new")
|
defaultLayout $(widgetFile "repo/repo-new")
|
||||||
FormFailure l -> do
|
FormFailure _l -> do
|
||||||
setMessage $ toHtml $ intercalate "; " l
|
setMessage "Repo creation failed, see errors below"
|
||||||
defaultLayout $(widgetFile "repo/repo-new")
|
defaultLayout $(widgetFile "repo/repo-new")
|
||||||
|
|
||||||
getRepoNewR :: Text -> Handler Html
|
getRepoNewR :: Text -> Handler Html
|
||||||
|
|
|
@ -34,7 +34,8 @@ flag library-only
|
||||||
default: False
|
default: False
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules: Data.Binary.Local
|
exposed-modules: Darcs.Local
|
||||||
|
Data.Binary.Local
|
||||||
Data.ByteString.Char8.Local
|
Data.ByteString.Char8.Local
|
||||||
Data.ByteString.Local
|
Data.ByteString.Local
|
||||||
Data.Char.Local
|
Data.Char.Local
|
||||||
|
|
Loading…
Reference in a new issue