Search WiP: Add searchbar component

Add youtube embeds
TODO in separate text file
2024-03-01 02:29:24 -05:00 · 2024-02-29 20:52:00 -05:00 · 2024-02-20 13:04:09 -05:00 · 2024-02-20 09:42:03 -05:00 · 2024-02-19 13:02:16 -05:00 · 2024-02-16 12:26:30 -05:00
30 changed files with 774 additions and 100 deletions
--- a/TODO.txt
+++ b/TODO.txt
@ -0,0 +1,24 @@
+- get embeds working
+- need to implement search
+- 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
+- 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
+    - 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
+- "infinite" scrolling  
+    - just load more!
+- 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
+- need to display the current time you are at (or Latest) ✓
+- add server sent event (only when in the "present" time wise) and listen
+  for new posts
--- a/chandlr.cabal
+++ b/chandlr.cabal
@ -76,11 +76,16 @@ executable chandlr
                      Component.Thread.Files
                      Component.Thread.Intro
                      Component.Thread.Model
+                      Component.Thread.Embed
                      Component.BodyRender
                      Routes
                      Common.AttachmentType
-                      BodyParser
-                      QuoteLinkParser
+                      Parsing.BodyParser
+                      Parsing.QuoteLinkParser
+                      Parsing.EmbedParser
+                      Parsing.PostPartType
+                      Component.TimeControl
+                      Component.Search


    -- LANGUAGE extensions used by modules in this package.
--- a/default.nix
+++ b/default.nix
@ -13,6 +13,7 @@ let
      pkgs.haskellPackages.cabal-install
      new_pkgs.haskellPackages.ghcjs-dom
      new_pkgs.haskellPackages.miso-from-html
+      new_pkgs.haskellPackages.hlint
    ];
  });

--- a/html/README.hs
+++ b/html/README.hs
@ -0,0 +1,5 @@
+You can use these snippets to generate Miso view syntax
+
+```bash
+cat timecontrol.html | miso-from-html
+```
--- a/html/mentions.html
+++ b/html/mentions.html
@ -0,0 +1,4 @@
+<span class="mentioned unimportant">
+  <a class="mentioned-476665" href="#476665">>>476665</a>
+  <a class="mentioned-476666" href="#476666">>>476666</a>
+</span>
--- a/html/scroll.js
+++ b/html/scroll.js
@ -0,0 +1,16 @@
+function onChange(e) {
+  console.log(e.target.value);
+}
+
+function main() {
+  console.log("Hello world");
+  var elem_range = document.querySelector("input.time-control");
+  console.log(elem_range);
+  elem_range.addEventListener('input', onChange);
+}
+
+if (document.readyState != "complete") {
+    window.addEventListener("load", main, { "once": true })
+} else {
+   main();
+}
--- a/html/scrollbar.html
+++ b/html/scrollbar.html
@ -0,0 +1,23 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+  <meta charset="UTF-8">
+  <title>Scrollbar demo</title>
+  <link href="tc.css" rel="stylesheet" />
+  <script language="javascript" src="scroll.js"></script>
+</head>
+<body>
+  <div class="timecontrol">
+    <div class="tc-scrollbar__wrapper">
+      <div class="tc-scrollbar__bar">
+        <div class="tc-scrollbar__scroller"></div>
+      </div>
+    </div>
+  </div>
+  <input class="time-control" type="range" min=-500 max=0 step=1 value=0>
+  <form class="search_form" action="/search" method="GET">
+    <input type="submit" value="🔍">
+    <input type="text" name="search">
+  </form>
+</body>
+</html>
--- a/html/searchform.html
+++ b/html/searchform.html
@ -0,0 +1,4 @@
+<form class="search_form" action="/search" method="GET">
+  <input type="submit" value="🔍">
+  <input type="text" name="search">
+</form>
--- a/html/tc.css
+++ b/html/tc.css
@ -0,0 +1,68 @@
+.timecontrol {
+  overflow-x: hidden;
+}
+
+.tc-scrollbar__wrapper,
+.time-control {
+  width: 70%;
+  margin-left: auto;
+  margin-right: auto;
+  display: block;
+}
+
+.tc-scrollbar__bar {
+  width: 100%;
+  height: 20px;
+  border-left: 2px solid black;
+  border-right: 2px dotted black;
+  position: relative;
+  box-sizing: border-box;
+}
+
+.tc-scrollbar__bar:before {
+  content: "";
+  display: block;
+  float: left;
+  width: 150%;
+  width: 100%;
+  height: 1px;
+  background-color: black;
+  position: relative;
+  top: calc(50% - .5px);
+}
+
+.tc-scrollbar__scroller {
+  height: 100%;
+  width: 20px;
+  box-sizing: border-box;
+  border: 3px solid black;
+  border-radius: 50%;
+  background-color: white;
+  position: absolute;
+  right: 0;
+}
+
+.search_form {
+  display: flex;
+  width: 70%;
+  margin-left: auto;
+  margin-right: auto;
+  margin-top: 1em;
+}
+
+.search_form input[name="search"] {
+  flex-grow: 1;
+  margin-left: .5em;
+  height: 2em;
+  box-sizing: border-box;
+  font-size: 1.25em;
+}
+
+.search_form input[type="submit"] {
+  flex-grow: 0;
+  height: 2em;
+  width: 2em;
+  text-align: middle;
+  box-sizing: border-box;
+  font-size: 1.25em;
+}
--- a/html/timecontrol.html
+++ b/html/timecontrol.html
@ -0,0 +1 @@
+<input class="time-control" type="range" min="-500" max="0" step="1" value="0">
--- 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,19 +3,13 @@
  <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" />
    <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/rts.js"></script>
    <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/lib.js"></script>
    <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/out.js"></script>
-    <style>
-      .post.op.multifile,
-      .post.reply.multifile .body {
-        clear: both;
-      }
-    </style>
  </head>
  <body>
  </body>
--- a/src/Action.hs
+++ b/src/Action.hs
@ -5,6 +5,7 @@ module Action where
 import Data.Text (Text)
 import Data.Aeson (FromJSON)
 import Data.Int (Int64)
+import Data.Time.Clock (UTCTime)
 import Miso (URI)

 import qualified Component.CatalogGrid as Grid
@ -13,6 +14,8 @@ import Network.CatalogPostType (CatalogPost)
 import Network.Http (HttpResult)
 import Network.SiteType (Site)
 import qualified Component.ThreadView as Thread
+import qualified Component.TimeControl as TC
+import qualified Component.Search as Search

 data GetThreadArgs = GetThreadArgs
    { website         :: Text
@ -22,11 +25,13 @@ data GetThreadArgs = GetThreadArgs

 data Action
    = GridAction Grid.Action
-    | GetLatest
    | GetThread GetThreadArgs
    | HaveLatest (HttpResult [ CatalogPost ])
    | HaveThread (HttpResult [ Site ])
    | forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a)
    | ThreadAction Thread.Action
+    | TimeAction TC.Time
+    | SearchAction Search.Action
+    | GoToTime UTCTime
    | ChangeURI URI
    | NoAction
--- a/src/Component/BodyRender.hs
+++ b/src/Component/BodyRender.hs
@ -16,6 +16,7 @@ import Miso
    , u_
    , em_
    , s_
+    , small_
    )

 import Miso.String (toMisoString)
@ -24,11 +25,13 @@ 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
+import qualified Network.ThreadType as Thread
+import qualified Network.PostType as Post

 {-
 - This is the inverse of parsePostBody from BodyParser except
@ -77,15 +80,24 @@ renderPostPart m (Quote parse_result) = elems parse_result
                    else
                        a_
                            [ href_ u ]
-                            [ text $ ">>" <> post_id ]
+                            $
+                            (text $ ">>" <> post_id)
+                            :
+                            if pid == op_id
+                            then [ small_ [] [ " (OP)" ] ]
+                            else []

            where
                linked_board = toMisoString $ boardName p

-                post_id = toMisoString $ show $ fromJust $ postId p
+                pid = fromJust $ postId p
+
+                post_id = toMisoString $ show pid

                current_board = toMisoString $ Board.pathpart $ head $ Site.boards (Model.site m)

+                op_id = Post.board_post_id $ head $ Thread.posts $ head $ Board.threads $ head $ Site.boards (Model.site m)
+

        full_url :: ParsedURL -> Maybe JSString
        full_url ParsedURL {..} = do
--- 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
--- a/src/Component/Search.hs
+++ b/src/Component/Search.hs
@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Component.Search
+( view
+, Interface (..)
+, update
+, Model (..)
+, Action (..)
+) where
+
+import Miso
+  ( View
+  , class_
+  , action_
+  , method_
+  , input_
+  , type_
+  , value_
+  , name_
+  , form_
+  , onChange
+  , onSubmit
+  , Effect
+  , (<#)
+  , consoleLog
+  , noEff
+  )
+import GHCJS.DOM.Types (JSString)
+
+data Action = SearchChange JSString | OnSubmit | NoAction
+
+data Model = Model
+  { search_term :: JSString
+  } deriving Eq
+
+data Interface a = Interface
+  { passAction :: Action -> a
+  }
+
+
+update :: Interface a -> Action -> Model -> Effect a Model
+update iface (SearchChange q) model = model { search_term = q } <# do
+  consoleLog q
+  return $ (passAction iface) NoAction
+
+update iface OnSubmit model = model <# do
+  consoleLog $ "Submit!" <> search_term model
+  return $ (passAction iface) NoAction
+
+update _ NoAction m = noEff m
+
+view :: Interface a -> View a
+view iface = form_
+    [ class_ "search_form"
+    , action_ "/search"
+    , method_ "GET"
+    , onSubmit $ pass OnSubmit
+    ]
+    [ input_
+        [ type_ "submit"
+        , value_ "🔍"
+        ]
+    , input_
+        [ type_ "text"
+        , name_ "search"
+        , onChange $ pass . SearchChange
+        ]
+    ]
+
+    where
+        pass = passAction iface
--- 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
@ -8,22 +8,38 @@ import Miso
  , href_
  , a_
  , class_
-  , id_
  , textProp
  , title_
  , span_
  , time_
  )

+import qualified Data.Map as Map
+import Data.Text (Text, pack)
 import GHCJS.DOM.Types (JSString)
 import Data.Foldable (toList)
 import Miso.String (toMisoString)
+import Data.Time.Clock (UTCTime, diffUTCTime)
+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)
+import Parsing.BodyParser (Backlinks)

-intro :: Post -> View a
-intro post = span_
+
+formatUTC :: UTCTime -> JSString
+formatUTC time = toMisoString $
+    formatTime defaultTimeLocale "%Y-%m-%d (%a) %T" time
+
+
+intro :: Site -> Board -> Thread -> Post -> Backlinks -> UTCTime -> View a
+intro site board thread post backlinks current_time = span_
  [ class_ "intro" ]
  ( subject ++
    [ " "
@ -32,24 +48,32 @@ intro post = span_
    -- TODO: Add flags (don't have that data in the db yet)
    , " "
    , time_
-        [ textProp "datetime" "2024-01-19T11:53:33Z"
-        , textProp "data-local" "true"
-        , title_ "14 days ago"
-        ][ "2024-01-19 (Fri) 06:53:33" ]
+        [ textProp "datetime" $ toMisoString $ show $ creation_time
+        , title_ $ toMisoString $ timeAgo current_time creation_time
+        ][ text $ formatUTC creation_time ]
    , " "
    , a_
        [ class_ "post_no"
-        , id_ "post_no_477700"
-        , href_ "/leftypol/res/477700.html#477700"
+        , href_ $ toMisoString $ post_url <> "#" <> b_post_id
        ][ "No." ]
    , a_
        [ class_ "post_no"
-        , href_ "/leftypol/res/477700.html#q477700"
-        ][ text $ toMisoString $ show $ Post.board_post_id post ]
+        , href_ $ toMisoString $ post_url <> "#q" <> b_post_id
+        ][ text $ toMisoString $ b_post_id ]
    ]
+    ++ mentions
  )

  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 ]
    subject = map (mkSubject . toMisoString) $ toList $ Post.subject post

@ -60,3 +84,53 @@ intro post = span_
    mkSubject s = span_ 
      [ class_ "subject" ]
      [ text s ]
+
+    b_post_id :: Text
+    b_post_id = pack $ show $ Post.board_post_id post
+
+    mentions :: [ View a ]
+    mentions =
+        case Map.lookup (Post.board_post_id post) backlinks of
+            Nothing -> []
+            Just [] -> []
+            Just xs -> span_
+                [ class_ "mentioned unimportant" ]
+                (map mention xs)
+                : []
+
+    mention :: Post -> View a
+    mention p =
+        a_
+            [ href_ $ "#" <> bpid
+            ]
+            [ text $ ">>" <> bpid ]
+
+        where
+            bpid :: JSString
+            bpid = toMisoString $ show $ Post.board_post_id p
+
+
+-- Convert UTCTime to a human-readable string
+timeAgo :: UTCTime -> UTCTime -> String
+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 < 60 = "Just now"
+    | diff < 3600 = formatTimeUnit (truncate (diff / 60) :: Int) "minute"
+    | diff < 86400 = formatTimeUnit (truncate (diff / 3600) :: Int) "hour"
+    | diff < 604800 = formatTimeUnit (truncate (diff / 86400) :: Int) "day"
+    | diff < 2592000 = formatTimeUnit (truncate (diff / 604800) :: Int) "week"
+    | diff < 31536000 = formatTimeUnit (truncate (diff / 2592000) :: Int) "month"
+    | otherwise = formatTimeUnit (truncate (diff / 31536000) :: Int) "year"
--- a/src/Component/Thread/Model.hs
+++ b/src/Component/Thread/Model.hs
@ -3,7 +3,8 @@ module Component.Thread.Model where
 import GHCJS.DOM.Types (JSString)
 import Network.SiteType (Site)
 import Network.PostType (Post)
-import BodyParser (PostPart)
+import Parsing.PostPartType (PostPart)
+import Data.Time.Clock (UTCTime)

 type PostWithBody = (Post, [ PostPart ])

@ -11,5 +12,6 @@ data Model = Model
  { site :: Site
  , media_root :: JSString
  , post_bodies :: [ PostWithBody ]
+  , current_time :: UTCTime
  } deriving Eq

--- a/src/Component/ThreadView.hs
+++ b/src/Component/ThreadView.hs
@ -27,17 +27,22 @@ import Miso
 import Data.Text (Text)
 import Miso.String (toMisoString)
 import GHCJS.DOM.Types (JSString)
+import Data.Time.Clock (UTCTime (..), secondsToDiffTime, getCurrentTime)
+import Data.Time.Calendar (Day (..))

 import Network.SiteType (Site)
 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.Embed (embed)
 import Component.Thread.Model
-import BodyParser
+import Parsing.BodyParser
 import qualified Component.BodyRender as Body

 initialModel :: JSString -> Site -> Model
@ -45,11 +50,12 @@ initialModel mroot s = Model
    { site = s
    , post_bodies = []
    , media_root = mroot
+    , current_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)
    }

 data Action
    = RenderSite Site
-    | UpdatePostBodies [ PostWithBody ]
+    | UpdatePostBodies UTCTime [ PostWithBody ]

 data Interface a = Interface { passAction :: Action -> a }

@ -59,7 +65,9 @@ update iface (RenderSite s) m = m { site = s } <# do

    mapM_ (consoleLog . toMisoString . show) bodies

-    return $ passAction iface $ UpdatePostBodies $ zip posts bodies
+    now <- getCurrentTime
+
+    return $ passAction iface $ UpdatePostBodies now $ zip posts bodies

    where
        getBody :: Maybe Text -> IO [ PostPart ]
@ -70,7 +78,7 @@ update iface (RenderSite s) m = m { site = s } <# do
        posts = Thread.posts $ head $ Board.threads $ head $ Site.boards s
 --update (RenderSite s) m = noEff (m { site = s })

-update _ (UpdatePostBodies pwbs) m = noEff m { post_bodies = pwbs }
+update _ (UpdatePostBodies t pwbs) m = noEff m { post_bodies = pwbs, current_time = t }


 view :: Model -> View a
@ -82,7 +90,7 @@ view m =
        , div_
            [ class_ "thread" ]
            (  (op_post thread_posts)
-            ++ map (reply m) (drop 1 (post_bodies m))
+            ++ map (reply m backlinks) (drop 1 (post_bodies m))
            )
        ]
    )
@ -94,9 +102,12 @@ view m =
                concatMap (Board.threads) $
                    Site.boards (site m)

+        backlinks :: Backlinks
+        backlinks = collectBacklinks (post_bodies m)
+
        op_post :: [ Post ] -> [ View a ]
        op_post [] = [ h2_ [] [ "There's nothing here" ] ]
-        op_post (x:_) = op m x
+        op_post (x:_) = op m x backlinks

        title :: JSString
        title = toMisoString $ (Site.name $ site m) <> " /" <> board <> "/"
@ -104,16 +115,16 @@ view m =
        board = Board.pathpart $ head $ Site.boards (site m)


-op :: Model -> Post -> [ View a ]
-op m op_post =
-    [ files (media_root m) (site m) op_post
+op :: Model -> Post -> Backlinks -> [ View a ]
+op m op_post backlinks =
+    [ files_or_embed_view
    , div_
        (
            [ class_ "post op"
            , id_ $ toMisoString $ show $ Post.board_post_id op_post
            ] ++ multi op_post
        )
-        [ intro op_post
+        [ intro site_ board thread op_post backlinks $ current_time m
        , div_
            [ class_ "body" ]
            (body $ post_bodies m)
@ -121,6 +132,22 @@ op m op_post =
    ]

    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
+
+        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
@ -132,8 +159,8 @@ multi post
    | otherwise = []


-reply :: Model -> PostWithBody -> View a
-reply m (post, parts) = div_
+reply :: Model -> Backlinks -> PostWithBody -> View a
+reply m backlinks (post, parts) = div_
    [ class_ "postcontainer"
    , id_ $ toMisoString $ show $ Post.board_post_id post
    ]
@ -145,10 +172,27 @@ reply m (post, parts) = div_
            [ class_ "post reply"
            ] ++ multi post
        )
-        [ intro post
-        , files (media_root m) (site m) post
+        [ intro site_ board thread post backlinks $ current_time m
+        , files_or_embed_view
        , div_
            [ class_ "body" ]
            (Body.render m parts)
        ]
    ]
+
+    where
+        files_or_embed_view :: View a
+        files_or_embed_view =
+          case (Post.embed post) of
+            Just _ -> embed post
+            Nothing -> files (media_root m) site_ post
+
+        site_ :: Site
+        site_ = site m
+
+        board :: Board
+        board = head $ Site.boards site_
+
+        thread :: Thread
+        thread = head $ Board.threads board
+
--- a/src/Component/TimeControl.hs
+++ b/src/Component/TimeControl.hs
@ -0,0 +1,121 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Component.TimeControl where
+
+import Miso
+    ( View
+    , div_
+    , class_
+    , input_
+    , step_
+    , min_
+    , max_
+    , type_
+    , value_
+    , (<#)
+    , consoleLog
+    , Effect
+    , noEff
+    , onInput
+    , onChange
+    )
+
+import Miso.String (toMisoString, fromMisoString)
+import GHCJS.DOM.Types (JSString)
+import Data.Time.Clock
+  ( UTCTime (..)
+  , getCurrentTime
+  , diffUTCTime
+  , addUTCTime
+  , secondsToDiffTime
+  )
+import Data.Time.Calendar (fromGregorian)
+
+data Time
+  = Now
+  | NoAction
+  | SlideInput JSString
+  | SlideChange JSString
+  deriving Show
+
+data Interface a = Interface
+    { passAction :: Time -> a
+    , goTo :: UTCTime -> a
+    }
+
+data Model = Model
+  { whereAt :: Integer
+  } deriving Eq
+
+initialModel :: Integer -> Model
+initialModel = Model
+
+view :: Interface a -> Model -> View a
+view iface m =
+    div_
+        [ class_ "time-control"
+        ]
+        [ input_
+            [ class_ "time-slider"
+            , type_ "range"
+            , min_ "-500"
+            , max_ "0"
+            , step_ "1"
+            , value_ $ toMisoString $ show (whereAt m)
+            , onInput $ pass SlideInput
+            , onChange $ pass SlideChange
+            ]
+        ]
+
+    where
+      pass action = \t -> passAction iface $ action t
+
+update
+    :: Interface a
+    -> Time
+    -> Model
+    -> Effect a Model
+update iface (SlideInput nstr) m = m <# do
+  consoleLog $ "Input: " <> nstr
+
+  return $ (passAction iface) NoAction
+
+update iface (SlideChange nstr) m = m { whereAt = n } <# do
+  consoleLog $ "Change: " <> nstr
+
+  now <- getCurrentTime
+
+  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 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
+    -- Calculate the total number of hours between the current time and the target date
+    totalHours = diffUTCTime currentTime earliest / secondsInHour
+
+    -- Calculate the number of hours to adjust based on linear interpolation
+    hoursToAdjust :: Integer
+    hoursToAdjust = round $ totalHours * (fromIntegral n / 500.0)
+
+    -- One hour in seconds
+    secondsInHour = 3600
--- a/src/Main.hs
+++ b/src/Main.hs
@ -11,6 +11,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Network.URI (uriPath)
 import System.FilePath ((</>))
+import Data.Time.Clock (UTCTime, getCurrentTime)

 import Data.Aeson (FromJSON)
 import Data.JSString (pack, append)
@ -32,6 +33,8 @@ import Miso
    , consoleLog
    , pushURI
    , uriSub
+    , time_
+    , class_
    )
 import GHCJS.DOM (currentDocument)
 import GHCJS.DOM.Types (toJSString, fromJSString, Element, JSString)
@ -46,6 +49,8 @@ import Network.CatalogPostType (CatalogPost)
 import qualified Network.CatalogPostType as CatalogPost
 import qualified Component.CatalogGrid as Grid
 import qualified Component.ThreadView as Thread
+import qualified Component.TimeControl as TC
+import qualified Component.Search as Search


 data Model = Model
@ -54,6 +59,9 @@ data Model = Model
    , thread_model :: Maybe Thread.Model
    , current_uri :: URI
    , media_root_ :: JSString
+    , current_time :: UTCTime
+    , tc_model :: TC.Model
+    , search_model :: Search.Model
    } deriving Eq


@ -65,7 +73,7 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result
        handlers = h_latest :<|> h_thread

        h_latest :: Model -> Action
-        h_latest = const GetLatest
+        h_latest = const $ GoToTime $ current_time model

        h_thread :: Text -> Text -> BoardThreadId -> Model -> Action
        h_thread website board_pathpart board_thread_id _ = GetThread GetThreadArgs {..}
@ -76,8 +84,9 @@ initialModel
    -> Int
    -> JSString
    -> URI
+    -> UTCTime
    -> Model
-initialModel pgroot client_fetch_count media_root u = Model
+initialModel pgroot client_fetch_count media_root u t = Model
    { grid_model = Grid.initialModel media_root
    , client_model = Client.Model
        { Client.pgApiRoot = pgroot
@ -86,6 +95,9 @@ initialModel pgroot client_fetch_count media_root u = Model
    , thread_model = Nothing
    , current_uri = u
    , media_root_ = media_root
+    , current_time = t
+    , tc_model = TC.initialModel 0
+    , search_model = Search.Model { Search.search_term = "" }
    }

 getMetadata :: String -> IO (Maybe JSString)
@ -118,7 +130,13 @@ main = do
    media_root <- getMetadata "media-root" >>=
        return . maybe "undefined" id

-    let initial_model = initialModel pg_api_root pg_fetch_count media_root uri
+    now <- getCurrentTime
+
+    let initial_model = initialModel
+          pg_api_root
+          pg_fetch_count
+          media_root uri
+          now

    startApp App
        { model         = initial_model
@ -142,8 +160,14 @@ mainView model = view
        handlers = catalog_view :<|> thread_view

        catalog_view :: Model -> View Action
-        catalog_view _ = div_ []
-            [ h1_ [] [ text "Overboard Catalog" ]
+        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)
+            , Search.view iSearch
            , Grid.view iGrid (grid_model model)
            ]

@ -183,10 +207,11 @@ mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do
    where
        new_model = m
            { thread_model =
-                body >>= Just . (Thread.initialModel (media_root_ m)) . head
+                body >>= Just . (Thread.initialModel $ media_root_ m) . head
            }

-mainUpdate GetLatest m = m <# Client.fetchLatest (client_model m) (iClient HaveLatest)
+mainUpdate (GoToTime t) m = m { current_time = t } <# do
+  Client.fetchLatest (client_model m) t (iClient HaveLatest)

 -- mainUpdate GetThread {..} m = noEff m

@ -203,8 +228,8 @@ mainUpdate (GetThread GetThreadArgs {..}) m = m <# do
            </> show board_thread_id
        }

-mainUpdate (ChangeURI old_uri) m = m { current_uri = old_uri } <# do
-    consoleLog $ "ChangeURI! " `append` (pack $ show $ old_uri)
+mainUpdate (ChangeURI uri) m = m { current_uri = uri } <# do
+    consoleLog $ "ChangeURI! " `append` (pack $ show $ uri)
    return NoAction

 mainUpdate (GridAction ga) m =
@ -222,6 +247,13 @@ mainUpdate (ThreadAction ta) model = do

    noEff model { thread_model = tm }

+mainUpdate (TimeAction ta) m =
+  TC.update iTime ta (tc_model m)
+  >>= \tm -> noEff m { tc_model = tm }
+
+mainUpdate (SearchAction sa) m =
+  Search.update iSearch sa (search_model m)
+  >>= \sm -> noEff m { search_model = sm }

 iGrid :: Grid.Interface Action
 iGrid = Grid.Interface
@ -246,17 +278,11 @@ iClient action = Client.Interface
 iThread :: Thread.Interface Action
 iThread = Thread.Interface { Thread.passAction = ThreadAction }

-{-
- - TODO:
- -  - Create the thread view
- -      - add routing so when you click in the catalog it goes to the thread
- -          - register onClick ✓
- -          - pevent default and consoleLog the event ✓
- -          - display page
- -          - history api / navigation for browser history ✓
- -      - create component ✓
- -
- -
- -  - make it isomorphic
- -      - move everything before or during this part into common lib
- -}
+iTime :: TC.Interface Action
+iTime = TC.Interface
+  { TC.passAction = TimeAction
+  , TC.goTo = GoToTime
+  }
+
+iSearch :: Search.Interface Action
+iSearch = Search.Interface { passAction = SearchAction }
--- 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/Client.hs
+++ b/src/Network/Client.hs
@ -68,12 +68,10 @@ http_ m iface api_path method payload =
    >>= return . (passAction iface) . Connect


-fetchLatest :: Model -> Interface a [ CatalogPost ] -> IO a
-fetchLatest m iface = do
-    now <- getCurrentTime
-
+fetchLatest :: Model -> UTCTime -> Interface a [ CatalogPost ] -> IO a
+fetchLatest m t iface = do
    let payload = Just $ FetchCatalogArgs
-            { max_time = now
+            { max_time = t
            , max_row_read = fetchCount m
            }

--- 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
@ -2,13 +2,18 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}

-module BodyParser
-( PostPart (..)
-, parsePostBody
-) where
+module Parsing.BodyParser
+    ( PostPart (..)
+    , parsePostBody
+    , collectBacklinks
+    , Backlinks
+    ) where

 import Data.Maybe (catMaybes)
+import Data.Map (Map)
+import qualified Data.Map as Map
 import GHCJS.DOM (currentDocument)
 import GHCJS.DOM.Types
    ( Element (..)
@ -24,28 +29,11 @@ import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains)
 import Data.Text (Text)
 import Miso (consoleLog)
 import Miso.String (fromMisoString)
-import Text.Parsec (ParseError)
+import qualified Network.PostType as Post
+import Component.Thread.Model (PostWithBody)

-import QuoteLinkParser
-
-
-data PostPart
-    = SimpleText JSString
-    | PostedUrl JSString
-    | Skip
-    | Quote (Either ParseError ParsedURL)
-        -- Quotes don't seem to be able to be spoilered
-        -- board links (which appear as quotes but start with >>>) break the tag
-    | GreenText     [ PostPart ]
-    | OrangeText    [ PostPart ]
-    | RedText       [ PostPart ]
-    | Spoiler       [ PostPart ]
-    -- you can't seem to spoiler greentext
-    | Bold          [ PostPart ]
-    | Underlined    [ PostPart ]
-    | Italics       [ PostPart ]
-    | Strikethrough [ PostPart ]
-    deriving (Show, Eq)
+import Parsing.PostPartType
+import Parsing.QuoteLinkParser


 nodeListToList :: NodeList -> IO [ Node ]
@ -157,3 +145,27 @@ parseS :: Element -> IO PostPart
 parseS element
    = parseChildNodes element
    >>= return . Strikethrough
+
+type Backlinks = Map Integer [Post.Post]
+
+collectBacklinks :: [PostWithBody] -> Backlinks
+collectBacklinks xs = foldr insertElement Map.empty xs
+  where
+    insertElement :: PostWithBody -> Backlinks -> Backlinks
+    insertElement (post, body) acc = foldr insertPost acc (quotedPosts body)
+      where
+        insertPost postId = Map.insertWith (++) postId [post]
+
+
+quotedPosts :: [ PostPart ] -> [ Integer ]
+quotedPosts [] = []
+quotedPosts (Quote (Right (ParsedURL { postId = Just p })) : xs) = [p] ++ quotedPosts xs
+quotedPosts ((GreenText     xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((OrangeText    xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((RedText       xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Spoiler       xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Bold          xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Underlined    xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Italics       xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Strikethrough xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts _ = []
--- 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
@ -0,0 +1,26 @@
+module Parsing.PostPartType where
+
+import GHCJS.DOM.Types (JSString)
+import Text.Parsec (ParseError)
+
+import Parsing.QuoteLinkParser (ParsedURL)
+
+data PostPart
+    = SimpleText JSString
+    | PostedUrl JSString
+    | Skip
+    | Quote (Either ParseError ParsedURL)
+        -- Quotes don't seem to be able to be spoilered
+        -- board links (which appear as quotes but start with >>>) break the tag
+    | GreenText     [ PostPart ]
+    | OrangeText    [ PostPart ]
+    | RedText       [ PostPart ]
+    | Spoiler       [ PostPart ]
+    -- you can't seem to spoiler greentext
+    | Bold          [ PostPart ]
+    | Underlined    [ PostPart ]
+    | Italics       [ PostPart ]
+    | Strikethrough [ PostPart ]
+    deriving (Show, Eq)
+
+
--- a/src/Parsing/QuoteLinkParser.hs
+++ b/src/Parsing/QuoteLinkParser.hs
@ -1,4 +1,4 @@
-module QuoteLinkParser
+module Parsing.QuoteLinkParser
    ( parseURL
    , ParsedURL (..)
    )
--- a/static/style.css
+++ b/static/style.css
@ -294,8 +294,7 @@ input[type="text"],input[type="password"],textarea {
  word-spacing: normal;
  font-size: inherit;
  font-family: sans-serif;
-
-  padding:0px!important;
+  padding:0px;
 }


@ -2015,3 +2014,49 @@ span.orangeQuote {
 .options_general_tab--select_opt select {
    float: none;
 }
+
+/*
+ * Deviations from original stylesheet specific to chandlr-miso
+ */
+
+.post.op.multifile,
+.post.reply.multifile .body {
+  clear: both;
+}
+
+.time-slider {
+  width: 70%;
+  margin-left: auto;
+  margin-right: auto;
+  display: block;
+}
+
+.page_heading * {
+  display: block;
+  text-align: center;
+}
+
+.search_form {
+  display: flex;
+  width: 70%;
+  margin: 1em auto;
+}
+
+.search_form input[name="search"] {
+  flex-grow: 1;
+  margin-left: .5em;
+  height: 2em;
+  box-sizing: border-box;
+  font-size: 1.25em;
+  padding: 0 .5em;
+}
+
+.search_form input[type="submit"] {
+  flex-grow: 0;
+  height: 2em;
+  width: 2em;
+  text-align: middle;
+  box-sizing: border-box;
+  font-size: 1.25em;
+}
+
Author	SHA1	Message	Date
towards-a-new-leftypol	f04fd2e591	Search WiP: Add searchbar component	2024-03-01 02:29:24 -05:00
towards-a-new-leftypol	02c7a48770	Add youtube embeds	2024-02-29 20:52:00 -05:00
towards-a-new-leftypol	2176e55bf6	TODO in separate text file	2024-02-20 13:04:09 -05:00
towards-a-new-leftypol	2e3ef2e841	Hook up jumping to an earlier time with the slider on the catalog page	2024-02-20 09:42:03 -05:00
towards-a-new-leftypol	49157c27f2	Add input range time control - add component module - hook up events, update function etc	2024-02-19 13:02:16 -05:00
towards-a-new-leftypol	0345a755a4	Backlinks aka mentions	2024-02-16 12:26:30 -05:00
towards-a-new-leftypol	a8594e31f7	remove unused attribute, commented out code	2024-02-14 12:12:12 -05:00
towards-a-new-leftypol	f4dda79c05	Working post no links	2024-02-14 12:09:48 -05:00
towards-a-new-leftypol	e2ce096289	Human readable time title attribute	2024-02-14 11:40:25 -05:00
towards-a-new-leftypol	9f9ee7d857	Format time (in UTC)	2024-02-14 08:27:36 -05:00
				`@ -0,0 +1 @@`
				`<input class="time-control" type="range" min="-500" max="0" step="1" value="0">`