diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for rowdy + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/rowdy-yesod.cabal b/rowdy-yesod.cabal new file mode 100644 --- /dev/null +++ b/rowdy-yesod.cabal @@ -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 +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 diff --git a/src/Rowdy/Yesod.hs b/src/Rowdy/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/Rowdy/Yesod.hs @@ -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 ! diff --git a/src/Rowdy/Yesod/Internal.hs b/src/Rowdy/Yesod/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rowdy/Yesod/Internal.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +