Enable darcs-push-over-SSH using the darcs executable

src/Vervis/Ssh.hs

@@ -69,15 +69,9 @@ data RepoSpec
     | SpecRepo Text
     deriving Show
 
---data DarcsFile
---    = DarcsFormat
---    | DarcsMotd
---    | DarcsInventory
---    deriving Show
-
 data Action
---    = DarcsCopy RepoSpec DarcsFile
     = DarcsTransferMode RepoSpec
+    | DarcsApply RepoSpec
     | GitUploadPack RepoSpec
     | GitReceivePack RepoSpec
     deriving Show
@@ -143,11 +137,13 @@ authorize (PublicKey name key) = do
 --TOD TODO TODO check paths for safety... no /./ or /../ and so on
 
 darcsRepoSpecP :: Parser RepoSpec
-darcsRepoSpecP = f <$> part <* char '/' <*> optional (part <* char '/')
+darcsRepoSpecP = f <$>
+                 part <*>
+                 optional (char '/' *> optional (part <* optional (char '/')))
     where
-    f repo Nothing       = SpecRepo repo
-    f sharer (Just repo) = SpecUserRepo sharer repo
-    part = takeWhile1 (/= '/')
+    f sharer (Just (Just repo)) = SpecUserRepo sharer repo
+    f repo _                    = SpecRepo repo
+    part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
 
 gitRepoSpecP :: Parser RepoSpec
 gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
@@ -160,6 +156,8 @@ gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
 actionP :: Parser Action
 actionP =   DarcsTransferMode <$>
             ("darcs transfer-mode --repodir " *> darcsRepoSpecP)
+        <|> DarcsApply <$>
+            ("darcs apply --all  --repodir '" *> darcsRepoSpecP <* char '\'')
         <|> GitUploadPack <$>
             ("git-upload-pack '"  *> gitRepoSpecP <* char '\'')
         <|> GitReceivePack <$>
@@ -216,28 +214,27 @@ whenGitRepoExists repoPath action = do
         then action
         else return $ ARFail "No such git repository"
 
---darcsFilePath :: DarcsFile -> FilePath
---darcsFilePath DarcsFormat    = "_darcs" </> "format"
---darcsFilePath DarcsMotd      = "_darcs" </> "prefs" </> "motd"
---darcsFilePath DarcsInventory = "_darcs" </> "format"
-
 runAction :: FilePath -> Bool -> Action -> Channel ActionResult
 runAction repoDir _wantReply action =
     case action of
-        --DarcsCopy spec file -> do
-        --    (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
-        --    let filePath = repoPath </> darcsFilePath file
-        --    exists <- liftIO $ doesFileExist filePath
-        --    if exists
-        --        then do
-        --            execute "scp" ["-f", filePath]
-        --            return ARProcess
-        --        else return $ ARFail "No such file in the repo"
         DarcsTransferMode spec -> do
             (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
             whenDarcsRepoExists repoPath $ do
                 execute "darcs" ["transfer-mode", "--repodir", repoPath]
                 return ARProcess
+        DarcsApply spec -> do
+            (sharer, repo, repoPath) <- resolveSpec' repoDir spec
+            -- Now we need to check whether the authenticated user (can get its
+            -- details with 'askAuthDetails') has write access to the repo.
+            -- This is currently true iff the authenticated user and the repo
+            -- sharer have the same ID. Since sharer names are unique, it's
+            -- enough to compare them.
+            userName <- T.pack . authUser <$> askAuthDetails
+            if userName == sharer
+                then whenDarcsRepoExists repoPath $ do
+                    execute "darcs" ["apply", "--all", "--repodir", repoPath]
+                    return ARProcess
+                else return $ ARFail "You can't push to this repository"
         GitUploadPack spec -> do
             (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
             whenGitRepoExists repoPath $ do