Shpadoinkle-router 0.2.0.0 → 0.2.0.1

raw patch · 6 files changed

+220/−116 lines, 6 filesdep +jsaddle-warpdep ~warpPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: jsaddle-warp

Dependency ranges changed: warp

API changes (from Hackage documentation)

Files

• README.md +5/−5
• Shpadoinkle-router.cabal +5/−5
• Shpadoinkle/Router.hs +147/−21
• Shpadoinkle/Router/Client.hs +23/−13
• Shpadoinkle/Router/HTML.hs +0/−47
• Shpadoinkle/Router/Server.hs +40/−25

@@ -24,10 +24,10 @@  ```haskell -- The accepted URIs-type SPA-  =            "echo" :> QueryParam "echo" Text :> Raw-  :<|> "v2" :> "echo" :> QueryParam "echo" Text :> Raw-  :<|> "home" :> Raw+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@@ -35,7 +35,7 @@   | Home  -- Surjection from URIs to routes-routes :: SPA :>> Route+routes :: SPA m :>> Route routes   =    REcho   :<|> REcho

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.32.0.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 1f447eca9bd32966123dd6a67d22331ec3365eaf01daa425e4da52100d935f37+-- hash: 287b71ef93760ce3e427d0d14f772ed6bee4c147edd12b6879f767ff727d2f7b  name:           Shpadoinkle-router-version:        0.2.0.0+version:        0.2.0.1 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@@ -28,7 +28,6 @@   exposed-modules:       Shpadoinkle.Router       Shpadoinkle.Router.Client-      Shpadoinkle.Router.HTML       Shpadoinkle.Router.Server   other-modules:       Paths_Shpadoinkle_router@@ -57,10 +56,11 @@   else     build-depends:         Shpadoinkle-backend-static+      , jsaddle-warp       , 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-      , warp >=3.2.28 && <3.3+      , warp >=3.2.28 && <3.4   default-language: Haskell2010

@@ -11,7 +11,6 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE TypeOperators             #-}@@ -33,9 +32,9 @@     -- * Classes     HasRouter(..), Routed(..)     -- * Types-    , Redirect(..), Router(..)+    , Redirect(..), Router(..), View, HTML     -- * Shpadoinkle with SPA-    , fullPageSPAC, fullPageSPA+    , fullPageSPAC, fullPageSPA, fullPageSPA'     -- * Navigation     , navigate     -- * Rehydration@@ -45,41 +44,75 @@     ) where  -import           Control.Applicative-import           Control.Compactable           as C-import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Aeson+import           Control.Applicative           (Alternative ((<|>)))+import           Control.Compactable           as C (Compactable (compact, filter))+import           Control.Monad                 (forever)+import           Control.Monad.IO.Class        (MonadIO (liftIO))+import           Data.Aeson                    (FromJSON, ToJSON, decode,+                                                encode) import           Data.ByteString.Lazy          (fromStrict, toStrict)-import           Data.Kind+import           Data.Kind                     (Type) import           Data.Maybe                    (isJust)-import           Data.Proxy+import           Data.Proxy                    (Proxy (..)) import           Data.Text                     (Text) import qualified Data.Text                     as T import           Data.Text.Encoding            (decodeUtf8, encodeUtf8)-import           GHC.TypeLits-import           GHCJS.DOM+import           GHC.TypeLits                  (KnownSymbol, Symbol, symbolVal)+import           GHCJS.DOM                     (currentWindowUnchecked,+                                                syncPoint) import           GHCJS.DOM.EventM              (on)-import           GHCJS.DOM.EventTargetClosures-import           GHCJS.DOM.History+import           GHCJS.DOM.EventTargetClosures (EventName, unsafeEventName)+import           GHCJS.DOM.History             (pushState) import           GHCJS.DOM.Location            (getPathname, getSearch)-import           GHCJS.DOM.PopStateEvent+import           GHCJS.DOM.PopStateEvent       (PopStateEvent) import           GHCJS.DOM.Types               (JSM, MonadJSM, liftJSM)-import           GHCJS.DOM.Window+import           GHCJS.DOM.Window              (Window, getHistory, getLocation) import           Language.Javascript.JSaddle   (fromJSVal, jsg)-import           Servant.API                   hiding (uriPath, uriQuery)+#ifndef ghcjs_HOST_OS+import           Servant.API                   (Accept (contentTypes), Capture,+                                                FromHttpApiData, HasLink (..),+                                                IsElem, MimeRender (..),+                                                QueryFlag, QueryParam,+                                                QueryParam', QueryParams, Raw,+                                                Required, type (:<|>) (..),+                                                type (:>))+#else+import           Servant.API                   (Capture, FromHttpApiData,+                                                HasLink (..), IsElem, QueryFlag,+                                                QueryParam, QueryParam',+                                                QueryParams, Raw, Required,+                                                type (:<|>) (..), type (:>))+#endif import           Servant.Links                 (Link, URI (..), linkURI,                                                 safeLink)-import           System.IO.Unsafe+import           System.IO.Unsafe              (unsafePerformIO) import           UnliftIO.Concurrent           (MVar, forkIO, newEmptyMVar,                                                 putMVar, takeMVar)-import           UnliftIO.STM                  (TVar, newTVarIO)+import           UnliftIO.STM                  (TVar, atomically, newTVarIO,+                                                writeTVar) import           Web.HttpApiData               (parseQueryParamMaybe,                                                 parseUrlPieceMaybe) -import           Shpadoinkle+import           Shpadoinkle                   (Backend, Continuation, Html,+                                                RawNode, h, hoist, kleisli, pur,+                                                shpadoinkle, text, type (~>),+                                                writeUpdate) +#ifndef ghcjs_HOST_OS ++import qualified Data.ByteString.Lazy          as BSL+import qualified Data.List.NonEmpty            as NE+import qualified Network.HTTP.Media            as M+import           Servant                       (Application, HasServer, Tagged)+import qualified Servant                       as S++import           Shpadoinkle.Backend.Static    (renderStatic)+++#endif++ default (Text)  @@ -122,6 +155,7 @@     Just fe -> return fe     _       -> s r + -- | 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@@ -212,7 +246,48 @@ fullPageSPA a b c v g s = fullPageSPAC @layout a b c v g (fmap (pur . const) . s)  +-- | 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.+{-# ANN fullPageSPA' ("HLint: ignore Reduce duplication" :: String) #-}+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?+  -> TVar a+  -- ^ where do we store the state?+  -> (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 (Continuation m a))+  -- ^ listen for route changes+  -> layout :>> r+  -- ^ how shall we relate urls to routes?+  -> JSM ()+fullPageSPA' toJSM backend model 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+      atomically $ writeTVar model i+      _ <- listenStateChange router $ writeUpdate model . kleisli . const+           . (fmap (hoist toJSM) . toJSM) . onRoute+      shpadoinkle toJSM backend i model view getStage+      syncPoint + -- | ?foo=bar&baz=qux -> [("foo","bar"),("baz","qux")] parseQuery :: Text -> [(Text,Text)] parseQuery =  (=<<) toKVs . T.splitOn "&" . T.drop 1@@ -249,6 +324,9 @@   _ <- forkIO . forever $ do     liftIO $ takeMVar syncRoute     getRoute w router $ maybe (return ()) handle+    syncPoint+    () <- liftIO $ return ()+    return ()   return ()  @@ -266,7 +344,7 @@     RQueryParamR sym f ->        case lookup (T.pack $ symbolVal sym) queries of             Nothing -> Nothing-            Just t -> fromRouter queries segs =<< f <$> parseQueryParamMaybe t+            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))@@ -360,3 +438,51 @@     route = RView     {-# INLINABLE route #-} +instance HasRouter (f '[HTML] (Html m b)) where+    type f '[HTML] (Html m b) :>> a = a++    route :: r -> Router r+    route = RView+    {-# INLINABLE route #-}++instance HasRouter (View m b) where+    type View m b :>> a = a++    route :: r -> Router r+    route = RView+    {-# INLINABLE route #-}+++#ifndef ghcjs_HOST_OS+++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+++instance HasServer (View m a) context where+  type ServerT (View m a) m' = Tagged m' Application+  route _                   = S.route          (Proxy @Raw)+  hoistServerWithContext _  = S.hoistServerWithContext (Proxy @Raw)+++#endif+++-- | A Mime type for rendering Html as "text/html"+data HTML :: Type+++-- | Servant terminal for Shpadoinkle views (recommended)+data View :: (Type -> Type) -> Type -> Type+++instance HasLink (View m a) where+  type MkLink (View m a) b = b+  toLink toA _ = toA

@@ -1,13 +1,14 @@ {-# 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. -- This module exists to save you from having to use CPP yourself. + module Shpadoinkle.Router.Client   ( runXHR   , runXHR'@@ -15,16 +16,24 @@   ) where  -import           Control.Monad (join)-import           Control.Monad.Catch-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           Control.Monad.Catch         (MonadThrow (throwM))+import           Data.Maybe                  (fromMaybe)+import           Data.Text                   (Text)+import           GHCJS.DOM.Types             (JSM)+import           Language.Javascript.JSaddle (FromJSVal (fromJSVal), jsg, (!))+import           Servant.Client.JS           (BaseUrl (..), ClientEnv (..),+                                              ClientError (..), ClientM (..),+                                              EmptyClient (..), HasClient (..),+                                              InvalidBaseUrlException, Response,+                                              ResponseF (..), Scheme (..),+                                              StreamingResponse, client,+                                              parseBaseUrl, runClientM,+                                              showBaseUrl,+                                              withStreamingRequestJSM)+import           Text.Read                   (readMaybe)+import           UnliftIO                    (MonadIO (liftIO)) + default (Text)  @@ -34,15 +43,16 @@   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)+  port <- fromMaybe (defaultPort protocol) . (readMaybe =<<) <$> (loc ! ("port" :: Text) >>= fromJSVal)   runXHR' m . ClientEnv $ BaseUrl protocol hostname port ""   where mapProtocol :: Maybe String -> Scheme         mapProtocol (Just "https:") = Https-        mapProtocol _ = Http+        mapProtocol _               = Http          defaultPort :: Scheme -> Int         defaultPort Https = 443-        defaultPort Http = 80+        defaultPort Http  = 80+  -- | Run the ClientM from Servant as an XHR request with a customized base URL. runXHR' :: ClientM a -> ClientEnv -> JSM a

@@ -1,47 +0,0 @@-{-# 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

@@ -25,19 +25,26 @@ #ifndef ghcjs_HOST_OS  -import           Data.ByteString.Lazy           as BS-import           Data.Text.Encoding-import           GHC.TypeLits-import           Network.Wai-import           Network.Wai.Application.Static+import           Data.ByteString.Lazy           as BS (ByteString, fromStrict,+                                                       length)+import           Data.Text.Encoding             (encodeUtf8)+import           GHC.TypeLits                   (Symbol)+import           Network.Wai                    (responseLBS)+import           Network.Wai.Application.Static (StaticSettings (ssLookupFile, ssMaxAge),+                                                 defaultWebAppSettings,+                                                 staticApp) import           Servant.API-import           Servant.Server-import           Servant.Server.StaticFiles-import           WaiAppStatic.Types+import           Servant.Server                 (HasServer (ServerT), Server,+                                                 Tagged (Tagged))+import           Servant.Server.StaticFiles     (serveDirectoryWith)+import           WaiAppStatic.Types             (File (..),+                                                 LookupResult (LRFile, LRNotFound),+                                                 MaxAge (MaxAgeSeconds), Piece,+                                                 toPieces) -import           Shpadoinkle-import           Shpadoinkle.Backend.Static-import           Shpadoinkle.Router+import           Shpadoinkle                    (Html)+import           Shpadoinkle.Backend.Static     (renderStatic)+import           Shpadoinkle.Router             (HasRouter (..), View)   -- | Helper to serve a 'ByteString' as a file from the web application interface.@@ -74,7 +81,7 @@   -- | Serve the UI by generating a Servant Server from the SPA URIs-class ServeRouter layout route where+class ServeRouter layout route m a where   serveUI     :: FilePath     -- ^ Where should we look for static assets?@@ -85,51 +92,59 @@     -> Server layout  -instance (ServeRouter x r, ServeRouter y r)-  => ServeRouter (x :<|> y) r where+instance (ServeRouter x r m a, ServeRouter y r m a)+  => ServeRouter (x :<|> y) r m a where    serveUI :: FilePath -> (r -> IO (Html m a)) -> (x :<|> y) :>> r -> Server (x :<|> y)   serveUI root view (x :<|> y) = serveUI @x root view x :<|> serveUI @y root view y   {-# INLINABLE serveUI #-} -instance ServeRouter sub r-  => ServeRouter (Capture sym x :> sub) r where+instance ServeRouter sub r m a+  => ServeRouter (Capture sym x :> sub) r m a where    serveUI :: FilePath -> (r -> IO (Html m a)) -> (x -> sub :>> r) -> Server (Capture sym x :> sub)   serveUI root view = (serveUI @sub root view .)   {-# INLINABLE serveUI #-} -instance ServeRouter sub r-  => ServeRouter (QueryParam sym x :> sub) r where+instance ServeRouter sub r m a+  => ServeRouter (QueryParam sym x :> sub) r m a where    serveUI :: FilePath -> (r -> IO (Html m a)) -> (Maybe x -> sub :>> r) -> Server (QueryParam sym x :> sub)   serveUI root view = (serveUI @sub root view .)   {-# INLINABLE serveUI #-} -instance ServeRouter sub r-  => ServeRouter (QueryParams sym x :> sub) r where+instance ServeRouter sub r m a+  => ServeRouter (QueryParams sym x :> sub) r m a where    serveUI :: FilePath -> (r -> IO (Html m a)) -> ([x] -> sub :>> r) -> Server (QueryParams sym x :> sub)   serveUI root view = (serveUI @sub root view .)   {-# INLINABLE serveUI #-} -instance ServeRouter sub r-  => ServeRouter (QueryFlag sym :> sub) r where+instance ServeRouter sub r m a+  => ServeRouter (QueryFlag sym :> sub) r m a where    serveUI :: FilePath -> (r -> IO (Html m a)) -> (Bool -> sub :>> r) -> Server (QueryFlag sym :> sub)   serveUI root view = (serveUI @sub root view .)   {-# INLINABLE serveUI #-} -instance ServeRouter sub r-  => ServeRouter ((path :: Symbol) :> sub) r where+instance ServeRouter sub r m a+  => ServeRouter ((path :: Symbol) :> sub) r m a where    serveUI :: FilePath -> (r -> IO (Html m a)) -> (path :> sub) :>> r -> Server (path :> sub)   serveUI = serveUI @sub   {-# INLINABLE serveUI #-} -instance ServeRouter Raw r where+instance ServeRouter Raw r m a where   serveUI :: FilePath -> (r -> IO (Html m a)) -> Raw :>> r -> Server Raw   serveUI root view = serveDirectoryWith . defaultSPAServerSettings root . view   {-# INLINABLE serveUI #-} +instance ServeRouter (View n b) r m a where+  serveUI :: FilePath -> (r -> IO (Html m a)) -> View n b :>> r -> Server (View n b)+  serveUI root view = serveDirectoryWithSpa . defaultSPAServerSettings root . view+  {-# INLINABLE serveUI #-}+++serveDirectoryWithSpa :: StaticSettings -> ServerT (View m a) n+serveDirectoryWithSpa = Tagged . staticApp #endif