diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index bf19514..507c459 100644 --- a/src/Vervis/Ssh.hs +++ b/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 - let repoPath = repoDir T.unpack sharer T.unpack repo - looksGood <- liftIO $ isRepo $ fromString repoPath - if looksGood - then execute "git-upload-pack" [repoPath] >> return ARProcess - else return $ ARFail "No such git repository" + (sharer, repo, repoPath) <- resolveSpec' repoDir spec + whenRepoExists repoPath $ do + execute "git-upload-pack" [repoPath] + return ARProcess + ReceivePack 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 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