0
/
chandler-miso
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add youtube embeds

This commit is contained in:
towards-a-new-leftypol 2024-02-29 20:52:00 -05:00
parent 2176e55bf6
commit 02c7a48770
18 changed files with 163 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
TODO.txt
View File

@ -1,19 +1,22 @@
- need to display the current time you are at (or Latest) - get embeds working
- Need to add server-side rendering
- need to implement search - 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 for fine-grained control
- need to change urls / history when time-travelling - have some process respond to http calls from the board to inform the db of new posts
- need to be able to view board, board should support timetravel - board view, boards should support timetravel
- need toolbar to navigate and select which boards to view - 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 - 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 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 - "infinite" scrolling
- just load more! - 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 flags
- need to support mod actions like saging a thread or deleting a post - 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) ✓

7
chandlr.cabal
View File

@ -79,9 +79,10 @@ executable chandlr
Component.BodyRender Component.BodyRender
Routes Routes
Common.AttachmentType Common.AttachmentType
BodyParser Parsing.BodyParser
QuoteLinkParser Parsing.QuoteLinkParser
PostPartType Parsing.EmbedParser
Parsing.PostPartType
Component.TimeControl Component.TimeControl

6
html/video_container.html Normal file
View File

@ -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>

7
index.html
View File

@ -3,7 +3,7 @@
<head> <head>
<meta name="viewport" content="width=device-width, initial-scale=1.0"> <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-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"> <meta name="media-root" content="http://10.4.0.1:8888">
<title>Chandlr</title> <title>Chandlr</title>
<link href="static/style.css" rel="stylesheet" /> <link href="static/style.css" rel="stylesheet" />
@ -22,6 +22,11 @@
margin-right: auto; margin-right: auto;
display: block; display: block;
} }
.page_heading * {
display: block;
text-align: center;
}
</style> </style>
</head> </head>
<body> <body>

4
src/Component/BodyRender.hs
View File

@ -25,8 +25,8 @@ import Text.Parsec (ParseError)
import GHCJS.DOM.Types (JSString) import GHCJS.DOM.Types (JSString)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import BodyParser (PostPart (..)) import Parsing.BodyParser (PostPart (..))
import QuoteLinkParser import Parsing.QuoteLinkParser
import qualified Component.Thread.Model as Model import qualified Component.Thread.Model as Model
import qualified Network.SiteType as Site import qualified Network.SiteType as Site
import qualified Network.BoardType as Board import qualified Network.BoardType as Board

16
src/Component/CatalogGrid.hs
View File

@ -25,6 +25,7 @@ import Miso.String (toMisoString, MisoString)
import Network.CatalogPostType (CatalogPost) import Network.CatalogPostType (CatalogPost)
import qualified Network.CatalogPostType as CatalogPost import qualified Network.CatalogPostType as CatalogPost
import Parsing.EmbedParser (extractVideoId)
data Model = Model data Model = Model
{ display_items :: [ CatalogPost ] { display_items :: [ CatalogPost ]
@ -115,12 +116,19 @@ gridItem iface m post =
post_count_str :: MisoString post_count_str :: MisoString
post_count_str = toMisoString $ (CatalogPost.estimated_post_count post) - 1 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 :: MisoString
thumb_url = thumb_url =
case mthumb_path of case embed_url of
-- TODO: what about embeds!? Nothing ->
Nothing -> "/static/default_thumbnail.png" case mthumb_path of
Just thumb_path -> (media_root m) `append` (toMisoString thumb_path) -- 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 :: Maybe Text
mthumb_path = do mthumb_path = do

56
src/Component/Thread/Embed.hs Normal file
View File

@ -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

2
src/Component/Thread/Intro.hs
View File

@ -30,7 +30,7 @@ import Network.BoardType (Board)
import qualified Network.BoardType as Board import qualified Network.BoardType as Board
import qualified Network.ThreadType as Thread import qualified Network.ThreadType as Thread
import Network.ThreadType (Thread) import Network.ThreadType (Thread)
import BodyParser (Backlinks) import Parsing.BodyParser (Backlinks)
formatUTC :: UTCTime -> JSString formatUTC :: UTCTime -> JSString

2
src/Component/Thread/Model.hs
View File

@ -3,7 +3,7 @@ module Component.Thread.Model where
import GHCJS.DOM.Types (JSString) import GHCJS.DOM.Types (JSString)
import Network.SiteType (Site) import Network.SiteType (Site)
import Network.PostType (Post) import Network.PostType (Post)
import PostPartType (PostPart) import Parsing.PostPartType (PostPart)
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
type PostWithBody = (Post, [ PostPart ]) type PostWithBody = (Post, [ PostPart ])

20
src/Component/ThreadView.hs
View File

@ -40,8 +40,9 @@ import qualified Network.ThreadType as Thread
import Network.ThreadType (Thread) import Network.ThreadType (Thread)
import Component.Thread.Files (files) import Component.Thread.Files (files)
import Component.Thread.Intro (intro) import Component.Thread.Intro (intro)
import Component.Thread.Embed (embed)
import Component.Thread.Model import Component.Thread.Model
import BodyParser import Parsing.BodyParser
import qualified Component.BodyRender as Body import qualified Component.BodyRender as Body
initialModel :: JSString -> Site -> Model initialModel :: JSString -> Site -> Model
@ -116,7 +117,7 @@ view m =
op :: Model -> Post -> Backlinks -> [ View a ] op :: Model -> Post -> Backlinks -> [ View a ]
op m op_post backlinks = op m op_post backlinks =
[ files (media_root m) site_ op_post [ files_or_embed_view
, div_ , div_
( (
[ class_ "post op" [ class_ "post op"
@ -131,6 +132,13 @@ op m op_post backlinks =
] ]
where 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
site_ = site m site_ = site m
@ -165,7 +173,7 @@ reply m backlinks (post, parts) = div_
] ++ multi post ] ++ multi post
) )
[ intro site_ board thread post backlinks $ current_time m [ intro site_ board thread post backlinks $ current_time m
, files (media_root m) site_ post , files_or_embed_view
, div_ , div_
[ class_ "body" ] [ class_ "body" ]
(Body.render m parts) (Body.render m parts)
@ -173,6 +181,12 @@ reply m backlinks (post, parts) = div_
] ]
where 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
site_ = site m site_ = site m

15
src/Component/TimeControl.hs
View File

@ -30,7 +30,7 @@ import Data.Time.Clock
, addUTCTime , addUTCTime
, secondsToDiffTime , secondsToDiffTime
) )
import Data.Time.Calendar (fromGregorian, Day) import Data.Time.Calendar (fromGregorian)
data Time data Time
= Now = Now
@ -76,8 +76,8 @@ update
-> Time -> Time
-> Model -> Model
-> Effect a Model -> Effect a Model
update iface (SlideInput time) m = m <# do update iface (SlideInput nstr) m = m <# do
consoleLog $ "Input: " <> time consoleLog $ "Input: " <> nstr
return $ (passAction iface) NoAction return $ (passAction iface) NoAction
@ -86,24 +86,27 @@ update iface (SlideChange nstr) m = m { whereAt = n } <# do
now <- getCurrentTime now <- getCurrentTime
return $ (goTo iface) $ interpolateTimeHours n now let newTime = interpolateTimeHours n now
return $ (goTo iface) newTime
where where
n :: Integer n :: Integer
n = read $ fromMisoString nstr n = read $ fromMisoString nstr
update _ _ m = noEff m update _ _ m = noEff m
earliest :: UTCTime 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 -- Linear interpolation function using hours
interpolateTimeHours :: Integer -> UTCTime -> UTCTime interpolateTimeHours :: Integer -> UTCTime -> UTCTime
interpolateTimeHours n currentTime interpolateTimeHours n currentTime
| n == 0 = currentTime | n == 0 = currentTime
| n == -500 = earliest
| otherwise = addUTCTime (fromIntegral hoursToAdjust * secondsInHour) currentTime | otherwise = addUTCTime (fromIntegral hoursToAdjust * secondsInHour) currentTime
where where

8
src/Main.hs
View File

@ -33,6 +33,8 @@ import Miso
, consoleLog , consoleLog
, pushURI , pushURI
, uriSub , uriSub
, time_
, class_
) )
import GHCJS.DOM (currentDocument) import GHCJS.DOM (currentDocument)
import GHCJS.DOM.Types (toJSString, fromJSString, Element, JSString) import GHCJS.DOM.Types (toJSString, fromJSString, Element, JSString)
@ -156,7 +158,11 @@ mainView model = view
catalog_view :: Model -> View Action catalog_view :: Model -> View Action
catalog_view m = div_ [] 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) , TC.view iTime (tc_model m)
, Grid.view iGrid (grid_model model) , Grid.view iGrid (grid_model model)
] ]

1
src/Network/CatalogPostType.hs
View File

@ -24,6 +24,7 @@ data CatalogPost = CatalogPost
, email :: Maybe Text , email :: Maybe Text
, thread_id :: Int , thread_id :: Int
-- , post_count :: Int -- , post_count :: Int
, embed :: Maybe Text
, estimated_post_count :: Int , estimated_post_count :: Int
, site_name :: Text , site_name :: Text
, pathpart :: Text , pathpart :: Text

1
src/Network/PostType.hs
View File

@ -19,6 +19,7 @@ data Post = Post
, email :: Maybe Text , email :: Maybe Text
, body_search_index :: Text , body_search_index :: Text
, thread_id :: Integer , thread_id :: Integer
, embed :: Maybe Text
, attachments :: [ Attachment ] , attachments :: [ Attachment ]
} deriving (Show, Generic, FromJSON, ToJSON, Eq) } deriving (Show, Generic, FromJSON, ToJSON, Eq)

6
src/BodyParser.hs → src/Parsing/BodyParser.hs
View File

@ -4,7 +4,7 @@
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module BodyParser module Parsing.BodyParser
( PostPart (..) ( PostPart (..)
, parsePostBody , parsePostBody
, collectBacklinks , collectBacklinks
@ -32,8 +32,8 @@ import Miso.String (fromMisoString)
import qualified Network.PostType as Post import qualified Network.PostType as Post
import Component.Thread.Model (PostWithBody) import Component.Thread.Model (PostWithBody)
import PostPartType import Parsing.PostPartType
import QuoteLinkParser import Parsing.QuoteLinkParser
nodeListToList :: NodeList -> IO [ Node ] nodeListToList :: NodeList -> IO [ Node ]

21
src/Parsing/EmbedParser.hs Normal file
View File

@ -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

4
src/PostPartType.hs → src/Parsing/PostPartType.hs
View File

@ -1,9 +1,9 @@
module PostPartType where module Parsing.PostPartType where
import GHCJS.DOM.Types (JSString) import GHCJS.DOM.Types (JSString)
import Text.Parsec (ParseError) import Text.Parsec (ParseError)
import QuoteLinkParser (ParsedURL) import Parsing.QuoteLinkParser (ParsedURL)
data PostPart data PostPart
= SimpleText JSString = SimpleText JSString

2
src/QuoteLinkParser.hs → src/Parsing/QuoteLinkParser.hs
View File

@ -1,4 +1,4 @@
module QuoteLinkParser module Parsing.QuoteLinkParser
( parseURL ( parseURL
, ParsedURL (..) , ParsedURL (..)
) )