diff --git a/chandlr.cabal b/chandlr.cabal index c2a677f..9661a8a 100644 --- a/chandlr.cabal +++ b/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. diff --git a/src/Action.hs b/src/Action.hs index fd6c9e3..e93c329 100644 --- a/src/Action.hs +++ b/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 diff --git a/src/Component/CatalogGrid.hs b/src/Component/CatalogGrid.hs index 39bbd06..674b086 100644 --- a/src/Component/CatalogGrid.hs +++ b/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 = diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index ff8e52d..bbe5e31 100644 --- a/src/Component/ThreadView.hs +++ b/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 ] + ] diff --git a/src/Main.hs b/src/Main.hs index 56cdd72..a21e18e 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Network/BoardType.hs b/src/Network/BoardType.hs new file mode 100644 index 0000000..bbe0c93 --- /dev/null +++ b/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) + diff --git a/src/Network/Client.hs b/src/Network/Client.hs index 90dfdaf..19ae35d 100644 --- a/src/Network/Client.hs +++ b/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 ()) diff --git a/src/Network/ClientTypes.hs b/src/Network/ClientTypes.hs index 3e127df..d0fafa2 100644 --- a/src/Network/ClientTypes.hs +++ b/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) diff --git a/src/Network/PostType.hs b/src/Network/PostType.hs new file mode 100644 index 0000000..473ddbd --- /dev/null +++ b/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) + diff --git a/src/Network/SiteType.hs b/src/Network/SiteType.hs new file mode 100644 index 0000000..7cf3193 --- /dev/null +++ b/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) diff --git a/src/Network/ThreadType.hs b/src/Network/ThreadType.hs new file mode 100644 index 0000000..592ae62 --- /dev/null +++ b/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)