From 0f401879b3f19468108deb4c63529f1e5b6e8105 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 2 Aug 2019 14:02:15 -0400 Subject: [PATCH] frontend: use now-upstreamed functions in Frontend.App and remove deprecated modules --- ChangeLog.md | 3 + common/Rhyolite/WebSocket.hs | 4 +- frontend/Rhyolite/Frontend/App.hs | 82 ++++++------------------- frontend/Rhyolite/Frontend/Request.hs | 43 ------------- frontend/Rhyolite/Frontend/WebSocket.hs | 35 ----------- frontend/rhyolite-frontend.cabal | 1 - 6 files changed, 23 insertions(+), 145 deletions(-) delete mode 100644 frontend/Rhyolite/Frontend/Request.hs delete mode 100644 frontend/Rhyolite/Frontend/WebSocket.hs diff --git a/ChangeLog.md b/ChangeLog.md index 686377f2..7e83f296 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,9 @@ This project's release branch is `master`. This log is written from the perspect ## 2019-08-02 - Unreleased * Remove `Rhyolite.Backend.Snap`. That module has been made obsolete by Obelisk. +* Frontend.App: Use reflex's `matchResponsesWithRequests` instead of `identifyTags` (now deleted). Change the identifier used by `TaggedRequest` and `TaggedResponse` to an `Int` +* Remove `mapRequesterT`. This has been upstreamed to reflex as `withRequesterT` +* Remove Frontend.Request and Frontend.WebSocket ## 2019-08-01 - Unreleased diff --git a/common/Rhyolite/WebSocket.hs b/common/Rhyolite/WebSocket.hs index 2debc0b7..d6ab62f3 100644 --- a/common/Rhyolite/WebSocket.hs +++ b/common/Rhyolite/WebSocket.hs @@ -42,14 +42,14 @@ instance FromJSON (View app ()) => FromJSON (WebSocketResponse app) instance ToJSON (View app ()) => ToJSON (WebSocketResponse app) -- | A request tagged with an identifier -data TaggedRequest r = TaggedRequest Value (SomeRequest r) +data TaggedRequest r = TaggedRequest Int (SomeRequest r) deriving (Typeable, Generic) instance Request r => FromJSON (TaggedRequest r) instance Request r => ToJSON (TaggedRequest r) -- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument. -data TaggedResponse = TaggedResponse Value Value +data TaggedResponse = TaggedResponse Int Value deriving (Typeable, Generic) instance FromJSON TaggedResponse diff --git a/frontend/Rhyolite/Frontend/App.hs b/frontend/Rhyolite/Frontend/App.hs index edca28ca..b93e75ed 100644 --- a/frontend/Rhyolite/Frontend/App.hs +++ b/frontend/Rhyolite/Frontend/App.hs @@ -9,7 +9,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} @@ -27,14 +26,13 @@ import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State.Strict import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Aeson.Types import Data.Bifunctor import qualified Data.ByteString.Lazy as LBS import Data.Coerce (coerce) import Data.Constraint (Dict (..)) import Data.Default (Default) -import qualified Data.IntMap as IntMap -import Data.Dependent.Map (DSum (..)) import qualified Data.Map as Map import Data.Semigroup ((<>)) import Data.Text (Text) @@ -268,11 +266,11 @@ runPrerenderedRhyoliteWidget url child = do return ( _appWebSocket_notification appWebSocket , _appWebSocket_response appWebSocket ) - (request', response') <- identifyTags request $ ffor response $ \(TaggedResponse t v) -> (t, v) - let request'' = fmap (fmapMaybe (\(t, v) -> case fromJSON v of + (request', response') <- matchResponsesWithRequests apiRequestJson request $ ffor response $ \(TaggedResponse t v) -> (t, v) + let request'' = fmap (Map.elems . Map.mapMaybeWithKey (\t v -> case fromJSON v of Success (v' :: (SomeRequest (AppRequest app))) -> Just $ TaggedRequest t v' _ -> Nothing)) request' - ((a, vs), request) <- flip runRequesterT response' $ runQueryT (unRhyoliteWidget child) view + ((a, vs), request) <- flip runRequesterT (fmapMaybe (traverseRequesterData (fmap Identity)) response') $ runQueryT (unRhyoliteWidget child) view nubbedVs :: Dynamic t (ViewSelector app SelectedCount) <- holdUniqDyn $ incrementalToDynamic (vs :: Incremental t (AdditivePatch (ViewSelector app SelectedCount))) view <- fmap join $ prerender (pure mempty) $ fromNotifications nubbedVs $ fmap (\_ -> SelectedCount 1) <$> notification return a @@ -296,15 +294,25 @@ runRhyoliteWidget url child = do rec appWebSocket <- openWebSocket' url request'' $ fmapMaybe (\c -> if c == mempty then Nothing else Just ()) <$> nubbedVs let notification = _appWebSocket_notification appWebSocket response = _appWebSocket_response appWebSocket - (request', response') <- identifyTags request $ ffor response $ \(TaggedResponse t v) -> (t, v) - let request'' = fmap (fmapMaybe (\(t, v) -> case fromJSON v of + (request', response') <- matchResponsesWithRequests apiRequestJson request $ ffor response $ \(TaggedResponse t v) -> (t, v) + let request'' = fmap (Map.elems . Map.mapMaybeWithKey (\t v -> case fromJSON v of Success (v' :: (SomeRequest (AppRequest app))) -> Just $ TaggedRequest t v' _ -> Nothing)) request' - ((a, vs), request) <- flip runRequesterT response' $ runQueryT (unRhyoliteWidget child) view + ((a, vs), request) <- flip runRequesterT (fmapMaybe (traverseRequesterData (fmap Identity)) response') $ runQueryT (unRhyoliteWidget child) view nubbedVs :: Dynamic t (ViewSelector app SelectedCount) <- holdUniqDyn $ incrementalToDynamic (vs :: Incremental t (AdditivePatch (ViewSelector app SelectedCount))) view <- fromNotifications nubbedVs $ fmap (\_ -> SelectedCount 1) <$> notification return (appWebSocket, a) +apiRequestJson + :: Request v + => v a + -> (Aeson.Value, Aeson.Value -> Maybe a) +apiRequestJson r = + ( requestToJSON r + , \v -> case requestResponseFromJSON r of + Dict -> parseMaybe parseJSON v + ) + fromNotifications :: forall m (t :: *) vs. (Query vs, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), Reflex t, MonadFix m, Monoid (QueryResult vs)) => Dynamic t vs -> Event t (QueryResult vs) @@ -317,46 +325,6 @@ fromNotifications vs ePatch = do data Decoder f = forall a. FromJSON a => Decoder (f a) -identifyTags - :: forall t v m. - ( MonadFix m - , MonadHold t m - , Reflex t - , Request v - ) - => Event t (RequesterData v) - -> Event t (Data.Aeson.Value, Data.Aeson.Value) - -> m ( Event t [(Data.Aeson.Value, Data.Aeson.Value)] - , Event t (RequesterData Identity) - ) -identifyTags send recv = do - rec nextId :: Behavior t Int <- hold 1 $ fmap (\(a, _, _) -> a) send' - waitingFor :: Incremental t (PatchMap Int (Decoder RequesterDataKey)) <- holdIncremental mempty $ leftmost - [ fmap (\(_, b, _) -> b) send' - , fmap snd recv' - ] - let send' = flip pushAlways send $ \dm -> do - oldNextId <- sample nextId - let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do - n <- get - put $ succ n - return (n, k :=> v) - patchWaitingFor = PatchMap $ Map.fromList $ ffor result $ \(n, k :=> v) -> case requestResponseFromJSON v of - Dict -> (n, Just (Decoder k)) - toSend = ffor result $ \(n, _ :=> v) -> (toJSON n, requestToJSON v) - return (newNextId, patchWaitingFor, toSend) - let recv' = flip push recv $ \(jsonN, jsonV) -> do - wf <- sample $ currentIncremental waitingFor - case parseMaybe parseJSON jsonN of - Nothing -> return Nothing - Just n -> - return $ case Map.lookup n wf of - Just (Decoder k) -> Just $ - let Just v = parseMaybe parseJSON jsonV - in (singletonRequesterData k $ Identity v, PatchMap $ Map.singleton n Nothing) - Nothing -> Nothing - return (fmap (\(_, _, c) -> c) send', fst <$> recv') - data AppWebSocket t app = AppWebSocket { _appWebSocket_notification :: Event t (View app ()) , _appWebSocket_response :: Event t TaggedResponse @@ -483,7 +451,7 @@ mapAuth -> RhyoliteWidget app t m a mapAuth token authorizeQuery authenticatedChild = RhyoliteWidget $ do v <- askQueryResult - (a, vs) <- lift $ mapRequesterT authorizeReq id $ runQueryT (withQueryT authorizeQuery authenticatedChild) v + (a, vs) <- lift $ withRequesterT authorizeReq id $ runQueryT (withQueryT authorizeQuery authenticatedChild) v -- tellQueryIncremental vs would seem simpler, but tellQueryDyn is more baked, subtracting off the removals properly. tellQueryDyn $ incrementalToDynamic vs return a @@ -494,17 +462,3 @@ mapAuth token authorizeQuery authenticatedChild = RhyoliteWidget $ do authorizeReq = \case ApiRequest_Public a -> ApiRequest_Public a ApiRequest_Private () a -> ApiRequest_Private token a - --- TODO: Upstream to reflex -mapRequesterT - :: (Reflex t, MonadFix m) - => (forall x. req x -> req' x) - -> (forall x. rsp' x -> rsp x) - -> RequesterT t req rsp m a - -> RequesterT t req' rsp' m a -mapRequesterT freq frsp child = do - rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp' - (a, req) <- lift $ runRequesterT child rsp - rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $ - fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req - return a diff --git a/frontend/Rhyolite/Frontend/Request.hs b/frontend/Rhyolite/Frontend/Request.hs deleted file mode 100644 index 33e3e8d8..00000000 --- a/frontend/Rhyolite/Frontend/Request.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Rhyolite.Frontend.Request {-# DEPRECATED "Import Reflex.Dom.Xhr.FormData instead" #-} where - -import Control.Lens (iforM_) -import Data.Map as Map -import Data.Text (Text) -import Data.Traversable (for) -import Foreign.JavaScript.TH -#ifdef __GHCJS__ -import qualified Data.Aeson as Aeson -import Control.Exception (SomeException, try) -import GHCJS.Marshal -import GHCJS.Marshal.Pure -#endif -import GHCJS.DOM.File (getName) -import qualified GHCJS.DOM.FormData as FD -import GHCJS.DOM.Types (File, IsBlob,MonadJSM, liftJSM) -import Reflex.Dom.Core hiding (newXMLHttpRequest) - -data FormValue blob = FormValue_Text Text - | FormValue_File blob (Maybe Text) -- maybe filename - -postForms - :: ( IsBlob blob, HasJSContext (Performable m), MonadJSM (Performable m) - , PerformEvent t m, TriggerEvent t m - , Traversable f) - => Text - -> Event t (f (Map Text (FormValue blob))) - -> m (Event t (f XhrResponse)) -postForms path payload = do - performMkRequestsAsync $ ffor payload $ \fs -> for fs $ \u -> liftJSM $ do - fd <- FD.newFormData Nothing - iforM_ u $ \k v -> case v of - FormValue_Text t -> FD.append fd k t - FormValue_File b fn -> FD.appendBlob fd k b fn - return $ xhrRequest "POST" path $ def & xhrRequestConfig_sendData .~ fd - -fileToFormValue :: MonadJSM m => File -> m (FormValue File) -fileToFormValue f = do - fn <- getName f - return $ FormValue_File f $ Just fn diff --git a/frontend/Rhyolite/Frontend/WebSocket.hs b/frontend/Rhyolite/Frontend/WebSocket.hs deleted file mode 100644 index d01bf5ea..00000000 --- a/frontend/Rhyolite/Frontend/WebSocket.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - -module Rhyolite.Frontend.WebSocket where - -import Data.Text (Text) -import Language.Javascript.JSaddle.Types -import Reflex.Dom.Core -import qualified Reflex.Dom.WebSocket as RDWS - --- | Warning: Only one of these websockets may be opened on a given page in most browsers -{-# DEPRECATED webSocket "Use Reflex.Dom.WebSocket.webSocket instead" #-} -webSocket - :: forall x t m. (HasJS x m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadJSM m, MonadJSM (Performable m), HasJSContext m) - => Text - -> WebSocketConfig t Text - -> m (WebSocket t) -webSocket = RDWS.webSocket diff --git a/frontend/rhyolite-frontend.cabal b/frontend/rhyolite-frontend.cabal index 63f13f37..d2dbeb24 100644 --- a/frontend/rhyolite-frontend.cabal +++ b/frontend/rhyolite-frontend.cabal @@ -64,7 +64,6 @@ library Rhyolite.Frontend.App Rhyolite.Frontend.Cookie Rhyolite.Frontend.Form - Rhyolite.Frontend.WebSocket Rhyolite.Frontend.Widget ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields -O2 -fprof-auto-calls -rtsopts -fexpose-all-unfoldings