diff --git a/TODO.txt b/TODO.txt index a55c4af..0bb4934 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,19 +1,22 @@ -- need to display the current time you are at (or Latest) -- Need to add server-side rendering +- get embeds working - need to implement search -- need a control to manually put in the datetime instead of using the slider +- change urls / history when time-travelling +- remove duplicate threads from view (duplicate because the OP has multiple pictures) +- server-side rendering +- control to manually put in the datetime instead of using the slider for fine-grained control -- need to change urls / history when time-travelling -- need to be able to view board, board should support timetravel +- have some process respond to http calls from the board to inform the db of new posts +- board view, boards should support timetravel - need toolbar to navigate and select which boards to view -- need to scrape other websites and add them in + - choose boards to display +- time slider should align times to the hour +- scrape other websites and add them in - i think this is more useful than the archival property, which is really just there to preserve links. the time travel thing is a bit of a gimmick -- need to have some process respond to http calls from the board to inform - the db of new posts - "infinite" scrolling - just load more! -- need to get embeds working +- more granular actions to display what is causing slowdowns (esp on mobile) +- fix thumbnails for older posts ✓ - need to support flags - need to support mod actions like saging a thread or deleting a post -- fix thumbnails for older posts +- need to display the current time you are at (or Latest) ✓ diff --git a/chandlr.cabal b/chandlr.cabal index c8ab120..b3528a6 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -79,9 +79,10 @@ executable chandlr Component.BodyRender Routes Common.AttachmentType - BodyParser - QuoteLinkParser - PostPartType + Parsing.BodyParser + Parsing.QuoteLinkParser + Parsing.EmbedParser + Parsing.PostPartType Component.TimeControl diff --git a/html/video_container.html b/html/video_container.html new file mode 100644 index 0000000..2e4921c --- /dev/null +++ b/html/video_container.html @@ -0,0 +1,6 @@ +
+ + + + [Embed] +
diff --git a/index.html b/index.html index 672d21e..aa36267 100644 --- a/index.html +++ b/index.html @@ -3,7 +3,7 @@ - + Chandlr @@ -22,6 +22,11 @@ margin-right: auto; display: block; } + + .page_heading * { + display: block; + text-align: center; + } diff --git a/src/Component/BodyRender.hs b/src/Component/BodyRender.hs index cba01b3..9cc5411 100644 --- a/src/Component/BodyRender.hs +++ b/src/Component/BodyRender.hs @@ -25,8 +25,8 @@ import Text.Parsec (ParseError) import GHCJS.DOM.Types (JSString) import Data.Maybe (fromJust) -import BodyParser (PostPart (..)) -import QuoteLinkParser +import Parsing.BodyParser (PostPart (..)) +import Parsing.QuoteLinkParser import qualified Component.Thread.Model as Model import qualified Network.SiteType as Site import qualified Network.BoardType as Board diff --git a/src/Component/CatalogGrid.hs b/src/Component/CatalogGrid.hs index 5f55685..720b288 100644 --- a/src/Component/CatalogGrid.hs +++ b/src/Component/CatalogGrid.hs @@ -25,6 +25,7 @@ import Miso.String (toMisoString, MisoString) import Network.CatalogPostType (CatalogPost) import qualified Network.CatalogPostType as CatalogPost +import Parsing.EmbedParser (extractVideoId) data Model = Model { display_items :: [ CatalogPost ] @@ -115,12 +116,19 @@ gridItem iface m post = post_count_str :: MisoString post_count_str = toMisoString $ (CatalogPost.estimated_post_count post) - 1 + embed_url :: Maybe String + embed_url = + (CatalogPost.embed post) >>= Just . (\(Right r) -> r) . extractVideoId . T.unpack + thumb_url :: MisoString thumb_url = - case mthumb_path of - -- TODO: what about embeds!? - Nothing -> "/static/default_thumbnail.png" - Just thumb_path -> (media_root m) `append` (toMisoString thumb_path) + case embed_url of + Nothing -> + case mthumb_path of + -- TODO: what about embeds!? + Nothing -> "/static/default_thumbnail.png" + Just thumb_path -> (media_root m) `append` (toMisoString thumb_path) + Just u -> "https://leftychan.net/vi/" <> toMisoString u <> "/0.jpg" mthumb_path :: Maybe Text mthumb_path = do diff --git a/src/Component/Thread/Embed.hs b/src/Component/Thread/Embed.hs new file mode 100644 index 0000000..6acaa5d --- /dev/null +++ b/src/Component/Thread/Embed.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Component.Thread.Embed where + +import Miso + ( View + , div_ + , class_ + , a_ + , href_ + , target_ + , img_ + , style_ + , src_ + , span_ + ) + +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Text (unpack) +import Data.JSString (JSString, pack) + +import qualified Network.PostType as Post +import Network.PostType (Post) +import Parsing.EmbedParser (extractVideoId) + +embed :: Post -> View a +embed post = div_ + [ class_ "video-container" ] + [ a_ + [ href_ $ "https://youtu.be/" <> video_id + , target_ "_blank" + , class_ "file" + ] + [ img_ + [ style_ $ Map.fromList + [ + ( "height" + , "190px" + ) + , + ( "width" + , "255px" + ) + ] + , src_ ("https://leftychan.net/vi/" <> video_id <> "/0.jpg") + , class_ "post-image" + ] + ] + , span_ [][ "[Embed]" ] + ] + + where + video_id :: JSString + video_id = pack $ fromJust $ + (Post.embed post) >>= Just . (\(Right r) -> r) . extractVideoId . unpack diff --git a/src/Component/Thread/Intro.hs b/src/Component/Thread/Intro.hs index 5ec8d9d..62cb9ae 100644 --- a/src/Component/Thread/Intro.hs +++ b/src/Component/Thread/Intro.hs @@ -30,7 +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) +import Parsing.BodyParser (Backlinks) formatUTC :: UTCTime -> JSString diff --git a/src/Component/Thread/Model.hs b/src/Component/Thread/Model.hs index f46a188..8361c64 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 PostPartType (PostPart) +import Parsing.PostPartType (PostPart) import Data.Time.Clock (UTCTime) type PostWithBody = (Post, [ PostPart ]) diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index 7ce39ef..7dcc5ec 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -40,8 +40,9 @@ import qualified Network.ThreadType as Thread import Network.ThreadType (Thread) import Component.Thread.Files (files) import Component.Thread.Intro (intro) +import Component.Thread.Embed (embed) import Component.Thread.Model -import BodyParser +import Parsing.BodyParser import qualified Component.BodyRender as Body initialModel :: JSString -> Site -> Model @@ -116,7 +117,7 @@ view m = op :: Model -> Post -> Backlinks -> [ View a ] op m op_post backlinks = - [ files (media_root m) site_ op_post + [ files_or_embed_view , div_ ( [ class_ "post op" @@ -131,6 +132,13 @@ op m op_post backlinks = ] where + files_or_embed_view :: View a + files_or_embed_view = + case (Post.embed op_post) of + Just _ -> embed op_post + Nothing -> files (media_root m) site_ op_post + + site_ :: Site site_ = site m @@ -165,7 +173,7 @@ reply m backlinks (post, parts) = div_ ] ++ multi post ) [ intro site_ board thread post backlinks $ current_time m - , files (media_root m) site_ post + , files_or_embed_view , div_ [ class_ "body" ] (Body.render m parts) @@ -173,6 +181,12 @@ reply m backlinks (post, parts) = div_ ] where + files_or_embed_view :: View a + files_or_embed_view = + case (Post.embed post) of + Just txt -> embed post + Nothing -> files (media_root m) site_ post + site_ :: Site site_ = site m diff --git a/src/Component/TimeControl.hs b/src/Component/TimeControl.hs index bc25bb6..6a54bc9 100644 --- a/src/Component/TimeControl.hs +++ b/src/Component/TimeControl.hs @@ -30,7 +30,7 @@ import Data.Time.Clock , addUTCTime , secondsToDiffTime ) -import Data.Time.Calendar (fromGregorian, Day) +import Data.Time.Calendar (fromGregorian) data Time = Now @@ -76,8 +76,8 @@ update -> Time -> Model -> Effect a Model -update iface (SlideInput time) m = m <# do - consoleLog $ "Input: " <> time +update iface (SlideInput nstr) m = m <# do + consoleLog $ "Input: " <> nstr return $ (passAction iface) NoAction @@ -86,24 +86,27 @@ update iface (SlideChange nstr) m = m { whereAt = n } <# do now <- getCurrentTime - return $ (goTo iface) $ interpolateTimeHours n now + let newTime = interpolateTimeHours n now + + return $ (goTo iface) newTime where n :: Integer n = read $ fromMisoString nstr - update _ _ m = noEff m earliest :: UTCTime -earliest = UTCTime (fromGregorian 2020 12 21) (secondsToDiffTime 19955) +--earliest = UTCTime (fromGregorian 2020 12 20) (secondsToDiffTime 82643) +earliest = UTCTime (fromGregorian 2020 12 20) (secondsToDiffTime 82644) -- Linear interpolation function using hours interpolateTimeHours :: Integer -> UTCTime -> UTCTime interpolateTimeHours n currentTime | n == 0 = currentTime + | n == -500 = earliest | otherwise = addUTCTime (fromIntegral hoursToAdjust * secondsInHour) currentTime where diff --git a/src/Main.hs b/src/Main.hs index f40d3d8..1d70505 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -33,6 +33,8 @@ import Miso , consoleLog , pushURI , uriSub + , time_ + , class_ ) import GHCJS.DOM (currentDocument) import GHCJS.DOM.Types (toJSString, fromJSString, Element, JSString) @@ -156,7 +158,11 @@ mainView model = view catalog_view :: Model -> View Action catalog_view m = div_ [] - [ h1_ [] [ text "Overboard Catalog" ] + [ div_ + [ class_ "page_heading" ] + [ h1_ [] [ text "Overboard Catalog" ] + , time_ [] [ text $ pack $ show $ current_time model ] + ] , TC.view iTime (tc_model m) , Grid.view iGrid (grid_model model) ] diff --git a/src/Network/CatalogPostType.hs b/src/Network/CatalogPostType.hs index a28b463..8a1742e 100644 --- a/src/Network/CatalogPostType.hs +++ b/src/Network/CatalogPostType.hs @@ -24,6 +24,7 @@ data CatalogPost = CatalogPost , email :: Maybe Text , thread_id :: Int -- , post_count :: Int + , embed :: Maybe Text , estimated_post_count :: Int , site_name :: Text , pathpart :: Text diff --git a/src/Network/PostType.hs b/src/Network/PostType.hs index 473ddbd..3269f8e 100644 --- a/src/Network/PostType.hs +++ b/src/Network/PostType.hs @@ -19,6 +19,7 @@ data Post = Post , email :: Maybe Text , body_search_index :: Text , thread_id :: Integer + , embed :: Maybe Text , attachments :: [ Attachment ] } deriving (Show, Generic, FromJSON, ToJSON, Eq) diff --git a/src/BodyParser.hs b/src/Parsing/BodyParser.hs similarity index 98% rename from src/BodyParser.hs rename to src/Parsing/BodyParser.hs index abaaa7f..2aabaf1 100644 --- a/src/BodyParser.hs +++ b/src/Parsing/BodyParser.hs @@ -4,7 +4,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} -module BodyParser +module Parsing.BodyParser ( PostPart (..) , parsePostBody , collectBacklinks @@ -32,8 +32,8 @@ import Miso.String (fromMisoString) import qualified Network.PostType as Post import Component.Thread.Model (PostWithBody) -import PostPartType -import QuoteLinkParser +import Parsing.PostPartType +import Parsing.QuoteLinkParser nodeListToList :: NodeList -> IO [ Node ] diff --git a/src/Parsing/EmbedParser.hs b/src/Parsing/EmbedParser.hs new file mode 100644 index 0000000..3a79c6d --- /dev/null +++ b/src/Parsing/EmbedParser.hs @@ -0,0 +1,21 @@ +module Parsing.EmbedParser + ( extractVideoId + ) + where + +import Text.Parsec +import Text.Parsec.String + +-- Parser to extract the video ID +videoIdParser :: Parser String +videoIdParser = do + -- Look for the data-video attribute + _ <- manyTill anyChar (try (string "data-video=\"") <|> string "href=\"https://youtu.be/") + -- Capture the video ID + videoId <- manyTill anyChar (try (char '\"') <|> (char '"' >> char ' ')) + -- Return the captured ID + return videoId + +-- Function to apply the parser and extract the video ID +extractVideoId :: String -> Either ParseError String +extractVideoId input = parse videoIdParser "" input diff --git a/src/PostPartType.hs b/src/Parsing/PostPartType.hs similarity index 89% rename from src/PostPartType.hs rename to src/Parsing/PostPartType.hs index a6582dd..59654f1 100644 --- a/src/PostPartType.hs +++ b/src/Parsing/PostPartType.hs @@ -1,9 +1,9 @@ -module PostPartType where +module Parsing.PostPartType where import GHCJS.DOM.Types (JSString) import Text.Parsec (ParseError) -import QuoteLinkParser (ParsedURL) +import Parsing.QuoteLinkParser (ParsedURL) data PostPart = SimpleText JSString diff --git a/src/QuoteLinkParser.hs b/src/Parsing/QuoteLinkParser.hs similarity index 98% rename from src/QuoteLinkParser.hs rename to src/Parsing/QuoteLinkParser.hs index 04d422e..11dbe3b 100644 --- a/src/QuoteLinkParser.hs +++ b/src/Parsing/QuoteLinkParser.hs @@ -1,4 +1,4 @@ -module QuoteLinkParser +module Parsing.QuoteLinkParser ( parseURL , ParsedURL (..) )