Implement getOutboxR, both (trivial) HTML and AS2
This commit is contained in:
parent
f07b56c259
commit
7bcbe52274
14 changed files with 407 additions and 61 deletions
|
@ -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
|
||||
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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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_
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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.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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
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, ≪, ⋘.
|
||||
|
|
Loading…
Reference in a new issue