From 11052951b74b9ad4b6a9412ae490086235f9154b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Jan 2021 13:40:40 +0100 Subject: Rewrite in Rust --- client/src/Util/Router.hs | 266 ---------------------------------------------- 1 file changed, 266 deletions(-) delete mode 100644 client/src/Util/Router.hs (limited to 'client/src/Util/Router.hs') 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 <> ")" -- cgit v1.2.3