Use the RBAC system to determine repo push access

src/Vervis/Form/Repo.hs

@@ -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
+data NewRepo = NewRepo
-newRepoAForm sid mpid = Repo
+    { 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 :: PersonId -> SharerId -> Maybe ProjectId -> Form NewRepo
-newRepoForm sid mpid = renderDivs $ newRepoAForm sid mpid
+newRepoForm pid sid mpid = renderDivs $ newRepoAForm pid sid mpid

src/Vervis/Handler/Repo.hs

@@ -109,20 +109,35 @@ getReposR user = do
 
 postReposR :: ShrIdent -> Handler Html
 postReposR user = do
-    Entity _pid person <- requireAuth
+    Entity pid person <- requireAuth
-    let sid = personIdent person
+    Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
-    ((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
+    ((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
+                        unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
-                case repoVcs repo of
+                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
+    Entity pid person <- requireAuth
-    let sid = personIdent person
+    Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
-    ((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
+    ((_result, widget), enctype) <- runFormPost $ newRepoForm pid sid Nothing
     defaultLayout $(widgetFile "repo/new")
 
 selectRepo :: ShrIdent -> RpIdent -> AppDB Repo

src/Vervis/Ssh.hs

@@ -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
+            can <- canPushTo sharer repo
-            -- details with 'askAuthDetails') has write access to the repo.
+            if can
-            -- 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
                 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
+            can <- canPushTo sharer repo
-            -- details with 'askAuthDetails') has write access to the repo.
+            if can
-            -- 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
                 then whenGitRepoExists repoPath $ do
                     execute "git-receive-pack" [repoPath]
                     return ARProcess