diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index 6ce5614..819e2f0 100644 --- a/src/Vervis/Form/Repo.hs +++ b/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 -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 7d05968..4494aa9 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -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 diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 48871e3..67a6afb 100644 --- a/src/Vervis/Ssh.hs +++ b/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 - -- 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