forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Write initial overview content and add project creation form

Browse source
This commit is contained in:
fr33domlover 2016-02-25 03:10:30 +00:00
parent 004fdb118e
commit 9b686c6db0
12 changed files with 247 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
config/routes
View file

@ -16,32 +16,33 @@
-- Yesod misc
-- ----------------------------------------------------------------------------
/static StaticR Static appStatic
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/static StaticR Static appStatic
/favicon.ico FaviconR 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/!new PersonNewR GET
/u/#Text PersonR GET
/u PeopleR GET POST
/u/!new PersonNewR GET
/u/#Text PersonR GET
/u/#Text/p ProjectsR GET
/u/#Text/p/#Text ProjectR 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
-- /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

13
src/Vervis/Field.hs → src/Vervis/Field/Person.hs
View file

@ -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
View 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

6
src/Vervis/Form.hs → src/Vervis/Form/Person.hs
View file

@ -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
View 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

25
src/Vervis/Foundation.hs
View file

@ -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

92
src/Vervis/Handler/Home.hs
View file

@ -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
if li
then do
rows <- do
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")
mp <- maybeAuth
case mp of
Just p -> personalOverview p
Nothing -> intro

2
src/Vervis/Handler/Person.hs
View file

@ -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)

31
src/Vervis/Handler/Project.hs
View file

@ -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

11
templates/personal-overview.hamlet
View file

@ -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
View 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>

6
vervis.cabal
View file

@ -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