packages feed

Shpadoinkle-router 0.1.0.1 → 0.2.0.0

raw patch · 7 files changed

+209/−99 lines, 7 filesdep +http-mediadep +servant-client-jsdep −jsaddle-domdep −servant-client-ghcjsdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: http-media, servant-client-js

Dependencies removed: jsaddle-dom, servant-client-ghcjs

Dependency ranges changed: aeson, base, bytestring, servant

API changes (from Hackage documentation)

- Shpadoinkle.Router: -- route can be the handler for more than one url.
- Shpadoinkle.Router: fromRouter :: [(Text, Text)] -> [Text] -> Router r -> Maybe r
+ Shpadoinkle.Router: -- one route can be the handler for more than one URL.
+ Shpadoinkle.Router: [RCapture] :: FromHttpApiData x => (x -> Router a) -> Router a
+ Shpadoinkle.Router: [RChoice] :: Router a -> Router a -> Router a
+ Shpadoinkle.Router: [RPath] :: KnownSymbol sym => Proxy sym -> Router a -> Router a
+ Shpadoinkle.Router: [RQueryFlag] :: KnownSymbol sym => Proxy sym -> (Bool -> Router a) -> Router a
+ Shpadoinkle.Router: [RQueryParamR] :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> (x -> Router a) -> Router a
+ Shpadoinkle.Router: [RQueryParam] :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> (Maybe x -> Router a) -> Router a
+ Shpadoinkle.Router: [RQueryParams] :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> ([x] -> Router a) -> Router a
+ Shpadoinkle.Router: [RView] :: a -> Router a
+ Shpadoinkle.Router: class (Applicative m, MonadIO m) => MonadJSM (m :: Type -> Type)
+ Shpadoinkle.Router: data Router a
+ Shpadoinkle.Router: fullPageSPAC :: forall layout b a r m. HasRouter layout => Backend b m a => Monad (b m) => Eq a => Functor m => (m ~> JSM) -> (TVar a -> b m ~> m) -> (r -> m a) -> (a -> Html (b m) a) -> b m RawNode -> (r -> m (Continuation m a)) -> (layout :>> r) -> JSM ()
+ Shpadoinkle.Router: instance (Shpadoinkle.Router.HasRouter sub, Web.Internal.HttpApiData.FromHttpApiData x, GHC.TypeLits.KnownSymbol sym) => Shpadoinkle.Router.HasRouter (Servant.API.QueryParam.QueryParam' '[Servant.API.Modifiers.Required] sym x Servant.API.Sub.:> sub)
+ Shpadoinkle.Router.Client: runXHR' :: ClientM a -> ClientEnv -> JSM a
+ Shpadoinkle.Router.HTML: data HTML
+ Shpadoinkle.Router.HTML: instance Servant.API.ContentTypes.Accept Shpadoinkle.Router.HTML.HTML
+ Shpadoinkle.Router.HTML: instance Servant.API.ContentTypes.MimeRender Shpadoinkle.Router.HTML.HTML (Shpadoinkle.Core.Html m a)
- Shpadoinkle.Router: -- | :>> (pronounced "routed as") should be surjective. As in one
+ Shpadoinkle.Router: -- | <a>:&gt;&gt;</a> (pronounced "routed as") should be surjective, as in
- Shpadoinkle.Router: fullPageSPA :: forall layout b a r m. HasRouter layout => Backend b m a => Eq a => (m ~> JSM) -> (TVar a -> b m ~> m) -> (r -> m a) -> (a -> Html (b m) a) -> b m RawNode -> (r -> a -> m a) -> (layout :>> r) -> JSM ()
+ Shpadoinkle.Router: fullPageSPA :: forall layout b a r m. HasRouter layout => Backend b m a => Monad (b m) => Eq a => Functor m => (m ~> JSM) -> (TVar a -> b m ~> m) -> (r -> m a) -> (a -> Html (b m) a) -> b m RawNode -> (r -> m a) -> (layout :>> r) -> JSM ()
- Shpadoinkle.Router.Client: runXHR :: MonadIO m => MonadThrow m => (JSM a -> m a) -> ClientM a -> m a
+ Shpadoinkle.Router.Client: runXHR :: ClientM a -> JSM a

Files

LICENSE view
@@ -1,26 +1,27 @@-Shpadoinkle Router, I think I know exactly what it means-Copyright © 2019 Isaac Shpaira+Shpadoinkle Router aka S11 Router+Copyright © 2020 Isaac Shapira All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-1. Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-notice, this list of conditions and the following disclaimer in the-documentation and/or other materials provided with the distribution.-3. Neither the name of the <`3:organization`> nor the-names of its contributors may be used to endorse or promote products-derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY <|2|> ''AS IS'' AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <|2|> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ * Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+ * Neither the name of Shpadoinkle nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,6 +1,7 @@ # Shpadoinkle Servant Router  [![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle)+[![Haddock](https://img.shields.io/badge/haddock-master-informational)](https://shpadoinkle.org/router) [![BSD-3](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![built with nix](https://img.shields.io/badge/built%20with-nix-41439a)](https://builtwithnix.org) [![Hackage](https://img.shields.io/hackage/v/Shpadoinkle-router.svg)](https://hackage.haskell.org/package/Shpadoinkle-router)@@ -8,17 +9,17 @@ [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/Shpadoinkle-router/badge)](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-router)  -A Servant combinator based router for Shpadoinkle single-page applications.+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+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. -Since interactions are done through the ADT, application code should be type-safe,+Because interactions are done through the ADT, application code should be type-safe, and route canonically.  ```haskell
Shpadoinkle-router.cabal view
@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 643336b80dad57ed97e0d7dc4bd18505a3975ae9343c124925a6d89c4b1ce920+-- hash: 1f447eca9bd32966123dd6a67d22331ec3365eaf01daa425e4da52100d935f37  name:           Shpadoinkle-router-version:        0.1.0.1+version:        0.2.0.0 synopsis:       A single page application rounter for Shpadoinkle based on Servant.-description:    Surjective single page application routing with Servant. Surjectivity 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.+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@@ -28,6 +28,7 @@   exposed-modules:       Shpadoinkle.Router       Shpadoinkle.Router.Client+      Shpadoinkle.Router.HTML       Shpadoinkle.Router.Server   other-modules:       Paths_Shpadoinkle_router@@ -36,27 +37,28 @@   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.5-    , base >=4.12.0 && <4.15-    , bytestring >=0.10.8 && <0.11+    , aeson >=1.4.4 && <1.6+    , base >=4.12.0 && <4.16+    , bytestring >=0.10.8 && <0.12     , compactable >=0.1.2 && <0.2     , exceptions >=0.10.3 && <0.11     , ghcjs-dom >=0.9.4 && <0.20     , http-api-data >=0.4.1 && <0.5+    , http-media     , jsaddle >=0.9.7 && <0.20-    , jsaddle-dom >=0.9.3 && <0.20     , lens >=4.17.1 && <5.0     , network-uri >=2.6.1 && <2.8-    , servant >=0.16 && <0.18+    , servant >=0.16 && <0.19     , text >=1.2.3 && <1.3     , unliftio >=0.2.12 && <0.3   if impl(ghcjs)     build-depends:-        servant-client-ghcjs+        servant-client-js >=0.1 && <0.2   else     build-depends:         Shpadoinkle-backend-static       , servant-client >=0.16.0 && <0.18+      , servant-client-js >=0.1 && <0.2       , servant-server >=0.16 && <0.18       , wai >=3.2.2 && <3.3       , wai-app-static >=3.1.6 && <3.2
Shpadoinkle/Router.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE TypeOperators             #-}@@ -18,32 +19,34 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-}  --- | This module provides for Servant based routing for Shpadoinkle applications.--- The technique in use is standard for Servant. We have a GADT @Router@, and some--- type class inductive programming with class @HasRouter@. The @Router@ the term--- necissary for the runtime operation of single page application routing.+-- | This module provides for Servant-based routing for Shpadoinkle applications.+-- The technique in use is standard for Servant. We have a GADT 'Router' and some+-- type class inductive programming with class 'HasRouter'. The 'Router' the term+-- necessary for the runtime operation of single page application routing. -- -- State changes are tracked by the "popstate" event and an @MVar ()@. Ideally this is--- done the browser's native api's only, and not an @MVar@. However that approach is--- blocked by a but in GHCjs which is documented here https://stackoverflow.com/questions/59954787/cant-get-dispatchevent-to-fire-in-ghcjs.+-- done via the browser's native APIs only and not an 'MVar', however that approach is+-- blocked by a bug in GHCjs which is documented <https://stackoverflow.com/questions/59954787/cant-get-dispatchevent-to-fire-in-ghcjs here>.  -module Shpadoinkle.Router-    ( Raw, Redirect(..)-    , fromRouter-    , HasRouter(..)-    , HasLink(..)-    , Routed(..)-    , fullPageSPA+module Shpadoinkle.Router (+    -- * Classes+    HasRouter(..), Routed(..)+    -- * Types+    , Redirect(..), Router(..)+    -- * Shpadoinkle with SPA+    , fullPageSPAC, fullPageSPA+    -- * Navigation     , navigate-    , withHydration-    , toHydration+    -- * Rehydration+    , withHydration, toHydration+    -- * Re-Exports+    , Raw, MonadJSM, HasLink(..)     ) where   import           Control.Applicative import           Control.Compactable           as C-import           Control.Concurrent import           Control.Monad import           Control.Monad.IO.Class import           Data.Aeson@@ -54,7 +57,6 @@ import           Data.Text                     (Text) import qualified Data.Text                     as T import           Data.Text.Encoding            (decodeUtf8, encodeUtf8)-import           GHC.Conc import           GHC.TypeLits import           GHCJS.DOM import           GHCJS.DOM.EventM              (on)@@ -62,12 +64,16 @@ import           GHCJS.DOM.History import           GHCJS.DOM.Location            (getPathname, getSearch) import           GHCJS.DOM.PopStateEvent+import           GHCJS.DOM.Types               (JSM, MonadJSM, liftJSM) import           GHCJS.DOM.Window import           Language.Javascript.JSaddle   (fromJSVal, jsg) import           Servant.API                   hiding (uriPath, uriQuery) import           Servant.Links                 (Link, URI (..), linkURI,                                                 safeLink) import           System.IO.Unsafe+import           UnliftIO.Concurrent           (MVar, forkIO, newEmptyMVar,+                                                putMVar, takeMVar)+import           UnliftIO.STM                  (TVar, newTVarIO) import           Web.HttpApiData               (parseQueryParamMaybe,                                                 parseUrlPieceMaybe) @@ -82,6 +88,7 @@   RChoice      :: Router a -> Router a -> Router a   RCapture     :: FromHttpApiData x => (x -> Router a) -> Router a   RQueryParam  :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> (Maybe x -> Router a) -> Router a+  RQueryParamR :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> (x -> Router a) -> Router a   RQueryParams :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> ([x] -> Router a) -> Router a   RQueryFlag   :: KnownSymbol sym => Proxy sym -> (Bool -> Router a) -> Router a   RPath        :: KnownSymbol sym => Proxy sym -> Router a -> Router a@@ -103,10 +110,10 @@ {-# NOINLINE syncRoute #-}  --- | When using serverside rendering you may benefit from seeding the page with--- data. This function get an assumed global variable on the page called "initState"--- if it's found, we return that. Otherwise we use the provided (r -> m a) function--- to generate the init state for our app, based on the currout route. Typically+-- | When using server-side rendering you may benefit from seeding the page with+-- data. This function get an assumed global variable on the page called "initState".+-- If it's found, we return that, otherwise we use the provided @(r -> m a)@ function+-- to generate the init state for our app, based on the current route. Typically -- this is used on the client side. withHydration :: (MonadJSM m, FromJSON a) => (r -> m a) -> r -> m a withHydration s r = do@@ -115,13 +122,13 @@     Just fe -> return fe     _       -> s r --- | When using serverside rendering you may benefit from seeding the page with+-- | When using server-side rendering, you may benefit from seeding the page with -- data. This function returns a script tag that makes a global variable "initState" -- containing a JSON representation to be used as the initial state of the application -- on page load. Typically this is used on the server side. toHydration :: ToJSON a => a -> Html m b toHydration fe =-  h "script" [] [ text . decodeUtf8 . toStrict $ "window.initState = '" <> encode fe <> "'" ]+  h "script" [] [ text $ "window.initState = '" <> (T.replace "'" "\\'" . decodeUtf8 . toStrict $ encode fe) <> "'" ]   -- | Change the browser's URL to the canonical URL for a given route `r`.@@ -137,14 +144,17 @@       liftIO $ putMVar syncRoute ()  --- | This method wraps @shpadoinkle@ providing for a convenient entrypoint+-- | 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--- itself.-fullPageSPA :: forall layout b a r m+-- app components with a function to respond to route changes and the route mapping+-- itself. This flavor provides access to the full power of @Continuation@ in case you+-- need to handle in-flight updates.+fullPageSPAC :: forall layout b a r m    . HasRouter layout   => Backend b m a+  => Monad (b m)   => Eq a+  => Functor m   => (m ~> JSM)   -- ^ how do we get to JSM?   -> (TVar a -> b m ~> m)@@ -155,24 +165,54 @@   -- ^ how should the html look?   -> b m RawNode   -- ^ where do we render?-  -> (r -> a -> m a)+  -> (r -> m (Continuation m a))   -- ^ listen for route changes   -> layout :>> r   -- ^ how shall we relate urls to routes?   -> JSM ()-fullPageSPA toJSM backend i' view getStage onRoute routes = do+fullPageSPAC toJSM backend i' view getStage onRoute routes = do   let router = route @layout @r routes   window <- currentWindowUnchecked   getRoute window router $ \case     Nothing -> return ()     Just r -> do       i <- toJSM $ i' r-      model <- createTerritory i-      _ <- listenStateChange router $ writeUpdate model . (toJSM .) . onRoute+      model <- newTVarIO i+      _ <- listenStateChange router $ writeUpdate model . kleisli . const+           . (fmap (hoist toJSM) . toJSM) . onRoute       shpadoinkle toJSM backend i model view getStage       syncPoint  +-- | 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+-- itself.+fullPageSPA :: forall layout b a r m+   . HasRouter layout+  => Backend b m a+  => Monad (b m)+  => Eq a+  => Functor m+  => (m ~> JSM)+  -- ^ how do we get to JSM?+  -> (TVar a -> b m ~> m)+  -- ^ What backend are we running?+  -> (r -> m a)+  -- ^ what is the initial state?+  -> (a -> Html (b m) a)+  -- ^ how should the html look?+  -> b m RawNode+  -- ^ where do we render?+  -> (r -> m a)+  -- ^ listen for route changes+  -> layout :>> r+  -- ^ how shall we relate urls to routes?+  -> JSM ()+fullPageSPA a b c v g s = fullPageSPAC @layout a b c v g (fmap (pur . const) . s)+++ -- | ?foo=bar&baz=qux -> [("foo","bar"),("baz","qux")] parseQuery :: Text -> [(Text,Text)] parseQuery =  (=<<) toKVs . T.splitOn "&" . T.drop 1@@ -201,23 +241,18 @@   handle $ fromRouter query segs router  -forkJSM :: JSM () -> JSM ()-forkJSM a = void . liftIO . forkIO . runJSM a =<< askJSM-{-# INLINE forkJSM #-}-- listenStateChange   :: Router r -> (r -> JSM ()) -> JSM () listenStateChange router handle = do   w <- currentWindowUnchecked   _ <- on w popstate . liftIO $ putMVar syncRoute ()-  _ <- liftJSM . forkJSM . forever $ do+  _ <- forkIO . forever $ do     liftIO $ takeMVar syncRoute     getRoute w router $ maybe (return ()) handle   return ()  --- | Get an @r@ from a route and url context+-- | Get an @r@ from a route and URL context fromRouter :: [(Text,Text)] -> [Text] -> Router r -> Maybe r fromRouter queries segs = \case     RChoice x y        -> fromRouter queries segs x <|> fromRouter queries segs y@@ -228,6 +263,10 @@         case lookup (T.pack $ symbolVal sym) queries of             Nothing -> fromRouter queries segs $ f Nothing             Just t  -> fromRouter queries segs $ f (parseQueryParamMaybe t)+    RQueryParamR sym f ->+       case lookup (T.pack $ symbolVal sym) queries of+            Nothing -> Nothing+            Just t -> fromRouter queries segs =<< f <$> parseQueryParamMaybe t     RQueryParams sym f ->         fromRouter queries segs . f . compact $ parseQueryParamMaybe . snd <$> C.filter             (\(k, _) -> k == T.pack (symbolVal sym))@@ -241,11 +280,11 @@     RView a            -> if null segs then Just a else Nothing  --- | This type class traverses the Servant API, and sets up a function to+-- | This type class traverses the Servant API and sets up a function to -- build its term level representation. class HasRouter layout where-    -- | :>> (pronounced "routed as") should be surjective.-    -- As in one route can be the handler for more than one url.+    -- | ':>>' (pronounced "routed as") should be surjective,+    -- as in one route can be the handler for more than one URL.     type layout :>> route :: Type     route :: layout :>> route -> Router route @@ -278,6 +317,14 @@     route :: (Maybe x -> sub :>> r) -> Router r     route = RQueryParam (Proxy @sym) . (route @sub .)     {-# INLINABLE route #-}++instance (HasRouter sub, FromHttpApiData x, KnownSymbol sym)+   => HasRouter (QueryParam' '[Required] sym x :> sub) where++  type (QueryParam' '[Required] sym x :> sub) :>> a = x -> sub :>> a++  route :: (x -> sub :>> r) -> Router r+  route = RQueryParamR (Proxy @sym) . (route @sub .)  instance (HasRouter sub, FromHttpApiData x, KnownSymbol sym)     => HasRouter (QueryParams sym x :> sub) where
Shpadoinkle/Router/Client.hs view
@@ -1,37 +1,49 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE RankNTypes    #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeOperators     #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-type-defaults              #-} --- | Helper for querying the server from client side code, using a derived client.+-- | Helper for querying the server from client side code using a derived client. -- This module exists to save you from having to use CPP yourself.  module Shpadoinkle.Router.Client   ( runXHR-#ifdef ghcjs_HOST_OS-  , module Servant.Client.Ghcjs-#else-  , module Servant.Client-#endif+  , runXHR'+  , module Servant.Client.JS   ) where  +import           Control.Monad (join) import           Control.Monad.Catch-#ifdef ghcjs_HOST_OS-import           Servant.Client.Ghcjs-#else-import           Servant.Client-#endif+import           Data.Maybe+import           Data.Text+import           Language.Javascript.JSaddle hiding (JSM)+import           Servant.Client.JS+import           Text.Read+import           GHCJS.DOM.Types hiding (Text) import           UnliftIO -import           Shpadoinkle+default (Text)   -- | Run the ClientM from Servant as an XHR request.--- Raises an exception if evalued with GHC.-runXHR :: MonadIO m => MonadThrow m => (JSM a -> m a) -> ClientM a -> m a-#ifdef ghcjs_HOST_OS-runXHR f m = f $ either throwM pure =<< runClientM m-#else-runXHR = error "not supported for ghc"-#endif+runXHR :: ClientM a -> JSM a+runXHR m = do -- TODO cache the base url or make it optional+  loc <- jsg ("window" :: Text) >>= (! ("location" :: Text))+  protocol <- mapProtocol <$> (loc ! ("protocol" :: Text) >>= fromJSVal)+  hostname <- fromMaybe "localhost" <$> (loc ! ("hostname" :: Text) >>= fromJSVal)+  port <- fromMaybe (defaultPort protocol) . join . fmap readMaybe <$> (loc ! ("port" :: Text) >>= fromJSVal)+  runXHR' m . ClientEnv $ BaseUrl protocol hostname port ""+  where mapProtocol :: Maybe String -> Scheme+        mapProtocol (Just "https:") = Https+        mapProtocol _ = Http++        defaultPort :: Scheme -> Int+        defaultPort Https = 443+        defaultPort Http = 80++-- | 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
+ Shpadoinkle/Router/HTML.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+++{-|+  HTML is a Servant combinator for the "text/html" MIME type, equipped with instances+  for serving Shpadoinkle's 'Html' type.+-}+++module Shpadoinkle.Router.HTML (HTML) where+++#ifndef ghcjs_HOST_OS+++import qualified Data.ByteString.Lazy       as BSL+import qualified Data.List.NonEmpty         as NE+import           Data.Text.Encoding+import qualified Network.HTTP.Media         as M+import           Servant.API                (Accept (..), MimeRender (..))++import           Shpadoinkle+import           Shpadoinkle.Backend.Static (renderStatic)+++data HTML+++instance Accept HTML where+    contentTypes _ =+      "text" M.// "html" M./: ("charset", "utf-8") NE.:|+      ["text" M.// "html"]+++instance MimeRender HTML (Html m a) where+  mimeRender _ =  BSL.fromStrict . encodeUtf8 . renderStatic+++#else+++data HTML+++#endif
Shpadoinkle/Router/Server.hs view
@@ -15,8 +15,8 @@ -- | Since the single page application URIs are specified with Servant, we can automate much -- of the process of serving the application with server-side rendering. This module provides -- the basic infrastructure for serving rendered HTML using the same code that would be used--- to render the same route on the client-side. Ensuring a consistent rendering, whether a--- URI is accessed via a client-side popstate event, or via the initial page load.+-- to render the same route on the client-side, ensuring a consistent rendering, whether a+-- URI is accessed via a client-side popstate event or via the initial page load.   module Shpadoinkle.Router.Server where@@ -40,7 +40,7 @@ import           Shpadoinkle.Router  --- | Helper to serve a @ByteString@ as a file from the web application interface.+-- | Helper to serve a 'ByteString' as a file from the web application interface. toFile :: Piece -> ByteString -> File toFile p bs = File   { fileGetSize     = fromIntegral $ BS.length bs@@ -51,7 +51,7 @@   }  --- | Serve index.html generated from a Shpadoinkle view, using the static backend, otherwise serve out of a directory.+-- | Serve index.html generated from a Shpadoinkle view using the static backend, otherwise serve out of a directory. defaultSPAServerSettings   :: FilePath   -- ^ Directory to try files