diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index b489eb6..bf19514 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -30,15 +30,22 @@ import Data.Attoparsec.Text import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) import Data.Foldable (find) +import Data.Git.Storage (isRepo) +import Data.Monoid ((<>)) +import Data.String (fromString) import Data.Text (Text) +import Formatting ((%)) import Database.Persist import Database.Persist.Sql import Network.SSH import Network.SSH.Channel import Network.SSH.Crypto import Network.SSH.Session +import System.FilePath (()) +import System.Process (CreateProcess (..), StdStream (..), createProcess, proc) import qualified Data.Text as T +import qualified Formatting as F import Vervis.Model import Vervis.Settings @@ -63,6 +70,13 @@ data RepoSpec data Action = UploadPack RepoSpec deriving Show +-- | Result of running an action on the server side as a response to an SSH +-- channel request. +data ActionResult + = ARDone Text -- ^ Action finished successfully with message + | ARProcess -- ^ Action executed process, the rest depends on the process + | ARFail Text -- ^ Action failed with message + ------------------------------------------------------------------------------- -- Utils ------------------------------------------------------------------------------- @@ -80,11 +94,6 @@ runSessDB action = do pool <- lift . lift $ ask runSqlPool action pool -chanFail :: Bool -> Text -> Channel () -chanFail wantReply msg = do - channelError $ T.unpack msg - when wantReply channelFail - ------------------------------------------------------------------------------- -- Auth ------------------------------------------------------------------------------- @@ -120,10 +129,10 @@ authorize (PublicKey name key) = do ------------------------------------------------------------------------------- repoSpecP :: Parser RepoSpec -repoSpecP = - SpecRepo <$> (msh *> part) - <|> SpecUserRepo <$> (msh *> part) <* char '/' <*> part +repoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part) where + f repo Nothing = SpecRepo repo + f sharer (Just repo) = SpecUserRepo sharer repo part = takeWhile1 $ \ c -> c /= '/' && c /= '\'' msh = optional (satisfy $ \ c -> c == '/' || c == '~') @@ -140,26 +149,63 @@ detectAction (Execute s) = Right action -> Right action detectAction _ = Left "Unsupported channel request" -runAction :: Bool -> Action -> Channel (Maybe Text) -runAction _wantReply action = - case action of - UploadPack repo -> return $ Just "Doesn't work yet" +resolveSpec :: RepoSpec -> Channel (Text, Text) +resolveSpec (SpecUserRepo u r) = return (u, r) +resolveSpec (SpecRepo r) = do + u <- T.pack . authUser <$> askAuthDetails + return (u, r) -handle :: Bool -> ChannelRequest -> Channel () -handle wantReply request = do +execute :: FilePath -> [String] -> Channel () +execute cmd args = do + lift $ $logDebugS src $ + F.sformat ("Executing " % F.string % " " % F.shown) cmd args + let config = (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + verifyPipe Nothing = error "createProcess didn't create all the pipes" + verifyPipe (Just h) = h + verifyPipes (mIn, mOut, mErr, ph) = + (verifyPipe mIn, verifyPipe mOut, verifyPipe mErr, ph) + spawnProcess $ verifyPipes <$> createProcess config + +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" + +handle :: FilePath -> Bool -> ChannelRequest -> Channel () +handle repoDir wantReply request = do lift $ $logDebugS src $ T.pack $ show request case detectAction request of - Left e -> err e + Left e -> do + lift $ $logDebugS src $ "Invalid action: " <> e + channelError $ T.unpack e + when wantReply channelFail Right act -> do lift $ $logDebugS src $ T.pack $ show act - res <- runAction wantReply act + res <- runAction repoDir wantReply act case res of - Nothing -> do + ARDone msg -> do + lift $ $logDebugS src $ "Action done: " <> msg + channelMessage $ T.unpack msg + when wantReply channelSuccess + channelDone + ARProcess -> do + lift $ $logDebugS src "Action ran process" + when wantReply channelSuccess + ARFail msg -> do + lift $ $logDebugS src $ "Action failed: " <> msg + channelError $ T.unpack msg when wantReply channelSuccess channelDone - Just msg -> err msg - where - err = chanFail wantReply ------------------------------------------------------------------------------- -- Config and running @@ -184,7 +230,7 @@ mkConfig settings pool logFunc = do flip runReaderT pool . flip runLoggingT logFunc } , cChannel = ChannelConfig - { ccRequestHandler = handle + { ccRequestHandler = handle $ appRepoDir settings , ccRunBaseMonad = flip runReaderT pool . flip runLoggingT logFunc } diff --git a/vervis.cabal b/vervis.cabal index 32eeda4..fd0fa40 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -124,6 +124,7 @@ library , persistent , persistent-postgresql , persistent-template + , process , safe , shakespeare , ssh