rowdy-yesod (empty) → 0.0.1.0
raw patch · 8 files changed
+428/−0 lines, 8 filesdep +basedep +hspecdep +rowdysetup-changed
Dependencies added: base, hspec, rowdy, rowdy-yesod, yesod-core
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +19/−0
- Setup.hs +2/−0
- rowdy-yesod.cabal +59/−0
- src/Rowdy/Yesod.hs +153/−0
- src/Rowdy/Yesod/Internal.hs +160/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for rowdy++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Matt Parsons (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Matt Parsons nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,19 @@+# `rowdy-yesod`++An implementation of the `rowdy` web route DSL for the Yesod web framework.+Check the [GitHub repo](https://www.github.com/parsonsmatt/rowdy) for more+information and examples.++```haskell+routes = do+ get "RootR"+ "users" // do+ resource "UserIndexR" [get, post]+ capture @Int // resource "UserR" [get, put]+ "admin" // "Admin" /: do+ get "PanelR" ! "admin" ! "cool"+ post "PanelR" ! "admin"+ "other-attr" // "safe" /! do+ get "SafeR"+ put "SafeR"+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rowdy-yesod.cabal view
@@ -0,0 +1,59 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9d563ed5769651d2cdd6c0ad047d961c424e9a91a4826688362cb02679399f62++name: rowdy-yesod+version: 0.0.1.0+synopsis: An EDSL for web application routes.+description: Please see the README on Github at <https://github.com/parsonsmatt/rowdy#readme>+category: Web+homepage: https://github.com/parsonsmatt/rowdy#readme+bug-reports: https://github.com/parsonsmatt/rowdy/issues+author: Matt Parsons+maintainer: parsonsmatt@gmail.com+copyright: 2018 Matt Parsons+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/parsonsmatt/rowdy++library+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat+ build-depends:+ base >=4.7 && <5+ , rowdy+ , yesod-core+ exposed-modules:+ Rowdy.Yesod+ Rowdy.Yesod.Internal+ other-modules:+ Paths_rowdy_yesod+ default-language: Haskell2010++test-suite specs+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , hspec+ , rowdy+ , rowdy-yesod+ , yesod-core+ other-modules:+ Paths_rowdy_yesod+ default-language: Haskell2010
+ src/Rowdy/Yesod.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Use your Rowdy route definitions with Yesod web applications.+module Rowdy.Yesod+ ( module Rowdy.Yesod+ , (//)+ , (/:)+ , Endpoint(..)+ , PathPiece(..)+ , Type(..)+ , Verb(..)+ ) where++import Data.Foldable (traverse_)+import Data.Typeable (Proxy (..), Typeable)+import Yesod.Routes.TH.Types++import Rowdy+import Rowdy.Yesod.Internal++-- | Convert a 'RouteDsl' into a representation that Yesod can use.+--+-- @+-- mkYesod "App" $ toYesod $ do+-- get "RootR"+-- "users" // do+-- resource "UserIndex" [get, post]+-- -- etc...+-- @+--+-- GHC freaks out if you try to use a type defined in the same module as the+-- route. Ensure that all types you use in the route are defined in an imported+-- module.+--+-- @since 0.0.1.0+toYesod :: Dsl () -> [ResourceTree String]+toYesod = routeTreeToResourceTree . runRouteDsl++-- | We specialize the 'RouteDsl' type to this as a shorthand.+type Dsl = RouteDsl String PathPiece Endpoint++-- | We support the most common HTTP verbs. Each of 'get', 'put', 'post', and+-- 'delete' are given a @String@ that represents the resource they are acting+-- for. The generated route type uses that resource as a constructor. The+-- generated dispatcher expects to see functions with the lowercase verb as+-- a prefix to the resource name. As an example:+--+-- @+-- get "HelloR"+-- @+--+-- Will create a route type @HelloR@ and expect a handler @getHelloR@ to be+-- defined.+--+-- @since 0.0.1.0+get, put, post, delete :: String -> Dsl ()+get = doVerb Get+put = doVerb Put+post = doVerb Post+delete = doVerb Delete++-- | Create an endpoint with the given named resource and verb.+--+-- @since 0.0.1.0+doVerb :: Verb -> String -> Dsl ()+doVerb v s = terminal (MkResource v s)++-- | Create a subsite with the given @name@, @type@, and accessor function name+-- to get the underlying application.+--+-- @since 0.0.1.0+subsite :: String -> String -> String -> Dsl ()+subsite name thing func =+ terminal (MkSubsite name thing func)++-- | Capture a dynamic path piece and parse it as the provided type. This+-- function is intended to be used with the @TypeApplications@ language+-- extension.+--+-- @+-- "users" // do+-- resource "UserIndexR" [get, post]+-- capture @UserId $ do+-- resource "UserR" [get, put, delete]+-- "posts" // do+-- resource "PostR" [get, post]+-- @+--+-- @since 0.0.1.0+capture :: forall typ. Typeable typ => PathPiece+capture =+ captureP (Proxy @typ)++-- | A version of 'capture' that accepts an explicit 'Proxy' argument. Use this+-- if you don't like the @TypeApplications@ syntax, or have a proxy on hand+-- already.+--+-- @since 0.0.1.0+captureP :: forall typ. Typeable typ => Proxy typ -> PathPiece+captureP = Capture . Type++-- | Define a number of handlers for the named resource. The following code+-- block:+--+-- @+-- do 'get' "HelloR"+-- 'put' "HelloR"+-- 'post' "HelloR"+-- 'delete' "HelloR"+-- @+--+-- is equivalent to this shorter form:+--+-- @+-- 'resource' "HelloR" ['get', 'put', 'post', 'delete']+-- @+--+-- @since 0.0.1.0+resource :: String -> [String -> Dsl ()] -> Dsl ()+resource = traverse_ . flip id++-- | Attach a route attribute to every element in the given DSL.+--+-- @since 0.0.1.0+attr :: String -> Dsl () -> Dsl ()+attr = pathComponent . Attr++-- | An infix operator alias for 'attr'.+--+-- @+-- "admin" // "admin" /! do+-- 'resource' "AdminR" ['get', 'put', 'post']+-- @+--+-- @since 0.0.1.0+(/!) :: String -> Dsl () -> Dsl ()+(/!) = attr++infixr 8 /!++-- | Provide an inline attribute to the given route.+--+-- @+-- get "HelloR" ! "friendly"+-- @+(!) :: Dsl () -> String -> Dsl ()+(!) = flip attr++infixl 8 !
+ src/Rowdy/Yesod/Internal.hs view
@@ -0,0 +1,160 @@++{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | An internal module. Depend on this at your own risk -- breaking changes to+-- this module's interface will not be represented as a major version bump.+module Rowdy.Yesod.Internal where++import Data.Char (toUpper)+import Data.Either (isLeft, lefts, rights)+import Data.Maybe (isJust)+import Data.String (IsString (..))+import Data.Typeable (Proxy (..), Typeable, eqT, typeRep)+import Yesod.Routes.TH.Types++import Rowdy++-- | An endpoint in the Yesod model.+data Endpoint+ = MkResource Verb String+ -- ^ A resource identified by a 'Verb' and a 'String' name.+ | MkSubsite String String String+ -- ^ A subsite.+ deriving (Eq, Show)++-- | The type of things that can affect a path.+data PathPiece+ = Literal String+ -- ^ Static string literals.+ | Capture Type+ -- ^ Dynamic captures.+ | Attr String+ -- ^ Route attributes. Not technically part of the path, but applies to+ -- everything below it in the tree.+ deriving (Eq, Show)++instance IsString PathPiece where+ fromString = Literal++-- | A value containing a 'Proxy' of some Haskell type.+data Type where+ Type :: Typeable t => Proxy t -> Type++instance Show Type where+ show (Type prxy) = show (typeRep prxy)++instance Eq Type where+ Type (_ :: Proxy t0) == Type (_ :: Proxy t1) =+ isJust (eqT @t0 @t1)++-- | The HTTP verbs.+data Verb = Get | Put | Post | Delete+ deriving (Eq, Show)++-- | Render a verb as an uppercase string.+renderVerb :: Verb -> String+renderVerb = map toUpper . show++-- | Convert the Rowdy 'RouteTree' structure into one appropriate for the Yesod+-- routing functions.+routeTreeToResourceTree :: [RouteTree String PathPiece Endpoint] -> [ResourceTree String]+routeTreeToResourceTree =+ foldr (go []) []+ where+ go+ :: [Either String (Piece String)]+ -> RouteTree String PathPiece Endpoint+ -> [ResourceTree String]+ -> [ResourceTree String]+ go pcs (Nest str xs) acc =+ ResourceParent str True pieces (foldr (go attrs) [] xs) : acc+ where+ pieces = rights (reverse pcs)+ attrs = filter isLeft pcs+ go pcs (PathComponent pp rest) acc =+ go (convPiece pp : pcs) rest acc+ go pcs (Leaf term) (ResourceLeaf Resource {..} : acc)+ | listEq eqPieceStr (rights (reverse pcs)) resourcePieces+ , Methods multi methods <- resourceDispatch+ =+ flip (:) acc . ResourceLeaf $+ case term of+ MkResource v str ->+ Resource+ { resourceName = str+ , resourcePieces = rights (reverse pcs)+ , resourceDispatch =+ Methods+ { methodsMulti = multi+ , methodsMethods = renderVerb v : methods+ }+ , resourceAttrs =+ lefts pcs+ , resourceCheck =+ True+ }+ MkSubsite str typ func ->+ Resource+ { resourceName = str+ , resourcePieces = reverse (rights pcs)+ , resourceDispatch =+ Subsite+ { subsiteType = typ+ , subsiteFunc = func+ }+ , resourceAttrs =+ lefts pcs+ , resourceCheck =+ True+ }+ go pcs (Leaf term) acc =+ flip (:) acc . ResourceLeaf $+ case term of+ MkResource v str ->+ Resource+ { resourceName = str+ , resourcePieces = reverse (rights pcs)+ , resourceDispatch =+ Methods+ { methodsMulti = Nothing+ , methodsMethods = [renderVerb v]+ }+ , resourceAttrs =+ lefts pcs+ , resourceCheck =+ True+ }+ MkSubsite str typ func ->+ Resource+ { resourceName = str+ , resourcePieces = reverse (rights pcs)+ , resourceDispatch =+ Subsite+ { subsiteType = typ+ , subsiteFunc = func+ }+ , resourceAttrs =+ lefts pcs+ , resourceCheck =+ True+ }++ convPiece :: PathPiece -> Either String (Piece String)+ convPiece = \case+ Literal str -> Right (Static str)+ Capture (Type prxy) -> Right (Dynamic (show (typeRep prxy)))+ Attr attr -> Left attr++ listEq :: (a -> a -> Bool) -> [a] -> [a] -> Bool+ listEq f (x:xs) (y:ys) = f x y && listEq f xs ys+ listEq _ [] [] = True+ listEq _ _ _ = False++ eqPieceStr :: Piece String -> Piece String -> Bool+ eqPieceStr (Static s2) (Static s1) = s1 == s2+ eqPieceStr (Dynamic d0) (Dynamic d1) = d0 == d1+ eqPieceStr _ _ = False
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+