Add youtube embeds

2024-02-29 20:52:00 -05:00 · 2024-02-29 20:52:00 -05:00 · 02c7a48770
parent 2176e55bf6
commit 02c7a48770
18 changed files with 163 additions and 38 deletions
--- 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) ✓
--- 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


--- a/html/video_container.html
+++ b/html/video_container.html
@ -0,0 +1,6 @@
+<div class="video-container" data-video="6lQcKiFy_DM">
+  <a href="https://youtu.be/6lQcKiFy_DM" target="_blank" class="file">
+    <img style="width:255px;height:190px;" src="/vi/6lQcKiFy_DM/0.jpg" class="post-image">
+  </a>
+  <span>[Embed]</span>
+</div>
--- a/index.html
+++ b/index.html
@ -3,7 +3,7 @@
  <head>
    <meta name="viewport" content="width=device-width, initial-scale=1.0">
    <meta name="postgrest-root" content="http://10.4.0.96:3000">
-    <meta name="postgrest-fetch-count" content="200">
+    <meta name="postgrest-fetch-count" content="500">
    <meta name="media-root" content="http://10.4.0.1:8888">
    <title>Chandlr</title>
    <link href="static/style.css" rel="stylesheet" />
@ -22,6 +22,11 @@
        margin-right: auto;
        display: block;
      }
+
+      .page_heading * {
+        display: block;
+        text-align: center;
+      }
    </style>
  </head>
  <body>
--- 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
--- 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 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
--- a/src/Component/Thread/Embed.hs
+++ 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
--- 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
--- 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 ])
--- 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

--- 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
--- 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_ []
+            [ 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)
            ]
--- 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
--- 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)

--- a/src/Parsing/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 ]
--- a/src/Parsing/EmbedParser.hs
+++ 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
--- a/src/Parsing/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
--- a/src/Parsing/QuoteLinkParser.hs
+++ b/src/Parsing/QuoteLinkParser.hs
@ -1,4 +1,4 @@
-module QuoteLinkParser
+module Parsing.QuoteLinkParser
    ( parseURL
    , ParsedURL (..)
    )