Implement getOutboxR, both (trivial) HTML and AS2

src/Data/Paginate/Local.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.
  -
@@ -42,13 +42,16 @@ module Data.Paginate.Local
     , nmNextJumps
     , nmLast
       -- ** Paginate
-    , paginate
+    , paginateMaybe
+    , paginateCount
+    , paginateTop
     )
 where
 
 import Prelude
 
 import Data.Default.Class
+import Data.Maybe
 import Data.Ratio
 
 data JumpSettings = JumpSettings
@@ -93,7 +96,7 @@ data PaginateSettings m f i = PaginateSettings
       -- the limit says how many items you should take after skipping.
       psSelect  :: Int -> Int -> m (Int, f i)
       -- | Get the current page
-    , psCurrent :: m Int
+    , psCurrent :: m (Maybe Int)
       -- | How many items to list in one page
     , psPer     :: Int
     }
@@ -143,19 +146,57 @@ navModel ns curr total = NavModel
     , nmLast      = navEdges ns
     }
 
--- | Get a page's contents and its navigation controls.
 paginate
+    :: Monad m
+    => PaginateSettings m f i
+    -> NavSettings
+    -> Int
+    -> m (Int, Int, f i, NavModel)
+paginate ps ns curr = do
+    let (offset, limit) = subseq (psPer ps) curr
+    (total, items) <- psSelect ps offset limit
+    let pages =
+            let (d, m) = total `divMod` psPer ps
+            in  if m == 0 then d else d + 1
+    return (total, pages, items, navModel ns curr pages)
+
+
+-- | Get a page's contents and its navigation controls.
+paginateMaybe
     :: Monad m
     => PaginateSettings m f i
     -- ^ How to get the page contents and split them into pages
     -> NavSettings
     -- ^ How to build page navigation controls for the user interface
-    -> m (f i, NavModel)
+    -> m (Maybe (Int, Int, f i, NavModel))
     -- ^ The items in the current page, and the navigation controls
-paginate ps ns = do
+paginateMaybe ps ns = do
-    curr <- psCurrent ps
+    mcurr <- psCurrent ps
-    let (offset, limit) = subseq (psPer ps) curr
+    traverse (paginate ps ns) mcurr
-    (total, items) <- psSelect ps offset limit
+
-    let (d, m) = total `divMod` psPer ps
+paginateCount
-        pages = if m == 0 then d else d + 1
+    :: Monad m
-    return (items, navModel ns curr pages)
+    => PaginateSettings m f i
+    -> NavSettings
+    -> m Int
+    -> m (Int, Int, Maybe (f i, NavModel))
+paginateCount ps ns count = do
+    mresult <- paginateMaybe ps ns
+    case mresult of
+        Nothing -> do
+            total <- count
+            let pages =
+                    let (d, m) = total `divMod` psPer ps
+                    in  if m == 0 then d else d + 1
+            return (total, pages, Nothing)
+        Just (total, pages, items, nav) ->
+            return (total, pages, Just (items, nav))
+
+paginateTop
+    :: Monad m
+    => PaginateSettings m f i
+    -> NavSettings
+    -> m (Int, Int, f i, NavModel)
+paginateTop ps ns = do
+    curr <- fromMaybe 1 <$> psCurrent ps
+    paginate ps ns curr

src/Network/FedURI.hs

@@ -30,6 +30,11 @@ module Network.FedURI
     , LocalURI (..)
     , l2f
     , f2l
+
+    , FedPageURI (..)
+    , LocalPageURI (..)
+    , lp2fp
+    , fp2lp
     )
 where
 
@@ -42,12 +47,15 @@ import Data.Char
 import Data.Hashable
 import Data.Maybe (fromJust)
 import Data.Text (Text)
+import Data.Text.Encoding
 import Database.Persist.Class (PersistField (..))
 import Database.Persist.Sql (PersistFieldSql (..))
 import GHC.Generics (Generic)
+import Network.HTTP.Types.URI
 import Network.URI
+import Text.Read
 
-import qualified Data.Text as T (pack, unpack, stripPrefix)
+import qualified Data.Text as T
 
 -- | An absolute URI with the following properties:
 --
@@ -127,6 +135,86 @@ toURI (FedURI h p f) = URI
 renderFedURI :: FedURI -> Text
 renderFedURI = T.pack . flip (uriToString id) "" . toURI
 
+-- | A 'FedURI' with a page number specified as a query parameter
+data FedPageURI = FedPageURI
+    { fpuriResource :: FedURI
+    , fpuriParam    :: Text
+    , fpuriPage     :: Int
+    }
+    deriving (Eq, Generic)
+
+instance Hashable FedPageURI
+
+instance FromJSON FedPageURI where
+    parseJSON = withText "FedPageURI" $ either fail return . parseFedPageURI
+
+instance ToJSON FedPageURI where
+    toJSON = error "toJSON FedPageURI"
+    toEncoding = toEncoding . renderFedPageURI
+
+parseFedPageURI :: Text -> Either String FedPageURI
+parseFedPageURI t = do
+    uri <- case parseURI $ T.unpack t of
+        Nothing -> Left "Invalid absolute URI"
+        Just u -> Right u
+    if uriScheme uri == "https:"
+        then Right ()
+        else Left "URI scheme isn't https"
+    URIAuth ui h p <- case uriAuthority uri of
+        Nothing -> Left "URI has empty authority"
+        Just a -> Right a
+    if ui == ""
+        then Right ()
+        else Left "URI has non-empty userinfo"
+    if p == ""
+        then Right ()
+        else Left "URI has non-empty port"
+    if any (== '.') h
+        then Right ()
+        else Left "Host doesn't contain periods"
+    if any isAsciiLetter h
+        then Right ()
+        else Left "Host doesn't contain ASCII letters"
+    (param, mval) <-
+        case parseQueryText $ encodeUtf8 $ T.pack $ uriQuery uri of
+            [] -> Left "URI query is empty"
+            [qp] -> Right qp
+            _ -> Left "URI has multiple query parameters"
+    val <-
+        case mval of
+            Nothing -> Left "URI query parameter doesn't have a value"
+            Just v -> Right v
+    page <-
+        case readMaybe $ T.unpack val of
+            Nothing -> Left "URI query param value isn't an integer"
+            Just n -> Right n
+    if page >= 1
+        then Right ()
+        else Left "URI page number isn't positive"
+    Right FedPageURI
+        { fpuriResource = FedURI
+            { furiHost     = T.pack h
+            , furiPath     = T.pack $ uriPath uri
+            , furiFragment = T.pack $ uriFragment uri
+            }
+        , fpuriParam = param
+        , fpuriPage  = page
+        }
+    where
+    isAsciiLetter c = isAsciiLower c || isAsciiUpper c
+
+toPageURI :: FedPageURI -> URI
+toPageURI (FedPageURI (FedURI h p f) qp qv) = URI
+    { uriScheme    = "https:"
+    , uriAuthority = Just $ URIAuth "" (T.unpack h) ""
+    , uriPath      = T.unpack p
+    , uriQuery     = "?" ++ T.unpack qp ++ "=" ++ show qv
+    , uriFragment  = T.unpack f
+    }
+
+renderFedPageURI :: FedPageURI -> Text
+renderFedPageURI = T.pack . flip (uriToString id) "" . toPageURI
+
 {-
 newtype InstanceURI = InstanceURI
     { iuriHost :: Text
@@ -167,3 +255,18 @@ l2f h (LocalURI p f) = FedURI h p f
 
 f2l :: FedURI -> (Text, LocalURI)
 f2l (FedURI h p f) = (h, LocalURI p f)
+
+data LocalPageURI = LocalPageURI
+    { lpuriResource :: LocalURI
+    , lpuriParam    :: Text
+    , lpuriPage     :: Int
+    }
+    deriving Eq
+
+lp2fp :: Text -> LocalPageURI -> FedPageURI
+lp2fp h (LocalPageURI lu p n) = FedPageURI (l2f h lu) p n
+
+fp2lp :: FedPageURI -> (Text, LocalPageURI)
+fp2lp (FedPageURI fu p n) =
+    let (h, lu) = f2l fu
+    in  (h, LocalPageURI lu p n)

src/Vervis/Foundation.hs

@@ -79,6 +79,7 @@ import Yesod.MonadSite
 
 import Text.Email.Local
 import Text.Jasmine.Local (discardm)
+import Yesod.Paginate.Local
 
 import Vervis.Access
 import Vervis.ActorKey
@@ -664,6 +665,9 @@ instance YesodActivityPub App where
                     else (renderUrl ActorKey2R, akey2)
         return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
 
+instance YesodPaginate App where
+    sitePageParamName _ = "page"
+
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of
         StaticR _                        -> ("", Nothing)

src/Vervis/Handler/Discussion.hs

@@ -112,7 +112,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
     lm <- get404 lmid
     unless (localMessageAuthor lm == pid) notFound
     m <- getJust $ localMessageRest lm
-    route2fed <- getEncodeRouteFed
+    route2fed <- getEncodeRouteHome
     uContext <- do
         let did = messageRoot m
         mt <- getValBy $ UniqueTicketDiscussion did
@@ -178,7 +178,7 @@ postTopReply hDest recipsA recipsC context replyP after = do
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
             FormSuccess nm -> return $ nmContent nm
-        encodeRouteFed <- getEncodeRouteFed
+        encodeRouteFed <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
         let encodeRecipRoute = l2f hDest . encodeRouteLocal
         shrAuthor <- do
@@ -242,7 +242,7 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
             FormSuccess nm -> return $ nmContent nm
-        encodeRouteFed <- getEncodeRouteFed
+        encodeRouteFed <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
         let encodeRecipRoute = l2f hDest . encodeRouteLocal
         (shrAuthor, uParent) <- do

src/Vervis/Handler/Inbox.hs

@@ -53,7 +53,7 @@ import Data.PEM (PEM (..))
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8')
 import Data.Text.Lazy.Encoding (decodeUtf8)
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock
 import Data.Time.Interval (TimeInterval, toTimeUnit)
 import Data.Time.Units (Second)
 import Database.Persist
@@ -65,8 +65,7 @@ import Text.Blaze.Html (Html)
 import Text.Shakespeare.I18N (RenderMessage)
 import UnliftIO.Exception (try)
 import Yesod.Auth (requireAuth)
-import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml, HandlerSite)
+import Yesod.Core
-import Yesod.Core.Content (TypedContent)
 import Yesod.Core.Json (requireJsonBody)
 import Yesod.Core.Handler
 import Yesod.Form.Fields (Textarea (..), textField, textareaField)
@@ -99,6 +98,9 @@ import Yesod.Hashids
 import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP
 
 import Data.Aeson.Local
+import Data.EventTime.Local
+import Data.Paginate.Local
+import Data.Time.Clock.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
@@ -138,7 +140,7 @@ getInboxR = do
 
 getSharerInboxR :: ShrIdent -> Handler TypedContent
 getSharerInboxR shr = do
-    (items, navModel) <- getPageAndNav $ \ off lim -> runDB $ do
+    (_, _, items, navModel) <- getPageAndNavTop $ \ off lim -> runDB $ do
         sid <- getKeyBy404 $ UniqueSharer shr
         pid <- getKeyBy404 $ UniquePersonIdent sid
         (,) <$> countItems pid
@@ -306,7 +308,61 @@ getPublishR = do
     defaultLayout $ activityWidget shr widget enctype
 
 getOutboxR :: ShrIdent -> Handler TypedContent
-getOutboxR = error "Not implemented yet"
+getOutboxR shr = do
+    (total, pages, mpage) <- runDB $ do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        pid <- getKeyBy404 $ UniquePersonIdent sid
+        let countAllItems = count [OutboxItemPerson ==. pid]
+            selectItems off lim = selectList [OutboxItemPerson ==. pid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
+        getPageAndNavCount countAllItems selectItems
+    let here = OutboxR shr
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRoutePageLocal <- getEncodeRoutePageLocal
+    let pageUrl = encodeRoutePageLocal here
+    host <- getsYesod $ appInstanceHost . appSettings
+    selectRep $ do
+        case mpage of
+            Nothing -> do
+                provideAP $ pure $ Doc host $ Collection
+                    { collectionId         = encodeRouteLocal here
+                    , collectionType       = CollectionTypeOrdered
+                    , collectionTotalItems = Just total
+                    , collectionCurrent    = Nothing
+                    , collectionFirst      = Just $ pageUrl 1
+                    , collectionLast       = Just $ pageUrl pages
+                    , collectionItems      = [] :: [Text]
+                    }
+                provideRep (redirectFirstPage here :: Handler Html)
+            Just (items, navModel) -> do
+                let current = nmCurrent navModel
+                provideAP $ pure $ Doc host $ CollectionPage
+                    { collectionPageId         = pageUrl current
+                    , collectionPageType       = CollectionPageTypeOrdered
+                    , collectionPageTotalItems = Nothing
+                    , collectionPageCurrent    = Just $ pageUrl current
+                    , collectionPageFirst      = Just $ pageUrl 1
+                    , collectionPageLast       = Just $ pageUrl pages
+                    , collectionPagePartOf     = encodeRouteLocal here
+                    , collectionPagePrev       =
+                        if current > 1
+                            then Just $ pageUrl $ current - 1
+                            else Nothing
+                    , collectionPageNext       =
+                        if current < pages
+                            then Just $ pageUrl $ current + 1
+                            else Nothing
+                    , collectionPageStartIndex = Nothing
+                    , collectionPageItems      = map (persistJSONValue . outboxItemActivity . entityVal) items
+                    }
+                provideRep $ do
+                    let pageNav = navWidget navModel
+                    now <- liftIO getCurrentTime
+                    let showTime =
+                            showEventTime .
+                            intervalToEventTime .
+                            FriendlyConvert .
+                            diffUTCTime now
+                    defaultLayout $(widgetFile "person/outbox")
 
 getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
 getOutboxItemR shr obkhid = do
@@ -335,7 +391,7 @@ postOutboxR shrAuthor = do
                 FormMissing -> throwE "Field(s) missing"
                 FormFailure _l -> throwE "Invalid input, see below"
                 FormSuccess r -> return r
-        encodeRouteFed <- getEncodeRouteFed
+        encodeRouteFed <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
         let encodeRecipRoute = l2f hTicket . encodeRouteLocal
             uTicket = encodeRecipRoute $ TicketR shrTicket prj num
@@ -376,7 +432,7 @@ getActorKey choose route = selectRep $ provideAP $ do
     actorKey <-
         liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
         getsYesod appActorKeys
-    route2uri <- getEncodeRouteFed
+    route2uri <- getEncodeRouteHome
     let (host, id_) = f2l $ route2uri route
     return $ Doc host PublicKey
         { publicKeyId       = id_

src/Vervis/Handler/Person.hs

@@ -129,7 +129,7 @@ getPersonNewR = redirect $ AuthR newAccountR
 
 getPerson :: ShrIdent -> Sharer -> Person -> Handler TypedContent
 getPerson shr sharer person = do
-    route2fed <- getEncodeRouteFed
+    route2fed <- getEncodeRouteHome
     route2local <- getEncodeRouteLocal
     let (host, me) = f2l $ route2fed $ SharerR shr
     selectRep $ do

src/Vervis/Handler/Project.hs

@@ -129,7 +129,7 @@ getProjectR shar proj = selectRep $ do
             Entity sid _s <- getBy404 $ UniqueSharer shar
             Entity _pid p <- getBy404 $ UniqueProject proj sid
             return p
-        route2fed <- getEncodeRouteFed
+        route2fed <- getEncodeRouteHome
         route2local <- getEncodeRouteLocal
         let (host, me) = f2l $ route2fed $ ProjectR shar proj
         return $ Doc host Actor

src/Vervis/Handler/Repo/Darcs.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -88,7 +88,7 @@ getDarcsRepoSource repository user repo dir = do
 getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler TypedContent
 getDarcsRepoHeadChanges shar repo = do
     path <- askRepoDir shar repo
-    (entries, navModel) <- getPageAndNav $
+    (_, _, entries, navModel) <- getPageAndNavTop $
         \ o l -> do
             mv <- liftIO $ D.readChangesView path o l
             case mv of

src/Vervis/Handler/Repo/Git.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -105,7 +105,7 @@ getGitRepoChanges shar repo ref = do
     (branches, tags) <- liftIO $ G.listRefs path
     if ref `S.member` branches || ref `S.member` tags
         then do
-            (entries, navModel) <- getPageAndNav $
+            (_, _, entries, navModel) <- getPageAndNavTop $
                 \ o l -> liftIO $ G.readChangesView path ref o l
             let refSelect = refSelectW shar repo branches tags
                 changes = changesW shar repo entries

src/Vervis/Handler/Sharer.hs

@@ -43,7 +43,7 @@ import Vervis.Widget.Sharer (sharerLinkW)
 
 getSharersR :: Handler Html
 getSharersR = do
-    (sharers, navModel) <- getPageAndNav $ \ off lim ->
+    (_, _, sharers, navModel) <- getPageAndNavTop $ \ off lim ->
         runDB $ do
             total <- count ([] :: [Filter Sharer])
             ss <- selectList [] [OffsetBy off, LimitTo lim, Asc SharerIdent]

src/Vervis/Paginate.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.
  -
@@ -14,7 +14,11 @@
  -}
 
 module Vervis.Paginate
-    ( getPageAndNav
+    ( redirectFirstPage
+    , getPageAndNavMaybe
+    , getPageAndNavCount
+    , getPageAndNavRedirect
+    , getPageAndNavTop
     , navWidget
     )
 where
@@ -26,9 +30,10 @@ import Data.Default.Class (def)
 import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Data.Text (Text)
+import Data.Traversable
 import Formatting (sformat, stext, int, (%))
-import Yesod.Core (MonadHandler (HandlerSite))
+import Yesod.Core
-import Yesod.Core.Handler (getCurrentRoute, lookupGetParam)
+import Yesod.Core.Handler
 import Yesod.Core.Widget (WidgetT)
 
 import qualified Data.Text as T (null, pack)
@@ -44,14 +49,13 @@ navSettings = def
 pageParam :: Text
 pageParam = "page"
 
-getCurrentPage :: MonadHandler m => m Int
+getCurrentPage :: MonadHandler m => m (Maybe Int)
-getCurrentPage = lookupGetParam pageParam <&> \ mpage ->
+getCurrentPage = do
-    case mpage of
+    mpage <- lookupGetParam pageParam
-        Nothing   -> 1
+    for mpage $ \ page ->
-        Just page ->
+        case second T.null <$> TR.decimal page of
-            case second T.null <$> TR.decimal page of
+            Right (n, True) -> return n
-                Right (p, True) -> p
+            _               -> invalidArgs [page]
-                _               -> 1
 
 paginateSettings
     :: MonadHandler m
@@ -65,12 +69,42 @@ paginateSettings select = def
 navWidgetSettings :: NavWidgetSettings
 navWidgetSettings = def
 
-getPageAndNav
+redirectFirstPage :: MonadHandler m => Route (HandlerSite m) -> m a
+redirectFirstPage route = redirect (route, [(pageParam, "1")])
+
+getPageAndNavMaybe
     :: MonadHandler m
     => (Int -> Int -> m (Int, f i))
     -- ^ Given offset and limit, get total number of items and chosen subset
-    -> m (f i, NavModel)
+    -> m (Maybe (Int, Int, f i, NavModel))
-getPageAndNav select = paginate (paginateSettings select) navSettings
+getPageAndNavMaybe select = paginateMaybe (paginateSettings select) navSettings
+
+getPageAndNavCount
+    :: MonadHandler m
+    => m Int
+    -> (Int -> Int -> m (f i))
+    -> m (Int, Int, Maybe (f i, NavModel))
+getPageAndNavCount count select =
+    paginateCount (paginateSettings select') navSettings count
+    where
+    select' off lim = (,) <$> count <*> select off lim
+
+getPageAndNavRedirect
+    :: MonadHandler m
+    => Route (HandlerSite m)
+    -> (Int -> Int -> m (Int, f i))
+    -> m (Int, Int, f i, NavModel)
+getPageAndNavRedirect route select = do
+    mresult <- paginateMaybe (paginateSettings select) navSettings
+    case mresult of
+        Nothing -> redirectFirstPage route
+        Just r -> return r
+
+getPageAndNavTop
+    :: MonadHandler m
+    => (Int -> Int -> m (Int, f i))
+    -> m (Int, Int, f i, NavModel)
+getPageAndNavTop select = paginateTop (paginateSettings select) navSettings
 
 navWidget :: NavModel -> WidgetT site IO ()
 navWidget nm = do

src/Web/ActivityPub.hs

@@ -33,6 +33,8 @@ module Web.ActivityPub
     , Actor (..)
     , CollectionType (..)
     , Collection (..)
+    , CollectionPageType (..)
+    , CollectionPage (..)
     , Recipient (..)
 
       -- * Activity
@@ -352,8 +354,8 @@ data Collection a = Collection
     , collectionType       :: CollectionType
     , collectionTotalItems :: Maybe Int
     , collectionCurrent    :: Maybe LocalURI
-    , collectionFirst      :: Maybe LocalURI
+    , collectionFirst      :: Maybe LocalPageURI
-    , collectionLast       :: Maybe LocalURI
+    , collectionLast       :: Maybe LocalPageURI
     , collectionItems      :: [a]
     }
 
@@ -366,16 +368,77 @@ instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where
                 <$> o .: "type"
                 <*> o .:? "totalItems"
                 <*> withHostMaybe host (fmap f2l <$> o .:? "current")
-                <*> withHostMaybe host (fmap f2l <$> o .:? "first")
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "first")
-                <*> withHostMaybe host (fmap f2l <$> o .:? "last")
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "last")
                 <*> optional (o .: "items" <|> o .: "orderedItems") .!= []
     toSeries host (Collection id_ typ total curr firzt last items)
         =  "id"         .=  l2f host id_
         <> "type"       .=  typ
         <> "totalItems" .=? total
         <> "current"    .=? (l2f host <$> curr)
-        <> "first"      .=? (l2f host <$> firzt)
+        <> "first"      .=? (lp2fp host <$> firzt)
-        <> "last"       .=? (l2f host <$> last)
+        <> "last"       .=? (lp2fp host <$> last)
+        <> "items"      .=% items
+
+data CollectionPageType
+    = CollectionPageTypeUnordered
+    | CollectionPageTypeOrdered
+
+instance FromJSON CollectionPageType where
+    parseJSON = withText "CollectionPageType" parse
+        where
+        parse "CollectionPage"        = pure CollectionPageTypeUnordered
+        parse "OrderedCollectionPage" = pure CollectionPageTypeOrdered
+        parse t = fail $ "Unknown collection page type: " ++ T.unpack t
+
+instance ToJSON CollectionPageType where
+    toJSON = error "toJSON CollectionPageType"
+    toEncoding ct =
+        toEncoding $ case ct of
+            CollectionPageTypeUnordered -> "CollectionPage" :: Text
+            CollectionPageTypeOrdered   -> "OrderedCollectionPage"
+
+data CollectionPage a = CollectionPage
+    { collectionPageId         :: LocalPageURI
+    , collectionPageType       :: CollectionPageType
+    , collectionPageTotalItems :: Maybe Int
+    , collectionPageCurrent    :: Maybe LocalPageURI
+    , collectionPageFirst      :: Maybe LocalPageURI
+    , collectionPageLast       :: Maybe LocalPageURI
+    , collectionPagePartOf     :: LocalURI
+    , collectionPagePrev       :: Maybe LocalPageURI
+    , collectionPageNext       :: Maybe LocalPageURI
+    , collectionPageStartIndex :: Maybe Int
+    , collectionPageItems      :: [a]
+    }
+
+instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
+    jsonldContext _ = ContextAS2
+    parseObject o = do
+        (host, id_) <- fp2lp <$> o .: "id"
+        fmap (host,) $
+            CollectionPage id_
+                <$> o .: "type"
+                <*> o .:? "totalItems"
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "current")
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "first")
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "last")
+                <*> withHost host (f2l <$> o .: "partOf")
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "prev")
+                <*> withHostMaybe host (fmap fp2lp <$> o .:? "next")
+                <*> o .:? "startIndex"
+                <*> optional (o .: "items" <|> o .: "orderedItems") .!= []
+    toSeries host (CollectionPage id_ typ total curr firzt last partOf prev next ind items)
+        =  "id"         .=  lp2fp host id_
+        <> "type"       .=  typ
+        <> "totalItems" .=? total
+        <> "current"    .=? (lp2fp host <$> curr)
+        <> "first"      .=? (lp2fp host <$> firzt)
+        <> "last"       .=? (lp2fp host <$> last)
+        <> "partOf"     .=  (l2f host partOf)
+        <> "prev"       .=? (lp2fp host <$> prev)
+        <> "next"       .=? (lp2fp host <$> next)
+        <> "startIndex" .=? ind
         <> "items"      .=% items
 
 data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI)

src/Yesod/FedURI.hs

@@ -14,15 +14,20 @@
  -}
 
 module Yesod.FedURI
-    ( getEncodeRouteFed
+    ( getEncodeRouteLocal
-    , getEncodeRouteLocal
+    , getEncodeRouteHome
+    , getEncodeRouteFed
     , decodeRouteLocal
+    , getEncodeRoutePageLocal
+    , getEncodeRoutePageHome
+    , getEncodeRoutePageFed
     )
 where
 
 import Prelude
 
 import Control.Monad
+import Data.Text (Text)
 import Data.Text.Encoding
 import Network.HTTP.Types.URI
 import Yesod.Core
@@ -32,16 +37,26 @@ import qualified Data.Text as T
 
 import Network.FedURI
 
-getEncodeRouteFed :: MonadHandler m => m (Route (HandlerSite m) -> FedURI)
+import Yesod.Paginate.Local
-getEncodeRouteFed = toFed <$> getUrlRender
+
+getEncodeRouteLocal :: MonadHandler m => m (Route (HandlerSite m) -> LocalURI)
+getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteHome
+
+getEncodeRouteHome :: MonadHandler m => m (Route (HandlerSite m) -> FedURI)
+getEncodeRouteHome = toFed <$> getUrlRender
     where
     toFed renderUrl route =
         case parseFedURI $ renderUrl route of
             Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
             Right u -> u
 
-getEncodeRouteLocal :: MonadHandler m => m (Route (HandlerSite m) -> LocalURI)
+getEncodeRouteFed :: MonadHandler m => m (Text -> Route (HandlerSite m) -> FedURI)
-getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteFed
+getEncodeRouteFed = toFed <$> getUrlRender
+    where
+    toFed renderUrl host route =
+        case parseFedURI $ renderUrl route of
+            Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
+            Right u -> u { furiHost = host }
 
 decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
 decodeRouteLocal =
@@ -51,3 +66,28 @@ decodeRouteLocal =
         if T.null $ luriFragment lu
             then Just lu
             else Nothing
+
+getEncodeRoutePageLocal
+    :: (MonadHandler m, YesodPaginate (HandlerSite m))
+    => m (Route (HandlerSite m) -> Int -> LocalPageURI)
+getEncodeRoutePageLocal = do
+    encodeRouteLocal <- getEncodeRouteLocal
+    param <- getsYesod sitePageParamName
+    return $ \ route page -> LocalPageURI (encodeRouteLocal route) param page
+
+getEncodeRoutePageHome
+    :: (MonadHandler m, YesodPaginate (HandlerSite m))
+    => m (Route (HandlerSite m) -> Int -> FedPageURI)
+getEncodeRoutePageHome = do
+    encodeRouteHome <- getEncodeRouteHome
+    param <- getsYesod sitePageParamName
+    return $ \ route page -> FedPageURI (encodeRouteHome route) param page
+
+getEncodeRoutePageFed
+    :: (MonadHandler m, YesodPaginate (HandlerSite m))
+    => m (Text -> Route (HandlerSite m) -> Int -> FedPageURI)
+getEncodeRoutePageFed = do
+    encodeRouteFed <- getEncodeRouteFed
+    param <- getsYesod sitePageParamName
+    return $
+        \ host route page -> FedPageURI (encodeRouteFed host route) param page

src/Yesod/Paginate/Local.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.
  -
@@ -14,8 +14,10 @@
  -}
 
 module Yesod.Paginate.Local
-    ( -- * Settings
+    ( -- * Typeclass
-      NavWidgetSettings ()
+      YesodPaginate (..)
+       -- * Settings
+    , NavWidgetSettings ()
     , nwsFirst
     , nwsLast
     , nwsPrev
@@ -31,7 +33,7 @@ import Prelude
 import Data.Default.Class
 import Data.Text (Text)
 import Text.Blaze (ToMarkup)
-import Yesod.Core (RenderRoute (..))
+import Yesod.Core
 import Yesod.Core.Widget (WidgetT, whamlet)
 
 import qualified Data.Text as T (pack)
@@ -39,6 +41,9 @@ import qualified Formatting as F
 
 import Data.Paginate.Local
 
+class Yesod site => YesodPaginate site where
+    sitePageParamName :: site -> Text
+
 -- | Settings for building a page navigation UI widget.
 data NavWidgetSettings = NavWidgetSettings
     { -- | Label for the first page link. Examples: 1, First, ≪, ⋘.