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

Parsing PostBodies seems to work okay 

- tie in parsing into the threadview update function
- that may not be the final place for it but it works for now to just
  bring out the Show instances.
- need a renderer now
This commit is contained in:
towards-a-new-leftypol 2024-02-09 09:19:32 -05:00
parent 3b1d130f41
commit 1950b45157
5 changed files with 58 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
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="1000"> <meta name="postgrest-fetch-count" content="200">
<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" />

2
src/Action.hs
View File

@ -12,6 +12,7 @@ import qualified Network.ClientTypes as C
import Network.CatalogPostType (CatalogPost) 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
data GetThreadArgs = GetThreadArgs data GetThreadArgs = GetThreadArgs
{ website :: Text { website :: Text
@ -26,5 +27,6 @@ data Action
| 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
| ChangeURI URI | ChangeURI URI
| NoAction | NoAction

24
src/BodyParser.hs
View File

@ -22,6 +22,7 @@ import GHCJS.DOM.JSFFI.Generated.Node hiding (contains)
import qualified GHCJS.DOM.JSFFI.Generated.NodeList as NodeList import qualified GHCJS.DOM.JSFFI.Generated.NodeList as NodeList
import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains) import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains)
import Data.Text (Text) import Data.Text (Text)
import Miso (consoleLog)
data PostPart data PostPart
@ -40,7 +41,7 @@ data PostPart
| Underlined [ PostPart ] | Underlined [ PostPart ]
| Italics [ PostPart ] | Italics [ PostPart ]
| Strikethrough [ PostPart ] | Strikethrough [ PostPart ]
deriving Show deriving (Show, Eq)
nodeListToList :: NodeList -> IO [ Node ] nodeListToList :: NodeList -> IO [ Node ]
@ -80,13 +81,16 @@ toPostPart_ node_type node
tagName :: JSString <- getTagName element tagName :: JSString <- getTagName element
case tagName of case tagName of
"a" -> parseAnchor element "A" -> parseAnchor element
"span" -> parseSpan element "SPAN" -> parseSpan element
"em" -> parseEm element "EM" -> parseEm element
"strong" -> parseStrong element "STRONG" -> parseStrong element
"u" -> parseU element "U" -> parseU element
"s" -> parseS element "S" -> parseS element
_ -> return $ SimpleText "Unsupported element" "BR" -> return Skip
_ -> do
consoleLog tagName
return $ SimpleText "Unsupported element"
| otherwise = return Skip | otherwise = return Skip
where where
@ -124,10 +128,10 @@ parseSpan element = do
| otherwise -> return $ SimpleText "Unsupported span class" | otherwise -> return $ SimpleText "Unsupported span class"
parseNodeList :: NodeList -> IO [PostPart] parseNodeList :: NodeList -> IO [ PostPart ]
parseNodeList nodes = nodeListToList nodes >>= mapM toPostPart parseNodeList nodes = nodeListToList nodes >>= mapM toPostPart
parseChildNodes :: Element -> IO [PostPart] parseChildNodes :: Element -> IO [ PostPart ]
parseChildNodes element = getChildNodes element >>= parseNodeList parseChildNodes element = getChildNodes element >>= parseNodeList
parseEm :: Element -> IO PostPart parseEm :: Element -> IO PostPart

33
src/Component/ThreadView.hs
View File

@ -6,6 +6,7 @@ module Component.ThreadView
, Action (..) , Action (..)
, update , update
, view , view
, Interface (..)
) where ) where
import Miso import Miso
@ -21,9 +22,11 @@ import Miso
, h2_ , h2_
, rawHtml , rawHtml
, Attribute , Attribute
, (<#)
, consoleLog
) )
import Data.Maybe (maybeToList) import Data.Maybe (maybeToList, catMaybes)
import Miso.String (toMisoString) import Miso.String (toMisoString)
import GHCJS.DOM.Types (JSString) import GHCJS.DOM.Types (JSString)
@ -37,21 +40,42 @@ import Component.Thread.Files (files)
import Component.Thread.Intro (intro) import Component.Thread.Intro (intro)
import BodyParser import BodyParser
type PostWithBody = (Post, [ PostPart ])
data Model = Model data Model = Model
{ site :: Site { site :: Site
, media_root :: JSString , media_root :: JSString
, post_bodies :: [ PostWithBody ]
} deriving Eq } deriving Eq
initialModel :: JSString -> Site -> Model initialModel :: JSString -> Site -> Model
initialModel mroot s = Model initialModel mroot s = Model
{ site = s { site = s
, post_bodies = []
, media_root = mroot , media_root = mroot
} }
data Action = RenderSite Site data Action
= RenderSite Site
| UpdatePostBodies [ PostWithBody ]
data Interface a = Interface { passAction :: Action -> a }
update :: Interface a -> Action -> Model -> Effect a Model
update iface (RenderSite s) m = m { site = s } <# do
bodies <- mapM parsePostBody (catMaybes $ map Post.body posts)
mapM_ (consoleLog . toMisoString . show) bodies
return $ passAction iface $ UpdatePostBodies $ zip posts bodies
where
posts :: [ Post ]
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 :: Action -> Model -> Effect a Model
update (RenderSite s) m = noEff (m { site = s })
view :: Model -> View a view :: Model -> View a
view m = view m =
@ -109,6 +133,7 @@ op m op_post =
| length (Post.attachments op_post) > 1 = [ class_ "multifile" ] | length (Post.attachments op_post) > 1 = [ class_ "multifile" ]
| otherwise = [] | otherwise = []
reply :: Model -> Post -> View a reply :: Model -> Post -> View a
reply m post = div_ reply m post = div_
[ class_ "postcontainer" [ class_ "postcontainer"

14
src/Main.hs
View File

@ -6,7 +6,7 @@
module Main where module Main where
import Data.Proxy import Data.Proxy
import Data.Maybe (maybe) import Data.Maybe (maybe, fromJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Network.URI (uriPath) import Network.URI (uriPath)
@ -180,7 +180,7 @@ mainUpdate (HaveThread Client.Error) m = m <# do
mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do
consoleLog "Have Thread!" consoleLog "Have Thread!"
return NoAction return $ ThreadAction $ Thread.RenderSite $ Thread.site $ fromJust $ thread_model new_model
where where
new_model = m new_model = m
@ -217,6 +217,13 @@ mainUpdate (ClientAction action ca) m =
Client.update (iClient action) ca (client_model m) Client.update (iClient action) ca (client_model m)
>>= \cm -> noEff (m { client_model = cm }) >>= \cm -> noEff (m { client_model = cm })
mainUpdate (ThreadAction ta) model = do
tm :: Maybe Thread.Model <- case thread_model model of
Nothing -> noEff Nothing
Just m -> Thread.update iThread ta m >>= return . Just
noEff model { thread_model = tm }
iGrid :: Grid.Interface Action iGrid :: Grid.Interface Action
iGrid = Grid.Interface iGrid = Grid.Interface
@ -238,6 +245,9 @@ iClient action = Client.Interface
, Client.returnResult = action , Client.returnResult = action
} }
iThread :: Thread.Interface Action
iThread = Thread.Interface { Thread.passAction = ThreadAction }
{- {-
- TODO: - TODO:
- - Create the thread view - - Create the thread view