Write initial overview content and add project creation form
This commit is contained in:
parent
004fdb118e
commit
9b686c6db0
12 changed files with 247 additions and 68 deletions
|
@ -36,7 +36,8 @@
|
|||
/u/!new PersonNewR GET
|
||||
/u/#Text PersonR GET
|
||||
|
||||
/u/#Text/p ProjectsR GET
|
||||
/u/#Text/p ProjectsR GET POST
|
||||
/u/#Text/p/!new ProjectNewR GET
|
||||
/u/#Text/p/#Text ProjectR GET
|
||||
|
||||
-- /u/#Text/p/#Text/r ReposR GET
|
||||
|
|
|
@ -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
|
||||
ok
|
||||
( "The first character must be a letter, and every other \
|
||||
\ character must be a letter, a digit, ‘.’ (period) , ‘-’ (dash) \
|
||||
\or ‘_’ (underscore)." :: Text)
|
||||
msg :: Text
|
||||
msg =
|
||||
"The first character must be a letter, and every other character \
|
||||
\must be a letter, a digit, ‘.’ (period) , ‘-’ (dash) or ‘_’ \
|
||||
\(underscore)."
|
||||
in checkBool ok msg
|
||||
|
||||
checkLoginUnique :: Field Handler Text -> Field Handler Text
|
||||
checkLoginUnique = checkM $ \ login -> runDB $ do
|
52
src/Vervis/Field/Project.hs
Normal file
52
src/Vervis/Field/Project.hs
Normal file
|
@ -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
|
|
@ -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
|
33
src/Vervis/Form/Project.hs
Normal file
33
src/Vervis/Form/Project.hs
Normal file
|
@ -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
|
|
@ -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.
|
||||
isAuthorized (AuthR _) _ = return Authorized
|
||||
isAuthorized FaviconR _ = return Authorized
|
||||
isAuthorized RobotsR _ = return Authorized
|
||||
-- Default to Authorized for now.
|
||||
-- Who can access which pages.
|
||||
isAuthorized (ProjectNewR ident) _ = do
|
||||
mp <- maybeAuth
|
||||
case mp of
|
||||
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
|
||||
|
|
|
@ -18,22 +18,20 @@ 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)
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
li <- loggedIn
|
||||
if li
|
||||
then do
|
||||
import qualified Database.Esqueleto as E ((==.))
|
||||
|
||||
intro :: Handler Html
|
||||
intro = do
|
||||
rows <- do
|
||||
repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
|
||||
where_ $
|
||||
project ^. ProjectSharer ==. sharer ^. SharerId &&.
|
||||
repo ^. RepoProject ==. project ^. ProjectId
|
||||
project ^. ProjectSharer E.==. sharer ^. SharerId &&.
|
||||
repo ^. RepoProject E.==. project ^. ProjectId
|
||||
orderBy
|
||||
[ asc $ sharer ^. SharerIdent
|
||||
, asc $ project ^. ProjectIdent
|
||||
|
@ -59,6 +57,22 @@ getHomeR = do
|
|||
defaultLayout $ do
|
||||
setTitle "Welcome to Vervis!"
|
||||
$(widgetFile "homepage")
|
||||
else defaultLayout $ do
|
||||
|
||||
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
|
||||
mp <- maybeAuth
|
||||
case mp of
|
||||
Just p -> personalOverview p
|
||||
Nothing -> intro
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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…
|
||||
|
|
21
templates/project-new.hamlet
Normal file
21
templates/project-new.hamlet
Normal file
|
@ -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>
|
|
@ -36,8 +36,10 @@ flag library-only
|
|||
library
|
||||
exposed-modules: Data.Char.Local
|
||||
Vervis.Application
|
||||
Vervis.Field
|
||||
Vervis.Form
|
||||
Vervis.Field.Person
|
||||
Vervis.Field.Project
|
||||
Vervis.Form.Person
|
||||
Vervis.Form.Project
|
||||
Vervis.Foundation
|
||||
Vervis.Git
|
||||
Vervis.Import
|
||||
|
|
Loading…
Reference in a new issue