Support git-push over SSH using the git binary

src/Vervis/Ssh.hs

@@ -68,7 +68,10 @@ data RepoSpec
     | SpecRepo Text
     deriving Show
 
-data Action = UploadPack RepoSpec deriving Show
+data Action
+    = UploadPack RepoSpec
+    | ReceivePack RepoSpec
+    deriving Show
 
 -- | Result of running an action on the server side as a response to an SSH
 -- channel request.
@@ -137,7 +140,8 @@ repoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
     msh  = optional (satisfy $ \ c -> c == '/' || c == '~')
 
 actionP :: Parser Action
-actionP = UploadPack <$> ("git-upload-pack '" *> repoSpecP <* char '\'')
+actionP =   UploadPack  <$> ("git-upload-pack '"  *> repoSpecP <* char '\'')
+        <|> ReceivePack <$> ("git-receive-pack '" *> repoSpecP <* char '\'')
 
 parseExec :: Text -> Either String Action
 parseExec input = parseOnly (actionP <* endOfInput) input
@@ -155,6 +159,12 @@ resolveSpec (SpecRepo r) = do
     u <- T.pack . authUser <$> askAuthDetails
     return (u, r)
 
+resolveSpec' :: FilePath -> RepoSpec -> Channel (Text, Text, FilePath)
+resolveSpec' repoDir spec = do
+    (u, r) <- resolveSpec spec
+    let repoPath = repoDir </> T.unpack u </> T.unpack r
+    return (u, r, repoPath)
+
 execute :: FilePath -> [String] -> Channel ()
 execute cmd args = do
     lift $ $logDebugS src $
@@ -170,16 +180,34 @@ 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
+    looksGood <- liftIO $ isRepo $ fromString repoPath
+    if looksGood
+        then action
+        else return $ ARFail "No such git repository"
+
 runAction :: FilePath -> Bool -> Action -> Channel ActionResult
 runAction repoDir _wantReply action =
     case action of
         UploadPack spec -> do
-            (sharer, repo) <- resolveSpec spec
+            (sharer, repo, repoPath) <- resolveSpec' repoDir spec
-            let repoPath = repoDir </> T.unpack sharer </> T.unpack repo
+            whenRepoExists repoPath $ do
-            looksGood <- liftIO $ isRepo $ fromString repoPath
+                execute "git-upload-pack" [repoPath]
-            if looksGood
+                return ARProcess
-                then execute "git-upload-pack" [repoPath] >> return ARProcess
+        ReceivePack spec -> do
-                else return $ ARFail "No such git repository"
+            (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 whenRepoExists repoPath $ do
+                    execute "git-receive-pack" [repoPath]
+                    return ARProcess
+                else return $ ARFail "You can't push to this repository"
 
 handle :: FilePath -> Bool -> ChannelRequest -> Channel ()
 handle repoDir wantReply request = do