mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-07 07:46:45 +09:00
c0965a4c47
* Repo collab now supports basic default roles developer/user/guest like project collab does * User/Anon collab for repos and projects are now stored as fields instead of in dedicated tables, there was never a need for dedicated tables but I didn't see that before * Repo push op is now part of `ProjectOperation` * `RepoRole` and related code has been entirely removed, only project roles remain and they're used for both repos and projects * This is the first not-totally-trivial DB migration in Vervis, it's automatic but please be careful and report errors
332 lines
12 KiB
Haskell
332 lines
12 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2019 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.Maybe (MaybeT (MaybeT, runMaybeT))
|
|
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.Maybe (isJust)
|
|
import Data.Monoid ((<>))
|
|
import Data.String (fromString)
|
|
import Data.Text (Text)
|
|
import Database.Persist
|
|
import Database.Persist.Sql
|
|
import Formatting ((%))
|
|
import Network.SSH
|
|
import Network.SSH.Channel
|
|
import Network.SSH.Crypto
|
|
import Network.SSH.Session
|
|
import System.Directory (doesFileExist, doesDirectoryExist)
|
|
import System.FilePath ((</>))
|
|
import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Formatting as F
|
|
|
|
import Vervis.Access
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Model.Role
|
|
import Vervis.Path
|
|
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 ShrIdent RpIdent
|
|
| SpecRepo RpIdent
|
|
deriving Show
|
|
|
|
data Action
|
|
= DarcsTransferMode RepoSpec
|
|
| DarcsApply RepoSpec
|
|
| GitUploadPack RepoSpec
|
|
| GitReceivePack 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
|
|
-------------------------------------------------------------------------------
|
|
|
|
--TOD TODO TODO check paths for safety... no /./ or /../ and so on
|
|
|
|
darcsRepoSpecP :: Parser RepoSpec
|
|
darcsRepoSpecP = f <$>
|
|
part <*>
|
|
optional (char '/' *> optional (part <* optional (char '/')))
|
|
where
|
|
f sharer (Just (Just repo)) = SpecUserRepo (text2shr sharer) (text2rp repo)
|
|
f repo _ = SpecRepo (text2rp repo)
|
|
part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
|
|
|
|
gitRepoSpecP :: Parser RepoSpec
|
|
gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
|
|
where
|
|
f repo Nothing = SpecRepo (text2rp repo)
|
|
f sharer (Just repo) = SpecUserRepo (text2shr sharer) (text2rp repo)
|
|
part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
|
|
msh = optional (satisfy $ \ c -> c == '/' || c == '~')
|
|
|
|
actionP :: Parser Action
|
|
actionP = DarcsTransferMode <$>
|
|
("darcs transfer-mode --repodir " *> darcsRepoSpecP)
|
|
<|> DarcsApply <$>
|
|
("darcs apply --all --repodir '" *> darcsRepoSpecP <* char '\'')
|
|
<|> GitUploadPack <$>
|
|
("git-upload-pack '" *> gitRepoSpecP <* char '\'')
|
|
<|> GitReceivePack <$>
|
|
("git-receive-pack '" *> gitRepoSpecP <* 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 (ShrIdent, RpIdent)
|
|
resolveSpec (SpecUserRepo u r) = return (u, r)
|
|
resolveSpec (SpecRepo r) = do
|
|
u <- text2shr . T.pack . authUser <$> askAuthDetails
|
|
return (u, r)
|
|
|
|
resolveSpec' :: FilePath -> RepoSpec -> Channel (ShrIdent, RpIdent, FilePath)
|
|
resolveSpec' root spec = do
|
|
(u, r) <- resolveSpec spec
|
|
return (u, r, repoDir root 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
|
|
|
|
whenRepoExists
|
|
:: Text
|
|
-> (FilePath -> IO Bool)
|
|
-> Bool
|
|
-> FilePath
|
|
-> Channel ActionResult
|
|
-> Channel ActionResult
|
|
whenRepoExists vcs checkFS checkedDB repoPath action = do
|
|
looksGood <- liftIO $ checkFS repoPath
|
|
if looksGood
|
|
then action
|
|
else do
|
|
when checkedDB $ lift $ $logErrorS src $
|
|
T.concat [vcs, " repo not found! ", T.pack repoPath]
|
|
return $ ARFail $ T.concat ["No such ", vcs, " repository"]
|
|
|
|
whenDarcsRepoExists
|
|
:: Bool -> FilePath -> Channel ActionResult -> Channel ActionResult
|
|
whenDarcsRepoExists =
|
|
whenRepoExists "Darcs" $ doesDirectoryExist . (</> "_darcs")
|
|
|
|
whenGitRepoExists
|
|
:: Bool -> FilePath -> Channel ActionResult -> Channel ActionResult
|
|
whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
|
|
|
|
canPushTo :: ShrIdent -> RpIdent -> Channel Bool
|
|
canPushTo shr rp = do
|
|
pid <- authId <$> askAuthDetails
|
|
oas <- runChanDB $ checkRepoAccess (Just pid) ProjOpPush shr rp
|
|
return $
|
|
case oas of
|
|
ObjectAccessAllowed -> True
|
|
_ -> False
|
|
|
|
runAction :: FilePath -> Bool -> Action -> Channel ActionResult
|
|
runAction repoDir _wantReply action =
|
|
case action of
|
|
DarcsTransferMode spec -> do
|
|
(_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
|
|
whenDarcsRepoExists False repoPath $ do
|
|
execute "darcs" ["transfer-mode", "--repodir", repoPath]
|
|
return ARProcess
|
|
DarcsApply spec -> do
|
|
(sharer, repo, repoPath) <- resolveSpec' repoDir spec
|
|
can <- canPushTo sharer repo
|
|
if can
|
|
then whenDarcsRepoExists True repoPath $ do
|
|
execute "darcs" ["apply", "--all", "--repodir", repoPath]
|
|
return ARProcess
|
|
else return $ ARFail "You can't push to this repository"
|
|
GitUploadPack spec -> do
|
|
(_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
|
|
whenGitRepoExists False repoPath $ do
|
|
execute "git-upload-pack" [repoPath]
|
|
return ARProcess
|
|
GitReceivePack spec -> do
|
|
(sharer, repo, repoPath) <- resolveSpec' repoDir spec
|
|
can <- canPushTo sharer repo
|
|
if can
|
|
then whenGitRepoExists True repoPath $ do
|
|
execute "git-receive-pack" [repoPath]
|
|
return ARProcess
|
|
else return $ ARFail "You can't push to this 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
|