From cd72af095e56e60f2c06badbbf5a7a9cdf2d0a02 Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Fri, 1 Mar 2024 17:46:04 -0500 Subject: [PATCH] Search WiP: hook Search into Client API, but don't call it yet --- TODO.txt | 4 ++-- src/Component/Search.hs | 30 +++++++++++++++++++++++++----- src/Main.hs | 24 ++++++++++++++++++------ src/Network/Client.hs | 17 ++++++++++++++++- src/Network/Http.hs | 12 +++++++----- 5 files changed, 68 insertions(+), 19 deletions(-) diff --git a/TODO.txt b/TODO.txt index 3dceb21..4b7d278 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,7 +1,7 @@ -- get embeds working +- 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) +- 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 diff --git a/src/Component/Search.hs b/src/Component/Search.hs index a970064..dfde953 100644 --- a/src/Component/Search.hs +++ b/src/Component/Search.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Component.Search ( view @@ -25,26 +26,45 @@ import Miso , consoleLog , noEff ) -import GHCJS.DOM.Types (JSString) +import Data.JSString (JSString, pack) +import qualified Network.ClientTypes as Client +import Network.CatalogPostType (CatalogPost) +import Network.Http (HttpResult (..)) -data Action = SearchChange JSString | OnSubmit | NoAction +data Action + = SearchChange JSString + | OnSubmit + | SearchResult (HttpResult [ CatalogPost ]) + | NoAction data Model = Model - { search_term :: JSString + { searchTerm :: JSString + , clientModel :: Client.Model } deriving Eq data Interface a = Interface { passAction :: Action -> a + , clientIface :: Client.Interface a [ CatalogPost ] } update :: Interface a -> Action -> Model -> Effect a Model -update iface (SearchChange q) model = model { search_term = q } <# do +update iface (SearchChange q) model = model { searchTerm = q } <# do consoleLog q return $ (passAction iface) NoAction update iface OnSubmit model = model <# do - consoleLog $ "Submit!" <> search_term model + consoleLog $ "Submit!" <> searchTerm model + return $ (passAction iface) NoAction + +update iface (SearchResult result) model = model <# do + consoleLog $ "Search result" + case result of + Error -> consoleLog $ "Error!" + HttpResponse {..} -> do + consoleLog $ (pack $ show $ status_code) <> " " <> (pack $ status_text) + consoleLog $ (pack $ show $ body) + return $ (passAction iface) NoAction update _ NoAction m = noEff m diff --git a/src/Main.hs b/src/Main.hs index 133a401..f18fd8d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -88,18 +88,25 @@ initialModel -> Model initialModel pgroot client_fetch_count media_root u t = Model { grid_model = Grid.initialModel media_root - , client_model = Client.Model - { Client.pgApiRoot = pgroot - , Client.fetchCount = client_fetch_count - } + , client_model = client_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 = "" } + , search_model = Search.Model + { Search.searchTerm = "" + , Search.clientModel = client_model_ + } } + where + client_model_ = Client.Model + { Client.pgApiRoot = pgroot + , Client.fetchCount = client_fetch_count + } + + getMetadata :: String -> IO (Maybe JSString) getMetadata key = do doc <- currentDocument @@ -112,6 +119,7 @@ getMetadata key = do Nothing -> return Nothing Just el -> getAttribute el ("content" :: JSString) + main :: IO () main = do consoleLog "Hello World!" @@ -285,4 +293,8 @@ iTime = TC.Interface } iSearch :: Search.Interface Action -iSearch = Search.Interface { passAction = SearchAction } +iSearch = + Search.Interface + { passAction = SearchAction + , clientIface = iClient (SearchAction . Search.SearchResult) + } diff --git a/src/Network/Client.hs b/src/Network/Client.hs index c573c4f..c659873 100644 --- a/src/Network/Client.hs +++ b/src/Network/Client.hs @@ -14,6 +14,7 @@ module Network.Client , getThread , Model (..) , update + , search ) where import GHC.Generics @@ -21,7 +22,6 @@ import Control.Monad (void) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (takeMVar) import Data.Aeson (ToJSON, FromJSON) -import Data.Time (getCurrentTime) import Data.Time.Clock (UTCTime) import GHCJS.DOM.Types (JSString) @@ -51,6 +51,10 @@ data FetchCatalogArgs = FetchCatalogArgs } deriving (Generic, ToJSON) +data SearchPostsArgs = SearchPostsArgs { search_text :: JSString } + deriving (Generic, ToJSON) + + http_ :: (ToJSON c, FromJSON b) => Model @@ -89,3 +93,14 @@ getThread m iface A.GetThreadArgs {..} = <> "&boards.pathpart=eq." <> toMisoString board_pathpart <> "&boards.threads.board_thread_id=eq." <> toMisoString (show board_thread_id) <> "&boards.threads.posts.order=board_post_id.asc" + + +search :: Model -> JSString -> Interface a [ CatalogPost ] -> IO a +search m query iface = + http_ m iface "/rpc/search_posts" Http.POST payload + + where + payload = Just $ SearchPostsArgs + { search_text = query + } + diff --git a/src/Network/Http.hs b/src/Network/Http.hs index c46d513..322ad67 100644 --- a/src/Network/Http.hs +++ b/src/Network/Http.hs @@ -73,11 +73,13 @@ mkResult xhr = do Left err -> do consoleLog $ toJSString $ show err return Error - Right x -> return HttpResponse - { status_code = status_code_int - , status_text = st - , body = Just x - } + Right x -> do + consoleLog $ toJSString "Decoding Successful" + return HttpResponse + { status_code = status_code_int + , status_text = st + , body = Just x + } http