diff --git a/src/Component/Thread/Intro.hs b/src/Component/Thread/Intro.hs index a3cf94f..d27a377 100644 --- a/src/Component/Thread/Intro.hs +++ b/src/Component/Thread/Intro.hs @@ -8,13 +8,13 @@ import Miso , href_ , a_ , class_ - , id_ , textProp , title_ , span_ , time_ ) +import Data.Text (Text, pack) import GHCJS.DOM.Types (JSString) import Data.Foldable (toList) import Miso.String (toMisoString) @@ -23,14 +23,21 @@ import Data.Time.Format (formatTime, defaultTimeLocale) import Network.PostType (Post) import qualified Network.PostType as Post +import Network.SiteType (Site) +import qualified Network.SiteType as Site +import Network.BoardType (Board) +import qualified Network.BoardType as Board +import qualified Network.ThreadType as Thread +import Network.ThreadType (Thread) formatUTC :: UTCTime -> JSString formatUTC time = toMisoString $ formatTime defaultTimeLocale "%Y-%m-%d (%a) %T" time -intro :: Post -> UTCTime -> View a -intro post current_time = span_ + +intro :: Site -> Board -> Thread -> Post -> UTCTime -> View a +intro site board thread post current_time = span_ [ class_ "intro" ] ( subject ++ [ " " @@ -46,17 +53,27 @@ intro post current_time = span_ , " " , a_ [ class_ "post_no" - , id_ "post_no_477700" - , href_ "/leftypol/res/477700.html#477700" + -- , href_ $ toMisoString $ "#" ++ b_post_id + , href_ $ toMisoString $ post_url <> "#" <> b_post_id + --, href_ "/leftypol/res/477700.html#477700" ][ "No." ] , a_ [ class_ "post_no" - , href_ "/leftypol/res/477700.html#q477700" - ][ text $ toMisoString $ show $ Post.board_post_id post ] + -- , href_ $ toMisoString $ "#q" ++ b_post_id + , href_ $ toMisoString $ post_url <> "#q" <> b_post_id + --, href_ "/leftypol/res/477700.html#q477700" + ][ text $ toMisoString $ b_post_id ] ] ) where + post_url :: Text + post_url + = "/" <> Site.name site + <> "/" <> Board.pathpart board + <> "/" <> pack (show $ Thread.board_thread_id thread) + + creation_time :: UTCTime creation_time = Post.creation_time post subject :: [ View a ] @@ -70,6 +87,9 @@ intro post current_time = span_ [ class_ "subject" ] [ text s ] + b_post_id :: Text + b_post_id = pack $ show $ Post.board_post_id post + -- Convert UTCTime to a human-readable string timeAgo :: UTCTime -> UTCTime -> String @@ -77,12 +97,14 @@ timeAgo currentTime pastTime = let diff = realToFrac $ diffUTCTime currentTime pastTime in humanReadableTimeDiff diff + -- Helper function to correctly format singular and plural units formatTimeUnit :: (Integral a, Show a) => a -> String -> String formatTimeUnit value unit | value == 1 = show value ++ " " ++ unit ++ " ago" | otherwise = show value ++ " " ++ unit ++ "s ago" + -- Convert time difference in seconds to a human-readable format humanReadableTimeDiff :: Double -> String humanReadableTimeDiff diff diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index d0454fd..5748216 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -35,7 +35,9 @@ import qualified Network.SiteType as Site import Network.PostType (Post) import qualified Network.PostType as Post import qualified Network.BoardType as Board +import Network.BoardType (Board) import qualified Network.ThreadType as Thread +import Network.ThreadType (Thread) import Component.Thread.Files (files) import Component.Thread.Intro (intro) import Component.Thread.Model @@ -111,14 +113,14 @@ view m = op :: Model -> Post -> [ View a ] op m op_post = - [ files (media_root m) (site m) op_post + [ files (media_root m) site_ op_post , div_ ( [ class_ "post op" , id_ $ toMisoString $ show $ Post.board_post_id op_post ] ++ multi op_post ) - [ intro op_post $ current_time m + [ intro site_ board thread op_post $ current_time m , div_ [ class_ "body" ] (body $ post_bodies m) @@ -126,6 +128,15 @@ op m op_post = ] where + site_ :: Site + site_ = site m + + board :: Board + board = head $ Site.boards site_ + + thread :: Thread + thread = head $ Board.threads board + body :: [ PostWithBody ] -> [ View a ] body [] = [] body x = Body.render m $ snd $ head x @@ -150,10 +161,21 @@ reply m (post, parts) = div_ [ class_ "post reply" ] ++ multi post ) - [ intro post $ current_time m - , files (media_root m) (site m) post + [ intro site_ board thread post $ current_time m + , files (media_root m) site_ post , div_ [ class_ "body" ] (Body.render m parts) ] ] + + where + site_ :: Site + site_ = site m + + board :: Board + board = head $ Site.boards site_ + + thread :: Thread + thread = head $ Board.threads board +