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

@@ -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

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 ->
+        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
             setMessage "Field(s) missing"
             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")
 
 getRepoNewR :: Text -> Handler Html

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