Merge pull request #178 from dmjio/routing

Initial commit of routing example

README.md

@@ -30,7 +30,7 @@
   </a>
 </p>
 
-**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

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/
     '';
   };

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
+

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 ()

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

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,15 +45,15 @@ 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
 
 -- | 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

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