diff --git a/src/Vervis/Field/Project.hs b/src/Vervis/Field/Project.hs
index 737bf49..8bd0cdc 100644
--- a/src/Vervis/Field/Project.hs
+++ b/src/Vervis/Field/Project.hs
@@ -14,7 +14,7 @@
-}
module Vervis.Field.Project
- ( mkIdentField
+ ( newProjectIdentField
)
where
@@ -25,10 +25,10 @@ import Data.Char.Local (isAsciiLetter)
import Data.Text (split)
import Database.Esqueleto
-import Vervis.Model.Ident (text2prj)
+import Vervis.Model.Ident (PrjIdent, prj2text, text2prj)
-checkIdentTemplate :: Field Handler Text -> Field Handler Text
-checkIdentTemplate =
+checkTemplate :: Field Handler Text -> Field Handler Text
+checkTemplate =
let charOk c = isAsciiLetter c || isDigit c
wordOk w = (not . null) w && all charOk w
identOk t = (not . null) t && all wordOk (split (== '-') t)
@@ -38,18 +38,20 @@ checkIdentTemplate =
\ASCII letters and digits."
in checkBool identOk msg
-checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text
-checkIdentUnique sid = checkM $ \ ident -> do
- let ident' = text2prj ident
+checkUniqueCI :: SharerId -> Field Handler PrjIdent -> Field Handler PrjIdent
+checkUniqueCI sid = checkM $ \ ident -> do
sames <- runDB $ select $ from $ \ project -> do
where_ $
- project ^. ProjectSharer ==. val sid &&.
- lower_ (project ^. ProjectIdent) ==. lower_ (val ident')
+ project ^. ProjectSharer ==. val sid &&.
+ lower_ (project ^. ProjectIdent) ==. lower_ (val ident)
limit 1
return ()
return $ if null sames
then Right ident
else Left ("You already have a project by that name" :: Text)
-mkIdentField :: SharerId -> Field Handler Text
-mkIdentField sid = checkIdentUnique sid . checkIdentTemplate $ textField
+projectIdentField :: Field Handler PrjIdent
+projectIdentField = convertField text2prj prj2text $ checkTemplate textField
+
+newProjectIdentField :: SharerId -> Field Handler PrjIdent
+newProjectIdentField sid = checkUniqueCI sid projectIdentField
diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs
index b164d6c..963ee4d 100644
--- a/src/Vervis/Form/Project.hs
+++ b/src/Vervis/Form/Project.hs
@@ -14,7 +14,8 @@
-}
module Vervis.Form.Project
- ( newProjectForm
+ ( NewProject (..)
+ , newProjectForm
, NewProjectCollab (..)
, newProjectCollabForm
, editProjectForm
@@ -32,17 +33,27 @@ import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo
-newProjectAForm :: SharerId -> AForm Handler Project
-newProjectAForm sid = Project
- <$> (text2prj <$> areq (mkIdentField sid) "Identifier*" Nothing)
- <*> pure sid
- <*> aopt textField "Name" Nothing
- <*> aopt textField "Description" Nothing
- <*> pure 1
- <*> pure Nothing
+data NewProject = NewProject
+ { npIdent :: PrjIdent
+ , npName :: Maybe Text
+ , npDesc :: Maybe Text
+ , npRole :: ProjectRoleId
+ }
-newProjectForm :: SharerId -> Form Project
-newProjectForm = renderDivs . newProjectAForm
+newProjectAForm :: PersonId -> SharerId -> AForm Handler NewProject
+newProjectAForm pid sid = NewProject
+ <$> areq (newProjectIdentField sid) "Identifier*" Nothing
+ <*> aopt textField "Name" Nothing
+ <*> aopt textField "Description" Nothing
+ <*> areq selectRole "Your role*" Nothing
+ where
+ selectRole =
+ selectField $
+ optionsPersistKey [ProjectRolePerson ==. pid] [] $
+ rl2text . projectRoleIdent
+
+newProjectForm :: PersonId -> SharerId -> Form NewProject
+newProjectForm pid sid = renderDivs $ newProjectAForm pid sid
data NewProjectCollab = NewProjectCollab
{ ncPerson :: PersonId
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index 5f3e2f3..42911ae 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/src/Vervis/Handler/Project.hs
@@ -37,7 +37,7 @@ import Data.Text (Text)
import Database.Persist
import Database.Esqueleto hiding (delete, (%), (==.))
import Text.Blaze.Html (Html)
-import Yesod.Auth (requireAuth)
+import Yesod.Auth (requireAuthId)
import Yesod.Core (defaultLayout)
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
import Yesod.Form.Functions (runFormPost)
@@ -65,15 +65,30 @@ getProjectsR ident = do
defaultLayout $(widgetFile "project/list")
postProjectsR :: ShrIdent -> Handler Html
-postProjectsR ident = do
- Entity _pid person <- requireAuth
- let sid = personIdent person
- ((result, widget), enctype) <- runFormPost $ newProjectForm sid
+postProjectsR shr = do
+ pid <- requireAuthId
+ Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
+ ((result, widget), enctype) <- runFormPost $ newProjectForm pid sid
case result of
- FormSuccess project -> do
- runDB $ insert_ project
+ FormSuccess np -> do
+ runDB $ do
+ let project = Project
+ { projectIdent = npIdent np
+ , projectSharer = sid
+ , projectName = npName np
+ , projectDesc = npDesc np
+ , projectNextTicket = 1
+ , projectWiki = Nothing
+ }
+ jid <- insert project
+ let collab = ProjectCollab
+ { projectCollabProject = jid
+ , projectCollabPerson = pid
+ , projectCollabRole = npRole np
+ }
+ insert_ collab
setMessage "Project added."
- redirect HomeR
+ redirect $ ProjectR shr (npIdent np)
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "project/new")
@@ -82,10 +97,10 @@ postProjectsR ident = do
defaultLayout $(widgetFile "project/new")
getProjectNewR :: ShrIdent -> Handler Html
-getProjectNewR ident = do
- Entity _pid person <- requireAuth
- let sid = personIdent person
- ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
+getProjectNewR shr = do
+ pid <- requireAuthId
+ Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
+ ((_result, widget), enctype) <- runFormPost $ newProjectForm pid sid
defaultLayout $(widgetFile "project/new")
getProjectR :: ShrIdent -> PrjIdent -> Handler Html
diff --git a/templates/project/new.hamlet b/templates/project/new.hamlet
index 704e6a5..d80cb02 100644
--- a/templates/project/new.hamlet
+++ b/templates/project/new.hamlet
@@ -12,8 +12,6 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$#