Parse thread response, begin rendering thread

chandlr.cabal

@@ -68,7 +68,12 @@ executable chandlr
                       Network.Client
                       Network.ClientTypes
                       Network.CatalogPostType
+                      Network.BoardType
+                      Network.SiteType
+                      Network.PostType
+                      Network.ThreadType
                       Routes
+                      Common.AttachmentType
 
 
     -- LANGUAGE extensions used by modules in this package.

src/Action.hs

@@ -11,6 +11,7 @@ import qualified Component.CatalogGrid as Grid
 import qualified Network.ClientTypes as C
 import Network.CatalogPostType (CatalogPost)
 import Network.Http (HttpResult)
+import Network.SiteType (Site)
 
 data GetThreadArgs = GetThreadArgs
     { website         :: Text
@@ -22,8 +23,8 @@ data Action
     = GridAction Grid.Action
     | GetLatest
     | GetThread GetThreadArgs
-    | HaveLatest (HttpResult [CatalogPost])
-    | HaveThread (HttpResult ())
+    | HaveLatest (HttpResult [ CatalogPost ])
+    | HaveThread (HttpResult [ Site ])
     | forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a)
     | ChangeURI URI
     | NoAction

src/Component/CatalogGrid.hs

@@ -41,7 +41,7 @@ data Action
     = DisplayItems [ CatalogPost ]
 
 data Interface a = Interface
-    { passAction :: Action -> a
+    { passAction :: Action -> a -- We're not using this.
     , threadSelected :: CatalogPost -> a
     }
 
@@ -56,7 +56,6 @@ update
     -> Model
     -> Effect a Model
 update _ (DisplayItems xs) m = noEff (m { display_items = xs })
--- update _ _ m = noEff m
 
 view :: Interface a -> Model -> View a
 view iface model =

src/Component/ThreadView.hs

@@ -1,11 +1,44 @@
 module Component.ThreadView
-( Model
+( Model (..)
+, initialModel
+, Action (..)
+, update
+, view
 ) where
 
-import Common.PostsType (Post)
+import Miso
+  ( View
+  , Effect
+  , div_
+  , text
+  , h1_
+  , noEff
+  )
+import Miso.String (toMisoString)
+import GHCJS.DOM.Types (JSString)
+
+import Network.SiteType (Site)
+import qualified Network.SiteType as Site
 
 data Model = Model
-  { thread_id :: Integer
-  , thread_posts :: [ Post ]
-  , thread_loading :: Bool
+  { site :: Site
+  , media_root :: JSString
   } deriving Eq
+
+initialModel :: JSString -> Site -> Model
+initialModel mroot s = Model
+    { site = s
+    , media_root = mroot
+    }
+
+data Action = RenderSite Site
+
+update :: Action -> Model -> Effect a Model
+update (RenderSite s) m = noEff (m { site = s })
+
+view :: Model -> View a
+view m =
+  div_
+    []
+    [ h1_ [] [ text $ toMisoString $ Site.name $ site m ]
+    ]

src/Main.hs

@@ -46,14 +46,16 @@ import Routes
 import qualified Network.Client as Client
 import Network.CatalogPostType (CatalogPost)
 import qualified Network.CatalogPostType as CatalogPost
-
 import qualified Component.CatalogGrid as Grid
+import qualified Component.ThreadView as Thread
 
 
 data Model = Model
-    { gridModel :: Grid.Model
-    , clientModel :: Client.Model
+    { grid_model :: Grid.Model
+    , client_model :: Client.Model
+    , thread_model :: Maybe Thread.Model
     , current_uri :: URI
+    , media_root_ :: JSString
     } deriving Eq
 
 
@@ -78,12 +80,14 @@ initialModel
     -> URI
     -> Model
 initialModel pgroot client_fetch_count media_root u = Model
-    { gridModel = Grid.initialModel media_root
-    , clientModel = Client.Model
+    { grid_model = Grid.initialModel media_root
+    , client_model = Client.Model
         { Client.pgApiRoot = pgroot
         , Client.fetchCount = client_fetch_count
         }
+    , thread_model = Nothing
     , current_uri = u
+    , media_root_ = media_root
     }
 
 getMetadata :: String -> IO (Maybe JSString)
@@ -142,12 +146,14 @@ mainView model = view
         catalog_view :: Model -> View Action
         catalog_view _ = div_ []
             [ h1_ [] [ text "Overboard Catalog" ]
-            , Grid.view iGrid (gridModel model)
+            , Grid.view iGrid (grid_model model)
             ]
 
         thread_view :: Text -> Text -> BoardThreadId -> Model -> View Action
-        thread_view site_name board_pathpart board_thread_id m =
-            h1_ [] [ text "Thread View" ]
+        thread_view site_name board_pathpart board_thread_id m = maybe
+            (h1_ [] [ text "Thread View" ])
+            Thread.view
+            (thread_model m)
 
         page404 :: View Action
         page404 = h1_ [] [ text "404 Not Found" ]
@@ -172,18 +178,24 @@ mainUpdate (HaveThread Client.Error) m = m <# do
     consoleLog "Getting Thread failed!"
     return NoAction
 
-mainUpdate (HaveThread (Client.HttpResponse {..})) m = m <# do
+mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do
     consoleLog "Have Thread!"
     return NoAction
 
-mainUpdate GetLatest m = m <# Client.fetchLatest (clientModel m) (iClient HaveLatest)
+    where
+        new_model = m
+            { thread_model =
+                body >>= Just . (Thread.initialModel (media_root_ m)) . head
+            }
+
+mainUpdate GetLatest m = m <# Client.fetchLatest (client_model m) (iClient HaveLatest)
 
 -- mainUpdate GetThread {..} m = noEff m
 
 mainUpdate (GetThread GetThreadArgs {..}) m = m <# do
     consoleLog $ "Thread " `append` (pack $ show $ board_thread_id)
     pushURI new_current_uri
-    Client.getThread (clientModel m) (iClient HaveThread) GetThreadArgs {..}
+    Client.getThread (client_model m) (iClient HaveThread) GetThreadArgs {..}
 
     where
         new_current_uri :: URI
@@ -198,12 +210,12 @@ mainUpdate (ChangeURI old_uri) m = m { current_uri = old_uri } <# do
     return NoAction
 
 mainUpdate (GridAction ga) m =
-    Grid.update iGrid ga (gridModel m)
-    >>= \gm -> noEff (m { gridModel = gm })
+    Grid.update iGrid ga (grid_model m)
+    >>= \gm -> noEff (m { grid_model = gm })
 
 mainUpdate (ClientAction action ca) m =
-    Client.update (iClient action) ca (clientModel m)
-    >>= \cm -> noEff (m { clientModel = cm })
+    Client.update (iClient action) ca (client_model m)
+    >>= \cm -> noEff (m { client_model = cm })
 
 
 iGrid :: Grid.Interface Action

src/Network/BoardType.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Network.BoardType where
+
+import GHC.Generics
+import Data.Text (Text)
+import Data.Aeson (FromJSON, ToJSON)
+import Network.ThreadType (Thread)
+
+data Board = Board
+  { board_id :: Int
+  , name     :: Maybe Text
+  , pathpart :: Text
+  , site_id  :: Int
+  , threads  :: [ Thread ]
+  } deriving (Show, Generic, FromJSON, ToJSON, Eq)
+

src/Network/Client.hs

@@ -30,6 +30,7 @@ import Miso.String (toMisoString)
 
 import qualified Network.Http as Http
 import Network.CatalogPostType (CatalogPost)
+import Network.SiteType (Site)
 import qualified Action as A
 import Network.ClientTypes
 
@@ -58,7 +59,7 @@ http_
     -> Http.HttpMethod
     -> Maybe c
     -> IO a
-http_ m iface api_path method payload = do
+http_ m iface api_path method payload =
     Http.http
         (pgApiRoot m <> api_path)
         method
@@ -79,7 +80,7 @@ fetchLatest m iface = do
     http_ m iface "/rpc/fetch_catalog" Http.POST payload
 
 
-getThread :: Model -> Interface a () -> A.GetThreadArgs -> IO a
+getThread :: Model -> Interface a [ Site ] -> A.GetThreadArgs -> IO a
 getThread m iface A.GetThreadArgs {..} =
     http_ m iface path Http.GET (Nothing :: Maybe ())
 

src/Network/ClientTypes.hs

@@ -1,7 +1,6 @@
 module Network.ClientTypes where
 
 import qualified Network.Http as Http
-import Network.CatalogPostType (CatalogPost)
 import GHCJS.DOM.Types (JSString)
 
 data Action a = Connect (Http.HttpActionResult a)

src/Network/PostType.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Network.PostType where
+
+import GHC.Generics
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Data.Aeson (FromJSON, ToJSON)
+import Common.AttachmentType (Attachment)
+
+data Post = Post
+  { post_id           :: Integer
+  , board_post_id     :: Integer
+  , creation_time     :: UTCTime
+  , body              :: Maybe Text
+  , subject           :: Maybe Text
+  , name              :: Maybe Text
+  , email             :: Maybe Text
+  , body_search_index :: Text
+  , thread_id         :: Integer
+  , attachments       :: [ Attachment ]
+  } deriving (Show, Generic, FromJSON, ToJSON, Eq)
+

src/Network/SiteType.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Network.SiteType where
+
+import GHC.Generics
+import Data.Text (Text)
+import Data.Aeson (FromJSON, ToJSON)
+import Network.BoardType (Board)
+
+data Site = Site
+  { site_id :: Int
+  , name    :: Text
+  , url     :: Text
+  , boards  :: [ Board ]
+  } deriving (Show, Generic, FromJSON, ToJSON, Eq)

src/Network/ThreadType.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Network.ThreadType where
+
+import GHC.Generics
+import Data.Time.Clock (UTCTime)
+import Data.Aeson (FromJSON, ToJSON)
+import Network.PostType (Post)
+
+data Thread = Thread
+  { thread_id       :: Integer
+  , board_thread_id :: Integer
+  , creation_time   :: UTCTime
+  , board_id        :: Int
+  , posts           :: [ Post ]
+  } deriving (Show, Generic, FromJSON, ToJSON, Eq)