diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 507c459..2aded99 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -41,6 +41,7 @@ import Network.SSH import Network.SSH.Channel import Network.SSH.Crypto import Network.SSH.Session +import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath (()) import System.Process (CreateProcess (..), StdStream (..), createProcess, proc) @@ -68,9 +69,17 @@ data RepoSpec | SpecRepo Text deriving Show +--data DarcsFile +-- = DarcsFormat +-- | DarcsMotd +-- | DarcsInventory +-- deriving Show + data Action - = UploadPack RepoSpec - | ReceivePack RepoSpec +-- = DarcsCopy RepoSpec DarcsFile + = DarcsTransferMode RepoSpec + | GitUploadPack RepoSpec + | GitReceivePack RepoSpec deriving Show -- | Result of running an action on the server side as a response to an SSH @@ -131,8 +140,15 @@ authorize (PublicKey name key) = do -- Actions ------------------------------------------------------------------------------- -repoSpecP :: Parser RepoSpec -repoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part) +--TOD TODO TODO check paths for safety... no /./ or /../ and so on + +darcsRepoSpecP :: Parser RepoSpec +darcsRepoSpecP = SpecUserRepo <$> part <* char '/' <*> part <* char '/' + where + part = takeWhile1 (/= '/') + +gitRepoSpecP :: Parser RepoSpec +gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part) where f repo Nothing = SpecRepo repo f sharer (Just repo) = SpecUserRepo sharer repo @@ -140,8 +156,12 @@ repoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part) msh = optional (satisfy $ \ c -> c == '/' || c == '~') actionP :: Parser Action -actionP = UploadPack <$> ("git-upload-pack '" *> repoSpecP <* char '\'') - <|> ReceivePack <$> ("git-receive-pack '" *> repoSpecP <* char '\'') +actionP = DarcsTransferMode <$> + ("darcs transfer-mode --repodir " *> darcsRepoSpecP) + <|> GitUploadPack <$> + ("git-upload-pack '" *> gitRepoSpecP <* char '\'') + <|> GitReceivePack <$> + ("git-receive-pack '" *> gitRepoSpecP <* char '\'') parseExec :: Text -> Either String Action parseExec input = parseOnly (actionP <* endOfInput) input @@ -180,22 +200,48 @@ 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 +whenDarcsRepoExists :: FilePath -> Channel ActionResult -> Channel ActionResult +whenDarcsRepoExists repoPath action = do + looksGood <- liftIO $ doesDirectoryExist $ repoPath "_darcs" + if looksGood + then action + else return $ ARFail "No such darcs 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" +--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 - UploadPack spec -> do - (sharer, repo, repoPath) <- resolveSpec' repoDir spec - whenRepoExists repoPath $ do + --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 + GitUploadPack spec -> do + (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec + whenGitRepoExists repoPath $ do execute "git-upload-pack" [repoPath] return ARProcess - ReceivePack spec -> do + GitReceivePack 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. @@ -204,7 +250,7 @@ runAction repoDir _wantReply action = -- enough to compare them. userName <- T.pack . authUser <$> askAuthDetails if userName == sharer - then whenRepoExists repoPath $ do + then whenGitRepoExists repoPath $ do execute "git-receive-pack" [repoPath] return ARProcess else return $ ARFail "You can't push to this repository"