diff --git a/config/routes b/config/routes index 802b184..76b916e 100644 --- a/config/routes +++ b/config/routes @@ -51,14 +51,10 @@ /s SharersR GET /s/#ShrIdent SharerR GET -/p PeopleR GET POST -/p/!new PersonNewR GET -/p/#ShrIdent PersonR GET POST -/p/#ShrIdent/activities PersonActivitiesR GET +/p PeopleR GET /g GroupsR GET POST /g/!new GroupNewR GET -/g/#ShrIdent GroupR GET /g/#ShrIdent/m GroupMembersR GET POST /g/#ShrIdent/m/!new GroupMemberNewR GET /g/#ShrIdent/m/#ShrIdent GroupMemberR GET DELETE POST diff --git a/src/Vervis/ActivityStreams.hs b/src/Vervis/ActivityStreams.hs index 886212e..767d933 100644 --- a/src/Vervis/ActivityStreams.hs +++ b/src/Vervis/ActivityStreams.hs @@ -217,8 +217,8 @@ provideAS2 as2 = do makeActor ur shr = Actor - { actorId = ur $ PersonR shr + { actorId = ur $ SharerR shr , actorType = "Person" - , actorInbox = ur $ PersonR shr - , actorOutbox = ur $ PersonActivitiesR shr + , actorInbox = ur $ SharerR shr + , actorOutbox = ur $ error "We don't have outboxes yet" } diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 05dac52..9cc07f9 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -719,14 +719,10 @@ instance YesodBreadcrumbs App where SharerR shar -> (shr2text shar, Just SharersR) PeopleR -> ("People", Just HomeR) - PersonNewR -> ("New", Just PeopleR) - PersonR shar -> (shr2text shar, Just PeopleR) - PersonActivitiesR shr -> ("Activities", Just $ PersonR shr) GroupsR -> ("Groups", Just HomeR) GroupNewR -> ("New", Just GroupsR) - GroupR shar -> (shr2text shar, Just GroupsR) - GroupMembersR shar -> ("Members", Just $ GroupR shar) + GroupMembersR shar -> ("Members", Just $ SharerR shar) GroupMemberNewR shar -> ("New", Just $ GroupMembersR shar) GroupMemberR grp memb -> ( shr2text memb , Just $ GroupMembersR grp @@ -754,7 +750,7 @@ instance YesodBreadcrumbs App where , Just $ ProjectRoleOpsR shr rl ) - ReposR shar -> ("Repos", Just $ PersonR shar) + ReposR shar -> ("Repos", Just $ SharerR shar) RepoNewR shar -> ("New", Just $ ReposR shar) RepoR shar repo -> (rp2text repo, Just $ ReposR shar) RepoEditR shr rp -> ("Edit", Just $ RepoR shr rp) @@ -784,7 +780,7 @@ instance YesodBreadcrumbs App where GitRefDiscoverR _ _ -> ("", Nothing) GitUploadRequestR _ _ -> ("", Nothing) - ProjectsR shar -> ("Projects", Just $ PersonR shar) + ProjectsR shar -> ("Projects", Just $ SharerR shar) ProjectNewR shar -> ("New", Just $ ProjectsR shar) ProjectR shar proj -> ( prj2text proj , Just $ ProjectsR shar diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 58da5ad..6afc254 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,7 +17,7 @@ module Vervis.Handler.Group ( getGroupsR , postGroupsR , getGroupNewR - , getGroupR + , getGroup , getGroupMembersR , postGroupMembersR , getGroupMemberNewR @@ -37,7 +37,8 @@ import Database.Persist import Text.Blaze.Html (Html) import Yesod.Auth (requireAuthId) import Yesod.Core (defaultLayout, setMessage) -import Yesod.Core.Handler (redirect, lookupPostParam, notFound) +import Yesod.Core.Content (TypedContent) +import Yesod.Core.Handler import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, getBy404) @@ -86,7 +87,7 @@ postGroupsR = do , groupMemberJoined = now } insert_ member - redirect $ GroupR $ ngIdent ng + redirect $ SharerR $ ngIdent ng FormMissing -> do setMessage "Field(s) missing" defaultLayout $(widgetFile "group/new") @@ -99,12 +100,8 @@ 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 +getGroup :: ShrIdent -> Group -> Handler TypedContent +getGroup shar group = selectRep $ provideRep $ defaultLayout $(widgetFile "group/one") getGroupMembersR :: ShrIdent -> Handler Html diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index e02e204..da525a3 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -232,8 +232,8 @@ postOutboxR = do return $ sharerIdent sharer renderUrl <- getUrlRender let route2uri = route2uri' renderUrl - actor = route2uri $ PersonR shr - actorID = renderUrl $ PersonR shr + actor = route2uri $ SharerR shr + actorID = renderUrl $ SharerR shr appendPath u t = u { furiPath = furiPath u <> t } activity = CreateActivity Create { createId = appendPath actor "/fake-activity" diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index df5696c..6c1376f 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -16,11 +16,7 @@ module Vervis.Handler.Person ( getResendVerifyEmailR , getPeopleR - , postPeopleR - , getPersonNewR - , getPersonR - , postPersonR - , getPersonActivitiesR + , getPerson ) where @@ -69,10 +65,10 @@ getPeopleR = do return $ sharer ^. SharerIdent defaultLayout $(widgetFile "people") +{- -- | Create new user postPeopleR :: Handler Html postPeopleR = redirect $ AuthR newAccountR -{- settings <- getsYesod appSettings if appRegister settings then do @@ -118,9 +114,9 @@ postPeopleR = redirect $ AuthR newAccountR redirect PeopleR -} +{- getPersonNewR :: Handler Html getPersonNewR = redirect $ AuthR newAccountR -{- regEnabled <- getsYesod $ appRegister . appSettings if regEnabled then do @@ -129,18 +125,14 @@ getPersonNewR = redirect $ AuthR newAccountR else notFound -} -getPersonR :: ShrIdent -> Handler TypedContent -getPersonR shr = do - person <- runDB $ do - Entity sid _s <- getBy404 $ UniqueSharer shr - Entity _pid p <- getBy404 $ UniquePersonIdent sid - return p +getPerson :: ShrIdent -> Person -> Handler TypedContent +getPerson shr person = do renderUrl <- getUrlRender let route2uri route = case parseFedURI $ renderUrl route of Left e -> error $ "getRenderUrl produced invalid FedURI!!! " ++ e Right u -> u - me = route2uri $ PersonR shr + me = route2uri $ SharerR shr selectRep $ do provideRep $ do secure <- getSecure @@ -155,9 +147,3 @@ getPersonR shr = do , publicKey2 = Just $ Left $ route2uri ActorKey2R } } - -postPersonR :: ShrIdent -> Handler TypedContent -postPersonR _ = notFound - -getPersonActivitiesR :: ShrIdent -> Handler TypedContent -getPersonActivitiesR _ = notFound diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index 4515e20..58f5462 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -21,15 +21,20 @@ where import Prelude +import Control.Applicative ((<|>)) import Control.Monad.Logger (logWarn) +import Control.Monad.Trans.Maybe import Data.Monoid ((<>)) import Database.Persist import Text.Blaze.Html (Html) import Yesod.Core (defaultLayout) +import Yesod.Core.Content (TypedContent) import Yesod.Core.Handler (redirect, notFound) import Yesod.Persist.Core (runDB, getBy404) import Vervis.Foundation +import Vervis.Handler.Person +import Vervis.Handler.Group import Vervis.Model import Vervis.Model.Ident (ShrIdent, shr2text) import Vervis.Paginate @@ -46,21 +51,18 @@ getSharersR = do let pageNav = navWidget navModel defaultLayout $(widgetFile "sharer/list") -getSharerR :: ShrIdent -> Handler Html +getSharerR :: ShrIdent -> Handler TypedContent getSharerR shr = do - isperson <- runDB $ do + ment <- runDB $ do Entity sid _sharer <- getBy404 $ UniqueSharer shr - mp <- getBy $ UniquePersonIdent sid - case mp of - Just _ -> return $ Just True - Nothing -> do - mg <- getBy $ UniqueGroup sid - case mg of - Just _ -> return $ Just False - Nothing -> return Nothing - case isperson of + runMaybeT + $ Left <$> MaybeT (getBy $ UniquePersonIdent sid) + <|> Right <$> MaybeT (getBy $ UniqueGroup sid) + case ment of Nothing -> do $logWarn $ "Found non-person non-group sharer: " <> shr2text shr notFound - Just True -> redirect $ PersonR shr - Just False -> redirect $ GroupR shr + Just ent -> + case ent of + Left (Entity _ p) -> getPerson shr p + Right (Entity _ g) -> getGroup shr g diff --git a/src/Vervis/Widget/Sharer.hs b/src/Vervis/Widget/Sharer.hs index d223ea6..2f584f6 100644 --- a/src/Vervis/Widget/Sharer.hs +++ b/src/Vervis/Widget/Sharer.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -36,7 +36,7 @@ sharerLinkW :: Sharer -> Widget sharerLinkW = link SharerR personLinkW :: Sharer -> Widget -personLinkW = link PersonR +personLinkW = link SharerR groupLinkW :: Sharer -> Widget -groupLinkW = link GroupR +groupLinkW = link SharerR diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index e23db78..a582a94 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -50,7 +50,7 @@ $# . $forall (sharer, mproj, repo, vcs, ago) <- rows - #{shr2text sharer} + #{shr2text sharer} $maybe proj <- mproj #{prj2text proj} diff --git a/templates/people.hamlet b/templates/people.hamlet index 5a00d2d..c6ab0bd 100644 --- a/templates/people.hamlet +++ b/templates/people.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2019 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -18,4 +18,4 @@ $# .