Enable Darcs repo cloning over SSH using darcs executable

src/Vervis/Ssh.hs

@@ -41,6 +41,7 @@ import Network.SSH
 import Network.SSH.Channel
 import Network.SSH.Crypto
 import Network.SSH.Session
+import System.Directory (doesFileExist, doesDirectoryExist)
 import System.FilePath ((</>))
 import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
 
@@ -68,9 +69,17 @@ data RepoSpec
     | SpecRepo Text
     deriving Show
 
+--data DarcsFile
+--    = DarcsFormat
+--    | DarcsMotd
+--    | DarcsInventory
+--    deriving Show
+
 data Action
-    = UploadPack RepoSpec
-    | ReceivePack RepoSpec
+--    = DarcsCopy RepoSpec DarcsFile
+    = DarcsTransferMode RepoSpec
+    | GitUploadPack RepoSpec
+    | GitReceivePack RepoSpec
     deriving Show
 
 -- | Result of running an action on the server side as a response to an SSH
@@ -131,8 +140,15 @@ authorize (PublicKey name key) = do
 -- Actions
 -------------------------------------------------------------------------------
 
-repoSpecP :: Parser RepoSpec
-repoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
+--TOD TODO TODO check paths for safety... no /./ or /../ and so on
+
+darcsRepoSpecP :: Parser RepoSpec
+darcsRepoSpecP = SpecUserRepo <$> part <* char '/' <*> part <* char '/'
+    where
+    part = takeWhile1 (/= '/')
+
+gitRepoSpecP :: Parser RepoSpec
+gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
     where
     f repo Nothing       = SpecRepo repo
     f sharer (Just repo) = SpecUserRepo sharer repo
@@ -140,8 +156,12 @@ repoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
     msh  = optional (satisfy $ \ c -> c == '/' || c == '~')
 
 actionP :: Parser Action
-actionP =   UploadPack  <$> ("git-upload-pack '"  *> repoSpecP <* char '\'')
-        <|> ReceivePack <$> ("git-receive-pack '" *> repoSpecP <* char '\'')
+actionP =   DarcsTransferMode <$>
+            ("darcs transfer-mode --repodir " *> darcsRepoSpecP)
+        <|> GitUploadPack <$>
+            ("git-upload-pack '"  *> gitRepoSpecP <* char '\'')
+        <|> GitReceivePack <$>
+            ("git-receive-pack '" *> gitRepoSpecP <* char '\'')
 
 parseExec :: Text -> Either String Action
 parseExec input = parseOnly (actionP <* endOfInput) input
@@ -180,22 +200,48 @@ execute cmd args = do
             (verifyPipe mIn, verifyPipe mOut, verifyPipe mErr, ph)
     spawnProcess $ verifyPipes <$> createProcess config
 
-whenRepoExists :: FilePath -> Channel ActionResult -> Channel ActionResult
-whenRepoExists repoPath action = do
+whenDarcsRepoExists :: FilePath -> Channel ActionResult -> Channel ActionResult
+whenDarcsRepoExists repoPath action = do
+    looksGood <- liftIO $ doesDirectoryExist $ repoPath </> "_darcs"
+    if looksGood
+        then action
+        else return $ ARFail "No such darcs repository"
+
+whenGitRepoExists :: FilePath -> Channel ActionResult -> Channel ActionResult
+whenGitRepoExists repoPath action = do
     looksGood <- liftIO $ isRepo $ fromString repoPath
     if looksGood
         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
-        UploadPack spec -> do
-            (sharer, repo, repoPath) <- resolveSpec' repoDir spec
-            whenRepoExists repoPath $ do
+        --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
+        GitUploadPack spec -> do
+            (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
+            whenGitRepoExists repoPath $ do
                 execute "git-upload-pack" [repoPath]
                 return ARProcess
-        ReceivePack spec -> do
+        GitReceivePack 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.
@@ -204,7 +250,7 @@ runAction repoDir _wantReply action =
             -- enough to compare them.
             userName <- T.pack . authUser <$> askAuthDetails
             if userName == sharer
-                then whenRepoExists repoPath $ do
+                then whenGitRepoExists repoPath $ do
                     execute "git-receive-pack" [repoPath]
                     return ARProcess
                 else return $ ARFail "You can't push to this repository"