Render quote links properly

src/BodyParser.hs

@@ -23,13 +23,17 @@ import qualified GHCJS.DOM.JSFFI.Generated.NodeList as NodeList
 import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains)
 import Data.Text (Text)
 import Miso (consoleLog)
+import Miso.String (fromMisoString)
+import Text.Parsec (ParseError)
+
+import QuoteLinkParser
 
 
 data PostPart
     = SimpleText JSString
     | PostedUrl JSString
     | Skip
-    | Quote JSString
+    | 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 ]
@@ -109,7 +113,7 @@ parseAnchor element = do
 
       case target of
         Just ("_blank" :: JSString) -> return $ PostedUrl href
-        _ -> return $ Quote href
+        _ -> return $ Quote $ parseURL $ fromMisoString href
 
 
 parseSpan :: Element -> IO PostPart

src/Component/BodyRender.hs

@@ -16,16 +16,19 @@ import Miso
     , u_
     , em_
     , s_
-    , title_
     )
 
-import Miso.String (toMisoString, fromMisoString)
+import Miso.String (toMisoString)
+import System.FilePath ((</>))
 import Text.Parsec (ParseError)
+import GHCJS.DOM.Types (JSString)
+import Data.Maybe (fromJust)
+
 import BodyParser (PostPart (..))
 import QuoteLinkParser
 import qualified Component.Thread.Model as Model
 import qualified Network.SiteType as Site
-import qualified Network.ThreadType as Thread
+import qualified Network.BoardType as Board
 
 {-
  - This is the inverse of parsePostBody from BodyParser except
@@ -51,21 +54,60 @@ renderPostPart _ (PostedUrl u) =
 
 renderPostPart _ Skip = br_ []
 
-renderPostPart m (Quote url) = elems parse_result
+renderPostPart m (Quote parse_result) = elems parse_result
     where
-        parse_result = parseURL $ fromMisoString url
-
         elems :: Either ParseError ParsedURL -> View a
         elems (Left err) =
             a_
-                [ href_ url
-                , title_ $ toMisoString $ show err
-                ]
-                [ text url ]
-        elems (Right ParsedURL {..}) =
-            a_
-                [ href_ url ]
-                [ text url ]
+                []
+                [ text $ toMisoString $ show err ]
+        elems (Right p) =
+            case full_url p of
+                Nothing ->
+                    a_
+                        [ href_ $ "/" <> site_name <> "/" <> linked_board <> "/" ]
+                        [ text $ ">>>/" <> linked_board <> "/" ]
+
+                Just u ->
+                    if current_board /= linked_board
+                    then
+                        a_
+                            [ href_ u ]
+                            [ text $ ">>>/" <> linked_board <> "/" <> post_id ]
+                    else
+                        a_
+                            [ href_ u ]
+                            [ text $ ">>" <> post_id ]
+
+            where
+                linked_board = toMisoString $ boardName p
+
+                post_id = toMisoString $ show $ fromJust $ postId p
+
+                current_board = toMisoString $ Board.pathpart $ head $ Site.boards (Model.site m)
+
+
+        full_url :: ParsedURL -> Maybe JSString
+        full_url ParsedURL {..} = do
+            tid <- threadId
+            pid <- postId
+
+            return $ "/" <> site_name <> "/" <> (toMisoString $ boardName </> show tid ++ "#" ++ show pid)
+
+        site_name = toMisoString $ Site.name $ Model.site m
+
+        -- cases of urls:
+        -- url:
+        -- /b/res/1.html#2
+        -- if on different board:
+        -- >>/b/2
+        -- if on same board or same thread:
+        -- >>2
+        --
+        -- url:
+        -- /b/index.html
+        -- if only board:
+        -- >>>/b/
 
 renderPostPart m (GreenText parts) =
     span_ [ class_ "quote" ] (render m parts)

src/Component/ThreadView.hs

@@ -18,7 +18,6 @@ import Miso
   , noEff
   , class_
   , id_
-  , textProp
   , h2_
   , Attribute
   , (<#)
@@ -107,7 +106,7 @@ op m op_post =
     , div_
         (
             [ class_ "post op"
-            , id_ "op_477700"
+            , id_ $ toMisoString $ show $ Post.board_post_id op_post
             ] ++ multi op_post
         )
         [ intro op_post
@@ -132,8 +131,7 @@ multi post
 reply :: Model -> PostWithBody -> View a
 reply m (post, parts) = div_
     [ class_ "postcontainer"
-    , id_ "pc477702"
-    , textProp "data-board" "leftypol"
+    , id_ $ toMisoString $ show $ Post.board_post_id post
     ]
     [ div_
         [ class_ "sidearrows" ]

src/QuoteLinkParser.hs

@@ -7,14 +7,12 @@ module QuoteLinkParser
 import Text.Parsec
 import Text.Parsec.String (Parser)
 
-
+-- Define a data type to hold the extracted components
 data ParsedURL = ParsedURL
-  { siteName    :: Maybe String
-  , boardName   :: String
+  { boardName   :: String
   , threadId    :: Maybe Integer
   , postId      :: Maybe Integer
-  } deriving (Show)
-
+  } deriving (Show, Eq)
 
 -- Parser for a segment of the path
 segment :: Parser String
@@ -24,32 +22,42 @@ segment = many (noneOf "/#")
 integer :: Parser Integer
 integer = read <$> many1 digit
 
--- Parser for the site name
-siteNameParser :: Parser (Maybe String)
-siteNameParser = optionMaybe $ char '/' >> segment
-
 -- Parser for the board name
 boardNameParser :: Parser String
 boardNameParser = char '/' >> segment
 
 -- Optional parser for the thread number
 threadNumberParser :: Parser (Maybe Integer)
-threadNumberParser = optionMaybe $ try (char '/' >> string "res/" >> integer)
+threadNumberParser = optionMaybe $ try $ do
+    _ <- char '/' >> string "res/"
+    tId <- integer
+    _ <- string ".html"
+    return tId
+
+-- Parser for index.html, returning Nothing for threadId and postId
+indexParser :: Parser (Maybe Integer, Maybe Integer)
+indexParser = try $ do
+  _ <- string "/index.html"
+  return (Nothing, Nothing)
+
+-- Combined URL parser
+urlParser :: Parser ParsedURL
+urlParser = do
+    bName <- boardNameParser
+
+    (tId, pId) <- try threadNumberParser >>= \mTid ->
+      case mTid of
+          Just tId -> do
+              pId <- postIdParser
+              return (Just tId, pId)
+          Nothing -> indexParser
+    eof  -- Expect the end of input
+    return $ ParsedURL bName tId pId
 
 -- Optional parser for the post ID
 postIdParser :: Parser (Maybe Integer)
 postIdParser = optionMaybe $ char '#' >> integer
 
--- Combined URL parser
-urlParser :: Parser ParsedURL
-urlParser = do
-  sName <- siteNameParser
-  bName <- boardNameParser
-  tId <- threadNumberParser
-  pId <- postIdParser
-  eof  -- Expect the end of input
-  return $ ParsedURL sName bName tId pId
-
 -- Function to run the parser
 parseURL :: String -> Either ParseError ParsedURL
-parseURL = parse urlParser "chan"
+parseURL = parse urlParser ""