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.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
import Data.ByteString.Char8 (ByteString, unpack)
import Data.ByteString.Lazy (fromStrict)
import Data.Foldable (find)
import Data.Text (pack)
import Database.Persist
import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool)
import Network.SSH
import Network.SSH.Channel
import Network.SSH.Crypto
import Network.SSH.Session

import Vervis.Model
import Vervis.Settings

type ChannelB = ReaderT ConnectionPool IO
type SessionB = ReaderT ConnectionPool IO
type Backend = SqlBackend

type Channel = ChannelT ChannelB
type Session = SessionT SessionB ChannelB
type SshChanDB = ReaderT Backend Channel
type SshSessDB = ReaderT Backend Session

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

runSessDB :: SshSessDB a -> Session a
runSessDB action = do
    pool <- lift ask
    runSqlPool action pool

chanFail :: Bool -> ByteString -> Channel ()
chanFail wantReply msg = do
    channelError $ unpack msg
    when wantReply channelFail

authorize :: Authorize -> Session Bool
authorize (Password  _    _)   = return False
authorize (PublicKey name key) = do
    mkeys <- runSessDB $ do
        mp <- getBy $ UniquePersonLogin $ pack name
        case mp of
            Nothing              -> return Nothing
            Just (Entity pid _p) ->
                fmap Just $ selectList [SshKeyPerson ==. pid] []
    case mkeys of
        Nothing -> do
            liftIO $ putStrLn "[SSH] auth failed: invalid user"
            return False
        Just keys -> do
            let eValue (Entity _ v) = v
                matches =
                    (== key) . blobToKey . fromStrict . sshKeyContent . eValue
            case find matches keys of
                Nothing -> do
                    liftIO $
                        putStrLn "[SSH] auth failed: no matching key found"
                    return False
                Just match -> do
                    liftIO $ putStrLn "[SSH] auth succeeded"
                    return True

handle :: Bool -> ChannelRequest -> Channel ()
handle wantReply request = do
    liftIO $ print request
    chanFail wantReply "I don't execute any commands yet, come back later"

ready :: IO ()
ready = putStrLn "SSH server component running"

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

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