diff --git a/config/routes b/config/routes index 3d3285d..0e45eb2 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 0378537..6e3e0ef 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -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) diff --git a/src/Vervis/Field/Person.hs b/src/Vervis/Field/Person.hs index 0ffd2b5..04eb22c 100644 --- a/src/Vervis/Field/Person.hs +++ b/src/Vervis/Field/Person.hs @@ -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 diff --git a/src/Vervis/Field/Sharer.hs b/src/Vervis/Field/Sharer.hs new file mode 100644 index 0000000..b490e96 --- /dev/null +++ b/src/Vervis/Field/Sharer.hs @@ -0,0 +1,66 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Form/Group.hs b/src/Vervis/Form/Group.hs new file mode 100644 index 0000000..2b87a55 --- /dev/null +++ b/src/Vervis/Form/Group.hs @@ -0,0 +1,44 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Form/Person.hs b/src/Vervis/Form/Person.hs index e5f176e..af42074 100644 --- a/src/Vervis/Form/Person.hs +++ b/src/Vervis/Form/Person.hs @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7333aba..e0dd891 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 + ) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs new file mode 100644 index 0000000..c080b16 --- /dev/null +++ b/src/Vervis/Handler/Group.hs @@ -0,0 +1,87 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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") diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 56e30b8..da73ab2 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -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 diff --git a/src/Vervis/Widget/Person.hs b/src/Vervis/Handler/Sharer.hs similarity index 65% rename from src/Vervis/Widget/Person.hs rename to src/Vervis/Handler/Sharer.hs index c0de691..1c73cf6 100644 --- a/src/Vervis/Widget/Person.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -13,18 +13,21 @@ - . -} -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" diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index dc812db..a104bbf 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -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 diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index c03093f..2f8207f 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -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 = diff --git a/src/Vervis/Widget/Sharer.hs b/src/Vervis/Widget/Sharer.hs new file mode 100644 index 0000000..d223ea6 --- /dev/null +++ b/src/Vervis/Widget/Sharer.hs @@ -0,0 +1,42 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index 3082780..01df6f0 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.hamlet @@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -^{sharerLinkW shr} +^{personLinkW shr}
#{showTime $ messageCreated msg}
diff --git a/templates/group/list.hamlet b/templates/group/list.hamlet new file mode 100644 index 0000000..fc77322 --- /dev/null +++ b/templates/group/list.hamlet @@ -0,0 +1,21 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ 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 +$# . + +

+ These are the groups registered in this Vervis instance. + +