diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 1946788..46a74cf 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -22,6 +22,7 @@ module Vervis.Handler.Repo.Git ) where +import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.Git.Graph import Data.Git.Harder @@ -67,10 +68,12 @@ import qualified Web.ActivityPub as AP import Data.ByteString.Char8.Local (takeLine) import Data.Git.Local +import Data.Paginate.Local import Text.FilePath.Local (breakExt) import Vervis.ActivityPub import Vervis.ChangeFeed (changeFeed) +import Vervis.Changes import Vervis.Form.Repo import Vervis.Foundation import Vervis.Path @@ -134,19 +137,57 @@ getGitRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler TypedContent getGitRepoChanges shar repo ref = do path <- askRepoDir shar repo (branches, tags) <- liftIO $ G.listRefs path - if ref `S.member` branches || ref `S.member` tags - then do - (_, _, entries, navModel) <- getPageAndNavTop $ - \ o l -> liftIO $ G.readChangesView path ref o l - let refSelect = refSelectW shar repo branches tags - changes = changesW shar repo entries - pageNav = navWidget navModel - feed = changeFeed shar repo (Just ref) VCSGit entries - selectRep $ do - provideRep $ defaultLayout $(widgetFile "repo/changes-git") - provideRep $ atomFeed feed - provideRep $ rssFeed feed - else notFound + unless (ref `S.member` branches || ref `S.member` tags) + notFound + let here = RepoChangesR shar repo ref + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeRoutePageLocal <- getEncodeRoutePageLocal + let pageUrl = encodeRoutePageLocal here + getChanges o l = liftIO $ G.readChangesView path ref o l + mpage <- getPageAndNavMaybe getChanges + case mpage of + Nothing -> do + (total, pages, _, _) <- getPageAndNavTop getChanges + let collection = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just total + , collectionCurrent = Nothing + , collectionFirst = Just $ pageUrl 1 + , collectionLast = Just $ pageUrl pages + , collectionItems = [] :: [Text] + } + provideHtmlAndAP collection $ redirectFirstPage here + Just (_total, pages, items, navModel) -> + let current = nmCurrent navModel + page = 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 (encodeRouteHome . RepoPatchR shar repo . leHash) + items + } + feed = changeFeed shar repo (Just ref) VCSGit items + in provideHtmlFeedAndAP page feed $ + let refSelect = refSelectW shar repo branches tags + changes = changesW shar repo items + pageNav = navWidget navModel + in $(widgetFile "repo/changes-git") getGitPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent getGitPatch shr rp ref = do diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 10ebc12..2650509 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -23,11 +23,13 @@ module Yesod.ActivityPub , provideHtmlAndAP , provideHtmlAndAP' , provideHtmlAndAP'' + , provideHtmlFeedAndAP ) where import Control.Exception import Control.Monad.Logger.CallStack +import Control.Monad.Trans.Writer import Data.Aeson import Data.Aeson.Encode.Pretty import Data.ByteString (ByteString) @@ -35,10 +37,14 @@ import Data.Foldable import Data.Function import Data.List import Data.List.NonEmpty (NonEmpty) +import Data.Semigroup import Data.Text (Text) import Network.HTTP.Client import Network.HTTP.Types.Header +import Yesod.AtomFeed import Yesod.Core hiding (logError, logDebug) +import Yesod.Feed +import Yesod.RssFeed import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M @@ -192,12 +198,17 @@ provideHtmlAndAP object widget = do host <- getsYesod siteInstanceHost provideHtmlAndAP' host object widget -provideHtmlAndAP' - :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a) - => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent -provideHtmlAndAP' host object widget = selectRep $ do - let doc = Doc host object - provideAP $ pure doc +provideHtmlAndAP_ + :: Yesod site + => (a -> Writer (Endo [ProvidedRep (HandlerFor site)]) ()) + -> (a -> WidgetFor site ()) + -> (a -> WidgetFor site ()) + -> a + -> WidgetFor site () + -> Maybe (Feed (Route site)) + -> HandlerFor site TypedContent +provideHtmlAndAP_ provide renderSky renderHl doc widget mfeed = selectRep $ do + provide doc provideRep $ do mval <- lookupGetParam "prettyjson" defaultLayout $ @@ -210,8 +221,8 @@ provideHtmlAndAP' host object widget = selectRep $ do Just "sky" -> True Just _ -> error "Invalid highlight style" if sky - then renderPrettyJSONSkylighting doc - else renderPrettyJSON doc + then renderSky doc + else renderHl doc mroute <- getCurrentRoute for_ mroute $ \ route -> do params <- reqGetParams <$> getRequest @@ -236,39 +247,48 @@ provideHtmlAndAP' host object widget = selectRep $ do [See JSON] |] + for_ mfeed $ \ feed -> do + provideRep $ atomFeed feed + provideRep $ rssFeed feed where delete' t = deleteBy ((==) `on` fst) (t, "") +provideHtmlAndAP' + :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a) + => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent +provideHtmlAndAP' host object widget = + provideHtmlAndAP_ + (provideAP . pure) + renderPrettyJSONSkylighting + renderPrettyJSON + (Doc host object) + widget + Nothing + provideHtmlAndAP'' :: Yesod site => PersistJSON a -> WidgetFor site () -> HandlerFor site TypedContent -provideHtmlAndAP'' body widget = selectRep $ do - provideAP' $ pure $ persistJSONBytes body - provideRep $ do - mval <- lookupGetParam "prettyjson" - defaultLayout $ - case mval of - Just "true" -> do - mhl <- lookupGetParam "highlight" - let sky = case mhl of - Nothing -> True - Just "hl2" -> False - Just "sky" -> True - Just _ -> error "Invalid highlight style" - pretty = encodePretty $ persistJSONObject body - if sky - then renderPrettyJSONSkylighting' pretty - else renderPrettyJSON' pretty - _ -> do - widget - mroute <- getCurrentRoute - for_ mroute $ \ route -> do - params <- reqGetParams <$> getRequest - let pj = ("prettyjson", "true") - hl = ("highlight", "sky") - params' = pj : hl : params - [whamlet| -
- - [See JSON] - |] +provideHtmlAndAP'' body widget = + provideHtmlAndAP_ + (provideAP' . pure . persistJSONBytes) + (renderPrettyJSONSkylighting' . encodePretty . persistJSONObject) + (renderPrettyJSON' . encodePretty . persistJSONObject) + body + widget + Nothing + +provideHtmlFeedAndAP + :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a) + => a u + -> Feed (Route site) + -> WidgetFor site () + -> HandlerFor site TypedContent +provideHtmlFeedAndAP object feed widget = do + host <- getsYesod siteInstanceHost + provideHtmlAndAP_ + (provideAP . pure) + renderPrettyJSONSkylighting + renderPrettyJSON + (Doc host object) + widget + (Just feed)