From 0345a755a4d400a6416f75ed4c197dd102e27914 Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Fri, 16 Feb 2024 12:26:30 -0500 Subject: [PATCH] Backlinks aka mentions --- chandlr.cabal | 1 + default.nix | 1 + html/mentions.html | 4 +++ src/BodyParser.hs | 58 +++++++++++++++++++++-------------- src/Component/BodyRender.hs | 16 ++++++++-- src/Component/Thread/Intro.hs | 28 +++++++++++++++-- src/Component/Thread/Model.hs | 2 +- src/Component/ThreadView.hs | 19 +++++++----- src/PostPartType.hs | 26 ++++++++++++++++ 9 files changed, 119 insertions(+), 36 deletions(-) create mode 100644 html/mentions.html create mode 100644 src/PostPartType.hs diff --git a/chandlr.cabal b/chandlr.cabal index e653958..610bcff 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -81,6 +81,7 @@ executable chandlr Common.AttachmentType BodyParser QuoteLinkParser + PostPartType -- LANGUAGE extensions used by modules in this package. diff --git a/default.nix b/default.nix index 9b22d67..628c0ae 100644 --- a/default.nix +++ b/default.nix @@ -13,6 +13,7 @@ let pkgs.haskellPackages.cabal-install new_pkgs.haskellPackages.ghcjs-dom new_pkgs.haskellPackages.miso-from-html + new_pkgs.haskellPackages.hlint ]; }); diff --git a/html/mentions.html b/html/mentions.html new file mode 100644 index 0000000..c3a685b --- /dev/null +++ b/html/mentions.html @@ -0,0 +1,4 @@ + + >>476665 + >>476666 + diff --git a/src/BodyParser.hs b/src/BodyParser.hs index 848e388..abaaa7f 100644 --- a/src/BodyParser.hs +++ b/src/BodyParser.hs @@ -2,13 +2,18 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} module BodyParser -( PostPart (..) -, parsePostBody -) where + ( PostPart (..) + , parsePostBody + , collectBacklinks + , Backlinks + ) where import Data.Maybe (catMaybes) +import Data.Map (Map) +import qualified Data.Map as Map import GHCJS.DOM (currentDocument) import GHCJS.DOM.Types ( Element (..) @@ -24,30 +29,13 @@ import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains) import Data.Text (Text) import Miso (consoleLog) import Miso.String (fromMisoString) -import Text.Parsec (ParseError) +import qualified Network.PostType as Post +import Component.Thread.Model (PostWithBody) +import PostPartType import QuoteLinkParser -data PostPart - = SimpleText JSString - | PostedUrl JSString - | Skip - | Quote (Either ParseError ParsedURL) - -- Quotes don't seem to be able to be spoilered - -- board links (which appear as quotes but start with >>>) break the tag - | GreenText [ PostPart ] - | OrangeText [ PostPart ] - | RedText [ PostPart ] - | Spoiler [ PostPart ] - -- you can't seem to spoiler greentext - | Bold [ PostPart ] - | Underlined [ PostPart ] - | Italics [ PostPart ] - | Strikethrough [ PostPart ] - deriving (Show, Eq) - - nodeListToList :: NodeList -> IO [ Node ] nodeListToList l = do len <- NodeList.getLength l @@ -157,3 +145,27 @@ parseS :: Element -> IO PostPart parseS element = parseChildNodes element >>= return . Strikethrough + +type Backlinks = Map Integer [Post.Post] + +collectBacklinks :: [PostWithBody] -> Backlinks +collectBacklinks xs = foldr insertElement Map.empty xs + where + insertElement :: PostWithBody -> Backlinks -> Backlinks + insertElement (post, body) acc = foldr insertPost acc (quotedPosts body) + where + insertPost postId = Map.insertWith (++) postId [post] + + +quotedPosts :: [ PostPart ] -> [ Integer ] +quotedPosts [] = [] +quotedPosts (Quote (Right (ParsedURL { postId = Just p })) : xs) = [p] ++ quotedPosts xs +quotedPosts ((GreenText xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((OrangeText xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((RedText xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((Spoiler xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((Bold xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((Underlined xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((Italics xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts ((Strikethrough xs) : xxs) = quotedPosts xs ++ quotedPosts xxs +quotedPosts _ = [] diff --git a/src/Component/BodyRender.hs b/src/Component/BodyRender.hs index 9f527a1..cba01b3 100644 --- a/src/Component/BodyRender.hs +++ b/src/Component/BodyRender.hs @@ -16,6 +16,7 @@ import Miso , u_ , em_ , s_ + , small_ ) import Miso.String (toMisoString) @@ -29,6 +30,8 @@ import QuoteLinkParser import qualified Component.Thread.Model as Model import qualified Network.SiteType as Site import qualified Network.BoardType as Board +import qualified Network.ThreadType as Thread +import qualified Network.PostType as Post {- - This is the inverse of parsePostBody from BodyParser except @@ -77,15 +80,24 @@ renderPostPart m (Quote parse_result) = elems parse_result else a_ [ href_ u ] - [ text $ ">>" <> post_id ] + $ + (text $ ">>" <> post_id) + : + if pid == op_id + then [ small_ [] [ " (OP)" ] ] + else [] where linked_board = toMisoString $ boardName p - post_id = toMisoString $ show $ fromJust $ postId p + pid = fromJust $ postId p + + post_id = toMisoString $ show pid current_board = toMisoString $ Board.pathpart $ head $ Site.boards (Model.site m) + op_id = Post.board_post_id $ head $ Thread.posts $ head $ Board.threads $ head $ Site.boards (Model.site m) + full_url :: ParsedURL -> Maybe JSString full_url ParsedURL {..} = do diff --git a/src/Component/Thread/Intro.hs b/src/Component/Thread/Intro.hs index 789c0b8..5ec8d9d 100644 --- a/src/Component/Thread/Intro.hs +++ b/src/Component/Thread/Intro.hs @@ -14,6 +14,7 @@ import Miso , time_ ) +import qualified Data.Map as Map import Data.Text (Text, pack) import GHCJS.DOM.Types (JSString) import Data.Foldable (toList) @@ -29,6 +30,7 @@ import Network.BoardType (Board) import qualified Network.BoardType as Board import qualified Network.ThreadType as Thread import Network.ThreadType (Thread) +import BodyParser (Backlinks) formatUTC :: UTCTime -> JSString @@ -36,8 +38,8 @@ formatUTC time = toMisoString $ formatTime defaultTimeLocale "%Y-%m-%d (%a) %T" time -intro :: Site -> Board -> Thread -> Post -> UTCTime -> View a -intro site board thread post current_time = span_ +intro :: Site -> Board -> Thread -> Post -> Backlinks -> UTCTime -> View a +intro site board thread post backlinks current_time = span_ [ class_ "intro" ] ( subject ++ [ " " @@ -59,6 +61,7 @@ intro site board thread post current_time = span_ , href_ $ toMisoString $ post_url <> "#q" <> b_post_id ][ text $ toMisoString $ b_post_id ] ] + ++ mentions ) where @@ -85,6 +88,27 @@ intro site board thread post current_time = span_ b_post_id :: Text b_post_id = pack $ show $ Post.board_post_id post + mentions :: [ View a ] + mentions = + case Map.lookup (Post.board_post_id post) backlinks of + Nothing -> [] + Just [] -> [] + Just xs -> span_ + [ class_ "mentioned unimportant" ] + (map mention xs) + : [] + + mention :: Post -> View a + mention p = + a_ + [ href_ $ "#" <> bpid + ] + [ text $ ">>" <> bpid ] + + where + bpid :: JSString + bpid = toMisoString $ show $ Post.board_post_id p + -- Convert UTCTime to a human-readable string timeAgo :: UTCTime -> UTCTime -> String diff --git a/src/Component/Thread/Model.hs b/src/Component/Thread/Model.hs index 7eb10d5..f46a188 100644 --- a/src/Component/Thread/Model.hs +++ b/src/Component/Thread/Model.hs @@ -3,7 +3,7 @@ module Component.Thread.Model where import GHCJS.DOM.Types (JSString) import Network.SiteType (Site) import Network.PostType (Post) -import BodyParser (PostPart) +import PostPartType (PostPart) import Data.Time.Clock (UTCTime) type PostWithBody = (Post, [ PostPart ]) diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index 5748216..7ce39ef 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -89,7 +89,7 @@ view m = , div_ [ class_ "thread" ] ( (op_post thread_posts) - ++ map (reply m) (drop 1 (post_bodies m)) + ++ map (reply m backlinks) (drop 1 (post_bodies m)) ) ] ) @@ -101,9 +101,12 @@ view m = concatMap (Board.threads) $ Site.boards (site m) + backlinks :: Backlinks + backlinks = collectBacklinks (post_bodies m) + op_post :: [ Post ] -> [ View a ] op_post [] = [ h2_ [] [ "There's nothing here" ] ] - op_post (x:_) = op m x + op_post (x:_) = op m x backlinks title :: JSString title = toMisoString $ (Site.name $ site m) <> " /" <> board <> "/" @@ -111,8 +114,8 @@ view m = board = Board.pathpart $ head $ Site.boards (site m) -op :: Model -> Post -> [ View a ] -op m op_post = +op :: Model -> Post -> Backlinks -> [ View a ] +op m op_post backlinks = [ files (media_root m) site_ op_post , div_ ( @@ -120,7 +123,7 @@ op m op_post = , id_ $ toMisoString $ show $ Post.board_post_id op_post ] ++ multi op_post ) - [ intro site_ board thread op_post $ current_time m + [ intro site_ board thread op_post backlinks $ current_time m , div_ [ class_ "body" ] (body $ post_bodies m) @@ -148,8 +151,8 @@ multi post | otherwise = [] -reply :: Model -> PostWithBody -> View a -reply m (post, parts) = div_ +reply :: Model -> Backlinks -> PostWithBody -> View a +reply m backlinks (post, parts) = div_ [ class_ "postcontainer" , id_ $ toMisoString $ show $ Post.board_post_id post ] @@ -161,7 +164,7 @@ reply m (post, parts) = div_ [ class_ "post reply" ] ++ multi post ) - [ intro site_ board thread post $ current_time m + [ intro site_ board thread post backlinks $ current_time m , files (media_root m) site_ post , div_ [ class_ "body" ] diff --git a/src/PostPartType.hs b/src/PostPartType.hs new file mode 100644 index 0000000..a6582dd --- /dev/null +++ b/src/PostPartType.hs @@ -0,0 +1,26 @@ +module PostPartType where + +import GHCJS.DOM.Types (JSString) +import Text.Parsec (ParseError) + +import QuoteLinkParser (ParsedURL) + +data PostPart + = SimpleText JSString + | PostedUrl JSString + | Skip + | Quote (Either ParseError ParsedURL) + -- Quotes don't seem to be able to be spoilered + -- board links (which appear as quotes but start with >>>) break the tag + | GreenText [ PostPart ] + | OrangeText [ PostPart ] + | RedText [ PostPart ] + | Spoiler [ PostPart ] + -- you can't seem to spoiler greentext + | Bold [ PostPart ] + | Underlined [ PostPart ] + | Italics [ PostPart ] + | Strikethrough [ PostPart ] + deriving (Show, Eq) + +