diff --git a/src/Data/Paginate/Local.hs b/src/Data/Paginate/Local.hs index 5b79c20..8739616 100644 --- a/src/Data/Paginate/Local.hs +++ b/src/Data/Paginate/Local.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. - @@ -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 - curr <- psCurrent ps - let (offset, limit) = subseq (psPer ps) curr - (total, items) <- psSelect ps offset limit - let (d, m) = total `divMod` psPer ps - pages = if m == 0 then d else d + 1 - return (items, navModel ns curr pages) +paginateMaybe ps ns = do + mcurr <- psCurrent ps + traverse (paginate ps ns) mcurr + +paginateCount + :: Monad m + => 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 diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs index 0eadde4..c266941 100644 --- a/src/Network/FedURI.hs +++ b/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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 5b795ff..5a0b248 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index c45bf6b..cac86c3 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 368bb8e..1a35980 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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.Content (TypedContent) +import Yesod.Core 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_ diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 1c8cc45..721f3ae 100644 --- a/src/Vervis/Handler/Person.hs +++ b/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 diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 9bd2fde..e9454ea 100644 --- a/src/Vervis/Handler/Project.hs +++ b/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 diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index e3b2852..7cdd436 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index fa9cfba..2664155 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index f329d17..c295376 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/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] diff --git a/src/Vervis/Paginate.hs b/src/Vervis/Paginate.hs index d99a8a0..0c4bee0 100644 --- a/src/Vervis/Paginate.hs +++ b/src/Vervis/Paginate.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. - @@ -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.Handler (getCurrentRoute, lookupGetParam) +import Yesod.Core +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 = lookupGetParam pageParam <&> \ mpage -> - case mpage of - Nothing -> 1 - Just page -> - case second T.null <$> TR.decimal page of - Right (p, True) -> p - _ -> 1 +getCurrentPage :: MonadHandler m => m (Maybe Int) +getCurrentPage = do + mpage <- lookupGetParam pageParam + for mpage $ \ page -> + case second T.null <$> TR.decimal page of + Right (n, True) -> return n + _ -> invalidArgs [page] 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) -getPageAndNav select = paginate (paginateSettings select) navSettings + -> m (Maybe (Int, Int, f i, NavModel)) +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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index b2dfa68..57e0a12 100644 --- a/src/Web/ActivityPub.hs +++ b/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 - , collectionLast :: Maybe LocalURI + , collectionFirst :: Maybe LocalPageURI + , 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 f2l <$> o .:? "last") + <*> withHostMaybe host (fmap fp2lp <$> o .:? "first") + <*> 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) - <> "last" .=? (l2f host <$> last) + <> "first" .=? (lp2fp host <$> firzt) + <> "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) diff --git a/src/Yesod/FedURI.hs b/src/Yesod/FedURI.hs index e585215..a38bd55 100644 --- a/src/Yesod/FedURI.hs +++ b/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) -getEncodeRouteFed = toFed <$> getUrlRender +import Yesod.Paginate.Local + +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) -getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteFed +getEncodeRouteFed :: MonadHandler m => m (Text -> Route (HandlerSite m) -> FedURI) +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 diff --git a/src/Yesod/Paginate/Local.hs b/src/Yesod/Paginate/Local.hs index fc91c07..f4d70a9 100644 --- a/src/Yesod/Paginate/Local.hs +++ b/src/Yesod/Paginate/Local.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. - @@ -14,8 +14,10 @@ -} module Yesod.Paginate.Local - ( -- * Settings - NavWidgetSettings () + ( -- * Typeclass + 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, ≪, ⋘.