Use the RBAC system to determine repo push access
This commit is contained in:
fr33domlover
parent
2d4fb85fca
commit
d655e7302e
3 changed files with 68 additions and 33 deletions
|
|
@ -14,7 +14,8 @@
|
|||
-}
|
||||
|
||||
module Vervis.Form.Repo
|
||||
( newRepoForm
|
||||
( NewRepo (..)
|
||||
, newRepoForm
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -22,17 +23,26 @@ where
|
|||
|
||||
import Vervis.Import
|
||||
import Vervis.Field.Repo
|
||||
import Vervis.Model.Ident (prj2text, text2rp)
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Repo
|
||||
|
||||
newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler Repo
|
||||
newRepoAForm sid mpid = Repo
|
||||
data NewRepo = NewRepo
|
||||
{ nrpIdent :: RpIdent
|
||||
, nrpVcs :: VersionControlSystem
|
||||
, nrpProj :: Maybe ProjectId
|
||||
, nrpDesc :: Maybe Text
|
||||
, nrpRole :: RoleId
|
||||
}
|
||||
|
||||
newRepoAForm
|
||||
:: PersonId -> SharerId -> Maybe ProjectId -> AForm Handler NewRepo
|
||||
newRepoAForm pid sid mpid = NewRepo
|
||||
<$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing)
|
||||
<*> pure sid
|
||||
<*> areq (selectFieldList vcsList) "Version control system*" Nothing
|
||||
<*> aopt selectProject "Project" (Just mpid)
|
||||
<*> aopt textField "Description" Nothing
|
||||
<*> pure "master"
|
||||
<*> areq selectRole "Your role*" Nothing
|
||||
where
|
||||
vcsList :: [(Text, VersionControlSystem)]
|
||||
vcsList =
|
||||
|
|
@ -43,6 +53,10 @@ newRepoAForm sid mpid = Repo
|
|||
selectField $
|
||||
optionsPersistKey [ProjectSharer ==. sid] [Asc ProjectIdent] $
|
||||
prj2text . projectIdent
|
||||
selectRole =
|
||||
selectField $
|
||||
optionsPersistKey [RolePerson ==. pid] [] $
|
||||
rl2text . roleIdent
|
||||
|
||||
newRepoForm :: SharerId -> Maybe ProjectId -> Form Repo
|
||||
newRepoForm sid mpid = renderDivs $ newRepoAForm sid mpid
|
||||
newRepoForm :: PersonId -> SharerId -> Maybe ProjectId -> Form NewRepo
|
||||
newRepoForm pid sid mpid = renderDivs $ newRepoAForm pid sid mpid
|
||||
|
|
|
|||
|
|
@ -109,20 +109,35 @@ getReposR user = do
|
|||
|
||||
postReposR :: ShrIdent -> Handler Html
|
||||
postReposR user = do
|
||||
Entity _pid person <- requireAuth
|
||||
let sid = personIdent person
|
||||
((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
||||
Entity pid person <- requireAuth
|
||||
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
|
||||
((result, widget), enctype) <- runFormPost $ newRepoForm pid sid Nothing
|
||||
case result of
|
||||
FormSuccess repo -> do
|
||||
FormSuccess nrp -> do
|
||||
parent <- askSharerDir user
|
||||
liftIO $ do
|
||||
createDirectoryIfMissing True parent
|
||||
let repoName =
|
||||
unpack $ CI.foldedCase $ unRpIdent $ repoIdent repo
|
||||
case repoVcs repo of
|
||||
unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
|
||||
case nrpVcs nrp of
|
||||
VCSDarcs -> D.createRepo parent repoName
|
||||
VCSGit -> G.createRepo parent repoName
|
||||
runDB $ insert_ repo
|
||||
runDB $ do
|
||||
let repo = Repo
|
||||
{ repoIdent = nrpIdent nrp
|
||||
, repoSharer = sid
|
||||
, repoVcs = nrpVcs nrp
|
||||
, repoProject = nrpProj nrp
|
||||
, repoDesc = nrpDesc nrp
|
||||
, repoMainBranch = "master"
|
||||
}
|
||||
rid <- insert repo
|
||||
let collab = Collab
|
||||
{ collabRepo = rid
|
||||
, collabPerson = pid
|
||||
, collabRole = nrpRole nrp
|
||||
}
|
||||
insert_ collab
|
||||
setMessage "Repo added."
|
||||
redirect $ ReposR user
|
||||
FormMissing -> do
|
||||
|
|
@ -134,9 +149,9 @@ postReposR user = do
|
|||
|
||||
getRepoNewR :: ShrIdent -> Handler Html
|
||||
getRepoNewR user = do
|
||||
Entity _pid person <- requireAuth
|
||||
let sid = personIdent person
|
||||
((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
||||
Entity pid person <- requireAuth
|
||||
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
|
||||
((_result, widget), enctype) <- runFormPost $ newRepoForm pid sid Nothing
|
||||
defaultLayout $(widgetFile "repo/new")
|
||||
|
||||
selectRepo :: ShrIdent -> RpIdent -> AppDB Repo
|
||||
|
|
|
|||
|
|
@ -25,18 +25,20 @@ 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 Formatting ((%))
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Formatting ((%))
|
||||
import Network.SSH
|
||||
import Network.SSH.Channel
|
||||
import Network.SSH.Crypto
|
||||
|
|
@ -49,6 +51,8 @@ import qualified Data.Text as T
|
|||
import qualified Formatting as F
|
||||
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Role
|
||||
import Vervis.Settings
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
|
@ -214,6 +218,18 @@ whenGitRepoExists repoPath action = do
|
|||
then action
|
||||
else return $ ARFail "No such git repository"
|
||||
|
||||
canPushTo :: Text -> Text -> Channel Bool
|
||||
canPushTo shr' rp' = do
|
||||
let shr = text2shr shr'
|
||||
rp = text2rp rp'
|
||||
pid <- authId <$> askAuthDetails
|
||||
ma <- runChanDB $ runMaybeT $ do
|
||||
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
|
||||
Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
|
||||
Entity _cid collab <- MaybeT $ getBy $ UniqueCollab rid pid
|
||||
MaybeT $ getBy $ UniqueAccess (collabRole collab) OpRepoPush
|
||||
return $ isJust ma
|
||||
|
||||
runAction :: FilePath -> Bool -> Action -> Channel ActionResult
|
||||
runAction repoDir _wantReply action =
|
||||
case action of
|
||||
|
|
@ -224,13 +240,8 @@ runAction repoDir _wantReply action =
|
|||
return ARProcess
|
||||
DarcsApply spec -> do
|
||||
(sharer, repo, repoPath) <- resolveSpec' repoDir spec
|
||||
-- Now we need to check whether the authenticated user (can get its
|
||||
-- details with 'askAuthDetails') has write access to the repo.
|
||||
-- This is currently true iff the authenticated user and the repo
|
||||
-- sharer have the same ID. Since sharer names are unique, it's
|
||||
-- enough to compare them.
|
||||
userName <- T.pack . authUser <$> askAuthDetails
|
||||
if userName == sharer
|
||||
can <- canPushTo sharer repo
|
||||
if can
|
||||
then whenDarcsRepoExists repoPath $ do
|
||||
execute "darcs" ["apply", "--all", "--repodir", repoPath]
|
||||
return ARProcess
|
||||
|
|
@ -242,13 +253,8 @@ runAction repoDir _wantReply action =
|
|||
return ARProcess
|
||||
GitReceivePack spec -> do
|
||||
(sharer, repo, repoPath) <- resolveSpec' repoDir spec
|
||||
-- Now we need to check whether the authenticated user (can get its
|
||||
-- details with 'askAuthDetails') has write access to the repo.
|
||||
-- This is currently true iff the authenticated user and the repo
|
||||
-- sharer have the same ID. Since sharer names are unique, it's
|
||||
-- enough to compare them.
|
||||
userName <- T.pack . authUser <$> askAuthDetails
|
||||
if userName == sharer
|
||||
can <- canPushTo sharer repo
|
||||
if can
|
||||
then whenGitRepoExists repoPath $ do
|
||||
execute "git-receive-pack" [repoPath]
|
||||
return ARProcess
|
||||
|
|
|
|||
Loading…
Reference in a new issue