vervis/src/Vervis/Ssh.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Ssh
    ( runSsh
    )
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)
import Database.Persist
import Database.Persist.Sql
import Network.SSH
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

type Channel = ChannelT UserAuthId ChannelBase
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"

runChanDB :: SshChanDB a -> Channel a
runChanDB action = do
    pool <- lift . lift $ ask
    runSqlPool action pool

runSessDB :: SshSessDB a -> Session a
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
-------------------------------------------------------------------------------

authorize :: Authorize -> Session (AuthResult UserAuthId)
authorize (Password  _    _)   = return AuthFail
authorize (PublicKey name key) = do
    mpk <- runSessDB $ do
        mp <- getBy $ UniquePersonLogin $ T.pack name
        case mp of
            Nothing              -> return Nothing
            Just (Entity pid _p) -> do
                ks <- selectList [SshKeyPerson ==. pid] []
                return $ Just (pid, ks)
    case mpk of
        Nothing -> do
            lift $ $logInfoS src "Auth failed: Invalid user"
            return AuthFail
        Just (pid, keys) -> do
            let eValue (Entity _ v) = v
                matches =
                    (== key) . blobToKey . fromStrict . sshKeyContent . eValue
            case find matches keys of
                Nothing -> do
                    lift $ $logInfoS src "Auth failed: No matching key found"
                    return AuthFail
                Just match -> do
                    lift $ $logInfoS src "Auth succeeded"
                    return $ AuthSuccess pid

-------------------------------------------------------------------------------
-- Actions
-------------------------------------------------------------------------------

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 =
    case action of
        UploadPack repo -> return $ Just "Doesn't work yet"

handle :: Bool -> ChannelRequest -> Channel ()
handle wantReply request = do
    lift $ $logDebugS src $ T.pack $ show request
    case detectAction request of
        Left e    -> err e
        Right act -> do
            lift $ $logDebugS src $ T.pack $ show act
            res <- runAction wantReply act
            case res of
                Nothing  -> do
                    when wantReply channelSuccess
                    channelDone
                Just msg -> err msg
    where
    err = chanFail wantReply

-------------------------------------------------------------------------------
-- Config and running
-------------------------------------------------------------------------------

ready :: LogFunc -> IO ()
ready = runLoggingT $ $logInfoS src "SSH server component starting"

mkConfig
    :: AppSettings
    -> ConnectionPool
    -> LogFunc
    -> IO (Config SessionBase ChannelBase UserAuthId)
mkConfig settings pool logFunc = do
    keyPair <- keyPairFromFile $ appSshKeyFile settings
    return $ Config
        { cSession     = SessionConfig
            { scAuthMethods  = ["publickey"]
            , scAuthorize    = authorize
            , scKeyPair      = keyPair
            , scRunBaseMonad =
                flip runReaderT pool . flip runLoggingT logFunc
            }
        , cChannel     = ChannelConfig
            { ccRequestHandler = handle
            , ccRunBaseMonad   =
                flip runReaderT pool . flip runLoggingT logFunc
            }
        , cPort        = fromIntegral $ appSshPort settings
        , cReadyAction = ready logFunc
        }

runSsh :: AppSettings -> ConnectionPool -> LogFunc -> IO ()
runSsh settings pool logFunc = do
    config <- mkConfig settings pool logFunc
    startConfig config