Shpadoinkle-router 0.3.0.0 → 0.3.0.1
raw patch · 5 files changed
+121/−85 lines, 5 files
Files
- CHANGELOG.md +0/−0
- README.md +2/−41
- Shpadoinkle-router.cabal +39/−29
- Shpadoinkle/Router.hs +75/−15
- Shpadoinkle/Router/Client.hs +5/−0
− CHANGELOG.md
README.md view
@@ -1,6 +1,6 @@ # Shpadoinkle Servant Router -[](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://gitlab.com/platonic/shpadoinkle) [](https://shpadoinkle.org/router) [](https://opensource.org/licenses/BSD-3-Clause) [](https://builtwithnix.org)@@ -9,43 +9,4 @@ [](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-router) -A Servant combinator-based router for Shpadoinkle single-page applications.-Consuming this router requires that you provide two types:--- Type alias for the recognized URIs-- ADT representing views that can be rendered--The relationship between these two types is surjective. meaning more than one URI-may result in the same route. This is important for backward compatibility, so the-routing schema can evolve while still supporting older schemas.--Because interactions are done through the ADT, application code should be type-safe,-and route canonically.--```haskell--- The accepted URIs-type SPA m- = "echo" :> QueryParam "echo" Text :> View m ()- :<|> "v2" :> "echo" :> QueryParam "echo" Text :> View m ()- :<|> "home" :> View m ()---- The routes that can be rendered-data Route- = Echo (Maybe Text)- | Home---- Surjection from URIs to routes-routes :: SPA m :>> Route-routes- = REcho- :<|> REcho- :<|> Home---- Canonical URI for each route-instance Routed SPA Route where- redirect = \case- REcho t -> Redirect (Proxy @("v2" :> "echo" :> QueryParam "echo" Text :> Raw)) ($ t)- Home -> Redirect (Proxy @("home" :> Raw)) id-```--The above specification can be used on both the client and the server. See the `servant-crud` example for more on how to use this technique.+## [Documentation ->](https://shpadoinkle.org/packages/router)
Shpadoinkle-router.cabal view
@@ -1,39 +1,47 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.33.0.------ see: https://github.com/sol/hpack------ hash: 3c7184e4c455d500951338935b68b93a593204314315d262e725f0540ee0bbd9--name: Shpadoinkle-router-version: 0.3.0.0-synopsis: A single page application rounter for Shpadoinkle based on Servant.-description: Surjective single page application routing with Servant. Surjectivity in this context means routes can be backward compatible, allowing URLs to evolve. Since routes are specified as Servant combinators, serving these routes from the backend is trivial. For an example of leveraging the client-server isomorphism via Servant specification, check the servant-crud example.-category: Web-author: Isaac Shapira-maintainer: fresheyeball@protonmail.com-license: BSD3-license-file: LICENSE-build-type: Simple+cabal-version: 2.2+name: Shpadoinkle-router+version: 0.3.0.1+category: Web+author: Isaac Shapira+maintainer: isaac.shapira@platonic.systems+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple extra-source-files:- README.md- CHANGELOG.md+ README.md+synopsis:+ A single page application rounter for Shpadoinkle based on Servant.+description:+ Surjective single page application routing with Servant. Surjectivity+ in this context means routes can be backward compatible, allowing URLs+ to evolve. Since routes are specified as Servant combinators, serving+ these routes from the backend is trivial. For an example of leveraging+ the client-server isomorphism via Servant specification,+ check the servant-crud example. + source-repository head type: git- location: https://gitlab.com/fresheyeball/Shpadoinkle.git+ location: https://gitlab.com/platonic/shpadoinkle.git + library exposed-modules:- Shpadoinkle.Router- Shpadoinkle.Router.Client- Shpadoinkle.Router.Server- other-modules:- Paths_Shpadoinkle_router- hs-source-dirs:- ./.- ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+ Shpadoinkle.Router+ Shpadoinkle.Router.Client+ Shpadoinkle.Router.Server++ hs-source-dirs: .++ ghc-options:+ -Wall+ -Wcompat+ -fwarn-redundant-constraints+ -fwarn-incomplete-uni-patterns+ -fwarn-tabs+ -fwarn-incomplete-record-updates+ -fwarn-identities+ build-depends: Shpadoinkle , aeson >=1.4.4 && <1.6@@ -51,6 +59,7 @@ , servant-rawm , text >=1.2.3 && <1.3 , unliftio >=0.2.12 && <0.3+ if impl(ghcjs) build-depends: servant-client-js >=0.1 && <0.2@@ -66,4 +75,5 @@ , wai >=3.2.2 && <3.3 , wai-app-static >=3.1.6 && <3.2 , warp >=3.2.28 && <3.4+ default-language: Haskell2010
Shpadoinkle/Router.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-}@@ -36,11 +37,13 @@ -- * Shpadoinkle with SPA , fullPageSPAC, fullPageSPA, fullPageSPA' -- * Navigation- , navigate+ , navigate, getURI -- * Rehydration , withHydration, toHydration -- * Re-Exports , Raw, S.RawM', S.RawM, MonadJSM, HasLink(..)+ -- * Sub route utilities+ , TraverseUnions (..), mapUnions ) where @@ -51,6 +54,7 @@ import Data.Aeson (FromJSON, ToJSON, decode, encode) import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Functor.Identity (Identity (..)) import Data.Kind (Type) import Data.Maybe (isJust) import Data.Proxy (Proxy (..))@@ -66,7 +70,8 @@ import GHCJS.DOM.Location (getPathname, getSearch) import GHCJS.DOM.PopStateEvent (PopStateEvent) import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM)-import GHCJS.DOM.Window (Window, getHistory, getLocation)+import GHCJS.DOM.Window (Window, getHistory, getLocation,+ scrollTo) import Language.Javascript.JSaddle (fromJSVal, jsg) #ifndef ghcjs_HOST_OS import Servant.API (Accept (contentTypes), Capture,@@ -95,9 +100,9 @@ import Web.HttpApiData (parseUrlPiece) import Shpadoinkle (Backend, Continuation, Html,- RawNode, h, hoist, kleisli, pur,- shpadoinkle, text, type (~>),- writeUpdate)+ NFData, RawNode, h, hoist,+ kleisli, pur, shpadoinkle, text,+ type (~>), writeUpdate) #ifndef ghcjs_HOST_OS @@ -167,18 +172,24 @@ -- | Change the browser's URL to the canonical URL for a given route `r`.-navigate :: forall a m r. MonadJSM m => Routed a r => r -> m ()+navigate :: forall a m r. (MonadJSM m, Routed a r) => r -> m () navigate r = do w <- currentWindowUnchecked history <- getHistory w+ let uri = getURI @a @r r+ pushState history () "" . Just . T.pack $+ "/" ++ uriPath uri ++ uriQuery uri ++ uriFragment uri+ liftIO $ putMVar syncRoute ()+++-- | Get the cannonical URI for a given route+getURI :: forall a r. Routed a r => r -> URI+getURI r = case redirect r :: Redirect a of- Redirect pr mf -> do- let uri = linkURI . mf $ safeLink (Proxy @a) pr- pushState history () "" . Just . T.pack $- "/" ++ uriPath uri ++ uriQuery uri ++ uriFragment uri- liftIO $ putMVar syncRoute ()+ Redirect pr mf -> linkURI . mf $ safeLink (Proxy @a) pr + -- | This method wraps @shpadoinkle@, providing for a convenient entrypoint -- for single page applications. It wires together your normal @shpadoinkle@ -- app components with a function to respond to route changes and the route mapping@@ -189,6 +200,7 @@ => Backend b m a => Monad (b m) => Eq a+ => NFData a => Functor m => (m ~> JSM) -- ^ how do we get to JSM?@@ -215,7 +227,7 @@ model <- newTVarIO i _ <- listenStateChange router $ writeUpdate model . kleisli . const . (fmap (hoist toJSM) . toJSM) . onRoute- shpadoinkle toJSM backend i model view getStage+ shpadoinkle toJSM backend model view getStage syncPoint @@ -228,6 +240,7 @@ => Backend b m a => Monad (b m) => Eq a+ => NFData a => Functor m => (m ~> JSM) -- ^ how do we get to JSM?@@ -257,6 +270,7 @@ => Backend b m a => Monad (b m) => Eq a+ => NFData a => Functor m => (m ~> JSM) -- ^ how do we get to JSM?@@ -285,7 +299,7 @@ atomically $ writeTVar model i _ <- listenStateChange router $ writeUpdate model . kleisli . const . (fmap (hoist toJSM) . toJSM) . onRoute- shpadoinkle toJSM backend i model view getStage+ shpadoinkle toJSM backend model view getStage syncPoint @@ -326,8 +340,7 @@ liftIO $ takeMVar syncRoute getRoute w router $ maybe (return ()) handle syncPoint- () <- liftIO $ return ()- return ()+ scrollTo w 0 0 return () @@ -499,3 +512,50 @@ instance HasLink (View m a) where type MkLink (View m a) b = b toLink toA _ = toA+++type family SwitchOutput layout b :: Type where+ SwitchOutput ((a :<|> as) :<|> r) b = (b :<|> SwitchOutput as b) :<|> SwitchOutput r b+ SwitchOutput (a :<|> r) b = b :<|> SwitchOutput r b+ SwitchOutput a b = b+++type family SwitchInput layout :: Type where+ SwitchInput ((a :<|> as) :<|> r) = a+ SwitchInput (a :<|> r) = a+ SwitchInput a = a+++class TraverseUnions m layout b where+ traverseUnions :: (SwitchInput layout -> m b) -> layout -> m (SwitchOutput layout b)++instance+ ( Applicative m+ , TraverseUnions m r b+ , TraverseUnions m as b+ , SwitchInput r ~ a+ , SwitchInput as ~ a)+ => TraverseUnions m ((a :<|> as) :<|> r) b where+ traverseUnions f ((a :<|> as) :<|> r) = (\a' as' r' -> (a' :<|> as') :<|> r')+ <$> f a+ <*> traverseUnions @m @as @b f as+ <*> traverseUnions @m @r @b f r++instance+ {-# OVERLAPPABLE #-}+ ( Applicative m+ , TraverseUnions m r b+ , SwitchInput (a :<|> r) ~ a+ , SwitchInput r ~ a+ , SwitchOutput (a :<|> r) b ~ (b :<|> SwitchOutput r b))+ => TraverseUnions m (a :<|> r) b where+ traverseUnions f (a :<|> r) = (:<|>) <$> f a <*> traverseUnions @m @r @b f r+++instance {-# OVERLAPPABLE #-} (SwitchOutput a b ~ b, SwitchInput a ~ a)+ => TraverseUnions m a b where+ traverseUnions f a = f a+++mapUnions :: TraverseUnions Identity a b => (SwitchInput a -> b) -> a -> SwitchOutput a b+mapUnions f = runIdentity . traverseUnions (Identity . f)
Shpadoinkle/Router/Client.hs view
@@ -12,6 +12,7 @@ module Shpadoinkle.Router.Client ( runXHR , runXHR'+ , runXHRe , module Servant.Client.JS ) where @@ -57,3 +58,7 @@ -- | Run the ClientM from Servant as an XHR request with a customized base URL. runXHR' :: ClientM a -> ClientEnv -> JSM a runXHR' m env = either (liftIO . throwM) pure =<< runClientM m env+++runXHRe :: ClientM a -> ClientEnv -> JSM (Either ClientError a)+runXHRe = runClientM