diff --git a/chandlr.cabal b/chandlr.cabal index 2deb3a9..c3146d9 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -79,6 +79,7 @@ executable chandlr Routes Common.AttachmentType BodyParser + QuoteLinkParser -- LANGUAGE extensions used by modules in this package. @@ -97,7 +98,8 @@ executable chandlr bytestring, filepath, network-uri, - containers + containers, + parsec -- Directories containing source files. hs-source-dirs: src diff --git a/src/Component/BodyRender.hs b/src/Component/BodyRender.hs index c59f267..ae6ef08 100644 --- a/src/Component/BodyRender.hs +++ b/src/Component/BodyRender.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Component.BodyRender where @@ -15,9 +16,13 @@ import Miso , u_ , em_ , s_ + , title_ ) +import Miso.String (toMisoString, fromMisoString) +import Text.Parsec (ParseError) import BodyParser (PostPart (..)) +import QuoteLinkParser {- - This is the inverse of parsePostBody from BodyParser except @@ -40,11 +45,24 @@ renderPostPart (PostedUrl u) = , target_ "_blank" ] [ text u ] + renderPostPart Skip = br_ [] -renderPostPart (Quote url) = - a_ - [ href_ url ] - [ text url ] + +renderPostPart (Quote url) = 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 ] renderPostPart (GreenText parts) = span_ [ class_ "quote" ] (render parts) diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index 1d868d2..ace2e39 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -38,7 +38,7 @@ import qualified Network.ThreadType as Thread import Component.Thread.Files (files) import Component.Thread.Intro (intro) import BodyParser -import Component.BodyRender +import qualified Component.BodyRender as Body type PostWithBody = (Post, [ PostPart ]) @@ -115,7 +115,7 @@ op m op_post = ( [ class_ "post op" , id_ "op_477700" - ] ++ multi + ] ++ multi op_post ) [ intro op_post , div_ @@ -125,14 +125,15 @@ op m op_post = ] where - multi :: [ Attribute a ] - multi - | length (Post.attachments op_post) > 1 = [ class_ "multifile" ] - | otherwise = [] - body :: [ PostWithBody ] -> [ View a ] body [] = [] - body x = render $ snd $ head x + body x = Body.render $ snd $ head x + + +multi :: Post -> [ Attribute a ] +multi post + | length (Post.attachments post) > 1 = [ class_ "multifile" ] + | otherwise = [] reply :: Model -> PostWithBody -> View a @@ -142,13 +143,15 @@ reply m (post, parts) = div_ , textProp "data-board" "leftypol" ] [ div_ - [ class_ "post reply" - , id_ "reply_477702" - ] + ( + [ class_ "post reply" + , id_ "reply_477702" + ] ++ multi post + ) [ intro post , files (media_root m) (site m) post , div_ [ class_ "body" ] - (render parts) + (Body.render parts) ] ] diff --git a/src/QuoteLinkParser.hs b/src/QuoteLinkParser.hs new file mode 100644 index 0000000..690cecd --- /dev/null +++ b/src/QuoteLinkParser.hs @@ -0,0 +1,55 @@ +module QuoteLinkParser + ( parseURL + , ParsedURL (..) + ) + where + +import Text.Parsec +import Text.Parsec.String (Parser) + + +data ParsedURL = ParsedURL + { siteName :: Maybe String + , boardName :: String + , threadId :: Maybe Integer + , postId :: Maybe Integer + } deriving (Show) + + +-- Parser for a segment of the path +segment :: Parser String +segment = many (noneOf "/#") + +-- Parser for an integer +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) + +-- 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"