@@ -1,8 +1,8 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE MultiParamTypeClasses #-}
34{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE RankNTypes #-}
5−
66module Reflex.Dom.Location
77 ( browserHistoryWith
88 , getLocationAfterHost
@@ -11,6 +11,11 @@ module Reflex.Dom.Location
1111 , getLocationPath
1212 , getLocationProtocol
1313 , getLocationUrl
14+ , manageHistory
15+ , HistoryCommand (..)
16+ , HistoryStateUpdate (..)
17+ , HistoryItem (..)
18+ , getLocationUri
1419 ) where
1520
1621import Reflex
@@ -18,16 +23,19 @@ import Reflex.Dom.Builder.Immediate (wrapDomEvent)
1823
1924import Control.Lens ((^.))
2025import Control.Monad ((>=>))
26+import Data.Monoid
2127import Data.Text (Text)
2228import qualified GHCJS.DOM as DOM
2329import qualified GHCJS.DOM.EventM as DOM
2430import qualified GHCJS.DOM.Location as Location
25−import GHCJS.DOM.Types (Location)
31+import qualified GHCJS.DOM.History as History
32+import qualified GHCJS.DOM.PopStateEvent as PopStateEvent
33+import GHCJS.DOM.Types (Location, History, SerializedScriptValue (..), liftJSM)
2634import qualified GHCJS.DOM.Types as DOM
2735import qualified GHCJS.DOM.Window as Window
2836import qualified GHCJS.DOM.WindowEventHandlers as DOM
29−import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, toJSVal)
30−
37+import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, ToJSVal (..), FromJSVal (..))
38+import Network.URI
3139
3240withLocation :: (MonadJSM m) => (Location -> m a) -> m a
3341withLocation f = DOM.currentWindowUnchecked >>= Window.getLocation >>= f
@@ -84,3 +92,70 @@ browserHistoryWith f = do
8492 loc0 <- f location
8593 locEv <- wrapDomEvent window (`DOM.on` DOM.popState) $ f location
8694 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