diff --git a/config/routes b/config/routes index c008b2f..aa36a6f 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Vervis/Field.hs b/src/Vervis/Field/Person.hs similarity index 90% rename from src/Vervis/Field.hs rename to src/Vervis/Field/Person.hs index 4329753..01ee9e5 100644 --- a/src/Vervis/Field.hs +++ b/src/Vervis/Field/Person.hs @@ -13,7 +13,7 @@ - . -} -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 diff --git a/src/Vervis/Field/Project.hs b/src/Vervis/Field/Project.hs new file mode 100644 index 0000000..1f43e74 --- /dev/null +++ b/src/Vervis/Field/Project.hs @@ -0,0 +1,52 @@ +{- 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.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 diff --git a/src/Vervis/Form.hs b/src/Vervis/Form/Person.hs similarity index 90% rename from src/Vervis/Form.hs rename to src/Vervis/Form/Person.hs index e050f99..2c6d6db 100644 --- a/src/Vervis/Form.hs +++ b/src/Vervis/Form/Person.hs @@ -13,7 +13,7 @@ - . -} -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 diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs new file mode 100644 index 0000000..3245a4e --- /dev/null +++ b/src/Vervis/Form/Project.hs @@ -0,0 +1,33 @@ +{- 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.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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index d8b69d6..c36fb8b 100644 --- a/src/Vervis/Foundation.hs +++ b/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. - 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 diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs index 617e18c..c7e21d2 100644 --- a/src/Vervis/Handler/Home.hs +++ b/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 - 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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index f6292ef..b4820dd 100644 --- a/src/Vervis/Handler/Person.hs +++ b/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) diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 602f26e..6f92769 100644 --- a/src/Vervis/Handler/Project.hs +++ b/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 diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index 63c5dbd..0e8ac89 100644 --- a/templates/personal-overview.hamlet +++ b/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 $# . +

Vervis > Overview for #{ident} +

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. + +

Projects + +