aboutsummaryrefslogtreecommitdiff
path: root/client/src/Util/Router.hs
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Util/Router.hs')
-rw-r--r--client/src/Util/Router.hs266
1 files changed, 0 insertions, 266 deletions
diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs
deleted file mode 100644
index e9d0a1a..0000000
--- a/client/src/Util/Router.hs
+++ /dev/null
@@ -1,266 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecursiveDo #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Util.Router (
- -- == High-level routers
- route
- , route'
- , partialPathRoute
-
- -- = Low-level URL bar access
- , getLoc
- , getURI
- , getUrlText
- , uriOrigin
- , URI
-
- -- = History movement
- , goForward
- , goBack
- ) where
-
-------------------------------------------------------------------------------
-import Control.Lens ((&), (.~), (^.))
-import Control.Monad.Fix (MonadFix)
-import qualified Data.ByteString.Char8 as BS
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import GHCJS.DOM (currentDocumentUnchecked,
- currentWindowUnchecked)
-import GHCJS.DOM.Document (createEvent)
-import GHCJS.DOM.Event (initEvent)
-import GHCJS.DOM.EventM (on)
-import GHCJS.DOM.EventTarget (dispatchEvent_)
-import GHCJS.DOM.History (History, back, forward,
- pushState)
-import GHCJS.DOM.Location (getHref)
-import GHCJS.DOM.PopStateEvent
-import GHCJS.DOM.Types (Location (..),
- PopStateEvent (..))
-import GHCJS.DOM.Types (MonadJSM, uncheckedCastTo)
-import qualified GHCJS.DOM.Types as DOM
-import GHCJS.DOM.Window (getHistory, getLocation)
-import GHCJS.DOM.WindowEventHandlers (popState)
-import GHCJS.Foreign (isFunction)
-import GHCJS.Marshal.Pure (pFromJSVal)
-import Language.Javascript.JSaddle (JSM, Object (..), ghcjsPure,
- liftJSM)
-import qualified Language.Javascript.JSaddle as JS
-import Reflex.Dom.Core hiding (EventName, Window)
-import qualified URI.ByteString as U
-------------------------------------------------------------------------------
-
-
--------------------------------------------------------------------------------
--- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic
--- routing of a widget
--- These sources of URL-bar change will be reflected in the output URI
--- - Input events to 'route'
--- - Browser Forward/Back button clicks
--- - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls
--- - Any URL changes followed by a popState event
--- But external calls to pushState that don't manually fire a popState
--- won't be detected
-route
- :: forall t m.
- ( MonadHold t m
- , PostBuild t m
- , TriggerEvent t m
- , PerformEvent t m
- , HasJSContext m
- , HasJSContext (Performable m)
- , MonadJSM m
- , MonadJSM (Performable m))
- => Event t T.Text
- -> m (Dynamic t (U.URIRef U.Absolute))
-route pushTo = do
- loc0 <- getURI
-
- _ <- performEvent $ ffor pushTo $ \t -> do
- let newState = Just t
- withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text)
- liftJSM dispatchEvent'
-
- locUpdates <- getPopState
- holdDyn loc0 locUpdates
-
-route'
- :: forall t m a b.
- ( MonadHold t m
- , PostBuild t m
- , TriggerEvent t m
- , PerformEvent t m
- , HasJSContext m
- , HasJSContext (Performable m)
- , MonadJSM m
- , MonadJSM (Performable m)
- , MonadFix m)
- => (URI -> a -> URI)
- -> (URI -> b)
- -> Event t a
- -> m (Dynamic t b)
-route' encode decode routeUpdate = do
- rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates)
- let urlUpdates = attachWith encode (current rUri) routeUpdate
- return $ decode <$> rUri
-
-
--------------------------------------------------------------------------------
--- | Route a single page app according to the part of the path after
--- pathBase
-partialPathRoute
- :: forall t m.
- ( MonadHold t m
- , PostBuild t m
- , DomBuilder t m
- , TriggerEvent t m
- , PerformEvent t m
- , HasJSContext m
- , HasJSContext (Performable m)
- , MonadJSM m
- , MonadJSM (Performable m)
- , MonadFix m)
- => T.Text -- ^ The path segments not related to SPA routing
- -- (leading '/' will be added automaticaly)
- -> Event t T.Text -- ^ Updates to the path segments used for routing
- -- These values will be appended to the base path
- -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing
-partialPathRoute pathBase pathUpdates = do
- route' (flip updateUrl) parseParts pathUpdates
- where
-
- rootPathBase :: T.Text
- rootPathBase =
- if T.null pathBase then
- ""
- else
- "/" <> cleanT pathBase
-
- toPath :: T.Text -> BS.ByteString
- toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath
-
- updateUrl :: T.Text -> URI -> URI
- updateUrl updateParts u = u & U.pathL .~ toPath updateParts
-
- parseParts :: URI -> [T.Text]
- parseParts u =
- maybe (error $ pfxErr u pathBase)
- (T.splitOn "/" . T.decodeUtf8 . cleanB) .
- BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $
- cleanB (u ^. U.pathL)
-
- cleanT = T.dropWhile (=='/')
- cleanB = BS.dropWhile (== '/')
-
-
--------------------------------------------------------------------------------
-uriOrigin :: U.URIRef U.Absolute -> T.Text
-uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r'
- where
- r' = r { U.uriPath = mempty
- , U.uriQuery = mempty
- , U.uriFragment = mempty
- }
-
-
--------------------------------------------------------------------------------
-getPopState
- :: forall t m.
- ( MonadHold t m
- , TriggerEvent t m
- , MonadJSM m) => m (Event t URI)
-getPopState = do
- window <- currentWindowUnchecked
- wrapDomEventMaybe window (`on` popState) $ do
- loc <- getLocation window
- locStr <- getHref loc
- return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr)
-
-
--------------------------------------------------------------------------------
-goForward :: (HasJSContext m, MonadJSM m) => m ()
-goForward = withHistory forward
-
-
--------------------------------------------------------------------------------
-goBack :: (HasJSContext m, MonadJSM m) => m ()
-goBack = withHistory back
-
-
--------------------------------------------------------------------------------
-withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a
-withHistory act = do
- w <- currentWindowUnchecked
- h <- getHistory w
- act h
-
-
--------------------------------------------------------------------------------
--- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window
-getLoc :: (HasJSContext m, MonadJSM m) => m Location
-getLoc = do
- win <- currentWindowUnchecked
- loc <- getLocation win
- return loc
-
-
--------------------------------------------------------------------------------
--- | (Unsafely) get the URL text of a window
-getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text
-getUrlText = getLoc >>= getHref
-
-
--------------------------------------------------------------------------------
-type URI = U.URIRef U.Absolute
-
-
--------------------------------------------------------------------------------
-getURI :: (HasJSContext m, MonadJSM m) => m URI
-getURI = do
- l <- getUrlText
- return $ either (error "No parse of window location") id .
- U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l
-
-
-dispatchEvent' :: JSM ()
-dispatchEvent' = do
- window <- currentWindowUnchecked
- obj@(Object o) <- JS.create
- JS.objSetPropertyByName obj ("cancelable" :: Text) True
- JS.objSetPropertyByName obj ("bubbles" :: Text) True
- JS.objSetPropertyByName obj ("view" :: Text) window
- event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case
- True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o
- False -> do
- doc <- currentDocumentUnchecked
- event <- createEvent doc ("PopStateEvent" :: Text)
- initEvent event ("popstate" :: Text) True True
- JS.objSetPropertyByName obj ("view" :: Text) window
- return $ uncheckedCastTo PopStateEvent event
-
- dispatchEvent_ window event
-
-
--------------------------------------------------------------------------------
-hush :: Either e a -> Maybe a
-hush (Right a) = Just a
-hush _ = Nothing
-
-
--------------------------------------------------------------------------------
-pfxErr :: URI -> T.Text -> String
-pfxErr pn pathBase =
- T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn)
- <> ") without expected prefix (" <> pathBase <> ")"
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 06:10:51 +0000