From 534ac9075c12be54bc8acad789f6d6bbe2d85bdc Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Fri, 1 Mar 2024 23:43:03 -0500 Subject: [PATCH] Saving search query using MVar and waiting for that MVar on form submit --- src/Component/Search.hs | 21 +++++++++++++++++---- src/Component/Search/SearchTypes.hs | 5 ++++- src/Main.hs | 20 +++++++++++++------- 3 files changed, 34 insertions(+), 12 deletions(-) diff --git a/src/Component/Search.hs b/src/Component/Search.hs index ab1575f..ab9219f 100644 --- a/src/Component/Search.hs +++ b/src/Component/Search.hs @@ -25,22 +25,34 @@ import Miso , (<#) , consoleLog , noEff - , batchEff ) import Data.JSString (pack) import qualified Network.Client as Client import Network.Http (HttpResult (..)) +import Control.Concurrent.MVar (tryTakeMVar, takeMVar, putMVar, swapMVar) + import Component.Search.SearchTypes update :: Interface a -> Action -> Model -> Effect a Model update iface (SearchChange q) model = model { searchTerm = q } <# do - consoleLog q + consoleLog $ "SearchChange " <> q + m_search_query <- tryTakeMVar (searchVar model) + + case m_search_query of + Nothing -> putMVar (searchVar model) q + Just _ -> swapMVar (searchVar model) q >> return () + return $ (passAction iface) NoAction -update iface (OnSubmit search_query) model = model { searchTerm = search_query } <# do +update iface OnSubmit model = model <# do + search_query <- takeMVar (searchVar model) consoleLog $ "Submit! " <> search_query Client.search (clientModel model) search_query (clientIface iface) +update iface (ChangeAndSubmit search_query) model = model { searchTerm = search_query } <# do + _ <- swapMVar (searchVar model) search_query + return $ (passAction iface) OnSubmit + update iface (SearchResult result) model = model <# do consoleLog $ "Received search results!" @@ -62,12 +74,13 @@ update iface (PassPostsToSelf search_results) model = model { displayResults = s update _ NoAction m = noEff m + view :: Interface a -> Model -> View a view iface m = form_ [ class_ "search_form" , action_ "/search" , method_ "GET" - , onSubmit $ pass $ OnSubmit $ searchTerm m + , onSubmit $ pass $ OnSubmit ] [ input_ [ type_ "submit" diff --git a/src/Component/Search/SearchTypes.hs b/src/Component/Search/SearchTypes.hs index 6b6836f..dea680d 100644 --- a/src/Component/Search/SearchTypes.hs +++ b/src/Component/Search/SearchTypes.hs @@ -2,19 +2,22 @@ module Component.Search.SearchTypes where import Data.JSString (JSString) import Network.Http (HttpResult (..)) +import Control.Concurrent.MVar (MVar) import qualified Network.ClientTypes as Client import Network.CatalogPostType (CatalogPost) data Action = SearchChange JSString - | OnSubmit JSString + | OnSubmit + | ChangeAndSubmit JSString | SearchResult (HttpResult [ CatalogPost ]) | PassPostsToSelf [ CatalogPost ] -- I think I don't understand something about the update type but I had to add this... | NoAction data Model = Model { searchTerm :: JSString + , searchVar :: MVar JSString , clientModel :: Client.Model , displayResults :: [ CatalogPost ] } deriving Eq diff --git a/src/Main.hs b/src/Main.hs index af5f3ce..7900cd1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,6 +12,7 @@ import qualified Data.Text as T import Network.URI (uriPath, uriQuery, escapeURIString, unEscapeString, isAllowedInURI) import System.FilePath (()) import Data.Time.Clock (UTCTime, getCurrentTime) +import Control.Concurrent.MVar (MVar, newEmptyMVar) import Data.Aeson (FromJSON) import Data.JSString (pack, append, unpack) @@ -51,7 +52,6 @@ import qualified Component.CatalogGrid as Grid import qualified Component.ThreadView as Thread import qualified Component.TimeControl as TC import qualified Component.Search as Search -import qualified Component.Search.SearchTypes as Search data Model = Model @@ -89,10 +89,10 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result h_thread website board_pathpart board_thread_id _ = GetThread GetThreadArgs {..} h_search :: Maybe Text -> Model -> Action - h_search Nothing model = GoToTime $ current_time model - h_search (Just search_query) model - | Search.searchTerm (search_model model) == unescaped_search_query = SearchResults unescaped_search_query - | otherwise = (Search.passAction iSearch) $ Search.OnSubmit $ toJSString $ T.unpack search_query + h_search Nothing m = GoToTime $ current_time m + h_search (Just search_query) m + | Search.searchTerm (search_model m) == unescaped_search_query = SearchResults unescaped_search_query + | otherwise = (Search.passAction iSearch) $ Search.ChangeAndSubmit unescaped_search_query where unescaped_search_query = toJSString $ unEscapeString $ T.unpack search_query @@ -104,8 +104,9 @@ initialModel -> JSString -> URI -> UTCTime + -> MVar JSString -> Model -initialModel pgroot client_fetch_count media_root u t = Model +initialModel pgroot client_fetch_count media_root u t smv = Model { grid_model = Grid.initialModel media_root , client_model = client_model_ , thread_model = Nothing @@ -115,6 +116,7 @@ initialModel pgroot client_fetch_count media_root u t = Model , tc_model = TC.initialModel 0 , search_model = Search.Model { Search.searchTerm = "" + , Search.searchVar = smv , Search.clientModel = client_model_ , Search.displayResults = [] } @@ -160,11 +162,14 @@ main = do now <- getCurrentTime + search_var <- newEmptyMVar + let initial_model = initialModel pg_api_root pg_fetch_count media_root uri now + search_var startApp App { model = initial_model @@ -285,6 +290,7 @@ mainUpdate (SearchAction sa) m = >>= \sm -> noEff m { search_model = sm } mainUpdate (SearchResults query) m = m { current_uri = new_current_uri } <# do + consoleLog $ "SearchResults new uri: " <> (pack $ show new_current_uri) pushURI new_current_uri return NoAction @@ -328,6 +334,6 @@ iSearch :: Search.Interface Action iSearch = Search.Interface { passAction = SearchAction - , clientIface = iClient (SearchAction . Search.SearchResult) + , clientIface = iClient $ SearchAction . Search.SearchResult , searchResults = SearchResults }