diff --git a/src/GitPackProto.hs b/src/GitPackProto.hs index 7bf664f..d92b1b9 100644 --- a/src/GitPackProto.hs +++ b/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 diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index fe33777..b489eb6 100644 --- a/src/Vervis/Ssh.hs +++ b/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 -detectAction _ = Nothing +repoSpecP :: Parser RepoSpec +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" - Just act -> do - lift $ $logDebugS src $ pack $ show act + Left e -> err e + Right act -> do + 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" diff --git a/vervis.cabal b/vervis.cabal index 7500bb1..32eeda4 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -87,6 +87,7 @@ library TupleSections RecordWildCards build-depends: aeson + , attoparsec , base , base64-bytestring , binary