aboutsummaryrefslogtreecommitdiff
path: root/client/src/Util
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Util')
-rw-r--r--client/src/Util/Css.hs9
-rw-r--r--client/src/Util/Router.hs266
2 files changed, 275 insertions, 0 deletions
diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs
new file mode 100644
index 0000000..804b10f
--- /dev/null
+++ b/client/src/Util/Css.hs
@@ -0,0 +1,9 @@
+module Util.Css
+ ( classes
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+classes :: [(Text, Bool)] -> Text
+classes = T.unwords . map fst . filter snd
diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs
new file mode 100644
index 0000000..e9d0a1a
--- /dev/null
+++ b/client/src/Util/Router.hs
@@ -0,0 +1,266 @@
+{-# 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-07-03 20:48:06 +0000