diff --git a/config/models b/config/models index 873a337..cded20f 100644 --- a/config/models +++ b/config/models @@ -53,6 +53,26 @@ GroupMember UniqueGroupMember person group +Role + ident RlIdent + person PersonId + desc Text + + UniqueRole person ident + +Access + role RoleId + op Operation + + UniqueAccess role op + +Collab + repo RepoId + person PersonId + role RoleId + + UniqueCollab repo person + ------------------------------------------------------------------------------- -- Projects ------------------------------------------------------------------------------- diff --git a/config/routes b/config/routes index 8e244a2..700f10c 100644 --- a/config/routes +++ b/config/routes @@ -50,6 +50,12 @@ /k/!new KeyNewR GET /k/#KyIdent KeyR GET DELETE POST +/r RolesR GET POST +/r/!new RoleNewR GET +/r/#RlIdent RoleR GET DELETE POST +/r/#RlIdent/a RoleOpsR GET POST +/r/#RlIdent/a/!new RoleOpNewR GET + -- ---------------------------------------------------------------------------- -- Projects -- ---------------------------------------------------------------------------- diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 6e3e0ef..eeeb75d 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -59,6 +59,7 @@ import Vervis.Handler.Key import Vervis.Handler.Person import Vervis.Handler.Project import Vervis.Handler.Repo +import Vervis.Handler.Role import Vervis.Handler.Sharer import Vervis.Handler.Ticket diff --git a/src/Vervis/Field/Role.hs b/src/Vervis/Field/Role.hs new file mode 100644 index 0000000..c8acc0a --- /dev/null +++ b/src/Vervis/Field/Role.hs @@ -0,0 +1,75 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Vervis.Field.Role + ( newRoleIdentField + , newOpField + ) +where + +import Prelude + +-- import Control.Monad (void) +-- import Control.Monad.Trans.Maybe +-- import Data.Char (isDigit) +-- import Data.Maybe (isNothing, isJust) +import Data.Text (Text) +import Database.Esqueleto +import Yesod.Form.Fields (textField, selectField, optionsEnum) +import Yesod.Form.Functions (checkM, convertField) +import Yesod.Form.Types (Field) +import Yesod.Persist.Core (runDB) + +-- import qualified Data.Text as T (null, all, find, split) + +-- import Data.Char.Local (isAsciiLetter) +import Vervis.Foundation (Handler, AppDB) +import Vervis.Model +import Vervis.Model.Ident (RlIdent, rl2text, text2rl) +import Vervis.Model.Role + +checkUniqueCI :: PersonId -> Field Handler RlIdent -> Field Handler RlIdent +checkUniqueCI pid = checkM $ \ rl -> do + sames <- runDB $ select $ from $ \ role -> do + where_ $ + role ^. RolePerson ==. val pid &&. + lower_ (role ^. RoleIdent) ==. lower_ (val rl) + limit 1 + return () + return $ if null sames + then Right rl + else Left ("This role name is already in use" :: Text) + +roleIdentField :: Field Handler RlIdent +roleIdentField = convertField text2rl rl2text textField + +newRoleIdentField :: PersonId -> Field Handler RlIdent +newRoleIdentField pid = checkUniqueCI pid roleIdentField + +opField :: Field Handler Operation +opField = selectField optionsEnum + +checkOpNew + :: AppDB RoleId -> Field Handler Operation -> Field Handler Operation +checkOpNew getrid = checkM $ \ op -> do + ma <- runDB $ do + rid <- getrid + getBy $ UniqueAccess rid op + return $ case ma of + Nothing -> Right op + Just _ -> Left ("Role already has this operation" :: Text) + +newOpField :: AppDB RoleId -> Field Handler Operation +newOpField getrid = checkOpNew getrid opField diff --git a/src/Vervis/Form/Role.hs b/src/Vervis/Form/Role.hs new file mode 100644 index 0000000..a1f366c --- /dev/null +++ b/src/Vervis/Form/Role.hs @@ -0,0 +1,53 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Vervis.Form.Role + ( NewRole (..) + , newRoleForm + , newRoleOpForm + ) +where + +import Prelude + +import Data.Text (Text) +import Yesod.Form.Fields (textField) +import Yesod.Form.Functions (areq, renderDivs) +import Yesod.Form.Types (AForm) + +import Vervis.Field.Role +import Vervis.Foundation (Handler, Form, AppDB) +import Vervis.Model +import Vervis.Model.Ident (RlIdent) +import Vervis.Model.Role + +data NewRole = NewRole + { nrIdent :: RlIdent + , nrDesc :: Text + } + +newRoleAForm :: PersonId -> AForm Handler NewRole +newRoleAForm pid = NewRole + <$> areq (newRoleIdentField pid) "Name*" Nothing + <*> areq textField "Description" Nothing + +newRoleForm :: PersonId -> Form NewRole +newRoleForm pid = renderDivs $ newRoleAForm pid + +newRoleOpAForm :: AppDB RoleId -> AForm Handler Operation +newRoleOpAForm getrid = areq (newOpField getrid) "Operation*" Nothing + +newRoleOpForm :: AppDB RoleId -> Form Operation +newRoleOpForm getrid = renderDivs $ newRoleOpAForm getrid diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4485ab6..7b4fd72 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -129,6 +129,12 @@ instance Yesod App where (KeyR _key , _ ) -> personAny (KeyNewR , _ ) -> personAny + (RolesR , _ ) -> personAny + (RoleNewR , _ ) -> personAny + (RoleR _rl , _ ) -> personAny + (RoleOpsR _rl , _ ) -> personAny + (RoleOpNewR _rl , _ ) -> personAny + (ReposR shar , True) -> person shar (RepoNewR user , _ ) -> person user (RepoR shar _ , True) -> person shar @@ -283,11 +289,21 @@ instance YesodBreadcrumbs App where GroupNewR -> ("New", Just GroupsR) GroupR shar -> (shr2text shar, Just GroupsR) GroupMembersR shar -> ("Members", Just $ GroupR shar) + GroupMemberNewR shar -> ("New", Just $ GroupMembersR shar) + GroupMemberR grp memb -> ( shr2text memb + , Just $ GroupMembersR grp + ) KeysR -> ("Keys", Just HomeR) KeyNewR -> ("New", Just KeysR) KeyR key -> (ky2text key, Just KeysR) + RolesR -> ("Roles", Just HomeR) + RoleNewR -> ("New", Just RolesR) + RoleR rl -> (rl2text rl, Just RolesR) + RoleOpsR rl -> ("Operations", Just $ RoleR rl) + RoleOpNewR rl -> ("New", Just $ RoleOpsR rl) + ReposR shar -> ("Repos", Just $ PersonR shar) RepoNewR shar -> ("New", Just $ ReposR shar) RepoR shar repo -> (rp2text repo, Just $ ReposR shar) diff --git a/src/Vervis/Handler/Role.hs b/src/Vervis/Handler/Role.hs new file mode 100644 index 0000000..8cc8e4c --- /dev/null +++ b/src/Vervis/Handler/Role.hs @@ -0,0 +1,136 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Vervis.Handler.Role + ( getRolesR + , postRolesR + , getRoleNewR + , getRoleR + , deleteRoleR + , postRoleR + , getRoleOpsR + , postRoleOpsR + , getRoleOpNewR + ) +where + +import Prelude + +import Database.Persist +import Text.Blaze.Html (Html) +import Yesod.Auth (requireAuthId) +import Yesod.Core (defaultLayout, setMessage) +import Yesod.Core.Handler (lookupPostParam, notFound, redirect) +import Yesod.Form.Functions (runFormPost) +import Yesod.Form.Types (FormResult (..)) +import Yesod.Persist.Core (runDB, getBy404) + +import Vervis.Form.Role +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident (RlIdent, rl2text) +import Vervis.Settings (widgetFile) + +getRolesR :: Handler Html +getRolesR = do + pid <- requireAuthId + roles <- runDB $ selectList [RolePerson ==. pid] [] + defaultLayout $(widgetFile "role/list") + +postRolesR :: Handler Html +postRolesR = do + pid <- requireAuthId + ((result, widget), enctype) <- runFormPost $ newRoleForm pid + case result of + FormSuccess nr -> do + runDB $ do + let role = Role + { roleIdent = nrIdent nr + , rolePerson = pid + , roleDesc = nrDesc nr + } + insert_ role + redirect $ RolesR + FormMissing -> do + setMessage "Field(s) missing" + defaultLayout $(widgetFile "role/new") + FormFailure _l -> do + setMessage "Invalid input, see errors below" + defaultLayout $(widgetFile "role/new") + +getRoleNewR :: Handler Html +getRoleNewR = do + pid <- requireAuthId + ((_result, widget), enctype) <- runFormPost $ newRoleForm pid + defaultLayout $(widgetFile "role/new") + +getRoleR :: RlIdent -> Handler Html +getRoleR rl = do + pid <- requireAuthId + Entity _rid role <- runDB $ getBy404 $ UniqueRole pid rl + defaultLayout $(widgetFile "role/one") + +deleteRoleR :: RlIdent -> Handler Html +deleteRoleR rl = do + pid <- requireAuthId + runDB $ do + Entity rid _r <- getBy404 $ UniqueRole pid rl + delete rid + setMessage "Role deleted." + redirect RolesR + +postRoleR :: RlIdent -> Handler Html +postRoleR rl = do + mmethod <- lookupPostParam "_method" + case mmethod of + Just "DELETE" -> deleteRoleR rl + _ -> notFound + +getRoleOpsR :: RlIdent -> Handler Html +getRoleOpsR rl = do + pid <- requireAuthId + ops <- runDB $ do + Entity rid _r <- getBy404 $ UniqueRole pid rl + map (accessOp . entityVal) <$> selectList [AccessRole ==. rid] [] + defaultLayout $(widgetFile "role/op/list") + +postRoleOpsR :: RlIdent -> Handler Html +postRoleOpsR rl = do + pid <- requireAuthId + let getrid = fmap entityKey $ getBy404 $ UniqueRole pid rl + ((result, widget), enctype) <- runFormPost $ newRoleOpForm getrid + case result of + FormSuccess op -> do + runDB $ do + rid <- getrid + let access = Access + { accessRole = rid + , accessOp = op + } + insert_ access + redirect $ RoleOpsR rl + FormMissing -> do + setMessage "Field(s) missing" + defaultLayout $(widgetFile "role/op/new") + FormFailure _l -> do + setMessage "Invalid input, see errors below" + defaultLayout $(widgetFile "role/op/new") + +getRoleOpNewR :: RlIdent -> Handler Html +getRoleOpNewR rl = do + pid <- requireAuthId + let getrid = fmap entityKey $ getBy404 $ UniqueRole pid rl + ((_result, widget), enctype) <- runFormPost $ newRoleOpForm getrid + defaultLayout $(widgetFile "role/op/new") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 01cb914..5e04d66 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -27,6 +27,7 @@ import Yesod.Auth.HashDB (HashDBUser (..)) import Vervis.Model.Group import Vervis.Model.Ident import Vervis.Model.Repo +import Vervis.Model.Role -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities at: diff --git a/src/Vervis/Model/Ident.hs b/src/Vervis/Model/Ident.hs index 83230cc..1bdf8bc 100644 --- a/src/Vervis/Model/Ident.hs +++ b/src/Vervis/Model/Ident.hs @@ -22,6 +22,9 @@ module Vervis.Model.Ident , KyIdent (..) , ky2text , text2ky + , RlIdent (..) + , rl2text + , text2rl , PrjIdent (..) , prj2text , text2prj @@ -67,6 +70,16 @@ ky2text = CI.original . unKyIdent text2ky :: Text -> KyIdent text2ky = KyIdent . CI.mk +newtype RlIdent = RlIdent { unRlIdent :: CI Text } + deriving + (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece) + +rl2text :: RlIdent -> Text +rl2text = CI.original . unRlIdent + +text2rl :: Text -> RlIdent +text2rl = RlIdent . CI.mk + newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text } deriving (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece) diff --git a/src/Vervis/Model/Role.hs b/src/Vervis/Model/Role.hs new file mode 100644 index 0000000..565a418 --- /dev/null +++ b/src/Vervis/Model/Role.hs @@ -0,0 +1,27 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Vervis.Model.Role + ( Operation (..) + ) +where + +import Prelude + +import Database.Persist.TH + +data Operation = OpRepoPush deriving (Eq, Show, Read, Enum, Bounded) + +derivePersistField "Operation" diff --git a/templates/role/list.hamlet b/templates/role/list.hamlet new file mode 100644 index 0000000..6a29e47 --- /dev/null +++ b/templates/role/list.hamlet @@ -0,0 +1,18 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ 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 +$# . + +