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

@@ -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"