├── .editorconfig ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── .travis.yml ├── README.md ├── cabal.project ├── examples ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml └── src │ ├── ExampleServant.hs │ └── ExampleYesod.hs ├── rowdy-servant ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── package.yaml ├── src │ └── Rowdy │ │ └── Servant.hs └── test │ └── Spec.hs ├── rowdy-yesod ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── package.yaml ├── rowdy-yesod.cabal ├── src │ └── Rowdy │ │ ├── Yesod.hs │ │ └── Yesod │ │ └── Internal.hs └── test │ ├── Rowdy │ └── YesodSpec.hs │ └── Spec.hs ├── rowdy ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── package.yaml ├── src │ └── Rowdy.hs └── test │ └── Spec.hs ├── stack.yaml └── stack.yaml.lock /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | root = true 3 | 4 | [Makefile] 5 | indent_style = tabs 6 | indent_size = 8 7 | end_of_line = lf 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | 12 | [*.{hs,md}] 13 | indent_style = space 14 | indent_size = 4 15 | end_of_line = lf 16 | charset = utf-8 17 | trim_trailing_whitespace = true 18 | insert_final_newline = true 19 | max_line_length = 80 20 | 21 | [*.yml] 22 | indent_style = space 23 | indent_size = 2 24 | end_of_line = lf 25 | charset = utf-8 26 | trim_trailing_whitespace = true 27 | insert_final_newline = true 28 | max_line_length = 80 29 | 30 | 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.cabal 3 | *~ 4 | dist-newstyle 5 | 6 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Specify additional command line arguments 10 | # 11 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 12 | 13 | 14 | # Control which extensions/flags/modules/functions can be used 15 | # 16 | # - extensions: 17 | # - default: false # all extension are banned by default 18 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 19 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 20 | # 21 | # - flags: 22 | # - {name: -w, within: []} # -w is allowed nowhere 23 | # 24 | # - modules: 25 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 26 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 27 | # 28 | # - functions: 29 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 30 | 31 | 32 | # Add custom hints for this project 33 | # 34 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 35 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 36 | 37 | 38 | # Turn on hints that are off by default 39 | # 40 | # Ban "module X(module X) where", to require a real export list 41 | # - warn: {name: Use explicit module export list} 42 | # 43 | # Replace a $ b $ c with a . b $ c 44 | # - group: {name: dollar, enabled: true} 45 | # 46 | # Generalise map to fmap, ++ to <> 47 | # - group: {name: generalise, enabled: true} 48 | 49 | 50 | # Ignore some builtin hints 51 | # - ignore: {name: Use let} 52 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 53 | 54 | 55 | # Define some custom infix operators 56 | # - fixity: infixr 3 ~^#^~ 57 | 58 | 59 | # To generate a suitable file for HLint do: 60 | # $ hlint --default > .hlint.yaml 61 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: global 43 | 44 | # The following options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Right-pad the module names to align imports in a group: 68 | # 69 | # - true: a little more readable 70 | # 71 | # > import qualified Data.List as List (concat, foldl, foldr, 72 | # > init, last, length) 73 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # 76 | # - false: diff-safe 77 | # 78 | # > import qualified Data.List as List (concat, foldl, foldr, init, 79 | # > last, length) 80 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 81 | # > init, last, length) 82 | # 83 | # Default: true 84 | pad_module_names: true 85 | 86 | # Long list align style takes effect when import is too long. This is 87 | # determined by 'columns' setting. 88 | # 89 | # - inline: This option will put as much specs on same line as possible. 90 | # 91 | # - new_line: Import list will start on new line. 92 | # 93 | # - new_line_multiline: Import list will start on new line when it's 94 | # short enough to fit to single line. Otherwise it'll be multiline. 95 | # 96 | # - multiline: One line per import list entry. 97 | # Type with constructor list acts like single import. 98 | # 99 | # > import qualified Data.Map as M 100 | # > ( empty 101 | # > , singleton 102 | # > , ... 103 | # > , delete 104 | # > ) 105 | # 106 | # Default: inline 107 | long_list_align: inline 108 | 109 | # Align empty list (importing instances) 110 | # 111 | # Empty list align has following options 112 | # 113 | # - inherit: inherit list_align setting 114 | # 115 | # - right_after: () is right after the module name: 116 | # 117 | # > import Vector.Instances () 118 | # 119 | # Default: inherit 120 | empty_list_align: inherit 121 | 122 | # List padding determines indentation of import list on lines after import. 123 | # This option affects 'long_list_align'. 124 | # 125 | # - : constant value 126 | # 127 | # - module_name: align under start of module name. 128 | # Useful for 'file' and 'group' align settings. 129 | list_padding: 4 130 | 131 | # Separate lists option affects formatting of import list for type 132 | # or class. The only difference is single space between type and list 133 | # of constructors, selectors and class functions. 134 | # 135 | # - true: There is single space between Foldable type and list of it's 136 | # functions. 137 | # 138 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 139 | # 140 | # - false: There is no space between Foldable type and list of it's 141 | # functions. 142 | # 143 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 144 | # 145 | # Default: true 146 | separate_lists: true 147 | 148 | # Space surround option affects formatting of import lists on a single 149 | # line. The only difference is single space after the initial 150 | # parenthesis and a single space before the terminal parenthesis. 151 | # 152 | # - true: There is single space associated with the enclosing 153 | # parenthesis. 154 | # 155 | # > import Data.Foo ( foo ) 156 | # 157 | # - false: There is no space associated with the enclosing parenthesis 158 | # 159 | # > import Data.Foo (foo) 160 | # 161 | # Default: false 162 | space_surround: false 163 | 164 | # Language pragmas 165 | - language_pragmas: 166 | # We can generate different styles of language pragma lists. 167 | # 168 | # - vertical: Vertical-spaced language pragmas, one per line. 169 | # 170 | # - compact: A more compact style. 171 | # 172 | # - compact_line: Similar to compact, but wrap each line with 173 | # `{-#LANGUAGE #-}'. 174 | # 175 | # Default: vertical. 176 | style: vertical 177 | 178 | # Align affects alignment of closing pragma brackets. 179 | # 180 | # - true: Brackets are aligned in same column. 181 | # 182 | # - false: Brackets are not aligned together. There is only one space 183 | # between actual import and closing bracket. 184 | # 185 | # Default: true 186 | align: true 187 | 188 | # stylish-haskell can detect redundancy of some language pragmas. If this 189 | # is set to true, it will remove those redundant pragmas. Default: true. 190 | remove_redundant: false 191 | 192 | # Replace tabs by spaces. This is disabled by default. 193 | # - tabs: 194 | # # Number of spaces to use for each tab. Default: 8, as specified by the 195 | # # Haskell report. 196 | # spaces: 8 197 | 198 | # Remove trailing whitespace 199 | - trailing_whitespace: {} 200 | 201 | # A common setting is the number of columns (parts of) code will be wrapped 202 | # to. Different steps take this into account. Default: 80. 203 | columns: 80 204 | 205 | # By default, line endings are converted according to the OS. You can override 206 | # preferred format here. 207 | # 208 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 209 | # 210 | # - lf: Convert to LF ("\n"). 211 | # 212 | # - crlf: Convert to CRLF ("\r\n"). 213 | # 214 | # Default: native. 215 | newline: native 216 | 217 | # Sometimes, language extensions are specified in a cabal file or from the 218 | # command line instead of using language pragmas in the file. stylish-haskell 219 | # needs to be aware of these, so it can parse the file correctly. 220 | # 221 | # No language extensions are enabled by default. 222 | language_extensions: 223 | - TemplateHaskell 224 | - QuasiQuotes 225 | - DerivingStrategies 226 | - MultiParamTypeClasses 227 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the complex Travis configuration, which is intended for use 2 | # on open source libraries which need compatibility across multiple GHC 3 | # versions, must work with cabal-install, and should be 4 | # cross-platform. For more information and other options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.ghc 21 | - $HOME/.cabal 22 | - $HOME/.stack 23 | 24 | # The different configurations we want to test. We have BUILD=cabal which uses 25 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 26 | # of those below. 27 | # 28 | # We set the compiler values here to tell Travis to use a different 29 | # cache file per set of arguments. 30 | # 31 | # If you need to have different apt packages for each combination in the 32 | # matrix, you can use a line such as: 33 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 34 | matrix: 35 | include: 36 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 37 | compiler: ": #GHC 8.2.2" 38 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 39 | - env: BUILD=cabal GHCVER=8.4.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 40 | compiler: ": #GHC 8.4.1" 41 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 42 | - env: BUILD=cabal GHCVER=8.4.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 43 | compiler: ": #GHC 8.4.2" 44 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 45 | 46 | # Build with the newest GHC and cabal-install. This is an accepted failure, 47 | # see below. 48 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 49 | compiler: ": #GHC HEAD" 50 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 51 | 52 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 53 | # variable, such as using --stack-yaml to point to a different file. 54 | - env: BUILD=stack ARGS="" 55 | compiler: ": #stack default" 56 | addons: {apt: {packages: [libgmp-dev]}} 57 | 58 | - env: BUILD=stack ARGS="--resolver lts-6" 59 | compiler: ": #stack 7.10.3" 60 | addons: {apt: {packages: [libgmp-dev]}} 61 | 62 | - env: BUILD=stack ARGS="--resolver lts-9" 63 | compiler: ": #stack 8.0.2" 64 | addons: {apt: {packages: [libgmp-dev]}} 65 | 66 | - env: BUILD=stack ARGS="--resolver lts-11" 67 | compiler: ": #stack 8.2.2" 68 | addons: {apt: {packages: [libgmp-dev]}} 69 | 70 | # Nightly builds are allowed to fail 71 | - env: BUILD=stack ARGS="--resolver nightly" 72 | compiler: ": #stack nightly" 73 | addons: {apt: {packages: [libgmp-dev]}} 74 | 75 | allow_failures: 76 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 77 | - env: BUILD=stack ARGS="--resolver nightly" 78 | 79 | before_install: 80 | # Using compiler above sets CC to an invalid value, so unset it 81 | - unset CC 82 | 83 | # We want to always allow newer versions of packages when building on GHC HEAD 84 | - CABALARGS="" 85 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 86 | 87 | # Download and unpack the stack executable 88 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 89 | - mkdir -p ~/.local/bin 90 | - | 91 | if [ `uname` = "Darwin" ] 92 | then 93 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 94 | else 95 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 96 | fi 97 | 98 | # Use the more reliable S3 mirror of Hackage 99 | mkdir -p $HOME/.cabal 100 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 101 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 102 | 103 | if [ "$CABALVER" != "1.16" ] 104 | then 105 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 106 | fi 107 | 108 | install: 109 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 110 | - if [ -f configure.ac ]; then autoreconf -i; fi 111 | - | 112 | set -ex 113 | case "$BUILD" in 114 | stack) 115 | # Add in extra-deps for older snapshots, as necessary 116 | stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 117 | stack --no-terminal $ARGS build cabal-install && \ 118 | stack --no-terminal $ARGS solver --update-config) 119 | 120 | # Build the dependencies 121 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 122 | ;; 123 | cabal) 124 | cabal --version 125 | travis_retry cabal update 126 | 127 | # Get the list of packages from the stack.yaml file. Note that 128 | # this will also implicitly run hpack as necessary to generate 129 | # the .cabal files needed by cabal-install. 130 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 131 | 132 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 133 | ;; 134 | esac 135 | set +ex 136 | 137 | script: 138 | - | 139 | set -ex 140 | case "$BUILD" in 141 | stack) 142 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 143 | ;; 144 | cabal) 145 | cabal new-test all 146 | ;; 147 | esac 148 | set +ex 149 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rowdy 2 | 3 | [![Build Status](https://travis-ci.org/parsonsmatt/rowdy.svg?branch=master)](https://travis-ci.org/parsonsmatt/rowdy) 4 | 5 | `rowdy` is DSL for defining web application routes. Check out [the examples](examples/)! 6 | 7 | ## Why? 8 | 9 | Servant has a cool DSL for routes. It is embedded into the type system, and type 10 | level programming in Haskell isn't nearly as pleasant as value-level 11 | programming. As a result, there can be a lot of complexity with common 12 | combinators, and you must be familiar with advanced type-level techniques to 13 | work with it. 14 | 15 | Yesod has a cool DSL for routes. It uses a Template Haskell quasiquoter to parse 16 | a non-Haskell DSL into a data structure, which is then used to generate routes. 17 | Since it isn't Haskell, you don't get good error messages, syntax highlighting, 18 | or the ability to define your own combinators. 19 | 20 | `rowdy` is a value level DSL for defining routes. A Template Haskell splice can 21 | then interpret the value at compile-time and provide a Yesod representation, or a 22 | Servant representation, or whatever else you'd like! 23 | 24 | ## Future plans 25 | 26 | Currently, `rowdy` supports Yesod-style routes concretely and completely. The 27 | Servant support is limited and not ready for publish yet -- if you have ideas 28 | for providing an extensible design for this, please let me know! 29 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | rowdy 3 | rowdy-yesod 4 | rowdy-servant 5 | examples 6 | -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | examples.cabal 3 | *~ -------------------------------------------------------------------------------- /examples/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for examples 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Matt Parsons (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Matt Parsons nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # examples 2 | 3 | There's an example yesod and servant app located in src. 4 | -------------------------------------------------------------------------------- /examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/package.yaml: -------------------------------------------------------------------------------- 1 | name: examples 2 | version: 0.1.0.0 3 | github: parsonsmatt/rowdy 4 | license: BSD3 5 | author: Matt Parsons 6 | maintainer: parsonsmatt@gmail.com 7 | copyright: 2018 Matt Parsons 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: Examples of the Rowdy DSL 15 | category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - rowdy 25 | - rowdy-servant 26 | - rowdy-yesod 27 | - servant-server 28 | - text 29 | - warp 30 | - yesod-core 31 | 32 | library: 33 | source-dirs: src 34 | -------------------------------------------------------------------------------- /examples/src/ExampleServant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | module ExampleServant where 11 | 12 | import Data.Typeable 13 | import qualified Network.Wai.Handler.Warp as Warp 14 | import Servant 15 | 16 | import Rowdy.Servant 17 | 18 | toServant "MyApi" $ do 19 | let unit = SomeType (Proxy @()) 20 | "users" // do 21 | get unit 22 | -- need to add reqBody support 23 | post unit 24 | capture @Int // do 25 | get unit 26 | "posts" // do 27 | get unit 28 | post unit 29 | 30 | handler :: Server MyApi 31 | handler = getUsers :<|> postUsers :<|> getUser :<|> getPosts :<|> postPost 32 | 33 | getUsers :: Handler () 34 | getUsers = pure () 35 | 36 | postUsers :: Handler () 37 | postUsers = pure () 38 | 39 | getUser :: Int -> Handler () 40 | getUser _ = pure () 41 | 42 | getPosts :: Int -> Handler () 43 | getPosts _ = pure () 44 | 45 | postPost :: Int -> Handler () 46 | postPost _ = pure () 47 | 48 | main :: IO () 49 | main = Warp.run 3000 (serve (Proxy @MyApi) handler) 50 | -------------------------------------------------------------------------------- /examples/src/ExampleYesod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | 9 | module ExampleYesod where 10 | 11 | import Data.Text (Text) 12 | import Network.Wai.Handler.Warp (run) 13 | import Yesod.Core (RenderRoute (..), Yesod, mkYesod, 14 | toWaiApp) 15 | 16 | import Rowdy.Yesod 17 | 18 | -- | This is my data type. There are many like it, but this one is mine. 19 | data Minimal = Minimal 20 | 21 | mkYesod "Minimal" $ toYesod $ do 22 | get "RootR" 23 | "users" // do 24 | resource "UserIndexR" [get, post] 25 | capture @Int // resource "UserR" [get, put] 26 | "admin" // "Admin" /: do 27 | get "PanelR" ! "admin" ! "cool" 28 | post "PanelR" ! "admin" 29 | "other-attr" // "safe" /! do 30 | get "SafeR" 31 | put "SafeR" 32 | 33 | instance Yesod Minimal 34 | 35 | getRootR :: Handler Text 36 | getRootR = pure "Hello, world!" 37 | 38 | getUserIndexR :: Handler () 39 | getUserIndexR = pure () 40 | 41 | postUserIndexR :: Handler () 42 | postUserIndexR = pure () 43 | 44 | getUserR :: Int -> Handler () 45 | getUserR _ = pure () 46 | 47 | putUserR :: Int -> Handler () 48 | putUserR _ = pure () 49 | 50 | getPanelR :: Handler () 51 | getPanelR = pure () 52 | 53 | postPanelR :: Handler () 54 | postPanelR = pure () 55 | 56 | getSafeR :: Handler () 57 | getSafeR = pure () 58 | 59 | putSafeR :: Handler () 60 | putSafeR = pure () 61 | 62 | main :: IO () 63 | main = run 3000 =<< toWaiApp Minimal 64 | -------------------------------------------------------------------------------- /rowdy-servant/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for rowdy 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /rowdy-servant/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Matt Parsons (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Matt Parsons nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /rowdy-servant/Makefile: -------------------------------------------------------------------------------- 1 | ghcid: 2 | ghcid -c "stack ghci" --restart package.yaml 3 | 4 | ghcid-test: 5 | ghcid -c "stack ghci rowdy:lib rowdy:test:specs" --restart package.yaml --test "main" 6 | 7 | .PHONY: ghcid ghcid-test 8 | -------------------------------------------------------------------------------- /rowdy-servant/README.md: -------------------------------------------------------------------------------- 1 | # `rowdy-servant` 2 | 3 | An implementation of the `rowdy` web route DSL for the Servant web framework. 4 | -------------------------------------------------------------------------------- /rowdy-servant/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /rowdy-servant/package.yaml: -------------------------------------------------------------------------------- 1 | name: rowdy-servant 2 | version: 0.0.1.0 3 | github: parsonsmatt/rowdy 4 | license: BSD3 5 | author: Matt Parsons 6 | maintainer: parsonsmatt@gmail.com 7 | copyright: 2018 Matt Parsons 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: An EDSL for web application routes. 14 | category: Web 15 | description: Please see the README on Github at 16 | 17 | dependencies: 18 | - base >= 4.7 && < 5 19 | - rowdy 20 | - servant 21 | - template-haskell 22 | 23 | library: 24 | source-dirs: src 25 | ghc-options: -Wall -Wcompat 26 | 27 | tests: 28 | specs: 29 | main: Spec.hs 30 | source-dirs: test 31 | ghc-options: 32 | - -threaded 33 | - -rtsopts 34 | - -with-rtsopts=-N 35 | dependencies: 36 | - rowdy-servant 37 | - hspec 38 | -------------------------------------------------------------------------------- /rowdy-servant/src/Rowdy/Servant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | module Rowdy.Servant 13 | ( module Rowdy.Servant 14 | , (//), SomeType(..) 15 | ) where 16 | 17 | import Data.String 18 | import Data.Typeable 19 | import Language.Haskell.TH as TH 20 | import Servant.API as Servant 21 | 22 | import Rowdy 23 | 24 | type Dsl = RouteDsl () PathPiece (Route SomeType) 25 | 26 | toServant :: String -> Dsl () -> Q [Dec] 27 | toServant apiName = renderRoutes . runRouteDsl 28 | where 29 | renderRoutes = 30 | fmap pure 31 | . tySynD (mkName apiName) [] 32 | . pure 33 | . foldr1 (\x acc -> ConT ''(:<|>) `AppT` x `AppT` acc) 34 | . map (uncurry routeToType) 35 | . concatMap unnest 36 | 37 | routeToType pcs (Route (MkResource verb (SomeType prxy))) = 38 | let pcs' = map pieceToType pcs 39 | end = verbToVerb verb 40 | `AppT` json 41 | `AppT` (ConT . mkName . show . typeRep) prxy 42 | in foldr (\x acc -> ConT ''(:>) `AppT` x `AppT` acc) end pcs' 43 | 44 | json = 45 | PromotedConsT 46 | `AppT` ConT ''JSON 47 | `AppT` PromotedNilT 48 | 49 | verbToVerb = ConT . \case 50 | Get -> ''Servant.Get 51 | Put -> ''Servant.Put 52 | Post -> ''Servant.Post 53 | Delete -> ''Servant.Delete 54 | 55 | pieceToType (Literal str) = 56 | LitT (StrTyLit str) 57 | pieceToType (Capture (SomeType prxy)) = 58 | ConT ''Capture 59 | `AppT` (LitT . StrTyLit . show $ typeRep prxy) 60 | `AppT` (ConT . mkName . show $ typeRep prxy) 61 | 62 | newtype Route a = Route (Endpoint a) 63 | 64 | data Endpoint a 65 | = MkResource RVerb a 66 | deriving (Show, Functor) 67 | 68 | data RVerb = Get | Put | Post | Delete 69 | deriving (Eq, Show) 70 | 71 | data PathPiece 72 | = Literal String 73 | | Capture SomeType 74 | deriving Show 75 | 76 | instance IsString PathPiece where 77 | fromString = Literal 78 | 79 | data SomeType where 80 | SomeType :: Typeable t => Proxy t -> SomeType 81 | 82 | instance Show SomeType where 83 | show (SomeType prxy) = show (typeRep prxy) 84 | 85 | get, put, post, delete :: SomeType -> Dsl () 86 | get = doVerb Get 87 | put = doVerb Put 88 | post = doVerb Post 89 | delete = doVerb Delete 90 | 91 | doVerb :: RVerb -> SomeType -> Dsl () 92 | doVerb verb r = terminal (Route (MkResource verb r)) 93 | 94 | capture :: forall typ. Typeable typ => PathPiece 95 | capture = Capture (SomeType (Proxy @typ)) 96 | -------------------------------------------------------------------------------- /rowdy-servant/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -------------------------------------------------------------------------------- /rowdy-yesod/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for rowdy-yesod 2 | 3 | ## 0.0.1.1 4 | 5 | - Fixed a bug where path components were being merged, resulting in dropped 6 | routes. 7 | -------------------------------------------------------------------------------- /rowdy-yesod/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Matt Parsons (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Matt Parsons nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /rowdy-yesod/Makefile: -------------------------------------------------------------------------------- 1 | ghcid: 2 | ghcid -c "stack ghci" --restart package.yaml 3 | 4 | ghcid-test: 5 | ghcid -c "stack ghci rowdy:lib rowdy:test:specs" --restart package.yaml --test "main" 6 | 7 | .PHONY: ghcid ghcid-test 8 | -------------------------------------------------------------------------------- /rowdy-yesod/README.md: -------------------------------------------------------------------------------- 1 | # `rowdy-yesod` 2 | 3 | An implementation of the `rowdy` web route DSL for the Yesod web framework. 4 | Check the [GitHub repo](https://www.github.com/parsonsmatt/rowdy) for more 5 | information and examples. 6 | 7 | ```haskell 8 | routes = do 9 | get "RootR" 10 | "users" // do 11 | resource "UserIndexR" [get, post] 12 | capture @Int // resource "UserR" [get, put] 13 | "admin" // "Admin" /: do 14 | get "PanelR" ! "admin" ! "cool" 15 | post "PanelR" ! "admin" 16 | "other-attr" // "safe" /! do 17 | get "SafeR" 18 | put "SafeR" 19 | ``` 20 | -------------------------------------------------------------------------------- /rowdy-yesod/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /rowdy-yesod/package.yaml: -------------------------------------------------------------------------------- 1 | name: rowdy-yesod 2 | version: 0.0.1.1 3 | github: parsonsmatt/rowdy 4 | license: BSD3 5 | author: Matt Parsons 6 | maintainer: parsonsmatt@gmail.com 7 | copyright: 2018 Matt Parsons 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: An EDSL for web application routes. 14 | category: Web 15 | description: Please see the README on Github at 16 | 17 | dependencies: 18 | - base >= 4.7 && < 5 19 | - rowdy 20 | - yesod-core 21 | 22 | library: 23 | source-dirs: src 24 | ghc-options: -Wall -Wcompat 25 | 26 | tests: 27 | specs: 28 | main: Spec.hs 29 | source-dirs: test 30 | ghc-options: 31 | - -threaded 32 | - -rtsopts 33 | - -with-rtsopts=-N 34 | dependencies: 35 | - rowdy-yesod 36 | - hspec 37 | -------------------------------------------------------------------------------- /rowdy-yesod/rowdy-yesod.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 086fe6aeae68ba318303b5279097f6c53f278815f782926c25a2eb7ed55234f4 8 | 9 | name: rowdy-yesod 10 | version: 0.0.1.1 11 | synopsis: An EDSL for web application routes. 12 | description: Please see the README on Github at 13 | category: Web 14 | homepage: https://github.com/parsonsmatt/rowdy#readme 15 | bug-reports: https://github.com/parsonsmatt/rowdy/issues 16 | author: Matt Parsons 17 | maintainer: parsonsmatt@gmail.com 18 | copyright: 2018 Matt Parsons 19 | license: BSD3 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | ChangeLog.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/parsonsmatt/rowdy 29 | 30 | library 31 | hs-source-dirs: 32 | src 33 | ghc-options: -Wall -Wcompat 34 | build-depends: 35 | base >=4.7 && <5 36 | , rowdy 37 | , yesod-core 38 | exposed-modules: 39 | Rowdy.Yesod 40 | Rowdy.Yesod.Internal 41 | other-modules: 42 | Paths_rowdy_yesod 43 | default-language: Haskell2010 44 | 45 | test-suite specs 46 | type: exitcode-stdio-1.0 47 | main-is: Spec.hs 48 | hs-source-dirs: 49 | test 50 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 51 | build-depends: 52 | base >=4.7 && <5 53 | , hspec 54 | , rowdy 55 | , rowdy-yesod 56 | , yesod-core 57 | other-modules: 58 | Rowdy.YesodSpec 59 | Paths_rowdy_yesod 60 | default-language: Haskell2010 61 | -------------------------------------------------------------------------------- /rowdy-yesod/src/Rowdy/Yesod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | -- | Use your Rowdy route definitions with Yesod web applications. 8 | module Rowdy.Yesod 9 | ( module Rowdy.Yesod 10 | , (//) 11 | , (/:) 12 | , Endpoint(..) 13 | , PathPiece(..) 14 | , Type(..) 15 | , Verb(..) 16 | ) where 17 | 18 | import Data.Foldable (traverse_) 19 | import Data.Typeable (Proxy (..), Typeable) 20 | import Yesod.Routes.TH.Types 21 | 22 | import Rowdy 23 | import Rowdy.Yesod.Internal 24 | 25 | -- | Convert a 'RouteDsl' into a representation that Yesod can use. 26 | -- 27 | -- @ 28 | -- mkYesod "App" $ toYesod $ do 29 | -- get "RootR" 30 | -- "users" // do 31 | -- resource "UserIndex" [get, post] 32 | -- -- etc... 33 | -- @ 34 | -- 35 | -- GHC freaks out if you try to use a type defined in the same module as the 36 | -- route. Ensure that all types you use in the route are defined in an imported 37 | -- module. 38 | -- 39 | -- @since 0.0.1.0 40 | toYesod :: Dsl () -> [ResourceTree String] 41 | toYesod = routeTreeToResourceTree . runRouteDsl 42 | 43 | -- | We specialize the 'RouteDsl' type to this as a shorthand. 44 | type Dsl = RouteDsl String PathPiece Endpoint 45 | 46 | -- | We support the most common HTTP verbs. Each of 'get', 'put', 'post', and 47 | -- 'delete' are given a @String@ that represents the resource they are acting 48 | -- for. The generated route type uses that resource as a constructor. The 49 | -- generated dispatcher expects to see functions with the lowercase verb as 50 | -- a prefix to the resource name. As an example: 51 | -- 52 | -- @ 53 | -- get "HelloR" 54 | -- @ 55 | -- 56 | -- Will create a route type @HelloR@ and expect a handler @getHelloR@ to be 57 | -- defined. 58 | -- 59 | -- @since 0.0.1.0 60 | get, put, post, delete :: String -> Dsl () 61 | get = doVerb Get 62 | put = doVerb Put 63 | post = doVerb Post 64 | delete = doVerb Delete 65 | 66 | -- | Create an endpoint with the given named resource and verb. 67 | -- 68 | -- @since 0.0.1.0 69 | doVerb :: Verb -> String -> Dsl () 70 | doVerb v s = terminal (MkResource v s) 71 | 72 | -- | Create a subsite with the given @name@, @type@, and accessor function name 73 | -- to get the underlying application. 74 | -- 75 | -- @since 0.0.1.0 76 | subsite :: String -> String -> String -> Dsl () 77 | subsite name thing func = 78 | terminal (MkSubsite name thing func) 79 | 80 | -- | Capture a dynamic path piece and parse it as the provided type. This 81 | -- function is intended to be used with the @TypeApplications@ language 82 | -- extension. 83 | -- 84 | -- @ 85 | -- "users" // do 86 | -- resource "UserIndexR" [get, post] 87 | -- capture @UserId $ do 88 | -- resource "UserR" [get, put, delete] 89 | -- "posts" // do 90 | -- resource "PostR" [get, post] 91 | -- @ 92 | -- 93 | -- @since 0.0.1.0 94 | capture :: forall typ. Typeable typ => PathPiece 95 | capture = 96 | captureP (Proxy @typ) 97 | 98 | -- | A version of 'capture' that accepts an explicit 'Proxy' argument. Use this 99 | -- if you don't like the @TypeApplications@ syntax, or have a proxy on hand 100 | -- already. 101 | -- 102 | -- @since 0.0.1.0 103 | captureP :: forall typ. Typeable typ => Proxy typ -> PathPiece 104 | captureP = Capture . Type 105 | 106 | -- | Define a number of handlers for the named resource. The following code 107 | -- block: 108 | -- 109 | -- @ 110 | -- do 'get' "HelloR" 111 | -- 'put' "HelloR" 112 | -- 'post' "HelloR" 113 | -- 'delete' "HelloR" 114 | -- @ 115 | -- 116 | -- is equivalent to this shorter form: 117 | -- 118 | -- @ 119 | -- 'resource' "HelloR" ['get', 'put', 'post', 'delete'] 120 | -- @ 121 | -- 122 | -- @since 0.0.1.0 123 | resource :: String -> [String -> Dsl ()] -> Dsl () 124 | resource = traverse_ . flip id 125 | 126 | -- | Attach a route attribute to every element in the given DSL. 127 | -- 128 | -- @since 0.0.1.0 129 | attr :: String -> Dsl () -> Dsl () 130 | attr = pathComponent . Attr 131 | 132 | -- | An infix operator alias for 'attr'. 133 | -- 134 | -- @ 135 | -- "admin" // "admin" /! do 136 | -- 'resource' "AdminR" ['get', 'put', 'post'] 137 | -- @ 138 | -- 139 | -- @since 0.0.1.0 140 | (/!) :: String -> Dsl () -> Dsl () 141 | (/!) = attr 142 | 143 | infixr 8 /! 144 | 145 | -- | Provide an inline attribute to the given route. 146 | -- 147 | -- @ 148 | -- get "HelloR" ! "friendly" 149 | -- @ 150 | (!) :: Dsl () -> String -> Dsl () 151 | (!) = flip attr 152 | 153 | infixl 8 ! 154 | -------------------------------------------------------------------------------- /rowdy-yesod/src/Rowdy/Yesod/Internal.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | -- | An internal module. Depend on this at your own risk -- breaking changes to 9 | -- this module's interface will not be represented as a major version bump. 10 | module Rowdy.Yesod.Internal where 11 | 12 | import Data.Char (toUpper) 13 | import Data.Either (isLeft, lefts, rights) 14 | import Data.Maybe (isJust) 15 | import Data.String (IsString (..)) 16 | import Data.Typeable (Proxy (..), Typeable, eqT, typeRep) 17 | import Yesod.Routes.TH.Types 18 | 19 | import Rowdy 20 | 21 | -- | An endpoint in the Yesod model. 22 | data Endpoint 23 | = MkResource Verb String 24 | -- ^ A resource identified by a 'Verb' and a 'String' name. 25 | | MkSubsite String String String 26 | -- ^ A subsite. 27 | deriving (Eq, Show) 28 | 29 | -- | The type of things that can affect a path. 30 | data PathPiece 31 | = Literal String 32 | -- ^ Static string literals. 33 | | Capture Type 34 | -- ^ Dynamic captures. 35 | | Attr String 36 | -- ^ Route attributes. Not technically part of the path, but applies to 37 | -- everything below it in the tree. 38 | deriving (Eq, Show) 39 | 40 | instance IsString PathPiece where 41 | fromString = Literal 42 | 43 | -- | A value containing a 'Proxy' of some Haskell type. 44 | data Type where 45 | Type :: Typeable t => Proxy t -> Type 46 | 47 | instance Show Type where 48 | show (Type prxy) = show (typeRep prxy) 49 | 50 | instance Eq Type where 51 | Type (_ :: Proxy t0) == Type (_ :: Proxy t1) = 52 | isJust (eqT @t0 @t1) 53 | 54 | -- | The HTTP verbs. 55 | data Verb = Get | Put | Post | Delete 56 | deriving (Eq, Show) 57 | 58 | -- | Render a verb as an uppercase string. 59 | renderVerb :: Verb -> String 60 | renderVerb = map toUpper . show 61 | 62 | -- | Convert the Rowdy 'RouteTree' structure into one appropriate for the Yesod 63 | -- routing functions. 64 | routeTreeToResourceTree :: [RouteTree String PathPiece Endpoint] -> [ResourceTree String] 65 | routeTreeToResourceTree = 66 | foldr (go []) [] 67 | where 68 | go 69 | :: [Either String (Piece String)] 70 | -> RouteTree String PathPiece Endpoint 71 | -> [ResourceTree String] 72 | -> [ResourceTree String] 73 | go pcs (Nest str xs) acc = 74 | ResourceParent str True pieces (foldr (go attrs) [] xs) : acc 75 | where 76 | pieces = rights (reverse pcs) 77 | attrs = filter isLeft pcs 78 | go pcs (PathComponent pp rest) acc = 79 | go (convPiece pp : pcs) rest acc 80 | go pcs (Leaf term) (ResourceLeaf Resource {..} : acc) 81 | | listEq eqPieceStr (rights (reverse pcs)) resourcePieces 82 | , Methods multi methods <- resourceDispatch 83 | , MkResource _ endpointName <- term 84 | , resourceName == endpointName 85 | = 86 | flip (:) acc . ResourceLeaf $ 87 | case term of 88 | MkResource v str -> 89 | Resource 90 | { resourceName = str 91 | , resourcePieces = rights (reverse pcs) 92 | , resourceDispatch = 93 | Methods 94 | { methodsMulti = multi 95 | , methodsMethods = renderVerb v : methods 96 | } 97 | , resourceAttrs = 98 | lefts pcs 99 | , resourceCheck = 100 | True 101 | } 102 | MkSubsite str typ func -> 103 | Resource 104 | { resourceName = str 105 | , resourcePieces = reverse (rights pcs) 106 | , resourceDispatch = 107 | Subsite 108 | { subsiteType = typ 109 | , subsiteFunc = func 110 | } 111 | , resourceAttrs = 112 | lefts pcs 113 | , resourceCheck = 114 | True 115 | } 116 | go pcs (Leaf term) acc = 117 | flip (:) acc . ResourceLeaf $ 118 | case term of 119 | MkResource v str -> 120 | Resource 121 | { resourceName = str 122 | , resourcePieces = reverse (rights pcs) 123 | , resourceDispatch = 124 | Methods 125 | { methodsMulti = Nothing 126 | , methodsMethods = [renderVerb v] 127 | } 128 | , resourceAttrs = 129 | lefts pcs 130 | , resourceCheck = 131 | True 132 | } 133 | MkSubsite str typ func -> 134 | Resource 135 | { resourceName = str 136 | , resourcePieces = reverse (rights pcs) 137 | , resourceDispatch = 138 | Subsite 139 | { subsiteType = typ 140 | , subsiteFunc = func 141 | } 142 | , resourceAttrs = 143 | lefts pcs 144 | , resourceCheck = 145 | True 146 | } 147 | 148 | convPiece :: PathPiece -> Either String (Piece String) 149 | convPiece = \case 150 | Literal str -> Right (Static str) 151 | Capture (Type prxy) -> Right (Dynamic (show (typeRep prxy))) 152 | Attr attr -> Left attr 153 | 154 | listEq :: (a -> a -> Bool) -> [a] -> [a] -> Bool 155 | listEq f (x:xs) (y:ys) = f x y && listEq f xs ys 156 | listEq _ [] [] = True 157 | listEq _ _ _ = False 158 | 159 | eqPieceStr :: Piece String -> Piece String -> Bool 160 | eqPieceStr (Static s2) (Static s1) = s1 == s2 161 | eqPieceStr (Dynamic d0) (Dynamic d1) = d0 == d1 162 | eqPieceStr _ _ = False 163 | -------------------------------------------------------------------------------- /rowdy-yesod/test/Rowdy/YesodSpec.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeApplications, OverloadedStrings, StandaloneDeriving, FlexibleInstances #-} 2 | 3 | module Rowdy.YesodSpec where 4 | 5 | import Data.Proxy 6 | import Rowdy 7 | import Rowdy.Yesod 8 | import Yesod.Routes.TH.Types 9 | import Test.Hspec 10 | 11 | deriving instance Eq (ResourceTree String) 12 | deriving instance Eq (Resource String) 13 | deriving instance Eq (Piece String) 14 | deriving instance Eq (Dispatch String) 15 | 16 | router = do 17 | get "RootR" 18 | "weight" // do 19 | get "WeightsR" 20 | "record" // do 21 | resource "RecordWeightR" [get, post] 22 | capture @Int // do 23 | delete "WeightR" 24 | 25 | "auth" // do 26 | resource "LoginR" [get, post] 27 | post "LogoutR" 28 | 29 | 30 | spec :: Spec 31 | spec = do 32 | describe "routes" $ do 33 | it "works" $ do 34 | runRouteDsl router 35 | `shouldBe` 36 | [ Leaf (MkResource Get "RootR") 37 | , PathComponent (Literal "weight") 38 | $ Leaf (MkResource Get "WeightsR") 39 | , PathComponent (Literal "weight") 40 | $ PathComponent (Literal "record") 41 | $ Leaf (MkResource Get "RecordWeightR") 42 | , PathComponent (Literal "weight") 43 | $ PathComponent (Literal "record") 44 | $ Leaf (MkResource Post "RecordWeightR") 45 | , PathComponent (Literal "weight") 46 | $ PathComponent (Capture (Type (Proxy @Int))) 47 | $ Leaf (MkResource Delete "WeightR") 48 | , PathComponent (Literal "auth") 49 | $ Leaf (MkResource Get "LoginR") 50 | , PathComponent (Literal "auth") 51 | $ Leaf (MkResource Post "LoginR") 52 | , PathComponent (Literal "auth") 53 | $ Leaf (MkResource Post "LogoutR") 54 | ] 55 | 56 | it "toYesod works" $ do 57 | toYesod router 58 | `shouldBe` 59 | [ ResourceLeaf (Resource "RootR" [] (Methods Nothing ["GET"]) [] True) 60 | , ResourceLeaf (Resource "WeightsR" [Static "weight"] (Methods Nothing ["GET"]) [] True) 61 | , ResourceLeaf (Resource "RecordWeightR" [Static "weight", Static "record"] (Methods Nothing ["GET", "POST"]) [] True) 62 | , ResourceLeaf (Resource "WeightR" [Static "weight", Dynamic "Int"] (Methods Nothing ["DELETE"]) [] True) 63 | , ResourceLeaf (Resource "LoginR" [Static "auth"] (Methods Nothing ["GET", "POST"]) [] True) 64 | , ResourceLeaf (Resource "LogoutR" [Static "auth"] (Methods Nothing ["POST"]) [] True) 65 | ] 66 | -------------------------------------------------------------------------------- /rowdy-yesod/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /rowdy/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for rowdy 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /rowdy/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Matt Parsons (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Matt Parsons nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /rowdy/Makefile: -------------------------------------------------------------------------------- 1 | ghcid: 2 | ghcid -c "stack ghci rowdy --ghci-options -fno-code" --restart package.yaml 3 | 4 | ghcid-test: 5 | ghcid -c "stack ghci rowdy:lib rowdy:test:specs --ghci-options -fobject-code" --restart package.yaml --test "main" 6 | 7 | .PHONY: ghcid ghcid-test 8 | -------------------------------------------------------------------------------- /rowdy/README.md: -------------------------------------------------------------------------------- 1 | # `rowdy` 2 | 3 | The core routing DSL for `rowdy`. 4 | Check the [GitHub repo](https://www.github.com/parsonsmatt/rowdy) for more 5 | information and examples. 6 | 7 | ```haskell 8 | -- Yesod-style: 9 | routes = do 10 | get "RootR" 11 | "users" // do 12 | resource "UserIndexR" [get, post] 13 | capture @Int // resource "UserR" [get, put] 14 | "admin" // "Admin" /: do 15 | get "PanelR" ! "admin" ! "cool" 16 | post "PanelR" ! "admin" 17 | "other-attr" // "safe" /! do 18 | get "SafeR" 19 | put "SafeR" 20 | ``` 21 | -------------------------------------------------------------------------------- /rowdy/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /rowdy/package.yaml: -------------------------------------------------------------------------------- 1 | name: rowdy 2 | version: 0.0.1.0 3 | github: parsonsmatt/rowdy 4 | license: BSD3 5 | author: Matt Parsons 6 | maintainer: parsonsmatt@gmail.com 7 | copyright: 2018 Matt Parsons 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: An EDSL for web application routes. 14 | category: Web 15 | description: Please see the README on Github at 16 | 17 | dependencies: 18 | - base >= 4.7 && < 5 19 | - mtl 20 | - dlist 21 | - containers 22 | 23 | library: 24 | source-dirs: src 25 | ghc-options: -Wall -Wcompat 26 | other-modules: Paths_rowdy 27 | 28 | tests: 29 | specs: 30 | main: Spec.hs 31 | source-dirs: test 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - rowdy 38 | - hspec 39 | -------------------------------------------------------------------------------- /rowdy/src/Rowdy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | 11 | -- | Rowdy is a DSL for defining web routes. The DSL is only a nice syntax for 12 | -- expressing the tree-like structure of routes -- to actually interpret the 13 | -- route into something useful, you'll need another package. 14 | -- 15 | -- @rowdy-yesod@ provides a function that converts this representation into the 16 | -- Yesod route format, allowing you to drop the quasiquotater and use a plain 17 | -- Haskell DSL. 18 | -- 19 | -- @rowdy-servant@ provides a function that converts the DSL into Servant's type 20 | -- level DSL for defining routes. This allows you to work with a value-level 21 | -- DSL, taking full advantage of Haskell's value level programming, and then 22 | -- promote the DSL to the type level using Template Haskell. 23 | module Rowdy where 24 | 25 | import Control.Monad.Writer 26 | import Data.DList (DList (..)) 27 | import qualified Data.DList as DList 28 | 29 | -- | A 'RouteDsl' is a type useful for constructing web routes. At it's heart, 30 | -- it is a DSL for constructing a 'RouteTree', and is totally optional. 31 | -- 32 | -- Routes are defined by how they handle @nest@ing, what sorts of values are 33 | -- used to represent @capture@s, and what values are used to represent 34 | -- endpoints. 35 | -- 36 | -- @since 0.0.1.0 37 | newtype RouteDsl nest capture terminal a = RouteDsl 38 | { unRouteDsl :: Writer (DForest nest capture terminal) a 39 | } deriving 40 | ( Functor, Applicative, Monad 41 | , MonadWriter (DForest nest capture terminal) 42 | ) 43 | 44 | -- | Run the given 'RouteDsl' and convert it into the 'Forest' of routes. If you 45 | -- are defining an interpreter for a web framework, you will want to call this 46 | -- on the 'RouteDsl' value. 47 | -- 48 | -- @since 0.0.1.0 49 | runRouteDsl :: RouteDsl n c e a -> Forest n c e 50 | runRouteDsl = 51 | DList.toList . execWriter . unRouteDsl 52 | 53 | -- | Run the given 'RouteDsl' and convert it into a 'DList' of routes. This is 54 | -- useful when implementing combinators. 55 | -- 56 | -- @since 0.0.1.0 57 | runRouteDsl' :: RouteDsl n c e a -> DForest n c e 58 | runRouteDsl' = execWriter . unRouteDsl 59 | 60 | -- | Introduce a @capture@ into all of the routes defined in the second 61 | -- argument. This function does not introduce nesting, so multiple distinct 62 | -- routes will be created. 63 | -- 64 | -- As an example: 65 | -- 66 | -- @ 67 | -- example :: RouteDsl nest String String () 68 | -- example = 69 | -- 'pathComponent' "hello" $ do 70 | -- 'terminal' "first route" 71 | -- 'terminal' "second route" 72 | -- @ 73 | -- 74 | -- Calling @'runRouteDsl' example@ will give a data structure like: 75 | -- 76 | -- @ 77 | -- [ 'PathComponent' "hello" ('Leaf' "first route") 78 | -- , 'PathComponent' "hello" ('Leaf' "second route") 79 | -- ] 80 | -- @ 81 | -- 82 | -- @since 0.0.1.0 83 | pathComponent 84 | :: capture 85 | -> RouteDsl nest capture endpoint () 86 | -> RouteDsl nest capture endpoint () 87 | pathComponent pp = 88 | tell . fmap (PathComponent pp) . runRouteDsl' 89 | 90 | -- | An infix operator for 'pathComponent'. 91 | -- 92 | -- @since 0.0.1.0 93 | (//) 94 | :: capture 95 | -> RouteDsl nest capture endpoint () 96 | -> RouteDsl nest capture endpoint () 97 | (//) = pathComponent 98 | 99 | infixr 5 // 100 | 101 | -- | Introduce a nesting point in the route DSL. While the 'pathComponent' 102 | -- function adds the @capture@ to each route defined in the second argument, 103 | -- this one preserves the tree-like structure of the declaration. 104 | -- 105 | -- @ 106 | -- example :: 'RouteDsl' String String String () 107 | -- example = 108 | -- 'pathComponent' "thing" $ 'nest' "hello" $ do 109 | -- terminal "first" 110 | -- terminal "second" 111 | -- @ 112 | -- 113 | -- Calling @'runRouteDsl' example@ would give a data structure like: 114 | -- 115 | -- @ 116 | -- [ 'PathComponent' "thing" ('Nest' 117 | -- [ Leaf "first" 118 | -- , Leaf "second" 119 | -- ] 120 | -- ) 121 | -- ] 122 | -- @ 123 | -- 124 | -- In constrast, if 'nest' were not called, you would see the 'PathComponent' 125 | -- repeated and distributed to both endpoints. 126 | -- 127 | -- @since 0.0.1.0 128 | nest 129 | :: nest 130 | -> RouteDsl nest capture endpoint () 131 | -> RouteDsl nest capture endpoint () 132 | nest str = tell . pure . Nest str . runRouteDsl 133 | 134 | -- | An infix operator alias for 'nest'. 135 | -- 136 | -- @since 0.0.1.0 137 | (/:) 138 | :: nest 139 | -> RouteDsl nest capture endpoint () 140 | -> RouteDsl nest capture endpoint () 141 | (/:) = nest 142 | 143 | infixr 7 /: 144 | 145 | -- | Record the given @endpoint@ as a route. 146 | -- 147 | -- @since 0.0.1.0 148 | terminal :: endpoint -> RouteDsl nest capture endpoint () 149 | terminal = tell . pure . Leaf 150 | 151 | -- | Convert a 'RouteTree' into a flattened list of routes. Each @terminal@ is 152 | -- paired with the list of @capture@s that preceeded it. 153 | -- 154 | -- @since 0.0.1.0 155 | unnest :: RouteTree nest capture terminal -> [([capture], terminal)] 156 | unnest = go mempty 157 | where 158 | go caps (Leaf term) = 159 | [(DList.toList caps, term)] 160 | go caps (PathComponent cap next) = 161 | go (DList.snoc caps cap) next 162 | go caps (Nest _ xs) = 163 | concatMap (go caps) xs 164 | 165 | 166 | -- | For efficiency's sake, we encode the route DSL as a 'DList' while defining 167 | -- them, and (for convenience's sake) we present them as an ordinary list when 168 | -- you run it. To prevent type complexity, we parameterize the forest on how 169 | -- we're working with it. 170 | -- 171 | -- @since 0.0.1.0 172 | type ForestOf f n capture terminal = f (RouteTree n capture terminal) 173 | 174 | -- | A difference list ('DList') of 'RouteTree' values. 175 | -- 176 | -- @since 0.0.1.0 177 | type DForest n c t = ForestOf DList n c t 178 | 179 | -- | A list of 'RouteTree' values. 180 | -- 181 | -- @since 0.0.1.0 182 | type Forest n c t = ForestOf [] n c t 183 | 184 | -- | The core data type that is produced by the 'RouteDsl'. If you'd prefer 185 | -- a non-monadic interface to creating these, you're welcome to use the 186 | -- constructors directly. 187 | -- 188 | -- The DSL defined as @example@ below has the route representation given by 189 | -- @desugared@: 190 | -- 191 | -- @ 192 | -- example :: 'Forest' String String String 193 | -- example = 'runRouteDsl' $ do 194 | -- "hello" // do 195 | -- 'terminal' "world" 196 | -- 'terminal' "friend" 197 | -- "nest" /: do 198 | -- 'terminal' "nope" 199 | -- 'terminal' "yes" 200 | -- 201 | -- desugared :: 'Forest' String String String 202 | -- desugared = 203 | -- [ 'PathComponent' "hello" ('Leaf' "world") 204 | -- , 'PathComponent' "hello" ('Leaf' "friend") 205 | -- , 'PathComponent' "hello" ('Nest' "nest" 206 | -- [ 'Leaf' "nope" 207 | -- , 'Leaf' "yes" 208 | -- ] 209 | -- ) 210 | -- ] 211 | -- @ 212 | -- 213 | -- @since 0.0.1.0 214 | data RouteTree nest capture terminal 215 | = Leaf terminal 216 | | PathComponent capture (RouteTree nest capture terminal) 217 | | Nest nest [RouteTree nest capture terminal] 218 | deriving (Eq, Show, Functor, Foldable) 219 | -------------------------------------------------------------------------------- /rowdy/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.2 2 | 3 | packages: 4 | - rowdy 5 | - rowdy-yesod 6 | - rowdy-servant 7 | - examples 8 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 506654 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/2.yaml 11 | sha256: 16bf823de040aa30863f26aab473f13477721aa0172514fc9b4041724b0534fb 12 | original: lts-11.2 13 | --------------------------------------------------------------------------------