{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Reflex.Dom.Location
  ( browserHistoryWith
  , getLocationAfterHost
  , getLocationFragment
  , getLocationHost
  , getLocationPath
  , getLocationProtocol
  , getLocationUrl
  , manageHistory
  , manageHistory'
  , manageHistoryExposingExternalUpdates
  , HistoryCommand (..)
  , HistoryStateUpdate (..)
  , HistoryItem (..)
  , getLocationUri
  , popHistoryState
  ) where

import Reflex
import Reflex.Dom.Builder.Immediate (wrapDomEvent)

import Control.Lens ((^.))
import Control.Monad ((>=>))
import Control.Monad.Fix (MonadFix)
import Data.Align (align)
import Data.Text (Text)
import Data.These (These(..))
import qualified GHCJS.DOM as DOM
import qualified GHCJS.DOM.EventM as DOM
import qualified GHCJS.DOM.Location as Location
import qualified GHCJS.DOM.History as History
import qualified GHCJS.DOM.PopStateEvent as PopStateEvent
import GHCJS.DOM.Types (Location, History, SerializedScriptValue (..), liftJSM)
import qualified GHCJS.DOM.Types as DOM
import qualified GHCJS.DOM.Window as Window
import qualified GHCJS.DOM.WindowEventHandlers as DOM
import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, ToJSVal (..), FromJSVal (..))
import Network.URI

withLocation :: (MonadJSM m) => (Location -> m a) -> m a
withLocation :: forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation Location -> m a
f = m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked m Window -> (Window -> m Location) -> m Location
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> m Location
forall (m :: * -> *). MonadDOM m => Window -> m Location
Window.getLocation m Location -> (Location -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Location -> m a
f

-- | Returns the full URI-decoded URL of the current window location.
getLocationUrl :: (MonadJSM m) => m Text
getLocationUrl :: forall (m :: * -> *). MonadJSM m => m Text
getLocationUrl = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation (Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHref (Location -> m Text) -> (Text -> m Text) -> Location -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText)

-- | Returns the host of the current window location
getLocationHost :: (MonadJSM m) => m Text
getLocationHost :: forall (m :: * -> *). MonadJSM m => m Text
getLocationHost = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHost

-- | Returns the protocol/scheme (e.g. @http:@ or @https:@) of the current window location
getLocationProtocol :: (MonadJSM m) => m Text
getLocationProtocol :: forall (m :: * -> *). MonadJSM m => m Text
getLocationProtocol = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getProtocol

-- | Returns the URI-decoded location after the host and port; i.e. returns the path, query, and fragment of the location.
getLocationAfterHost :: (MonadJSM m) => m Text
getLocationAfterHost :: forall (m :: * -> *). MonadJSM m => m Text
getLocationAfterHost = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation ((Location -> m Text) -> m Text) -> (Location -> m Text) -> m Text
forall a b. (a -> b) -> a -> b
$ \Location
loc -> do
  pathname <- Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPathname Location
loc
  search <- Location.getSearch loc
  hash <- Location.getHash loc
  decodeURI (mconcat [pathname, search, hash] :: Text)

-- | Returns the URI-decoded path of the current window location.
getLocationPath :: (MonadJSM m) => m Text
getLocationPath :: forall (m :: * -> *). MonadJSM m => m Text
getLocationPath = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation (Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPathname (Location -> m Text) -> (Text -> m Text) -> Location -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText)

-- | Returns the URI-decoded fragment/hash of the current window location.
getLocationFragment :: (MonadJSM m) => m Text
getLocationFragment :: forall (m :: * -> *). MonadJSM m => m Text
getLocationFragment = (Location -> m Text) -> m Text
forall (m :: * -> *) a. MonadJSM m => (Location -> m a) -> m a
withLocation (Location -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHash (Location -> m Text) -> (Text -> m Text) -> Location -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText)


-- | Decodes a URI with JavaScript's @decodeURI@ function.
--
-- FIXME: @decodeURI@ will throw when URI is malformed
decodeURI :: (MonadJSM m, ToJSString a, FromJSString b) => a -> m b
decodeURI :: forall (m :: * -> *) a b.
(MonadJSM m, ToJSString a, FromJSString b) =>
a -> m b
decodeURI a
input = do
  window <-  m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  window' <- DOM.liftJSM $ toJSVal window
  DOM.liftJSM $ window' ^. js1 ("decodeURI"::Text) input >>= fromJSValUnchecked

decodeURIText :: (MonadJSM m) => Text -> m Text
decodeURIText :: forall (m :: * -> *). MonadJSM m => Text -> m Text
decodeURIText = Text -> m Text
forall (m :: * -> *) a b.
(MonadJSM m, ToJSString a, FromJSString b) =>
a -> m b
decodeURI

-- | Builds a Dynamic carrying the current window location.
browserHistoryWith :: (MonadJSM m, TriggerEvent t m, MonadHold t m)
                   => (forall jsm. MonadJSM jsm => Location -> jsm a)
                   -- ^ A function to encode the window location in a more useful form (e.g. @getLocationAfterHost@).
                   -> m (Dynamic t a)
browserHistoryWith :: forall (m :: * -> *) t a.
(MonadJSM m, TriggerEvent t m, MonadHold t m) =>
(forall (jsm :: * -> *). MonadJSM jsm => Location -> jsm a)
-> m (Dynamic t a)
browserHistoryWith forall (jsm :: * -> *). MonadJSM jsm => Location -> jsm a
f = do
  window <- m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  location <- Window.getLocation window
  loc0 <- f location
  locEv <- wrapDomEvent window (`DOM.on` DOM.popState) $ f location
  holdDyn loc0 locEv

--TODO: Pending https://github.com/haskell/network-uri/issues/39, ensure that
--we're handling escaping of URIs correctly
data HistoryItem = HistoryItem
  { HistoryItem -> SerializedScriptValue
_historyItem_state :: SerializedScriptValue
  , HistoryItem -> URI
_historyItem_uri :: URI
  -- ^ NOTE: All URIs in this module are assumed to be already percent-escaped
  }

data HistoryStateUpdate = HistoryStateUpdate
  { HistoryStateUpdate -> SerializedScriptValue
_historyStateUpdate_state :: SerializedScriptValue
  , HistoryStateUpdate -> Text
_historyStateUpdate_title :: Text
  , HistoryStateUpdate -> Maybe URI
_historyStateUpdate_uri :: Maybe URI
  -- ^ If Just, update the URI; otherwise leave it unchanged
  -- NOTE: All URIs in this module are assumed to be already percent-escaped
  }

data HistoryCommand
   = HistoryCommand_PushState HistoryStateUpdate
   | HistoryCommand_ReplaceState HistoryStateUpdate

runHistoryCommand :: MonadJSM m => History -> HistoryCommand -> m ()
runHistoryCommand :: forall (m :: * -> *).
MonadJSM m =>
History -> HistoryCommand -> m ()
runHistoryCommand History
history = \case
  HistoryCommand_PushState HistoryStateUpdate
su -> History -> SerializedScriptValue -> Text -> Maybe String -> m ()
forall (m :: * -> *) data' title url.
(MonadDOM m, ToJSVal data', ToJSString title, ToJSString url) =>
History -> data' -> title -> Maybe url -> m ()
History.pushState History
history
    (HistoryStateUpdate -> SerializedScriptValue
_historyStateUpdate_state HistoryStateUpdate
su)
    (HistoryStateUpdate -> Text
_historyStateUpdate_title HistoryStateUpdate
su)
    (URI -> String
forall a. Show a => a -> String
show (URI -> String) -> Maybe URI -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HistoryStateUpdate -> Maybe URI
_historyStateUpdate_uri HistoryStateUpdate
su)
  HistoryCommand_ReplaceState HistoryStateUpdate
su -> History -> SerializedScriptValue -> Text -> Maybe String -> m ()
forall (m :: * -> *) data' title url.
(MonadDOM m, ToJSVal data', ToJSString title, ToJSString url) =>
History -> data' -> title -> Maybe url -> m ()
History.replaceState History
history
    (HistoryStateUpdate -> SerializedScriptValue
_historyStateUpdate_state HistoryStateUpdate
su)
    (HistoryStateUpdate -> Text
_historyStateUpdate_title HistoryStateUpdate
su)
    (URI -> String
forall a. Show a => a -> String
show (URI -> String) -> Maybe URI -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HistoryStateUpdate -> Maybe URI
_historyStateUpdate_uri HistoryStateUpdate
su)

getLocationUriAuth :: MonadJSM m => Location -> m URIAuth
getLocationUriAuth :: forall (m :: * -> *). MonadJSM m => Location -> m URIAuth
getLocationUriAuth Location
location = String -> String -> String -> URIAuth
URIAuth String
"" -- Username and password don't seem to be available in most browsers
  (String -> String -> URIAuth) -> m String -> m (String -> URIAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHostname Location
location
  m (String -> URIAuth) -> m String -> m URIAuth
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> String
appendColonIfNotEmpty (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPort Location
location)
  where appendColonIfNotEmpty :: String -> String
appendColonIfNotEmpty = \case
          String
"" -> String
""
          String
x -> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x

getLocationUri :: MonadJSM m => Location -> m URI
getLocationUri :: forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location = String -> Maybe URIAuth -> String -> String -> String -> URI
URI
  (String -> Maybe URIAuth -> String -> String -> String -> URI)
-> m String
-> m (Maybe URIAuth -> String -> String -> String -> URI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getProtocol Location
location
  m (Maybe URIAuth -> String -> String -> String -> URI)
-> m (Maybe URIAuth) -> m (String -> String -> String -> URI)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> m URIAuth -> m (Maybe URIAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> m URIAuth
forall (m :: * -> *). MonadJSM m => Location -> m URIAuth
getLocationUriAuth Location
location)
  m (String -> String -> String -> URI)
-> m String -> m (String -> String -> URI)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getPathname Location
location
  m (String -> String -> URI) -> m String -> m (String -> URI)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getSearch Location
location
  m (String -> URI) -> m String -> m URI
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> m String
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
Location -> m result
Location.getHash Location
location

manageHistory :: (MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => Event t HistoryCommand -> m (Dynamic t HistoryItem)
manageHistory :: forall (m :: * -> *) t.
(MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m,
 MonadJSM (Performable m)) =>
Event t HistoryCommand -> m (Dynamic t HistoryItem)
manageHistory Event t HistoryCommand
runCmd = do
  window <- m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  location <- Window.getLocation window
  history <- Window.getHistory window
  let getCurrentHistoryItem = SerializedScriptValue -> URI -> HistoryItem
HistoryItem
        (SerializedScriptValue -> URI -> HistoryItem)
-> JSM SerializedScriptValue -> JSM (URI -> HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> History -> JSM SerializedScriptValue
forall (m :: * -> *).
MonadDOM m =>
History -> m SerializedScriptValue
History.getState History
history
        JSM (URI -> HistoryItem) -> JSM URI -> JSM HistoryItem
forall a b. JSM (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> JSM URI
forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location
  item0 <- liftJSM getCurrentHistoryItem
  itemSetInternal <- performEvent $ ffor runCmd $ \HistoryCommand
cmd -> JSM HistoryItem -> Performable m HistoryItem
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM HistoryItem -> Performable m HistoryItem)
-> JSM HistoryItem -> Performable m HistoryItem
forall a b. (a -> b) -> a -> b
$ do
    History -> HistoryCommand -> JSM ()
forall (m :: * -> *).
MonadJSM m =>
History -> HistoryCommand -> m ()
runHistoryCommand History
history HistoryCommand
cmd
    JSM HistoryItem
getCurrentHistoryItem
  itemSetExternal <- wrapDomEvent window (`DOM.on` DOM.popState) $ do
    e <- DOM.event
    HistoryItem
      <$> (SerializedScriptValue <$> PopStateEvent.getState e)
      <*> getLocationUri location
  holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
--TODO: Handle title setting better

manageHistory'
  :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))
  => Event t ()
  -- ^ Don't do anything until this event has fired
  -> Event t HistoryCommand
  -> m (Dynamic t HistoryItem)
manageHistory' :: forall (m :: * -> *) t.
(MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m,
 PerformEvent t m, MonadJSM (Performable m)) =>
Event t () -> Event t HistoryCommand -> m (Dynamic t HistoryItem)
manageHistory' Event t ()
switchover Event t HistoryCommand
runCmd = (Dynamic t HistoryItem, Event t HistoryItem)
-> Dynamic t HistoryItem
forall a b. (a, b) -> a
fst ((Dynamic t HistoryItem, Event t HistoryItem)
 -> Dynamic t HistoryItem)
-> m (Dynamic t HistoryItem, Event t HistoryItem)
-> m (Dynamic t HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t ()
-> Event t HistoryCommand
-> m (Dynamic t HistoryItem, Event t HistoryItem)
forall (m :: * -> *) t.
(MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m,
 PerformEvent t m, MonadJSM (Performable m)) =>
Event t ()
-> Event t HistoryCommand
-> m (Dynamic t HistoryItem, Event t HistoryItem)
manageHistoryExposingExternalUpdates Event t ()
switchover Event t HistoryCommand
runCmd

manageHistoryExposingExternalUpdates
  :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))
  => Event t ()
  -- ^ Don't do anything until this event has fired
  -> Event t HistoryCommand
  -> m (Dynamic t HistoryItem, Event t HistoryItem)
manageHistoryExposingExternalUpdates :: forall (m :: * -> *) t.
(MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m,
 PerformEvent t m, MonadJSM (Performable m)) =>
Event t ()
-> Event t HistoryCommand
-> m (Dynamic t HistoryItem, Event t HistoryItem)
manageHistoryExposingExternalUpdates Event t ()
switchover Event t HistoryCommand
runCmd = do
  window <- m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
  location <- Window.getLocation window
  history <- Window.getHistory window
  let getCurrentHistoryItem = SerializedScriptValue -> URI -> HistoryItem
HistoryItem
        (SerializedScriptValue -> URI -> HistoryItem)
-> JSM SerializedScriptValue -> JSM (URI -> HistoryItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> History -> JSM SerializedScriptValue
forall (m :: * -> *).
MonadDOM m =>
History -> m SerializedScriptValue
History.getState History
history
        JSM (URI -> HistoryItem) -> JSM URI -> JSM HistoryItem
forall a b. JSM (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Location -> JSM URI
forall (m :: * -> *). MonadJSM m => Location -> m URI
getLocationUri Location
location
  item0 <- liftJSM getCurrentHistoryItem
  itemSetExternal' <- wrapDomEvent window (`DOM.on` DOM.popState) $ do
    e <- DOM.event
    HistoryItem
      <$> (SerializedScriptValue <$> PopStateEvent.getState e)
      <*> getLocationUri location
  let f :: (Bool, Maybe a) -> These a () -> (Maybe (Bool, Maybe a), Maybe a)
      f (Bool
switched, Maybe a
acc) = \case
        This a
change
          | Bool
switched -> (Maybe (Bool, Maybe a)
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
change)
          | Bool
otherwise -> ((Bool, Maybe a) -> Maybe (Bool, Maybe a)
forall a. a -> Maybe a
Just (Bool
switched, a -> Maybe a
forall a. a -> Maybe a
Just a
change), Maybe a
forall a. Maybe a
Nothing)
        That () -> ((Bool, Maybe a) -> Maybe (Bool, Maybe a)
forall a. a -> Maybe a
Just (Bool
True, Maybe a
forall a. Maybe a
Nothing), Maybe a
acc)
        These a
change () -> ((Bool, Maybe a) -> Maybe (Bool, Maybe a)
forall a. a -> Maybe a
Just (Bool
True, Maybe a
forall a. Maybe a
Nothing), a -> Maybe a
forall a. a -> Maybe a
Just a
change)
  -- Accumulate the events before switchover
  (_, cmd') <- mapAccumMaybeB f (False, Nothing) $ align (leftmost [Left <$> runCmd, Right <$> itemSetExternal']) switchover
  let (itemSetInternal', itemSetExternal) = fanEither cmd'
  itemSetInternal <- performEvent $ ffor itemSetInternal' $ \HistoryCommand
cmd -> JSM HistoryItem -> Performable m HistoryItem
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM HistoryItem -> Performable m HistoryItem)
-> JSM HistoryItem -> Performable m HistoryItem
forall a b. (a -> b) -> a -> b
$ do
    History -> HistoryCommand -> JSM ()
forall (m :: * -> *).
MonadJSM m =>
History -> HistoryCommand -> m ()
runHistoryCommand History
history HistoryCommand
cmd
    JSM HistoryItem
getCurrentHistoryItem
  currentHistoryItem <- holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]
  pure (currentHistoryItem, itemSetExternal)
--TODO: Handle title setting better

popHistoryState
  :: (PerformEvent t m, MonadJSM (Performable m))
  => Event t ()
  -> m ()
popHistoryState :: forall t (m :: * -> *).
(PerformEvent t m, MonadJSM (Performable m)) =>
Event t () -> m ()
popHistoryState Event t ()
evt =
  Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ()
evt ((() -> Performable m ()) -> Event t (Performable m ()))
-> (() -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    window <- Performable m Window
forall (m :: * -> *). MonadDOM m => m Window
DOM.currentWindowUnchecked
    history <- Window.getHistory window
    History.back history