Switch actor ID URIs to be /s/ACTOR instead of /p and /g

See Vervis ticket #60.
2019-02-14 22:13:58 +00:00 · 2019-02-14 22:13:58 +00:00 · e8ba301c6a
commit e8ba301c6a
parent 754709833a
10 changed files with 44 additions and 67 deletions
--- 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
--- 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"
        }
--- 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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"
--- 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- a/templates/homepage.hamlet
+++ b/templates/homepage.hamlet
@ -50,7 +50,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
  $forall (sharer, mproj, repo, vcs, ago) <- rows
    <tr>
      <td>
-        <a href=@{PersonR sharer}>#{shr2text sharer}
+        <a href=@{SharerR sharer}>#{shr2text sharer}
      <td>
        $maybe proj <- mproj
          <a href=@{ProjectR sharer proj}>#{prj2text proj}
--- a/templates/people.hamlet
+++ b/templates/people.hamlet
@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@ -18,4 +18,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <ul>
  $forall Value ident <- people
    <li>
-      <a href=@{PersonR ident}>#{shr2text ident}
+      <a href=@{SharerR ident}>#{shr2text ident}