Enable git-fetch using the git executable

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
             }

vervis.cabal

@@ -124,6 +124,7 @@ library
                      , persistent
                      , persistent-postgresql
                      , persistent-template
+                     , process
                      , safe
                      , shakespeare
                      , ssh