diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/Shpadoinkle-router.cabal b/Shpadoinkle-router.cabal --- a/Shpadoinkle-router.cabal +++ b/Shpadoinkle-router.cabal @@ -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 diff --git a/Shpadoinkle/Router.hs b/Shpadoinkle/Router.hs --- a/Shpadoinkle/Router.hs +++ b/Shpadoinkle/Router.hs @@ -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 diff --git a/Shpadoinkle/Router/Client.hs b/Shpadoinkle/Router/Client.hs --- a/Shpadoinkle/Router/Client.hs +++ b/Shpadoinkle/Router/Client.hs @@ -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 diff --git a/Shpadoinkle/Router/HTML.hs b/Shpadoinkle/Router/HTML.hs deleted file mode 100644 --- a/Shpadoinkle/Router/HTML.hs +++ /dev/null @@ -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 diff --git a/Shpadoinkle/Router/Server.hs b/Shpadoinkle/Router/Server.hs --- a/Shpadoinkle/Router/Server.hs +++ b/Shpadoinkle/Router/Server.hs @@ -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