From 9ed1f4c99ddb08933174b6cfc4ce648e2377a718 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Mon, 18 Jun 2018 08:30:57 +0000
Subject: [PATCH] Fix: Sharer and repo in SSH address path weren't being
lowercased in SSH server
The sharer and repo were being taken and used as is to check push permissions,
which is how it's supposed to be, *but* they were also being used as is to
build the repo path! So sharer and repo names that aren't all lowercase were
getting "No such repository" errors when trying to push.
I changed `RepoSpec` to hold `ShrIdent` and `RpIdent` instead of plain `Text`,
to avoid confusions like that and be clear and explicit about the
representation, and failures to find a repo after verifying it against the DB
are now logged as errors to help with debugging.
I hope this fixes the problem.
---
src/Vervis/Ssh.hs | 69 ++++++++++++++++++++++++++---------------------
1 file changed, 39 insertions(+), 30 deletions(-)
diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs
index c452175..f1b7957 100644
--- a/src/Vervis/Ssh.hs
+++ b/src/Vervis/Ssh.hs
@@ -53,6 +53,7 @@ import qualified Formatting as F
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Role
+import Vervis.Path
import Vervis.Settings
-------------------------------------------------------------------------------
@@ -69,8 +70,8 @@ type SshChanDB = SqlPersistT Channel
type SshSessDB = SqlPersistT Session
data RepoSpec
- = SpecUserRepo Text Text
- | SpecRepo Text
+ = SpecUserRepo ShrIdent RpIdent
+ | SpecRepo RpIdent
deriving Show
data Action
@@ -145,15 +146,15 @@ darcsRepoSpecP = f <$>
part <*>
optional (char '/' *> optional (part <* optional (char '/')))
where
- f sharer (Just (Just repo)) = SpecUserRepo sharer repo
- f repo _ = SpecRepo repo
+ f sharer (Just (Just repo)) = SpecUserRepo (text2shr sharer) (text2rp repo)
+ f repo _ = SpecRepo (text2rp repo)
part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
gitRepoSpecP :: Parser RepoSpec
gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
where
- f repo Nothing = SpecRepo repo
- f sharer (Just repo) = SpecUserRepo sharer repo
+ f repo Nothing = SpecRepo (text2rp repo)
+ f sharer (Just repo) = SpecUserRepo (text2shr sharer) (text2rp repo)
part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
msh = optional (satisfy $ \ c -> c == '/' || c == '~')
@@ -177,17 +178,16 @@ detectAction (Execute s) =
Right action -> Right action
detectAction _ = Left "Unsupported channel request"
-resolveSpec :: RepoSpec -> Channel (Text, Text)
+resolveSpec :: RepoSpec -> Channel (ShrIdent, RpIdent)
resolveSpec (SpecUserRepo u r) = return (u, r)
resolveSpec (SpecRepo r) = do
- u <- T.pack . authUser <$> askAuthDetails
+ u <- text2shr . T.pack . authUser <$> askAuthDetails
return (u, r)
-resolveSpec' :: FilePath -> RepoSpec -> Channel (Text, Text, FilePath)
-resolveSpec' repoDir spec = do
+resolveSpec' :: FilePath -> RepoSpec -> Channel (ShrIdent, RpIdent, FilePath)
+resolveSpec' root spec = do
(u, r) <- resolveSpec spec
- let repoPath = repoDir </> T.unpack u </> T.unpack r
- return (u, r, repoPath)
+ return (u, r, repoDir root u r)
execute :: FilePath -> [String] -> Channel ()
execute cmd args = do
@@ -204,24 +204,33 @@ execute cmd args = do
(verifyPipe mIn, verifyPipe mOut, verifyPipe mErr, ph)
spawnProcess $ verifyPipes <$> createProcess config
-whenDarcsRepoExists :: FilePath -> Channel ActionResult -> Channel ActionResult
-whenDarcsRepoExists repoPath action = do
- looksGood <- liftIO $ doesDirectoryExist $ repoPath </> "_darcs"
+whenRepoExists
+ :: Text
+ -> (FilePath -> IO Bool)
+ -> Bool
+ -> FilePath
+ -> Channel ActionResult
+ -> Channel ActionResult
+whenRepoExists vcs checkFS checkedDB repoPath action = do
+ looksGood <- liftIO $ checkFS repoPath
if looksGood
then action
- else return $ ARFail "No such darcs repository"
+ else do
+ when checkedDB $ lift $ $logErrorS src $
+ T.concat [vcs, " repo not found! ", T.pack repoPath]
+ return $ ARFail $ T.concat ["No such ", vcs, " 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"
+whenDarcsRepoExists
+ :: Bool -> FilePath -> Channel ActionResult -> Channel ActionResult
+whenDarcsRepoExists =
+ whenRepoExists "Darcs" $ doesDirectoryExist . (</> "_darcs")
-canPushTo :: Text -> Text -> Channel Bool
-canPushTo shr' rp' = do
- let shr = text2shr shr'
- rp = text2rp rp'
+whenGitRepoExists
+ :: Bool -> FilePath -> Channel ActionResult -> Channel ActionResult
+whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
+
+canPushTo :: ShrIdent -> RpIdent -> Channel Bool
+canPushTo shr rp = do
pid <- authId <$> askAuthDetails
ma <- runChanDB $ runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
@@ -241,27 +250,27 @@ runAction repoDir _wantReply action =
case action of
DarcsTransferMode spec -> do
(_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
- whenDarcsRepoExists repoPath $ do
+ whenDarcsRepoExists False repoPath $ do
execute "darcs" ["transfer-mode", "--repodir", repoPath]
return ARProcess
DarcsApply spec -> do
(sharer, repo, repoPath) <- resolveSpec' repoDir spec
can <- canPushTo sharer repo
if can
- then whenDarcsRepoExists repoPath $ do
+ then whenDarcsRepoExists True 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
+ whenGitRepoExists False repoPath $ do
execute "git-upload-pack" [repoPath]
return ARProcess
GitReceivePack spec -> do
(sharer, repo, repoPath) <- resolveSpec' repoDir spec
can <- canPushTo sharer repo
if can
- then whenGitRepoExists repoPath $ do
+ then whenGitRepoExists True repoPath $ do
execute "git-receive-pack" [repoPath]
return ARProcess
else return $ ARFail "You can't push to this repository"