244 lines
8.5 KiB
Haskell
244 lines
8.5 KiB
Haskell
{- 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.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
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- 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
|
|
|
|
-- | 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
|
|
-------------------------------------------------------------------------------
|
|
|
|
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
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- 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 = 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 == '~')
|
|
|
|
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"
|
|
|
|
resolveSpec :: RepoSpec -> Channel (Text, Text)
|
|
resolveSpec (SpecUserRepo u r) = return (u, r)
|
|
resolveSpec (SpecRepo r) = do
|
|
u <- T.pack . authUser <$> askAuthDetails
|
|
return (u, r)
|
|
|
|
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 -> 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 repoDir wantReply act
|
|
case res of
|
|
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
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- 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 $ appRepoDir settings
|
|
, 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
|