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

Compare commits

base: 0:1b819fea2c0108b8d8e86937628e76eac0aef41b
Branches Tags
0:master
...
compare: 0:f04fd2e591f4a734991b1eaa608af62f687067df
Branches Tags
0:master

10 Commits
1b819fea2c ... f04fd2e591

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
30 changed files with 774 additions and 100 deletions
Show Stats Expand all files Collapse all files

24
TODO.txt Normal file
View File

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

9
chandlr.cabal
View File

@ -76,11 +76,16 @@ executable chandlr
Component.Thread.Files Component.Thread.Files
Component.Thread.Intro Component.Thread.Intro
Component.Thread.Model Component.Thread.Model
Component.Thread.Embed
Component.BodyRender Component.BodyRender
Routes Routes
Common.AttachmentType Common.AttachmentType
BodyParser Parsing.BodyParser
QuoteLinkParser Parsing.QuoteLinkParser
Parsing.EmbedParser
Parsing.PostPartType
Component.TimeControl
Component.Search
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.

1
default.nix
View File

@ -13,6 +13,7 @@ let
pkgs.haskellPackages.cabal-install pkgs.haskellPackages.cabal-install
new_pkgs.haskellPackages.ghcjs-dom new_pkgs.haskellPackages.ghcjs-dom
new_pkgs.haskellPackages.miso-from-html new_pkgs.haskellPackages.miso-from-html
new_pkgs.haskellPackages.hlint
]; ];
}); });

5
html/README.hs Normal file
View File

@ -0,0 +1,5 @@
You can use these snippets to generate Miso view syntax
```bash
cat timecontrol.html | miso-from-html
```

4
html/mentions.html Normal file
View File

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

16
html/scroll.js Normal file
View File

@ -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();
}

23
html/scrollbar.html Normal file
View File

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

4
html/searchform.html Normal file
View File

@ -0,0 +1,4 @@
<form class="search_form" action="/search" method="GET">
<input type="submit" value="🔍">
<input type="text" name="search">
</form>

68
html/tc.css Normal file
View File

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

1
html/timecontrol.html Normal file
View File

@ -0,0 +1 @@
<input class="time-control" type="range" min="-500" max="0" step="1" value="0">

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>

8
index.html
View File

@ -3,19 +3,13 @@
<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" />
<script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/rts.js"></script> <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/lib.js"></script>
<script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/out.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> </head>
<body> <body>
</body> </body>

7
src/Action.hs
View File

@ -5,6 +5,7 @@ module Action where
import Data.Text (Text) import Data.Text (Text)
import Data.Aeson (FromJSON) import Data.Aeson (FromJSON)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Time.Clock (UTCTime)
import Miso (URI) import Miso (URI)
import qualified Component.CatalogGrid as Grid import qualified Component.CatalogGrid as Grid
@ -13,6 +14,8 @@ import Network.CatalogPostType (CatalogPost)
import Network.Http (HttpResult) import Network.Http (HttpResult)
import Network.SiteType (Site) import Network.SiteType (Site)
import qualified Component.ThreadView as Thread import qualified Component.ThreadView as Thread
import qualified Component.TimeControl as TC
import qualified Component.Search as Search
data GetThreadArgs = GetThreadArgs data GetThreadArgs = GetThreadArgs
{ website :: Text { website :: Text
@ -22,11 +25,13 @@ data GetThreadArgs = GetThreadArgs
data Action data Action
= GridAction Grid.Action = GridAction Grid.Action
| GetLatest
| GetThread GetThreadArgs | GetThread GetThreadArgs
| HaveLatest (HttpResult [ CatalogPost ]) | HaveLatest (HttpResult [ CatalogPost ])
| HaveThread (HttpResult [ Site ]) | HaveThread (HttpResult [ Site ])
| forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a) | forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a)
| ThreadAction Thread.Action | ThreadAction Thread.Action
| TimeAction TC.Time
| SearchAction Search.Action
| GoToTime UTCTime
| ChangeURI URI | ChangeURI URI
| NoAction | NoAction

20
src/Component/BodyRender.hs
View File

@ -16,6 +16,7 @@ import Miso
, u_ , u_
, em_ , em_
, s_ , s_
, small_
) )
import Miso.String (toMisoString) import Miso.String (toMisoString)
@ -24,11 +25,13 @@ 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
import qualified Network.ThreadType as Thread
import qualified Network.PostType as Post
{- {-
- This is the inverse of parsePostBody from BodyParser except - This is the inverse of parsePostBody from BodyParser except
@ -77,15 +80,24 @@ renderPostPart m (Quote parse_result) = elems parse_result
else else
a_ a_
[ href_ u ] [ href_ u ]
[ text $ ">>" <> post_id ] $
(text $ ">>" <> post_id)
:
if pid == op_id
then [ small_ [] [ " (OP)" ] ]
else []
where where
linked_board = toMisoString $ boardName p 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) 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 -> Maybe JSString
full_url ParsedURL {..} = do full_url ParsedURL {..} = do

8
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 embed_url of
Nothing ->
case mthumb_path of case mthumb_path of
-- TODO: what about embeds!? -- TODO: what about embeds!?
Nothing -> "/static/default_thumbnail.png" Nothing -> "/static/default_thumbnail.png"
Just thumb_path -> (media_root m) `append` (toMisoString thumb_path) 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

71
src/Component/Search.hs Normal file
View File

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

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

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

@ -8,22 +8,38 @@ import Miso
, href_ , href_
, a_ , a_
, class_ , class_
, id_
, textProp , textProp
, title_ , title_
, span_ , span_
, time_ , time_
) )
import qualified Data.Map as Map
import Data.Text (Text, pack)
import GHCJS.DOM.Types (JSString) import GHCJS.DOM.Types (JSString)
import Data.Foldable (toList) import Data.Foldable (toList)
import Miso.String (toMisoString) import Miso.String (toMisoString)
import Data.Time.Clock (UTCTime, diffUTCTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Network.PostType (Post) import Network.PostType (Post)
import qualified Network.PostType as 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" ] [ class_ "intro" ]
( subject ++ ( subject ++
[ " " [ " "
@ -32,24 +48,32 @@ intro post = span_
-- TODO: Add flags (don't have that data in the db yet) -- TODO: Add flags (don't have that data in the db yet)
, " " , " "
, time_ , time_
[ textProp "datetime" "2024-01-19T11:53:33Z" [ textProp "datetime" $ toMisoString $ show $ creation_time
, textProp "data-local" "true" , title_ $ toMisoString $ timeAgo current_time creation_time
, title_ "14 days ago" ][ text $ formatUTC creation_time ]
][ "2024-01-19 (Fri) 06:53:33" ]
, " " , " "
, a_ , a_
[ class_ "post_no" [ class_ "post_no"
, id_ "post_no_477700" , href_ $ toMisoString $ post_url <> "#" <> b_post_id
, href_ "/leftypol/res/477700.html#477700"
][ "No." ] ][ "No." ]
, a_ , a_
[ class_ "post_no" [ class_ "post_no"
, href_ "/leftypol/res/477700.html#q477700" , href_ $ toMisoString $ post_url <> "#q" <> b_post_id
][ text $ toMisoString $ show $ Post.board_post_id post ] ][ text $ toMisoString $ b_post_id ]
] ]
++ mentions
) )
where 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 :: [ View a ]
subject = map (mkSubject . toMisoString) $ toList $ Post.subject post subject = map (mkSubject . toMisoString) $ toList $ Post.subject post
@ -60,3 +84,53 @@ intro post = span_
mkSubject s = span_ mkSubject s = span_
[ class_ "subject" ] [ class_ "subject" ]
[ text s ] [ 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"

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

@ -3,7 +3,8 @@ 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 BodyParser (PostPart) import Parsing.PostPartType (PostPart)
import Data.Time.Clock (UTCTime)
type PostWithBody = (Post, [ PostPart ]) type PostWithBody = (Post, [ PostPart ])
@ -11,5 +12,6 @@ data Model = Model
{ site :: Site { site :: Site
, media_root :: JSString , media_root :: JSString
, post_bodies :: [ PostWithBody ] , post_bodies :: [ PostWithBody ]
, current_time :: UTCTime
} deriving Eq } deriving Eq

72
src/Component/ThreadView.hs
View File

@ -27,17 +27,22 @@ import Miso
import Data.Text (Text) import Data.Text (Text)
import Miso.String (toMisoString) import Miso.String (toMisoString)
import GHCJS.DOM.Types (JSString) import GHCJS.DOM.Types (JSString)
import Data.Time.Clock (UTCTime (..), secondsToDiffTime, getCurrentTime)
import Data.Time.Calendar (Day (..))
import Network.SiteType (Site) import Network.SiteType (Site)
import qualified Network.SiteType as Site import qualified Network.SiteType as Site
import Network.PostType (Post) import Network.PostType (Post)
import qualified Network.PostType as Post import qualified Network.PostType as Post
import qualified Network.BoardType as Board import qualified Network.BoardType as Board
import Network.BoardType (Board)
import qualified Network.ThreadType as Thread import qualified Network.ThreadType as 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
@ -45,11 +50,12 @@ initialModel mroot s = Model
{ site = s { site = s
, post_bodies = [] , post_bodies = []
, media_root = mroot , media_root = mroot
, current_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)
} }
data Action data Action
= RenderSite Site = RenderSite Site
| UpdatePostBodies [ PostWithBody ] | UpdatePostBodies UTCTime [ PostWithBody ]
data Interface a = Interface { passAction :: Action -> a } 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 mapM_ (consoleLog . toMisoString . show) bodies
return $ passAction iface $ UpdatePostBodies $ zip posts bodies now <- getCurrentTime
return $ passAction iface $ UpdatePostBodies now $ zip posts bodies
where where
getBody :: Maybe Text -> IO [ PostPart ] 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 posts = Thread.posts $ head $ Board.threads $ head $ Site.boards s
--update (RenderSite s) m = noEff (m { site = 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 view :: Model -> View a
@ -82,7 +90,7 @@ view m =
, div_ , div_
[ class_ "thread" ] [ class_ "thread" ]
( (op_post thread_posts) ( (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) $ concatMap (Board.threads) $
Site.boards (site m) Site.boards (site m)
backlinks :: Backlinks
backlinks = collectBacklinks (post_bodies m)
op_post :: [ Post ] -> [ View a ] op_post :: [ Post ] -> [ View a ]
op_post [] = [ h2_ [] [ "There's nothing here" ] ] op_post [] = [ h2_ [] [ "There's nothing here" ] ]
op_post (x:_) = op m x op_post (x:_) = op m x backlinks
title :: JSString title :: JSString
title = toMisoString $ (Site.name $ site m) <> " /" <> board <> "/" title = toMisoString $ (Site.name $ site m) <> " /" <> board <> "/"
@ -104,16 +115,16 @@ view m =
board = Board.pathpart $ head $ Site.boards (site m) board = Board.pathpart $ head $ Site.boards (site m)
op :: Model -> Post -> [ View a ] op :: Model -> Post -> Backlinks -> [ View a ]
op m op_post = op m op_post backlinks =
[ files (media_root m) (site m) op_post [ files_or_embed_view
, div_ , div_
( (
[ class_ "post op" [ class_ "post op"
, id_ $ toMisoString $ show $ Post.board_post_id op_post , id_ $ toMisoString $ show $ Post.board_post_id op_post
] ++ multi op_post ] ++ multi op_post
) )
[ intro op_post [ intro site_ board thread op_post backlinks $ current_time m
, div_ , div_
[ class_ "body" ] [ class_ "body" ]
(body $ post_bodies m) (body $ post_bodies m)
@ -121,6 +132,22 @@ op m op_post =
] ]
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 m
board :: Board
board = head $ Site.boards site_
thread :: Thread
thread = head $ Board.threads board
body :: [ PostWithBody ] -> [ View a ] body :: [ PostWithBody ] -> [ View a ]
body [] = [] body [] = []
body x = Body.render m $ snd $ head x body x = Body.render m $ snd $ head x
@ -132,8 +159,8 @@ multi post
| otherwise = [] | otherwise = []
reply :: Model -> PostWithBody -> View a reply :: Model -> Backlinks -> PostWithBody -> View a
reply m (post, parts) = div_ reply m backlinks (post, parts) = div_
[ class_ "postcontainer" [ class_ "postcontainer"
, id_ $ toMisoString $ show $ Post.board_post_id post , id_ $ toMisoString $ show $ Post.board_post_id post
] ]
@ -145,10 +172,27 @@ reply m (post, parts) = div_
[ class_ "post reply" [ class_ "post reply"
] ++ multi post ] ++ multi post
) )
[ intro post [ intro site_ board thread post backlinks $ current_time m
, files (media_root m) (site m) post , files_or_embed_view
, div_ , div_
[ class_ "body" ] [ class_ "body" ]
(Body.render m parts) (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

121
src/Component/TimeControl.hs Normal file
View File

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

70
src/Main.hs
View File

@ -11,6 +11,7 @@ import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Network.URI (uriPath) import Network.URI (uriPath)
import System.FilePath ((</>)) import System.FilePath ((</>))
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Aeson (FromJSON) import Data.Aeson (FromJSON)
import Data.JSString (pack, append) import Data.JSString (pack, append)
@ -32,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)
@ -46,6 +49,8 @@ import Network.CatalogPostType (CatalogPost)
import qualified Network.CatalogPostType as CatalogPost import qualified Network.CatalogPostType as CatalogPost
import qualified Component.CatalogGrid as Grid import qualified Component.CatalogGrid as Grid
import qualified Component.ThreadView as Thread import qualified Component.ThreadView as Thread
import qualified Component.TimeControl as TC
import qualified Component.Search as Search
data Model = Model data Model = Model
@ -54,6 +59,9 @@ data Model = Model
, thread_model :: Maybe Thread.Model , thread_model :: Maybe Thread.Model
, current_uri :: URI , current_uri :: URI
, media_root_ :: JSString , media_root_ :: JSString
, current_time :: UTCTime
, tc_model :: TC.Model
, search_model :: Search.Model
} deriving Eq } deriving Eq
@ -65,7 +73,7 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result
handlers = h_latest :<|> h_thread handlers = h_latest :<|> h_thread
h_latest :: Model -> Action h_latest :: Model -> Action
h_latest = const GetLatest h_latest = const $ GoToTime $ current_time model
h_thread :: Text -> Text -> BoardThreadId -> Model -> Action h_thread :: Text -> Text -> BoardThreadId -> Model -> Action
h_thread website board_pathpart board_thread_id _ = GetThread GetThreadArgs {..} h_thread website board_pathpart board_thread_id _ = GetThread GetThreadArgs {..}
@ -76,8 +84,9 @@ initialModel
-> Int -> Int
-> JSString -> JSString
-> URI -> URI
-> UTCTime
-> Model -> 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 { grid_model = Grid.initialModel media_root
, client_model = Client.Model , client_model = Client.Model
{ Client.pgApiRoot = pgroot { Client.pgApiRoot = pgroot
@ -86,6 +95,9 @@ initialModel pgroot client_fetch_count media_root u = Model
, thread_model = Nothing , thread_model = Nothing
, current_uri = u , current_uri = u
, media_root_ = media_root , media_root_ = media_root
, current_time = t
, tc_model = TC.initialModel 0
, search_model = Search.Model { Search.search_term = "" }
} }
getMetadata :: String -> IO (Maybe JSString) getMetadata :: String -> IO (Maybe JSString)
@ -118,7 +130,13 @@ main = do
media_root <- getMetadata "media-root" >>= media_root <- getMetadata "media-root" >>=
return . maybe "undefined" id 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 startApp App
{ model = initial_model { model = initial_model
@ -142,8 +160,14 @@ mainView model = view
handlers = catalog_view :<|> thread_view handlers = catalog_view :<|> thread_view
catalog_view :: Model -> View Action catalog_view :: Model -> View Action
catalog_view _ = div_ [] catalog_view m = div_ []
[ div_
[ class_ "page_heading" ]
[ h1_ [] [ text "Overboard Catalog" ] [ 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) , Grid.view iGrid (grid_model model)
] ]
@ -183,10 +207,11 @@ mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do
where where
new_model = m new_model = m
{ thread_model = { 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 -- mainUpdate GetThread {..} m = noEff m
@ -203,8 +228,8 @@ mainUpdate (GetThread GetThreadArgs {..}) m = m <# do
</> show board_thread_id </> show board_thread_id
} }
mainUpdate (ChangeURI old_uri) m = m { current_uri = old_uri } <# do mainUpdate (ChangeURI uri) m = m { current_uri = uri } <# do
consoleLog $ "ChangeURI! " `append` (pack $ show $ old_uri) consoleLog $ "ChangeURI! " `append` (pack $ show $ uri)
return NoAction return NoAction
mainUpdate (GridAction ga) m = mainUpdate (GridAction ga) m =
@ -222,6 +247,13 @@ mainUpdate (ThreadAction ta) model = do
noEff model { thread_model = tm } 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 Action
iGrid = Grid.Interface iGrid = Grid.Interface
@ -246,17 +278,11 @@ iClient action = Client.Interface
iThread :: Thread.Interface Action iThread :: Thread.Interface Action
iThread = Thread.Interface { Thread.passAction = ThreadAction } iThread = Thread.Interface { Thread.passAction = ThreadAction }
{- iTime :: TC.Interface Action
- TODO: iTime = TC.Interface
- - Create the thread view { TC.passAction = TimeAction
- - add routing so when you click in the catalog it goes to the thread , TC.goTo = GoToTime
- - register onClick ✓ }
- - pevent default and consoleLog the event ✓
- - display page iSearch :: Search.Interface Action
- - history api / navigation for browser history ✓ iSearch = Search.Interface { passAction = SearchAction }
- - create component ✓
-
-
- - make it isomorphic
- - move everything before or during this part into common lib
-}

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

8
src/Network/Client.hs
View File

@ -68,12 +68,10 @@ http_ m iface api_path method payload =
>>= return . (passAction iface) . Connect >>= return . (passAction iface) . Connect
fetchLatest :: Model -> Interface a [ CatalogPost ] -> IO a fetchLatest :: Model -> UTCTime -> Interface a [ CatalogPost ] -> IO a
fetchLatest m iface = do fetchLatest m t iface = do
now <- getCurrentTime
let payload = Just $ FetchCatalogArgs let payload = Just $ FetchCatalogArgs
{ max_time = now { max_time = t
, max_row_read = fetchCount m , max_row_read = fetchCount m
} }

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)

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

@ -2,13 +2,18 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module BodyParser module Parsing.BodyParser
( PostPart (..) ( PostPart (..)
, parsePostBody , parsePostBody
, collectBacklinks
, Backlinks
) where ) where
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Map (Map)
import qualified Data.Map as Map
import GHCJS.DOM (currentDocument) import GHCJS.DOM (currentDocument)
import GHCJS.DOM.Types import GHCJS.DOM.Types
( Element (..) ( Element (..)
@ -24,28 +29,11 @@ import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains)
import Data.Text (Text) import Data.Text (Text)
import Miso (consoleLog) import Miso (consoleLog)
import Miso.String (fromMisoString) import Miso.String (fromMisoString)
import Text.Parsec (ParseError) import qualified Network.PostType as Post
import Component.Thread.Model (PostWithBody)
import QuoteLinkParser import Parsing.PostPartType
import Parsing.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)
nodeListToList :: NodeList -> IO [ Node ] nodeListToList :: NodeList -> IO [ Node ]
@ -157,3 +145,27 @@ parseS :: Element -> IO PostPart
parseS element parseS element
= parseChildNodes element = parseChildNodes element
>>= return . Strikethrough >>= 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 _ = []

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

26
src/Parsing/PostPartType.hs Normal file
View File

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

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

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

49
static/style.css
View File

@ -294,8 +294,7 @@ input[type="text"],input[type="password"],textarea {
word-spacing: normal; word-spacing: normal;
font-size: inherit; font-size: inherit;
font-family: sans-serif; font-family: sans-serif;
padding:0px;
padding:0px!important;
} }
@ -2015,3 +2014,49 @@ span.orangeQuote {
.options_general_tab--select_opt select { .options_general_tab--select_opt select {
float: none; 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;
}