diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index ea97f71..48871e3 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -69,15 +69,9 @@ data RepoSpec | SpecRepo Text deriving Show ---data DarcsFile --- = DarcsFormat --- | DarcsMotd --- | DarcsInventory --- deriving Show - data Action --- = DarcsCopy RepoSpec DarcsFile = DarcsTransferMode RepoSpec + | DarcsApply RepoSpec | GitUploadPack RepoSpec | GitReceivePack RepoSpec deriving Show @@ -143,11 +137,13 @@ authorize (PublicKey name key) = do --TOD TODO TODO check paths for safety... no /./ or /../ and so on darcsRepoSpecP :: Parser RepoSpec -darcsRepoSpecP = f <$> part <* char '/' <*> optional (part <* char '/') +darcsRepoSpecP = f <$> + part <*> + optional (char '/' *> optional (part <* optional (char '/'))) where - f repo Nothing = SpecRepo repo - f sharer (Just repo) = SpecUserRepo sharer repo - part = takeWhile1 (/= '/') + f sharer (Just (Just repo)) = SpecUserRepo sharer repo + f repo _ = SpecRepo repo + part = takeWhile1 $ \ c -> c /= '/' && c /= '\'' gitRepoSpecP :: Parser RepoSpec gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part) @@ -160,6 +156,8 @@ gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part) actionP :: Parser Action actionP = DarcsTransferMode <$> ("darcs transfer-mode --repodir " *> darcsRepoSpecP) + <|> DarcsApply <$> + ("darcs apply --all --repodir '" *> darcsRepoSpecP <* char '\'') <|> GitUploadPack <$> ("git-upload-pack '" *> gitRepoSpecP <* char '\'') <|> GitReceivePack <$> @@ -216,28 +214,27 @@ whenGitRepoExists repoPath action = do 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 - --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 + DarcsApply 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 whenDarcsRepoExists 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