git.iko.soy/reflex-dom
on develop help sign in
Add some more history-management functions
748e7c1Ryan Trinkle
reflex-dom-core/default.nix+2−2
compare with develop
unifiedsplit
@@ -5,7 +5,7 @@
5, monad-control, mtl, primitive, ref-tf, reflex, semigroups, stdenv
5, monad-control, mtl, primitive, ref-tf, reflex, semigroups, stdenv
6, stm, template-haskell, temporary, text, these, transformers
6, stm, template-haskell, temporary, text, these, transformers
7, unix, zenc, hashable, chromium, process, jsaddle-warp
7, unix, zenc, hashable, chromium, process, jsaddle-warp
8−, linux-namespaces, iproute
8+, linux-namespaces, iproute, network-uri
9}:
9}:
10let addGcTestDepends = drv: if stdenv.system != "x86_64-linux" then drv else drv // {
10let addGcTestDepends = drv: if stdenv.system != "x86_64-linux" then drv else drv // {
11 testHaskellDepends = (drv.testHaskellDepends or []) ++ [ temporary jsaddle-warp process linux-namespaces ];
11 testHaskellDepends = (drv.testHaskellDepends or []) ++ [ temporary jsaddle-warp process linux-namespaces ];
@@ -21,7 +21,7 @@ in mkDerivation (addGcTestDepends {
21 dependent-sum-template directory exception-transformers ghcjs-dom
21 dependent-sum-template directory exception-transformers ghcjs-dom
22 jsaddle keycode lens monad-control mtl primitive ref-tf
22 jsaddle keycode lens monad-control mtl primitive ref-tf
23 reflex semigroups stm template-haskell text these transformers
23 reflex semigroups stm template-haskell text these transformers
24− unix zenc
24+ unix zenc network-uri
25 ] ++ (if ghc.isGhcjs or false then [
25 ] ++ (if ghc.isGhcjs or false then [
26 hashable
26 hashable
27 ] else []);
27 ] else []);
reflex-dom-core/reflex-dom-core.cabal+1
@@ -71,6 +71,7 @@ library
71 text == 1.2.*,
71 text == 1.2.*,
72 these >= 0.4 && < 0.8,
72 these >= 0.4 && < 0.8,
73 transformers >= 0.3 && < 0.6,
73 transformers >= 0.3 && < 0.6,
74+ network-uri >= 2.6.1 && < 2.7,
74 zenc == 0.1.*
75 zenc == 0.1.*
75
76
76 if impl(ghcjs)
77 if impl(ghcjs)
reflex-dom-core/src/Reflex/Dom/Location.hs+79−4
@@ -1,8 +1,8 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
5−
6module Reflex.Dom.Location
6module Reflex.Dom.Location
7 ( browserHistoryWith
7 ( browserHistoryWith
8 , getLocationAfterHost
8 , getLocationAfterHost
@@ -11,6 +11,11 @@ module Reflex.Dom.Location
11 , getLocationPath
11 , getLocationPath
12 , getLocationProtocol
12 , getLocationProtocol
13 , getLocationUrl
13 , getLocationUrl
14+ , manageHistory
15+ , HistoryCommand (..)
16+ , HistoryStateUpdate (..)
17+ , HistoryItem (..)
18+ , getLocationUri
14 ) where
19 ) where
15
20
16import Reflex
21import Reflex
@@ -18,16 +23,19 @@ import Reflex.Dom.Builder.Immediate (wrapDomEvent)
18
23
19import Control.Lens ((^.))
24import Control.Lens ((^.))
20import Control.Monad ((>=>))
25import Control.Monad ((>=>))
26+import Data.Monoid
21import Data.Text (Text)
27import Data.Text (Text)
22import qualified GHCJS.DOM as DOM
28import qualified GHCJS.DOM as DOM
23import qualified GHCJS.DOM.EventM as DOM
29import qualified GHCJS.DOM.EventM as DOM
24import qualified GHCJS.DOM.Location as Location
30import qualified GHCJS.DOM.Location as Location
31+import qualified GHCJS.DOM.History as History
32+import qualified GHCJS.DOM.PopStateEvent as PopStateEvent
25−import GHCJS.DOM.Types (Location)
33+import GHCJS.DOM.Types (Location, History, SerializedScriptValue (..), liftJSM)
26import qualified GHCJS.DOM.Types as DOM
34import qualified GHCJS.DOM.Types as DOM
27import qualified GHCJS.DOM.Window as Window
35import qualified GHCJS.DOM.Window as Window
28import qualified GHCJS.DOM.WindowEventHandlers as DOM
36import qualified GHCJS.DOM.WindowEventHandlers as DOM
29−import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, toJSVal)
37+import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, ToJSVal (..), FromJSVal (..))
30−
38+import Network.URI
31
39
32withLocation :: (MonadJSM m) => (Location -> m a) -> m a
40withLocation :: (MonadJSM m) => (Location -> m a) -> m a
33withLocation f = DOM.currentWindowUnchecked >>= Window.getLocation >>= f
41withLocation f = DOM.currentWindowUnchecked >>= Window.getLocation >>= f
@@ -84,3 +92,70 @@ browserHistoryWith f = do
84 loc0 <- f location
92 loc0 <- f location
85 locEv <- wrapDomEvent window (`DOM.on` DOM.popState) $ f location
93 locEv <- wrapDomEvent window (`DOM.on` DOM.popState) $ f location
86 holdDyn loc0 locEv
94 holdDyn loc0 locEv
95+
96+--TODO: Pending https://github.com/haskell/network-uri/issues/39, ensure that
97+--we're handling escaping of URIs correctly
98+data HistoryItem = HistoryItem
99+ { _historyItem_state :: SerializedScriptValue
100+ , _historyItem_uri :: URI
101+ -- ^ NOTE: All URIs in this module are assumed to be already percent-escaped
102+ }
103+
104+data HistoryStateUpdate = HistoryStateUpdate
105+ { _historyStateUpdate_state :: SerializedScriptValue
106+ , _historyStateUpdate_title :: Text
107+ , _historyStateUpdate_uri :: Maybe URI
108+ -- ^ If Just, update the URI; otherwise leave it unchanged
109+ -- NOTE: All URIs in this module are assumed to be already percent-escaped
110+ }
111+
112+data HistoryCommand
113+ = HistoryCommand_PushState HistoryStateUpdate
114+ | HistoryCommand_ReplaceState HistoryStateUpdate
115+
116+runHistoryCommand :: MonadJSM m => History -> HistoryCommand -> m ()
117+runHistoryCommand history = \case
118+ HistoryCommand_PushState su -> History.pushState history
119+ (_historyStateUpdate_state su)
120+ (_historyStateUpdate_title su)
121+ (show <$> _historyStateUpdate_uri su)
122+ HistoryCommand_ReplaceState su -> History.replaceState history
123+ (_historyStateUpdate_state su)
124+ (_historyStateUpdate_title su)
125+ (show <$> _historyStateUpdate_uri su)
126+
127+getLocationUriAuth :: MonadJSM m => Location -> m URIAuth
128+getLocationUriAuth location = URIAuth "" -- Username and password don't seem to be available in most browsers
129+ <$> Location.getHostname location
130+ <*> (appendColonIfNotEmpty <$> Location.getPort location)
131+ where appendColonIfNotEmpty = \case
132+ "" -> ""
133+ x -> ":" <> x
134+
135+getLocationUri :: MonadJSM m => Location -> m URI
136+getLocationUri location = URI
137+ <$> Location.getProtocol location
138+ <*> (Just <$> getLocationUriAuth location)
139+ <*> Location.getPathname location
140+ <*> Location.getSearch location
141+ <*> Location.getHash location
142+
143+manageHistory :: (MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => Event t HistoryCommand -> m (Dynamic t HistoryItem)
144+manageHistory runCmd = do
145+ window <- DOM.currentWindowUnchecked
146+ location <- Window.getLocation window
147+ history <- Window.getHistory window
148+ let getCurrentHistoryItem = HistoryItem
149+ <$> History.getState history
150+ <*> getLocationUri location
151+ item0 <- liftJSM getCurrentHistoryItem
152+ itemSetInternal <- performEvent $ ffor runCmd $ \cmd -> liftJSM $ do
153+ runHistoryCommand history cmd
154+ getCurrentHistoryItem
155+ itemSetExternal <- wrapDomEvent window (`DOM.on` DOM.popState) $ do
156+ e <- DOM.event
157+ HistoryItem
158+ <$> (SerializedScriptValue <$> PopStateEvent.getState e)
159+ <*> getLocationUri location
160+ holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
161+--TODO: Handle title setting better