forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Add group routes

Browse source
This commit is contained in:
fr33domlover 2016-05-24 21:48:21 +00:00
parent ac893b6040
commit bc66463776
21 changed files with 397 additions and 93 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
config/routes
View file

@ -21,25 +21,36 @@
/robots.txt RobotsR GET
-- ----------------------------------------------------------------------------
-- User login
-- ----------------------------------------------------------------------------
/auth AuthR Auth getAuth
-- ----------------------------------------------------------------------------
-- Everything else...
-- Current user
-- ----------------------------------------------------------------------------
/ HomeR GET
/s PeopleR GET POST
/s/!new PersonNewR GET
/s/#ShrIdent PersonR GET
/auth AuthR Auth getAuth
-- ----------------------------------------------------------------------------
-- People
-- ----------------------------------------------------------------------------
/s SharersR GET
/s/#ShrIdent SharerR GET
/p PeopleR GET POST
/p/!new PersonNewR GET
/p/#ShrIdent PersonR GET
/g GroupsR GET POST
/g/!new GroupNewR GET
/g/#ShrIdent GroupR GET
/k KeysR GET POST
/k/!new KeyNewR GET
/k/#KyIdent KeyR GET DELETE POST
-- ----------------------------------------------------------------------------
-- Projects
-- ----------------------------------------------------------------------------
/s/#ShrIdent/r ReposR GET POST
/s/#ShrIdent/r/!new RepoNewR GET
/s/#ShrIdent/r/#RpIdent RepoR GET DELETE POST

2
src/Vervis/Application.hs
View file

@ -53,11 +53,13 @@ import Yesod.Default.Main (LogFunc)
-- Don't forget to add new modules to your cabal file!
import Vervis.Handler.Common
import Vervis.Handler.Git
import Vervis.Handler.Group
import Vervis.Handler.Home
import Vervis.Handler.Key
import Vervis.Handler.Person
import Vervis.Handler.Project
import Vervis.Handler.Repo
import Vervis.Handler.Sharer
import Vervis.Handler.Ticket
import Vervis.Ssh (runSsh)

32
src/Vervis/Field/Person.hs
View file

@ -14,8 +14,7 @@
-}
module Vervis.Field.Person
( loginField
, passField
( passField
)
where
@ -27,35 +26,6 @@ import Database.Esqueleto
import Data.Char.Local (isAsciiLetter)
import Vervis.Model.Ident (text2shr)
checkLoginTemplate :: Field Handler Text -> Field Handler Text
checkLoginTemplate =
let first = isAsciiLetter
rest c = isAsciiLetter c || isDigit c || c `elem` ("-._" :: String)
ok t =
case uncons t of
Just (c, r) -> first c && all rest r
Nothing -> False
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 -> do
let login' = text2shr login
sames <- runDB $ select $ from $ \ sharer -> do
where_ $ lower_ (sharer ^. SharerIdent) ==. lower_ (val login')
limit 1
return ()
return $ if null sames
then Right login
else Left ("This username is already in use" :: Text)
loginField :: Field Handler Text
loginField = checkLoginUnique . checkLoginTemplate $ textField
checkPassLength :: Field Handler Text -> Field Handler Text
checkPassLength =
let msg :: Text

66
src/Vervis/Field/Sharer.hs Normal file
View file

@ -0,0 +1,66 @@
{- 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.Sharer
( sharerIdentField
, newSharerIdentField
)
where
import Prelude
import Data.Char (isDigit)
import Data.Maybe (isJust)
import Data.Text (Text)
import Database.Esqueleto
import Yesod.Form.Fields (textField)
import Yesod.Form.Functions (checkBool, checkM, convertField)
import Yesod.Form.Types (Field)
import Yesod.Persist.Core (runDB)
import qualified Data.Text as T (null, all, find, split)
import Data.Char.Local (isAsciiLetter)
import Vervis.Foundation (Handler)
import Vervis.Model
import Vervis.Model.Ident (ShrIdent, shr2text, text2shr)
checkTemplate :: Field Handler Text -> Field Handler Text
checkTemplate =
let charOk c = isAsciiLetter c || isDigit c
wordOk w = not (T.null w) && T.all charOk w
containsLetter = isJust . T.find isAsciiLetter
ok t =
let ws = T.split (== '-') t
in containsLetter t && all wordOk ws
msg :: Text
msg = "Expecting words of letters and digits, separated by hyphens"
in checkBool ok msg
checkUniqueCI :: Field Handler ShrIdent -> Field Handler ShrIdent
checkUniqueCI = checkM $ \ shar -> do
sames <- runDB $ select $ from $ \ sharer -> do
where_ $ lower_ (sharer ^. SharerIdent) ==. lower_ (val shar)
limit 1
return ()
return $ if null sames
then Right shar
else Left ("This sharer name is already in use" :: Text)
sharerIdentField :: Field Handler ShrIdent
sharerIdentField = convertField text2shr shr2text $ checkTemplate textField
newSharerIdentField :: Field Handler ShrIdent
newSharerIdentField = checkUniqueCI sharerIdentField

44
src/Vervis/Form/Group.hs Normal file
View file

@ -0,0 +1,44 @@
{- 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.Group
( NewGroup (..)
, newGroupForm
)
where
import Prelude
import Data.Text (Text)
import Yesod.Form.Fields (textField)
import Yesod.Form.Functions (aopt, areq, renderDivs)
import Yesod.Form.Types (AForm)
import Vervis.Field.Sharer (newSharerIdentField)
import Vervis.Foundation (Handler, Form)
import Vervis.Model.Ident (ShrIdent)
data NewGroup = NewGroup
{ ngIdent :: ShrIdent
, ngName :: Maybe Text
}
newGroupAForm :: AForm Handler NewGroup
newGroupAForm = NewGroup
<$> areq newSharerIdentField "Name*" Nothing
<*> aopt textField "Full name" Nothing
newGroupForm :: Form NewGroup
newGroupForm = renderDivs newGroupAForm

32
src/Vervis/Form/Person.hs
View file

@ -14,28 +14,30 @@
-}
module Vervis.Form.Person
( PersonNew (..)
, formPersonNew
( NewPerson (..)
, newPersonForm
)
where
import Vervis.Import
import Vervis.Field.Person
import Vervis.Field.Sharer
import Vervis.Model.Ident (ShrIdent)
data PersonNew = PersonNew
{ uLogin :: Text
, uPass :: Text
, uName :: Maybe Text
, uEmail :: Maybe Text
data NewPerson = NewPerson
{ npLogin :: ShrIdent
, npPass :: Text
, npName :: Maybe Text
, npEmail :: Maybe Text
}
newPersonAForm :: AForm Handler PersonNew
newPersonAForm = PersonNew
<$> areq loginField "Username*" Nothing
<*> areq passField "Password*" Nothing
<*> aopt textField "Full name" Nothing
<*> aopt emailField "E-mail" Nothing
newPersonAForm :: AForm Handler NewPerson
newPersonAForm = NewPerson
<$> areq newSharerIdentField "Username*" Nothing
<*> areq passField "Password*" Nothing
<*> aopt textField "Full name" Nothing
<*> aopt emailField "E-mail" Nothing
formPersonNew :: Form PersonNew
formPersonNew = renderDivs newPersonAForm
newPersonForm :: Form NewPerson
newPersonForm = renderDivs newPersonAForm

29
src/Vervis/Foundation.hs
View file

@ -246,7 +246,15 @@ loggedInAs ident msg = do
instance YesodBreadcrumbs App where
breadcrumb route = return $ case route of
StaticR _ -> ("", Nothing)
FaviconR -> ("", Nothing)
RobotsR -> ("", Nothing)
HomeR -> ("Home", Nothing)
AuthR _ -> ("Auth", Nothing)
SharersR -> ("Sharers", Just HomeR)
SharerR shar -> (shr2text shar, Just SharersR)
PeopleR -> ("People", Just HomeR)
PersonNewR -> ("New", Just PeopleR)
@ -270,6 +278,10 @@ instance YesodBreadcrumbs App where
, Just $ RepoHeadChangesR shar repo
)
DarcsDownloadR _ _ _ -> ("", Nothing)
GitRefDiscoverR _ _ -> ("", Nothing)
ProjectsR shar -> ("Projects", Just $ PersonR shar)
ProjectNewR shar -> ("New", Just $ ProjectsR shar)
ProjectR shar proj -> ( prj2text proj
@ -286,5 +298,18 @@ instance YesodBreadcrumbs App where
TicketEditR shar proj num -> ( "Edit"
, Just $ TicketR shar proj num
)
_ -> ("", Nothing)
TicketDiscussionR shar proj num -> ( "Discussion"
, Just $ TicketR shar proj num
)
TicketMessageR shar proj t c -> ( T.pack $ '#' : show c
, Just $
TicketDiscussionR shar proj t
)
TicketTopReplyR shar proj num -> ( "New topic"
, Just $
TicketDiscussionR shar proj num
)
TicketReplyR shar proj num cnum -> ( "Reply"
, Just $
TicketMessageR shar proj num cnum
)

87
src/Vervis/Handler/Group.hs Normal file
View file

@ -0,0 +1,87 @@
{- 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.Handler.Group
( getGroupsR
, postGroupsR
, getGroupNewR
, getGroupR
)
where
import Prelude
import Control.Monad.IO.Class (liftIO)
import Data.Time.Clock (getCurrentTime)
import Database.Esqueleto
import Text.Blaze.Html (Html)
import Yesod.Core (defaultLayout, setMessage)
import Yesod.Core.Handler (redirect)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404)
import Vervis.Form.Group
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (ShrIdent)
import Vervis.Settings (widgetFile)
import Vervis.Widget.Sharer (groupLinkW)
getGroupsR :: Handler Html
getGroupsR = do
groups <- runDB $ select $ from $ \ (sharer, group) -> do
where_ $ sharer ^. SharerId ==. group ^. GroupIdent
orderBy [asc $ sharer ^. SharerIdent]
return sharer
defaultLayout $(widgetFile "group/list")
postGroupsR :: Handler Html
postGroupsR = do
((result, widget), enctype) <- runFormPost newGroupForm
case result of
FormSuccess ng -> do
now <- liftIO getCurrentTime
runDB $ do
let sharer = Sharer
{ sharerIdent = ngIdent ng
, sharerName = ngName ng
, sharerCreated = now
}
sid <- insert sharer
let group = Group
{ groupIdent = sid
}
insert_ group
redirect $ GroupR $ ngIdent ng
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "group/new")
FormFailure _l -> do
setMessage "Group creation failed, see errors below"
defaultLayout $(widgetFile "group/new")
getGroupNewR :: Handler Html
getGroupNewR = do
((_result, widget), enctype) <- runFormPost newGroupForm
defaultLayout $(widgetFile "group/new")
getGroupR :: ShrIdent -> Handler Html
getGroupR shar = do
group <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shar
Entity _gid g <- getBy404 $ UniqueGroup sid
return g
defaultLayout $(widgetFile "group/one")

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

@ -47,24 +47,24 @@ postPeopleR = do
regEnabled <- getsYesod $ appRegister . appSettings
if regEnabled
then do
((result, widget), enctype) <- runFormPost formPersonNew
((result, widget), enctype) <- runFormPost newPersonForm
case result of
FormSuccess pn -> do
FormSuccess np -> do
now <- liftIO getCurrentTime
runDB $ do
let sharer = Sharer
{ sharerIdent = text2shr $ uLogin pn
, sharerName = uName pn
{ sharerIdent = npLogin np
, sharerName = npName np
, sharerCreated = now
}
sid <- insert sharer
let person = Person
{ personIdent = sid
, personLogin = uLogin pn
, personLogin = shr2text $ npLogin np
, personHash = Nothing
, personEmail = uEmail pn
, personEmail = npEmail np
}
person' <- setPassword (uPass pn) person
person' <- setPassword (npPass np) person
insert_ person'
redirectUltDest HomeR
FormMissing -> do
@ -77,18 +77,12 @@ postPeopleR = do
getPersonNewR :: Handler Html
getPersonNewR = do
mpid <- maybeAuthId
if isJust mpid
then redirect HomeR
else do
regEnabled <- appRegister . appSettings <$> getYesod
if regEnabled
then do
((_result, widget), enctype) <- runFormPost formPersonNew
defaultLayout $ do
setTitle "Vervis > People > New"
$(widgetFile "person-new")
else notFound
regEnabled <- getsYesod $ appRegister . appSettings
if regEnabled
then do
((_result, widget), enctype) <- runFormPost newPersonForm
defaultLayout $(widgetFile "person-new")
else notFound
getPersonR :: ShrIdent -> Handler Html
getPersonR ident = do

19
src/Vervis/Widget/Person.hs → src/Vervis/Handler/Sharer.hs
View file

@ -13,18 +13,21 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Widget.Person
( sharerLinkW
module Vervis.Handler.Sharer
( getSharersR
, getSharerR
)
where
import Prelude
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (shr2text)
import Vervis.Settings (widgetFile)
import Text.Blaze.Html (Html)
sharerLinkW :: Sharer -> Widget
sharerLinkW sharer = $(widgetFile "sharer-link")
import Vervis.Foundation (Handler)
import Vervis.Model.Ident (ShrIdent)
getSharersR :: Handler Html
getSharersR = error "TODO"
getSharerR :: ShrIdent -> Handler Html
getSharerR shar = error "TODO"

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

@ -63,7 +63,7 @@ import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile)
import Vervis.TicketFilter (filterTickets)
import Vervis.Widget.Discussion (discussionW)
import Vervis.Widget.Person (sharerLinkW)
import Vervis.Widget.Sharer (personLinkW)
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
getTicketsR shar proj = do

2
src/Vervis/Widget/Discussion.hs
View file

@ -42,7 +42,7 @@ import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model
import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile)
import Vervis.Widget.Person (sharerLinkW)
import Vervis.Widget.Sharer (personLinkW)
messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget
messageW now shr msg reply =

42
src/Vervis/Widget/Sharer.hs Normal file
View file

@ -0,0 +1,42 @@
{- 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.Widget.Sharer
( sharerLinkW
, personLinkW
, groupLinkW
)
where
import Prelude
import Yesod.Core (Route)
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (ShrIdent, shr2text)
import Vervis.Settings (widgetFile)
link :: (ShrIdent -> Route App) -> Sharer -> Widget
link route sharer = $(widgetFile "sharer-link")
sharerLinkW :: Sharer -> Widget
sharerLinkW = link SharerR
personLinkW :: Sharer -> Widget
personLinkW = link PersonR
groupLinkW :: Sharer -> Widget
groupLinkW = link GroupR

2
templates/discussion/widget/message.hamlet
View file

@ -12,7 +12,7 @@ $# 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/>.
^{sharerLinkW shr}
^{personLinkW shr}
<div>
#{showTime $ messageCreated msg}
<div>

21
templates/group/list.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/>.
<p>
These are the groups registered in this Vervis instance.
<ul>
$forall Entity _sid sharer <- groups
<li>
^{groupLinkW sharer}

17
templates/group/new.hamlet Normal file
View file

@ -0,0 +1,17 @@
$# 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/>.
<form method=POST action=@{GroupsR} enctype=#{enctype}>
^{widget}
<input type=submit>

16
templates/group/one.hamlet Normal file
View file

@ -0,0 +1,16 @@
$# 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/>.
<p>
TODO list the group's members here, and later also roles etc.

2
templates/sharer-link.hamlet
View file

@ -12,7 +12,7 @@ $# 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/>.
<a href=@{PersonR $ sharerIdent sharer}>
<a href=@{route $ sharerIdent sharer}>
$maybe name <- sharerName sharer
#{name}
$nothing

2
templates/ticket/list.hamlet
View file

@ -32,7 +32,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<td>
<a href=@{TicketR shar proj number}>#{number}
<td>
^{sharerLinkW author}
^{personLinkW author}
<td>
<a href=@{TicketR shar proj number}>#{title}
<td>

4
templates/ticket/one.hamlet
View file

@ -21,13 +21,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
Created on #{formatTime defaultTimeLocale "%F" $ ticketCreated ticket} by
^{sharerLinkW author}
^{personLinkW author}
<p>
Status:
$if ticketDone ticket
Closed on #{formatTime defaultTimeLocale "%F" $ ticketClosed ticket} by
^{sharerLinkW closer}
^{personLinkW closer}
$else
Open

6
vervis.cabal
View file

@ -83,7 +83,9 @@ library
Vervis.Field.Person
Vervis.Field.Project
Vervis.Field.Repo
Vervis.Field.Sharer
Vervis.Form.Discussion
Vervis.Form.Group
Vervis.Form.Key
Vervis.Form.Person
Vervis.Form.Project
@ -96,6 +98,7 @@ library
Vervis.Handler.Common
Vervis.Handler.Discussion
Vervis.Handler.Git
Vervis.Handler.Group
Vervis.Handler.Home
Vervis.Handler.Key
Vervis.Handler.Person
@ -103,6 +106,7 @@ library
Vervis.Handler.Repo
Vervis.Handler.Repo.Darcs
Vervis.Handler.Repo.Git
Vervis.Handler.Sharer
Vervis.Handler.Ticket
Vervis.Import
Vervis.Import.NoFoundation
@ -122,8 +126,8 @@ library
Vervis.TicketFilter
Vervis.Widget
Vervis.Widget.Discussion
Vervis.Widget.Person
Vervis.Widget.Repo
Vervis.Widget.Sharer
-- other-modules:
default-extensions: TemplateHaskell
QuasiQuotes