When creating a project, must choose a role for self

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')
+            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

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
+data NewProject = NewProject
+    { npIdent :: PrjIdent
+    , npName  :: Maybe Text
+    , npDesc  :: Maybe Text
+    , npRole  :: ProjectRoleId
+    }
+
+newProjectAForm :: PersonId -> SharerId -> AForm Handler NewProject
+newProjectAForm pid sid = NewProject
+    <$> areq (newProjectIdentField sid) "Identifier*" Nothing
     <*> aopt textField                  "Name"        Nothing
     <*> aopt textField                  "Description" Nothing
-    <*> pure 1
-    <*> pure Nothing
+    <*> areq selectRole                 "Your role*"  Nothing
+    where
+    selectRole =
+        selectField $
+        optionsPersistKey [ProjectRolePerson ==. pid] [] $
+        rl2text . projectRoleIdent
 
-newProjectForm :: SharerId -> Form Project
-newProjectForm = renderDivs . newProjectAForm
+newProjectForm :: PersonId -> SharerId -> Form NewProject
+newProjectForm pid sid = renderDivs $ newProjectAForm pid sid
 
 data NewProjectCollab = NewProjectCollab
     { ncPerson :: PersonId

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

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
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-Enter your details and click "Submit" to create a new project.
-
-<form method=POST action=@{ProjectsR ident} enctype=#{enctype}>
+<form method=POST action=@{ProjectsR shr} enctype=#{enctype}>
   ^{widget}
   <input type=submit>