diff --git a/app/Main.hs b/app/Main.hs index ca1e7d3..f576ef1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -49,6 +49,7 @@ import qualified Common.Component.CatalogGrid as Grid import qualified Common.Component.TimeControl as TC import Common.FrontEnd.Action (GetThreadArgs (..)) import qualified Common.Component.Thread.Model as Thread +import qualified Common.Component.ThreadView as Thread import Common.Network.SiteType (Site) data HtmlPage a = forall b. (ToJSON b) => HtmlPage (JSONSettings, b, a) @@ -174,11 +175,14 @@ threadView settings website board_pathpart board_thread_id = do case thread_results of Left err -> throwError $ err500 { errBody = fromString $ show err } - Right site -> pure $ render now $ head site + Right site -> do + let s = head site + posts_and_bodies <- liftIO $ Thread.getPostWithBodies s + pure $ render posts_and_bodies now s where - render :: UTCTime -> Site -> HtmlPage (View FE.Action) - render t site = + render :: [ Thread.PostWithBody ] -> UTCTime -> Site -> HtmlPage (View FE.Action) + render posts_and_bodies t site = HtmlPage ( settings , site @@ -200,7 +204,7 @@ threadView settings website board_pathpart board_thread_id = do thread_model = Thread.Model { Thread.site = site , Thread.media_root = pack $ media_root settings - , Thread.post_bodies = [] + , Thread.post_bodies = posts_and_bodies , Thread.current_time = t } diff --git a/app/Parsing/BodyParser.hs b/app/Parsing/BodyParser.hs index 0bd38d9..eb229f9 100644 --- a/app/Parsing/BodyParser.hs +++ b/app/Parsing/BodyParser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Parsing.BodyParser ( PostPart (..) , parsePostBody @@ -5,10 +7,34 @@ module Parsing.BodyParser , Backlinks ) where -import Data.Text (Text) +import Data.Text (Text, unpack) import Common.Parsing.PostPartType import Common.Parsing.PostBodyUtils +import Common.Parsing.QuoteLinkParser + +tagsToPostParts :: [ Tag Text ] -> [ PostPart ] +tagsToPostParts = concatMap tagToPostPart + + +tagToPostPart :: Tag Text -> [ PostPart ] +tagToPostPart (TagText t) = SimpleText t : [] +tagToPostPart (TagOpen "a" attrs) = parseAnchor attrs : [] +tagToPostPart (TagOpen "span" attrs) = parseSpan attrs : [] + + +parseAnchor :: [ Attribute Text ] -> PostPart +parseAnchor attrs = + case lookup "href" attrs of + Nothing -> SimpleText "Anchor without href" + Just href -> + case lookup "target" attrs of + Just "_blank" -> PostedUrl href + _ -> Quote $ parseURL $ unpack href + + +parseSpan :: [ Attribute Text ] -> PostPart parsePostBody :: Text -> IO [ PostPart ] -parsePostBody = undefined +parsePostBody html = + return $ tagsToPostParts $ parseTags html diff --git a/chandlr-server.cabal b/chandlr-server.cabal index 06588fd..5ded0dc 100644 --- a/chandlr-server.cabal +++ b/chandlr-server.cabal @@ -122,7 +122,8 @@ executable chandlr-server http-types, cmdargs, mtl, - utf8-string + utf8-string, + tagsoup -- Directories containing source files. hs-source-dirs: app