From 894d1512d59ce78cc5430d55fcd5d2cd21d99b91 Mon Sep 17 00:00:00 2001 From: David Johnson Date: Mon, 10 Jul 2017 00:16:57 -0700 Subject: [PATCH] Initial commit of routing example --- README.md | 5 +- default.nix | 3 +- examples/router/Main.hs | 80 ++++++++++++++++++++++++++ ghcjs-src/Miso.hs | 4 +- ghcjs-src/Miso/Router.hs | 2 +- ghcjs-src/Miso/Subscription/History.hs | 38 ++++++++---- miso.cabal | 17 ++++++ 7 files changed, 134 insertions(+), 15 deletions(-) create mode 100644 examples/router/Main.hs diff --git a/README.md b/README.md index fcc44af6..708e5047 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,7 @@

-**Miso** is a small "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework featuring a virtual-dom, diffing / patching algorithm, event delegation, event batching, SVG, Server-sent events, Websockets, and an extensible Subscription-based subsystem. Inspired by [Elm](http://elm-lang.org/), [Redux](http://redux.js.org/) and [Bobril](http://github.com/bobris/bobril). `IO` and other effects (like `XHR`) can be introduced into the system via the `Effect` data type. Miso makes heavy use of the [GHCJS](https://github.com/ghcjs/ghcjs) FFI and therefore has minimal dependencies. +**Miso** is a small "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework featuring a virtual-dom, diffing / patching algorithm, event delegation, event batching, SVG, Server-sent events, Websockets, type-safe [servant](https://haskell-servant.github.io/)-style routing and an extensible Subscription-based subsystem. Inspired by [Elm](http://elm-lang.org/), [Redux](http://redux.js.org/) and [Bobril](http://github.com/bobris/bobril). `IO` and other effects (like `XHR`) can be introduced into the system via the `Effect` data type. Miso makes heavy use of the [GHCJS](https://github.com/ghcjs/ghcjs) FFI and therefore has minimal dependencies. ## Examples - TodoMVC @@ -42,6 +42,9 @@ - Websocket - [Link](https://websocket.haskell-miso.org/) - [Source](https://github.com/dmjio/miso/blob/master/examples/websocket/Main.hs) + - Router + - [Link](https://router.haskell-miso.org/) + - [Source](https://github.com/dmjio/miso/blob/master/examples/router/Main.hs) - SVG - [Link](https://svg.haskell-miso.org/) - Simple diff --git a/default.nix b/default.nix index 12323595..714f8dbd 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ let inherit (nixpkgs) phantomjs2 closurecompiler; miso-ghc = ghc802.callPackage ./miso-ghc.nix { }; miso-ghcjs = (ghcjs.callPackage ./miso-ghcjs.nix { }).overrideDerivation (drv: { - doCheck = tests; + doCheck = tests && !isDarwin; doHaddock = haddock; postInstall = '' mkdir -p $out/bin/mario.jsexe/imgs @@ -31,6 +31,7 @@ let ${nixpkgs.s3cmd}/bin/s3cmd sync --recursive ${result.miso-ghcjs}/bin/mario.jsexe/ s3://aws-website-mario-5u38b/ ${nixpkgs.s3cmd}/bin/s3cmd sync --recursive ${result.miso-ghcjs}/bin/todo-mvc.jsexe/ s3://aws-website-todo-mvc-hs61i/ ${nixpkgs.s3cmd}/bin/s3cmd sync --recursive ${result.miso-ghcjs}/bin/websocket.jsexe/ s3://aws-website-websocket-0gx34/ + ${nixpkgs.s3cmd}/bin/s3cmd sync --recursive ${result.miso-ghcjs}/bin/router.jsexe/ s3://aws-website-router-gfy22/ ${nixpkgs.s3cmd}/bin/s3cmd sync --recursive ${result.miso-ghcjs}/share/doc/x86_64-osx-ghcjs-0.2.0-ghc7_10_3/*/html/ s3://aws-website-miso-ghcjs-1yv32/ ''; }; diff --git a/examples/router/Main.hs b/examples/router/Main.hs new file mode 100644 index 00000000..42b22c4f --- /dev/null +++ b/examples/router/Main.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + +import Data.Proxy +import Servant.API + +import Miso + +-- | Model +data Model + = Model + { uri :: URI + -- ^ current URI of application + } deriving (Eq, Show) + +-- | Action +data Action + = HandleURI URI + | ChangeURI URI + | NoOp + deriving (Show, Eq) + +-- | Main entry point +main :: IO () +main = do + currentRoute <- getURI + startApp App { model = Model currentRoute, ..} + where + update = updateModel + events = defaultEvents + subs = [ uriSub HandleURI ] + view = viewModel + +-- | Update your model +updateModel :: Action -> Model -> Effect Model Action +updateModel (HandleURI u) m = m { uri = u } <# do + pure NoOp +updateModel (ChangeURI u) m = m <# do + pushURI u + pure NoOp +updateModel _ m = noEff m + +-- | View function, with routing +viewModel :: Model -> View Action +viewModel Model {..} = + case runRoute uri (Proxy :: Proxy API) handlers of + Left _ -> the404 + Right v -> v + where + handlers = about :<|> home + home = div_ [] [ + div_ [] [ text "home" ] + , button_ [ onClick goAbout ] [ text "go about" ] + ] + about = div_ [] [ + div_ [] [ text "about" ] + , button_ [ onClick goHome ] [ text "go home" ] + ] + the404 = div_ [] [ + text "the 404 :(" + , button_ [ onClick goHome ] [ text "go home" ] + ] + +-- | Type-level routes +type API = About :<|> Home +type Home = View Action +type About = "about" :> View Action + +-- | Type-safe links used in `onClick` event handlers to route the application +goAbout, goHome :: Action +(goHome, goAbout) = (goto api home, goto api about) + where + goto a b = ChangeURI (safeLink a b) + home = Proxy :: Proxy Home + about = Proxy :: Proxy About + api = Proxy :: Proxy API + diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs index 44dfb2fd..7feb2267 100644 --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -19,6 +19,7 @@ module Miso , module Miso.Html , module Miso.Subscription , module Miso.Types + , module Miso.Router ) where import Control.Concurrent @@ -30,13 +31,14 @@ import qualified Data.Sequence as S import JavaScript.Web.AnimationFrame import Miso.Concurrent +import Miso.Delegate import Miso.Diff import Miso.Effect import Miso.Event import Miso.Html +import Miso.Router import Miso.Subscription import Miso.Types -import Miso.Delegate -- | Runs a miso application startApp :: Eq model => App model action -> IO () diff --git a/ghcjs-src/Miso/Router.hs b/ghcjs-src/Miso/Router.hs index 7f499185..d2b6f374 100644 --- a/ghcjs-src/Miso/Router.hs +++ b/ghcjs-src/Miso/Router.hs @@ -18,7 +18,7 @@ -- Stability : experimental -- Portability : non-portable ---------------------------------------------------------------------------- -module Miso.Router where +module Miso.Router ( runRoute, RoutingError(..) ) where import qualified Data.ByteString.Char8 as BS import Data.Proxy diff --git a/ghcjs-src/Miso/Subscription/History.hs b/ghcjs-src/Miso/Subscription/History.hs index 6d6159ea..4a25a284 100644 --- a/ghcjs-src/Miso/Subscription/History.hs +++ b/ghcjs-src/Miso/Subscription/History.hs @@ -20,12 +20,17 @@ module Miso.Subscription.History , forward , go , uriSub + , URI (..) ) where -import Miso.String +import Control.Concurrent +import Control.Monad import GHCJS.Foreign.Callback -import Network.URI hiding (path) -import Miso.Html.Internal ( Sub ) +import Miso.Concurrent +import Miso.Html.Internal ( Sub ) +import Miso.String +import Network.URI hiding (path) +import System.IO.Unsafe -- | Retrieves current URI of page getURI :: IO URI @@ -40,7 +45,7 @@ getURI = do -- | Pushes a new URI onto the History stack pushURI :: URI -> IO () {-# INLINE pushURI #-} -pushURI uri = pushStateNoModel uri { uriPath = path } +pushURI uri = pushStateNoModel uri { uriPath = path } >> notify chan where path | uriPath uri == mempty = "/" | otherwise = uriPath uri @@ -48,7 +53,7 @@ pushURI uri = pushStateNoModel uri { uriPath = path } -- | Replaces current URI on stack replaceURI :: URI -> IO () {-# INLINE replaceURI #-} -replaceURI uri = replaceTo' uri { uriPath = path } +replaceURI uri = replaceTo' uri { uriPath = path } >> notify chan where path | uriPath uri == mempty = "/" | otherwise = uriPath uri @@ -66,14 +71,21 @@ forward = forward' -- | Jumps to a specific position in history go :: Int -> IO () {-# INLINE go #-} -go = go' +go n = go' n + +chan :: Notify +{-# NOINLINE chan #-} +chan = unsafePerformIO newNotify -- | Subscription for `popState` events, from the History API uriSub :: (URI -> action) -> Sub action model -uriSub = \f _ sink -> +uriSub = \f _ sink -> do + void.forkIO.forever $ do + wait chan >> do + sink =<< f <$> getURI onPopState =<< do - ps <- f <$> getURI - asyncCallback $ sink ps + asyncCallback $ do + sink =<< f <$> getURI foreign import javascript unsafe "window.history.go($1);" go' :: Int -> IO () @@ -101,8 +113,12 @@ foreign import javascript unsafe "window.history.replaceState(null, null, $1);" pushStateNoModel :: URI -> IO () {-# INLINE pushStateNoModel #-} -pushStateNoModel = pushStateNoModel' . pack . show +pushStateNoModel u = do + pushStateNoModel' . pack . show $ u + notify chan replaceTo' :: URI -> IO () {-# INLINE replaceTo' #-} -replaceTo' = replaceState' . pack . show +replaceTo' u = do + replaceState' . pack . show $ u + notify chan diff --git a/miso.cabal b/miso.cabal index 24152f8e..b78800cd 100644 --- a/miso.cabal +++ b/miso.cabal @@ -53,6 +53,23 @@ executable todo-mvc default-language: Haskell2010 +executable router + main-is: + Main.hs + if !impl(ghcjs) || !flag(examples) + buildable: False + else + hs-source-dirs: + examples/router + build-depends: + aeson, + base < 5, + containers, + miso, + servant + default-language: + Haskell2010 + executable websocket main-is: Main.hs