diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -0,0 +1,6 @@ +# Todo + +* proper handling of non-routable paths (current error message isn't suitable for production) +* use generics to generate list of routable paths +* better support/documentation for customising path rendering +* tests diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,9 @@ +2014-05-06 0.2.0.0 + +* Document functions properly +* pass if routing fails +* Fix haddocks & improve tutorial + +2014-05-03 0.1.0.0 + +* Initial release. diff --git a/snap-web-routes.cabal b/snap-web-routes.cabal --- a/snap-web-routes.cabal +++ b/snap-web-routes.cabal @@ -1,8 +1,16 @@ name: snap-web-routes -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Type safe URLs for Snap -description: Type safe URL generation and routing for Snap using web-routes -homepage: http://github.com/lukerandall/snap-web-routes +description: + Type safe URL generation and routing for Snap using web-routes. + . + To get started, run through the tutorial in Snap.Web.Routes. + . + This builds on + done by Jeremy Shaw. Thanks Jeremy! + +homepage: https://github.com/lukerandall/snap-web-routes +bug-reports: https://github.com/lukerandall/snap-web-routes/issues license: BSD3 license-file: LICENSE author: Luke Randall @@ -14,6 +22,8 @@ extra-source-files: LICENSE, README.md + TODO.md + changelog library hs-source-dirs: src @@ -21,6 +31,7 @@ exposed-modules: Snap.Web.Routes Snap.Web.Routes.Heist + Snap.Web.Routes.Types build-depends: base >= 4.4 && < 5, @@ -33,3 +44,7 @@ xmlhtml >= 0.1 default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/lukerandall/snap-web-routes.git diff --git a/src/Snap/Web/Routes.hs b/src/Snap/Web/Routes.hs --- a/src/Snap/Web/Routes.hs +++ b/src/Snap/Web/Routes.hs @@ -1,129 +1,174 @@ -{-| - -This module provides a ready to use implementation of `web-routes` for Snap. - -To get going, you'll need to add a few things to `Application.hs`. - -> {-# LANGUAGE DeriveGeneric #-} -> {-# LANGUAGE FlexibleInstances #-} -> {-# LANGUAGE TypeFamilies #-} - -DeriveGeneric is used to derive the `PathInfo` instance for your URL data type, -the rest are needed by `web-routes`. - -> import Data.Text (Text) -> import Snap.Web.Routes - -"Snap.Web.Routes" exports the data types needed to define your `PathInfo` and -`MonadRoute` instances below. - -> data AppUrl -> = Count Int -> | Echo Text -> | Paths [Text] -> deriving (Generic) - -Define your application's URL data type. Deriving a `Generic` instance gives -you a `PathInfo` instance for free. - -> data App = App -> { _routeFn :: AppUrl -> [(Text, Maybe Text)] -> Text -> } - -Extend your App type to include a routing function. - -> instance PathInfo AppUrl - -Get your free PathInfo instance. Alternatives are to use `web-routes-th` or -implement PathInfo yourself. - -> instance MonadRoute (Handler App App) where -> type URL (Handler App App) = AppUrl -> askRouteFn = gets _routeFn - -Define your MonadRoute instance. In particular, `type URL (Handler App App)` -must be set to your URL data type defined above and `askRouteFn` should point -to the routing function you added to your App type. - -Moving on to `Site.hs`. - -> import Snap.Web.Routes - -Snap.Web.Routes provides a convenience router function you'll need. - -> routes :: [(ByteString, Handler App App ())] -> routes = [ ("", serveDirectory "static") -> , ("", routeWith routeAppUrl) -> ] - -Add your routes to the bottom of the routes list using routeWith. - -> routeAppUrl :: AppUrl -> Handler App App () -> routeAppUrl appUrl = -> case appUrl of -> (Count n) -> writeText $ ("Count = " `T.append` (T.pack $ show n)) -> (Echo text) -> echo text -> (Paths ps) -> writeText $ T.intercalate " " ps - -> echo :: T.Text -> Handler App App () -> echo msg = heistLocal (bindString "message" msg) $ render "echo" - -Define the handler for each data constructor in your URL data type. - -> app :: SnapletInit App App -> app = makeSnaplet "app" "An example application with snap-web-routes." Nothing $ do -> addRoutes routes -> return $ App renderRoute - -Lastly, add the routing function to your app. If you prefixed the routes in routeWith: - -> , ("/prefix", routeWith routeAppUrl) - -then use `renderRouteWithPrefix` instead: - -> return . App $ renderRouteWithPrefix "/prefix" - -|-} - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +-- | +-- This module provides a ready to use implementation of `web-routes` for Snap. +-- +-- The tutorial assumes you have a standard Snap app with an Application.hs and +-- Site.hs. +-- +-- To get going, you'll need to add a few things to Application.hs +-- +-- @ +-- -- Enable a few extensions +-- +-- \-\- Needed to derive a generic instance for our URL data type +-- \{\-\# LANGUAGE DeriveGeneric \#\-\} +-- +-- \-\- Needed by web-routes +-- \{\-\# LANGUAGE FlexibleInstances \#\-\} +-- \{\-\# LANGUAGE TypeFamilies \#\-\} +-- +-- \-\- Paths and params are of type Text. +-- import Data.Text (Text) +-- +-- \-\- Snap.Web.Routes.Types exports everything you need to +-- \-\- define your PathInfo and MonadRoute instances. +-- import Snap.Web.Routes.Types +-- +-- \-\- Your URL data type. Deriving a `Generic` instance gives +-- \-\- you a `PathInfo` instance for free. +-- data AppUrl +-- = Count Int +-- | Echo Text +-- | Paths [Text] +-- deriving (Generic) +-- +-- \-\- Extend your App type to include a routing function. +-- data App = App +-- { _routeFn :: AppUrl -> [(Text, Maybe Text)] -> Text +-- } +-- +-- \-\- Thanks to the wonders of Generic, an empty instance +-- \-\- definition is all we need. Alternately, you can implement +-- \-\- toPathSegments and fromPathSegments yourself or use +-- \-\- web-routes-th. +-- instance PathInfo AppUrl +-- +-- \-\- Set URL (Handler App App) to your URL data type defined above +-- \-\- and askRouteFn must point to the routing function you added to +-- \-\- your App. +-- instance MonadRoute (Handler App App) where +-- type URL (Handler App App) = AppUrl +-- askRouteFn = gets _routeFn +-- @ +-- +-- Moving on to Site.hs. +-- +-- @ +-- \-\- Snap.Web.Routes provides routing functions +-- import Snap.Web.Routes +-- +-- \-\- Add your new routes using routeWith +-- routes :: [(ByteString, Handler App App ())] +-- routes = [ ("", routeWith routeAppUrl) +-- , ("", serveDirectory "static") +-- ] +-- +-- \-\- Define handlers for each data constructor in your URL data type. +-- routeAppUrl :: AppUrl -> Handler App App () +-- routeAppUrl appUrl = +-- case appUrl of +-- (Count n) -> writeText $ ("Count = " `T.append` (T.pack $ show n)) +-- (Echo text) -> echo text +-- (Paths ps) -> writeText $ T.intercalate " " ps +-- +-- \-\- You'll note that these are normal Snap handlers, except they can take +-- \-\- values from the data constructor as arguments. This is a lot nicer than +-- \-\- having to use getParam. +-- echo :: T.Text -> Handler App App () +-- echo msg = heistLocal (bindString "message" msg) $ render "echo" +-- +-- \-\- Add the routing function to your app. +-- app :: SnapletInit App App +-- app = makeSnaplet "app" "An example snap-web-routes app." Nothing $ do +-- addRoutes routes +-- return $ App renderRoute +-- @ +-- +-- If you prefixed the routes in routeWith +-- +-- > ("/prefix", routeWith routeAppUrl) +-- +-- then use `renderRouteWithPrefix` instead: +-- +-- > return . App $ renderRouteWithPrefix "/prefix" +-- +-- If you are having trouble figuring out why a particular request isn't routing +-- as expected, try replacing 'routeWith' with 'routeWithDebug'. It'll display +-- the available routes, as well as any failed route parses. Just remember that +-- it's not suitable for production use. + + module Snap.Web.Routes - ( renderRoute + ( routeWith + , routeWithDebug + , renderRoute , renderRouteWithPrefix - , routeWith , heistUrl - , gets - , Generic - , MonadRoute(..) - , PathInfo(..) ) where import Control.Monad.State (lift, gets) import Data.Text (Text, append, pack) import Heist (HeistT) import Snap.Core -import Snap.Web.Routes.Heist import Snap.Snaplet +import Snap.Web.Routes.Heist import Web.Routes -instance (MonadRoute m) => MonadRoute (HeistT n m) where - type URL (HeistT n m) = URL m - askRouteFn = lift askRouteFn +------------------------------------------------------------------------------ +-- | Given a routing function, routes matching requests or calls +-- 'Snap.Core.pass'. +routeWith :: (PathInfo url, MonadSnap m) => + (url -> m ()) -- ^ routing function + -> m () +routeWith = flip routeWithOr $ const pass -routeWith :: (PathInfo url, MonadSnap m) => (url -> m ()) -> m () -routeWith router = +------------------------------------------------------------------------------ +-- | Given a routing function, routes matching requests or returns debugging +-- information. This is __not suitable for production__, but can be useful in +-- seeing what paths are available or determining why a path isn't routing as +-- expected. +routeWithDebug :: (PathInfo url, MonadSnap m) => + (url -> m ()) -- ^ routing function + -> m () +routeWithDebug = flip routeWithOr (\err -> writeText err) + + +------------------------------------------------------------------------------ +routeWithOr + :: (PathInfo url, MonadSnap m) => (url -> m ()) -> (Text -> m ()) -> m () +routeWithOr router onLeft = do rq <- getRequest case fromPathInfo $ rqPathInfo rq of - (Left e) -> writeText (pack e) + (Left e) -> onLeft . pack $ e (Right url) -> router url -renderRoute :: PathInfo url => url -> [(Text, Maybe Text)] -> Text +------------------------------------------------------------------------------ +-- | Turn a route and params into a path. +renderRoute :: PathInfo url => + url -- ^ URL data constructor + -> [(Text, Maybe Text)] -- ^ parameters + -> Text -- ^ rendered route renderRoute = renderRouteWithPrefix "" -renderRouteWithPrefix :: PathInfo url => Text -> url -> [(Text, Maybe Text)] -> Text -renderRouteWithPrefix prefix url params = prefix `append` toPathInfoParams url params +------------------------------------------------------------------------------ +-- | Turn a route and params into a path with the given prefix. +renderRouteWithPrefix + :: PathInfo url => + Text -- ^ route prefix + -> url -- ^ URL data constructor + -> [(Text, Maybe Text)] -- ^ parameters + -> Text -- ^ rendered route +renderRouteWithPrefix p u params = p `append` toPathInfoParams u params + + +------------------------------------------------------------------------------ +-- | MonadRoute instance for 'HeistT'. +instance (MonadRoute m) => MonadRoute (HeistT n m) where + type URL (HeistT n m) = URL m + askRouteFn = lift askRouteFn diff --git a/src/Snap/Web/Routes/Heist.hs b/src/Snap/Web/Routes/Heist.hs --- a/src/Snap/Web/Routes/Heist.hs +++ b/src/Snap/Web/Routes/Heist.hs @@ -5,7 +5,8 @@ import Text.XmlHtml hiding (render) import Web.Routes - +------------------------------------------------------------------------------ +-- | Render a url as a `Heist` splice. heistUrl :: MonadRoute m => URL m -> m [Node] heistUrl u = do t <- showURL u diff --git a/src/Snap/Web/Routes/Types.hs b/src/Snap/Web/Routes/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Web/Routes/Types.hs @@ -0,0 +1,10 @@ +module Snap.Web.Routes.Types + ( gets + , Generic + , MonadRoute(..) + , PathInfo(..) + ) where + +import Control.Monad.State (gets) +import Snap.Core +import Web.Routes