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