mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-09 21:06:46 +09:00
9ed1f4c99d
The sharer and repo were being taken and used as is to check push permissions, which is how it's supposed to be, *but* they were also being used as is to build the repo path! So sharer and repo names that aren't all lowercase were getting "No such repository" errors when trying to push. I changed `RepoSpec` to hold `ShrIdent` and `RpIdent` instead of plain `Text`, to avoid confusions like that and be clear and explicit about the representation, and failures to find a repo after verifying it against the DB are now logged as errors to help with debugging. I hope this fixes the problem.
338 lines
12 KiB
Haskell
338 lines
12 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.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.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
|
|
ma <- runChanDB $ runMaybeT $ do
|
|
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
|
|
Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
|
|
let asCollab = do
|
|
Entity _ c <- MaybeT $ getBy $ UniqueRepoCollab rid pid
|
|
return $ repoCollabRole c
|
|
asUser = do
|
|
Entity _ cu <- MaybeT $ getBy $ UniqueRepoCollabUser rid
|
|
return $ repoCollabUserRole cu
|
|
role <- asCollab <|> asUser
|
|
MaybeT $ getBy $ UniqueRepoAccess role RepoOpPush
|
|
return $ isJust ma
|
|
|
|
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
|