Parse the git-uploac-pack SSH command properly

src/GitPackProto.hs

@@ -38,30 +38,3 @@ import Data.Word
 
 data RepoRef = RepoRef Text Text Text
 
-data RepoSpec
-    = SpecUserProjRepo Text Text Text
-    | SpecProjRepo Text Text
-    | SpecUserRepo Text Text
-    | SpecRepo Text
-    deriving Show
-
-data Action = UploadPack RepoSpec deriving Show
-
-repoSpecP :: Parser RepoSpec
-repoSpecP =
-        SpecRepo         <$> msep *> part
-    <|> SpecProjRepo     <$> msep *> part <* sep <*> part
-    <|> SpecUserRepo     <$> home *> part <* sep <*> part
-    <|> SpecUserProjRepo <$> msh  *> part <* sep <*> part <* sep <*> part
-    where
-    part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
-    sep  = char '/'
-    msep = optional sep
-    home = char '~'
-    msh  = optional $ satisfy $ \ c -> c == '/' || c == '~'
-
-actionP :: Parser Action
-actionP = UploadPack <$> ("git-upload-pack '" *> repoSpecP <* char '\'')
-
-parseExec :: Text -> Either String Action
-parseExec input = parseOnly (actionP <* endOfInput) input

src/Vervis/Ssh.hs

@@ -20,15 +20,17 @@ where
 
 import Prelude
 
+import Control.Applicative ((<|>), optional)
 import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
+import Data.Attoparsec.Text
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy (fromStrict)
 import Data.Foldable (find)
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text)
 import Database.Persist
 import Database.Persist.Sql
 import Network.SSH
@@ -36,9 +38,15 @@ import Network.SSH.Channel
 import Network.SSH.Crypto
 import Network.SSH.Session
 
+import qualified Data.Text as T
+
 import Vervis.Model
 import Vervis.Settings
 
+-------------------------------------------------------------------------------
+-- Types
+-------------------------------------------------------------------------------
+
 type ChannelBase = LoggingT (ReaderT ConnectionPool IO)
 type SessionBase = LoggingT (ReaderT ConnectionPool IO)
 type UserAuthId = PersonId
@@ -48,6 +56,17 @@ type Session = SessionT SessionBase UserAuthId ChannelBase
 type SshChanDB = SqlPersistT Channel
 type SshSessDB = SqlPersistT Session
 
+data RepoSpec
+    = SpecUserRepo Text Text
+    | SpecRepo Text
+    deriving Show
+
+data Action = UploadPack RepoSpec deriving Show
+
+-------------------------------------------------------------------------------
+-- Utils
+-------------------------------------------------------------------------------
+
 src :: Text
 src = "SSH"
 
@@ -63,14 +82,18 @@ runSessDB action = do
 
 chanFail :: Bool -> Text -> Channel ()
 chanFail wantReply msg = do
-    channelError $ unpack msg
+    channelError $ T.unpack msg
     when wantReply channelFail
 
+-------------------------------------------------------------------------------
+-- Auth
+-------------------------------------------------------------------------------
+
 authorize :: Authorize -> Session (AuthResult UserAuthId)
 authorize (Password  _    _)   = return AuthFail
 authorize (PublicKey name key) = do
     mpk <- runSessDB $ do
-        mp <- getBy $ UniquePersonLogin $ pack name
+        mp <- getBy $ UniquePersonLogin $ T.pack name
         case mp of
             Nothing              -> return Nothing
             Just (Entity pid _p) -> do
@@ -92,10 +115,30 @@ authorize (PublicKey name key) = do
                     lift $ $logInfoS src "Auth succeeded"
                     return $ AuthSuccess pid
 
-data Action = UploadPack () deriving Show
+-------------------------------------------------------------------------------
+-- Actions
+-------------------------------------------------------------------------------
 
-detectAction :: ChannelRequest -> Maybe Action
+repoSpecP :: Parser RepoSpec
-detectAction _ = Nothing
+repoSpecP =
+        SpecRepo     <$> (msh *> part)
+    <|> SpecUserRepo <$> (msh *> part) <* char '/' <*> part
+    where
+    part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
+    msh  = optional (satisfy $ \ c -> c == '/' || c == '~')
+
+actionP :: Parser Action
+actionP = UploadPack <$> ("git-upload-pack '" *> repoSpecP <* char '\'')
+
+parseExec :: Text -> Either String Action
+parseExec input = parseOnly (actionP <* endOfInput) input
+
+detectAction :: ChannelRequest -> Either Text Action
+detectAction (Execute s) =
+    case parseExec $ T.pack s of
+        Left _       -> Left "Unsupported command"
+        Right action -> Right action
+detectAction _           = Left "Unsupported channel request"
 
 runAction :: Bool -> Action -> Channel (Maybe Text)
 runAction _wantReply action =
@@ -104,11 +147,11 @@ runAction _wantReply action =
 
 handle :: Bool -> ChannelRequest -> Channel ()
 handle wantReply request = do
-    lift $ $logDebugS src $ pack $ show request
+    lift $ $logDebugS src $ T.pack $ show request
     case detectAction request of
-        Nothing  -> err "Unsupported request"
+        Left e    -> err e
-        Just act -> do
+        Right act -> do
-            lift $ $logDebugS src $ pack $ show act
+            lift $ $logDebugS src $ T.pack $ show act
             res <- runAction wantReply act
             case res of
                 Nothing  -> do
@@ -118,6 +161,10 @@ handle wantReply request = do
     where
     err = chanFail wantReply
 
+-------------------------------------------------------------------------------
+-- Config and running
+-------------------------------------------------------------------------------
+
 ready :: LogFunc -> IO ()
 ready = runLoggingT $ $logInfoS src "SSH server component starting"
 

vervis.cabal

@@ -87,6 +87,7 @@ library
                        TupleSections
                        RecordWildCards
   build-depends:       aeson
+                     , attoparsec
                      , base
                      , base64-bytestring
                      , binary