Write initial overview content and add project creation form

config/routes

@@ -16,32 +16,33 @@
 -- Yesod misc
 -- ----------------------------------------------------------------------------
 
-/static                      StaticR    Static appStatic
+/static                      StaticR     Static appStatic
-/favicon.ico                 FaviconR   GET
+/favicon.ico                 FaviconR    GET
-/robots.txt                  RobotsR    GET
+/robots.txt                  RobotsR     GET
 
 -- ----------------------------------------------------------------------------
 -- User signup and login
 -- ----------------------------------------------------------------------------
 
-/auth                        AuthR      Auth   getAuth
+/auth                        AuthR       Auth   getAuth
 
 -- ----------------------------------------------------------------------------
 -- Everything else...
 -- ----------------------------------------------------------------------------
 
-/                            HomeR      GET
+/                            HomeR       GET
 
-/u                           PeopleR    GET POST
+/u                           PeopleR     GET POST
-/u/!new                      PersonNewR GET
+/u/!new                      PersonNewR  GET
-/u/#Text                     PersonR    GET
+/u/#Text                     PersonR     GET
 
-/u/#Text/p                   ProjectsR  GET
+/u/#Text/p                   ProjectsR   GET POST
-/u/#Text/p/#Text             ProjectR   GET
+/u/#Text/p/!new              ProjectNewR GET
+/u/#Text/p/#Text             ProjectR    GET
 
 -- /u/#Text/p/#Text/r           ReposR     GET
 -- /u/#Text/p/#Text/r/#Text     RepoR      GET
 -- /u/#Text/p/#Text/t           TicketsR   GET
 -- /u/#Text/p/#Text/t/#TicketId TicketR    GET
 -- /u/#Text/p/#Text/w           WikiR      GET
--- /u/#Text/p/#Text/w/+Texts    WikiPageR GET
+-- /u/#Text/p/#Text/w/+Texts    WikiPageR  GET

src/Vervis/Field/Person.hs

@@ -13,7 +13,7 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Field
+module Vervis.Field.Person
     ( loginField
     , passField
     )
@@ -32,11 +32,12 @@ checkLoginTemplate =
             case uncons t of
                 Just (c, r) -> first c && all rest r
                 Nothing     -> False
-    in  checkBool
+        msg :: Text
-            ok
+        msg =
-            ( "The first character must be a letter, and every other \
+            "The first character must be a letter, and every other character \
-            \ character must be a letter, a digit, ‘.’ (period) , ‘-’ (dash) \
+            \must be a letter, a digit, ‘.’ (period) , ‘-’ (dash) or ‘_’ \
-            \or ‘_’ (underscore)." :: Text)
+            \(underscore)."
+    in  checkBool ok msg
 
 checkLoginUnique :: Field Handler Text -> Field Handler Text
 checkLoginUnique = checkM $ \ login -> runDB $ do

src/Vervis/Field/Project.hs

@@ -0,0 +1,52 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Field.Project
+    ( mkIdentField
+    )
+where
+
+import Vervis.Import
+
+import Data.Char (isDigit)
+import Data.Char.Local (isAsciiLetter)
+import Data.Text (split)
+
+checkIdentTemplate :: Field Handler Text -> Field Handler Text
+checkIdentTemplate =
+    let charOk c = isAsciiLetter c || isDigit c
+        wordOk w = (not . null) w && all charOk w
+        identOk t = (not . null) t && all wordOk (split (== '-') t)
+        msg :: Text
+        msg = "The project identifier must be a sequence of one or more words \
+            \separated by hyphens (‘-’), and each such word may contain \
+            \ASCII letters and digits."
+    in  checkBool identOk msg
+
+checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text
+checkIdentUnique sid = checkM $ \ ident -> do
+    let project = Project
+            { projectIdent  = ident
+            , projectSharer = sid
+            , projectName   = Nothing
+            , projectDesc   = Nothing
+            }
+    mup <- runDB $ checkUnique project
+    return $ if isNothing mup
+        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

src/Vervis/Form/Person.hs

@@ -13,7 +13,7 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Form
+module Vervis.Form.Person
     ( PersonNew (..)
     , formPersonNew
     )
@@ -21,7 +21,7 @@ where
 
 import Vervis.Import
 
-import Vervis.Field
+import Vervis.Field.Person
 
 data PersonNew = PersonNew
     { uLogin :: Text
@@ -36,4 +36,4 @@ newPersonAForm = PersonNew
     <*> aopt emailField "E-mail" Nothing
 
 formPersonNew :: Form PersonNew
-formPersonNew = renderTable newPersonAForm
+formPersonNew = renderDivs newPersonAForm

src/Vervis/Form/Project.hs

@@ -0,0 +1,33 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Form.Project
+    ( newProjectForm
+    )
+where
+
+import Vervis.Import
+
+import Vervis.Field.Project
+
+newProjectAForm :: SharerId -> AForm Handler Project
+newProjectAForm sid = Project
+    <$> areq (mkIdentField sid) "Identifier*" Nothing
+    <*> pure sid
+    <*> aopt textField "Name" Nothing
+    <*> aopt textField "Description" Nothing
+
+newProjectForm :: SharerId -> Form Project
+newProjectForm = renderDivs . newProjectAForm

src/Vervis/Foundation.hs

@@ -55,7 +55,7 @@ data App = App
 mkYesodData "App" $(parseRoutesFile "config/routes")
 
 -- | A convenient synonym for creating forms.
-type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
+type Form a = Html -> MForm (HandlerT App IO) (FormResult a, Widget)
 
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
@@ -104,11 +104,24 @@ instance Yesod App where
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
 
-    -- Routes not requiring authentication.
+    -- Who can access which pages.
-    isAuthorized (AuthR _) _ = return Authorized
+    isAuthorized (ProjectNewR ident) _ = do
-    isAuthorized FaviconR _ = return Authorized
+        mp <- maybeAuth
-    isAuthorized RobotsR _ = return Authorized
+        case mp of
-    -- Default to Authorized for now.
+            Nothing                   -> return AuthenticationRequired
+            Just (Entity _pid person) -> do
+                let sid = personIdent person
+                msharer <- runDB $ get sid
+                case msharer of
+                    Nothing -> return $ Unauthorized $
+                        "Integrity error: User " <>
+                        personLogin person <>
+                        " specified a nonexistent sharer ID"
+                    Just sharer ->
+                        if ident == sharerIdent sharer
+                            then return Authorized
+                            else return $ Unauthorized
+                                "You can’t create projects for other users"
     isAuthorized _ _ = return Authorized
 
     -- This function creates static content files in the static folder

src/Vervis/Handler/Home.hs

@@ -18,47 +18,61 @@ module Vervis.Handler.Home
     )
 where
 
-import Vervis.Import hiding ((==.))
+import Vervis.Import
 
-import Database.Esqueleto
+import Database.Esqueleto hiding ((==.))
 import Vervis.Git
-import Vervis.Handler.Util (loggedIn)
+
+import qualified Database.Esqueleto as E ((==.))
+
+intro :: Handler Html
+intro = do
+    rows <- do
+        repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
+            where_ $
+                project ^. ProjectSharer E.==. sharer ^. SharerId &&.
+                repo ^. RepoProject E.==. project ^. ProjectId
+            orderBy
+                [ asc $ sharer ^. SharerIdent
+                , asc $ project ^. ProjectIdent
+                , asc $ repo ^. RepoIdent
+                ]
+            return
+                ( sharer ^. SharerIdent
+                , project ^. ProjectIdent
+                , repo ^. RepoIdent
+                )
+        liftIO $ forM repos $ \ (Value sharer, Value project, Value repo) -> do
+            let path =
+                    unpack $
+                    intercalate "/"
+                        [ "state2"
+                        , sharer
+                        , project
+                        , repo
+                        ]
+            dt <- lastChange path
+            ago <- timeAgo dt
+            return (sharer, project, repo, ago)
+    defaultLayout $ do
+        setTitle "Welcome to Vervis!"
+        $(widgetFile "homepage")
+
+personalOverview :: Entity Person -> Handler Html
+personalOverview (Entity _pid person) = do
+    (ident, projects) <- runDB $ do
+        let sid = personIdent person
+        sharer <- get404 sid
+        projs <- selectList [ProjectSharer ==. sid] [Asc ProjectIdent]
+        let pi (Entity _ proj) = projectIdent proj
+        return (sharerIdent sharer, map pi projs)
+    defaultLayout $ do
+        setTitle "Vervis > Overview"
+        $(widgetFile "personal-overview")
 
 getHomeR :: Handler Html
 getHomeR = do
-    li <- loggedIn
+    mp <- maybeAuth
-    if li
+    case mp of
-        then do
+        Just p  -> personalOverview p
-            rows <- do
+        Nothing -> intro
-                repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
-                    where_ $
-                        project ^. ProjectSharer ==. sharer ^. SharerId &&.
-                        repo ^. RepoProject ==. project ^. ProjectId
-                    orderBy
-                        [ asc $ sharer ^. SharerIdent
-                        , asc $ project ^. ProjectIdent
-                        , asc $ repo ^. RepoIdent
-                        ]
-                    return
-                        ( sharer ^. SharerIdent
-                        , project ^. ProjectIdent
-                        , repo ^. RepoIdent
-                        )
-                liftIO $ forM repos $ \ (Value sharer, Value project, Value repo) -> do
-                    let path =
-                            unpack $
-                            intercalate "/"
-                                [ "state2"
-                                , sharer
-                                , project
-                                , repo
-                                ]
-                    dt <- lastChange path
-                    ago <- timeAgo dt
-                    return (sharer, project, repo, ago)
-            defaultLayout $ do
-                setTitle "Welcome to Vervis!"
-                $(widgetFile "homepage")
-        else defaultLayout $ do
-                setTitle "Vervis > Overview"
-                $(widgetFile "personal-overview")

src/Vervis/Handler/Person.hs

@@ -25,7 +25,7 @@ import Vervis.Import hiding ((==.))
 --import Prelude
 
 import Database.Esqueleto hiding (isNothing)
-import Vervis.Form
+import Vervis.Form.Person
 --import Model
 import Text.Blaze (text)
 import Yesod.Auth.HashDB (setPassword)

src/Vervis/Handler/Project.hs

@@ -15,6 +15,8 @@
 
 module Vervis.Handler.Project
     ( getProjectsR
+    , postProjectsR
+    , getProjectNewR
     , getProjectR
     )
 where
@@ -26,6 +28,7 @@ import Text.Blaze (text)
 import Database.Esqueleto
 --import Model
 --import Yesod.Core (Handler)
+import Vervis.Form.Project
 
 getProjectsR :: Text -> Handler Html
 getProjectsR ident = do
@@ -39,6 +42,34 @@ getProjectsR ident = do
         setTitle $ text $ "Vervis > People > " <> ident <> " > Projects"
         $(widgetFile "projects")
 
+postProjectsR :: Text -> Handler Html
+postProjectsR ident = do
+    Entity _pid person <- requireAuth
+    let sid = personIdent person
+    ((result, widget), enctype) <- runFormPost $ newProjectForm sid
+    case result of
+        FormSuccess project -> do
+            runDB $ insert_ project
+            setMessage "Project added."
+            --redirect $ ProjectsR ident
+            --redirect HomeR
+            redirectUltDest HomeR
+        FormMissing -> do
+            setMessage "Field(s) missing"
+            defaultLayout $(widgetFile "project-new")
+        FormFailure l -> do
+            setMessage $ toHtml $ intercalate "; " l
+            defaultLayout $(widgetFile "project-new")
+
+getProjectNewR :: Text -> Handler Html
+getProjectNewR ident = do
+    Entity _pid person <- requireAuth
+    let sid = personIdent person
+    ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
+    defaultLayout $ do
+        setTitle $ toHtml $ "Vervis > People > " <> ident <> " > New Project"
+        $(widgetFile "project-new")
+
 getProjectR :: Text -> Text -> Handler Html
 getProjectR user proj = do
     projects <- runDB $ select $ from $ \ (sharer, project) -> do

templates/personal-overview.hamlet

@@ -12,7 +12,18 @@ $# 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/>.
 
+<h1>Vervis > Overview for #{ident}
+
 <p>
   This is the homepage for logged-in users. You should eventually see a
   personal overview here. Your projects, repos, news, notifications, settings
   and so on.
+
+<h2>Projects
+
+<ul>
+  $forall project <- projects
+    <li>
+      <a href=@{ProjectR ident project}>#{project}
+  <li>
+    <a href=@{ProjectNewR ident}>Create new…

templates/project-new.hamlet

@@ -0,0 +1,21 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ 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
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<h1>Vervis > People > #{ident} > New Project
+
+Enter your details and click "Submit" to create a new project.
+
+<form method=POST action=@{ProjectsR ident} enctype=#{enctype}>
+  ^{widget}
+  <input type=submit>

vervis.cabal

@@ -36,8 +36,10 @@ flag library-only
 library
   exposed-modules:     Data.Char.Local
                        Vervis.Application
-                       Vervis.Field
+                       Vervis.Field.Person
-                       Vervis.Form
+                       Vervis.Field.Project
+                       Vervis.Form.Person
+                       Vervis.Form.Project
                        Vervis.Foundation
                        Vervis.Git
                        Vervis.Import