diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , ScopedTypeVariables - , FlexibleContexts - , DeriveDataTypeable - , DataKinds - #-} - - -module Main where - -import Web.Routes.Nested -import Network.Wai.Trans -import Network.Wai.Handler.Warp -import Network.HTTP.Types -import Text.Regex -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Attoparsec.Text hiding (match) -import Data.Monoid -import Data.Typeable -import Control.Monad.IO.Class -import Control.Monad.Catch -import Control.Monad.Trans - - -defApp :: Application -defApp _ respond = respond - $ textOnly "404 :(" status404 [] - -main :: IO () -main = run 3000 $ - (routeAuth authorize routes - `catchMiddlewareT` handleUploadError - `catchMiddlewareT` handleAuthError - ) defApp - where - handleUploadError u = fileExtsToMiddleware $ - overFileExts [Text] (mapStatus $ const status400) $ - case u of - NoChunkedBody -> text "No chunked body allowed!" - UploadTooLarge -> text "Upload too large" - - handleAuthError e = fileExtsToMiddleware $ - overFileExts [Text] (mapStatus $ const status400) $ - case e of - NeedsAuth -> text "Authentication needed" - --- | A set of symbolic security roles -data AuthRole = AuthRole - deriving (Show, Eq) - --- | The error thrown during authentication or authorization. --- --- I would encourage other security-related error schemes: --- --- - one data type for user authority errors - like when a logged-in user tries to access --- the admin console --- - one for types of failed authentication, during login (user doesn't exist, --- incorrect password, etc.) --- - one for malicious attacks - for instance if someone has tried (and failed) to login --- 5 times in the last minute, or multiple requests to the same resource -data AuthError = NeedsAuth - deriving (Show, Eq, Typeable) - -instance Exception AuthError - --- | Simple function that returns a response modification function - like --- something that adds to the response headers - to maintain a session cookie, --- for instance. --- --- You can use 'Control.Monad.Catch.throwM' to throw arbitrary errors, but --- you should also catch them with 'Network.Wai.Trans.catchMiddlewareT' to --- avoid runtime exceptions. -authorize :: ( Monad m - , MonadThrow m - ) => Request -> [AuthRole] -> m () -authorize req ss | null ss = return () - | otherwise = throwM NeedsAuth - --- | The error thrown during the uploading function -data UploadError = NoChunkedBody - | UploadTooLarge - deriving (Show, Typeable) - -instance Exception UploadError - - -routes :: ( MonadIO m - , MonadThrow m - ) => HandlerT (MiddlewareT m) (SecurityToken AuthRole) m () -routes = do - matchHere (action rootHandle) - matchGroup (l_ "foo" o_) $ do - matchHere (action fooHandle) - auth AuthRole DontProtectHere - match (l_ "bar" o_) (action barHandle) - match (p_ "double" double o_) doubleHandle - match emailRoute emailHandle - match (l_ "baz" o_) (\app req -> action (bazHandle req) app req) - matchAny (action notFoundHandle) - where - rootHandle :: MonadIO m => ActionT m () - rootHandle = - get $ do - text "Home" - json ("Home" :: T.Text) - - -- `/foo` - fooHandle :: MonadIO m => ActionT m () - fooHandle = get $ text "foo!" - - -- `/foo/bar` - barHandle :: MonadIO m => ActionT m () - barHandle = - get $ do - text "bar!" - json ("json bar!" :: T.Text) - - -- `/foo/1234e12`, uses attoparsec - doubleHandle :: MonadIO m => Double-> MiddlewareT m - doubleHandle d = action $ get $ text $ LT.pack (show d) <> " foos" - - -- `/athan@foo.com` - emailRoute :: UrlChunks '[ 'Just [String] ] - emailRoute = r_ "email" (mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") o_ - - emailHandle :: MonadIO m => [String] -> MiddlewareT m - emailHandle e = action $ get $ text $ LT.pack (show e) <> " email" - - -- `/baz - bazHandle :: ( MonadIO m - , MonadThrow m - ) => Request -> ActionT m () - bazHandle req = do - get $ text "baz!" - post $ do - lift $ uploader req - text "uploaded!" - where - uploader :: (MonadIO m, MonadThrow m) => Request -> m () - uploader req = - case requestBodyLength req of - ChunkedBody -> throwM NoChunkedBody - KnownLength l | l > 1024 -> throwM UploadTooLarge - | otherwise -> liftIO $ print =<< strictRequestBody req - - - notFoundHandle :: MonadIO m => ActionT m () - notFoundHandle = get $ - overFileExts [Text] (mapStatus $ const status400) $ - text "Not Found :(" diff --git a/nested-routes.cabal b/nested-routes.cabal --- a/nested-routes.cabal +++ b/nested-routes.cabal @@ -1,145 +1,106 @@ -Name: nested-routes -Version: 8.0.1 -Author: Athan Clark -Maintainer: Athan Clark -License: BSD3 -License-File: LICENSE -Synopsis: Declarative, compositional Wai responses -Category: Web -Description: - A method to writing Wai responses - . - This library attempts to make it easier to write nice Wai response handlers - by giving us a Sinatra/ - -like syntax for declaring HTTP-verb oriented - routes, in addition to file-extension handling and rose-tree like composition. - Not only do we have literal route specification, like - & - , but we - can also embed - - parsers and - /directly/ in our routes, with our handlers - reflecting their results. -Cabal-Version: >= 1.10 -Build-Type: Simple - - -Flag Example - Description: Build the trivial example. - Default: False - -Library - Default-Language: Haskell2010 - HS-Source-Dirs: src - GHC-Options: -Wall - Exposed-Modules: Web.Routes.Nested - Web.Routes.Nested.Match - Web.Routes.Nested.Types - Build-Depends: base >= 4.8 && < 5 - , attoparsec - , bifunctors - , bytestring - , errors - , exceptions - , extractable-singleton - , hashable - , hashtables - , monad-control-aligned - , mtl - , poly-arity >= 0.0.7 - , pred-set >= 0.0.1 - , pred-trie >= 0.5.1 - , regex-compat - , semigroups - , text - , transformers - , tries - , unordered-containers - , wai-transformers >= 0.0.7 - , wai-middleware-content-type >= 0.5.0.1 - , wai-middleware-verbs >= 0.3.1 - - -Test-Suite test - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - HS-Source-Dirs: test - GHC-Options: -Wall -threaded - Main-Is: Test.hs - Other-Modules: Spec - Web.Routes.NestedSpec - Web.Routes.NestedSpec.Basic - Build-Depends: base - , nested-routes - , attoparsec - , bytestring - , composition-extra - , errors - , exceptions - , hashable - , hashtables - , HSet - , http-types - , mtl - , poly-arity - , pred-trie - , pred-set - , regex-compat - , semigroups - , text - , transformers - , tries - , unordered-containers - , wai-transformers - , wai-middleware-content-type - , wai-middleware-verbs - , hspec - , hspec-wai - , tasty - , tasty-hspec +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 3cba23da53b9eb7a5d98a85f0bdb6467464282f0dfcd97e2e82f38e36ffd4b6b +name: nested-routes +version: 8.0.2 +synopsis: Declarative, compositional Wai responses +description: This library attempts to make it easier to write nice Wai response handlers by giving us a Sinatra/ -like syntax for declaring HTTP-verb oriented routes, in addition to file-extension handling and rose-tree like composition. Not only do we have literal route specification, like & , but we can also embed parsers and /directly/ in our routes, with our handlers reflecting their results. +category: Web +homepage: https://github.com/athanclark/nested-routes#readme +bug-reports: https://github.com/athanclark/nested-routes/issues +maintainer: Athan Clark +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 -Executable example - if flag(Example) - Buildable: True - else - Buildable: False - Default-Language: Haskell2010 - HS-Source-Dirs: src - , examples - GHC-Options: -Wall -threaded - Main-Is: Main.hs - Other-Modules: Web.Routes.Nested - Web.Routes.Nested.Types - Web.Routes.Nested.Match - Build-Depends: base - , nested-routes >= 7 - , attoparsec - , bytestring - , composition-extra - , errors - , exceptions - , hashable - , hashtables - , HSet - , http-types - , mtl - , poly-arity - , pred-set - , pred-trie - , regex-compat - , semigroups - , text - , transformers - , tries - , unordered-containers - , wai-transformers - , wai-middleware-content-type - , wai-middleware-verbs - , warp +source-repository head + type: git + location: https://github.com/athanclark/nested-routes +library + exposed-modules: + Web.Routes.Nested + Web.Routes.Nested.Match + Web.Routes.Nested.Types + other-modules: + Paths_nested_routes + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + attoparsec + , base >=4.9 && <5 + , bifunctors + , bytestring + , errors + , exceptions + , extractable-singleton + , hashable + , hashtables + , monad-control-aligned + , mtl + , poly-arity >=0.0.7 + , pred-set >=0.0.1 + , pred-trie >=0.5.1 + , regex-compat + , semigroups + , text + , transformers + , tries + , unordered-containers + , wai-middleware-content-type >=0.5.0.1 + , wai-middleware-verbs >=0.3.1 + , wai-transformers >=0.0.7 + default-language: Haskell2010 -Source-Repository head - Type: git - Location: https://github.com/athanclark/nested-routes.git +test-suite spec + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Spec + Web.Routes.NestedSpec + Web.Routes.NestedSpec.Basic + Web.Routes.Nested + Web.Routes.Nested.Match + Web.Routes.Nested.Types + Paths_nested_routes + hs-source-dirs: + test + src + ghc-options: -Wall + build-depends: + HSet + , attoparsec + , base + , bifunctors + , bytestring + , composition-extra + , errors + , exceptions + , extractable-singleton + , hashable + , hashtables + , hspec + , hspec-wai + , http-types + , monad-control-aligned + , mtl + , poly-arity + , pred-set + , pred-trie + , regex-compat + , semigroups + , tasty + , tasty-hspec + , text + , transformers + , tries + , unordered-containers + , wai-middleware-content-type + , wai-middleware-verbs + , wai-transformers + default-language: Haskell2010 diff --git a/src/Web/Routes/Nested.hs b/src/Web/Routes/Nested.hs --- a/src/Web/Routes/Nested.hs +++ b/src/Web/Routes/Nested.hs @@ -75,9 +75,11 @@ , module Network.Wai.Middleware.ContentType ) where +import Web.Routes.Nested.Match (UrlChunks, origin_) import Web.Routes.Nested.Match +import Web.Routes.Nested.Types (RouterT, execRouterT, Tries (..), ExtrudeSoundly) import Web.Routes.Nested.Types -import Network.Wai.Trans +import Network.Wai.Trans (MiddlewareT, Request, pathInfo) import Network.Wai.Middleware.Verbs import Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData) @@ -88,22 +90,24 @@ import Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..)) import Data.List.NonEmpty (NonEmpty (..), fromList) import qualified Data.Text as T -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import Data.Monoid -import Data.Function.Poly -import Data.Bifunctor (bimap) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Monoid ((<>), First (..)) +import Data.Function.Poly (ArityTypeListIso) +import Data.Bifunctor (bimap) import qualified Control.Monad.State as S -import Control.Monad.Catch -import Control.Monad.Trans -import Control.Arrow -import Control.Monad.ST +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Arrow (first) +import Control.Monad.ST (stToIO) -- | The constraints necessary for 'match'. type Match xs' xs childContent resultContent = - ( Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) + ( xs' ~ CatMaybes xs + , Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) , ArityTypeListIso childContent xs' resultContent ) @@ -131,7 +135,6 @@ -- by a predicate with 'matchGroup', -- then we would need another level of arity /before/ the @Double@. match :: ( Monad m - , xs' ~ CatMaybes xs , Match xs' xs childContent resultContent ) => UrlChunks xs -- ^ Predicative path to match against -> childContent -- ^ The response to send @@ -172,7 +175,6 @@ -- doing this with a parser or regular expression will necessitate the existing -- arity in the handlers before the progam can compile. matchGroup :: ( Monad m - , xs' ~ CatMaybes xs , MatchGroup xs' xs childContent resultContent childSec resultSec ) => UrlChunks xs -- ^ Predicative path to match against -> RouterT childContent childSec m () -- ^ Child routes to nest @@ -225,8 +227,7 @@ -- with 'routeAuth': -- -- > route routes . routeAuth routes -route :: ( Monad m - , MonadIO m +route :: ( MonadIO m ) => RouterT (MiddlewareT m) sec m a -- ^ The Router -> MiddlewareT m route hs app req resp = do @@ -246,8 +247,7 @@ -- an exception based on the current 'Network.Wai.Middleware.Request' and -- the /layers/ of 'auth' tokens passed in your router, turn your router -- into a 'Control.Monad.guard' for middlewares, basically. -routeAuth :: ( Monad m - , MonadIO m +routeAuth :: ( MonadIO m , MonadThrow m ) => (Request -> [sec] -> m ()) -- ^ authorization method -> RouterT (MiddlewareT m) (SecurityToken sec) m a -- ^ The Router @@ -259,8 +259,7 @@ -- * Extraction ------------------------------- -- | Extracts only the normal 'match', 'matchGroup' and 'matchHere' routes. -extractMatch :: ( Monad m - , MonadIO m +extractMatch :: ( MonadIO m ) => [T.Text] -- ^ The path to match against -> RouterT r sec m a -- ^ The Router -> m (Maybe r) @@ -279,8 +278,7 @@ -- | Extracts only the 'matchAny' responses; something like the greatest-lower-bound. -extractMatchAny :: ( Monad m - , MonadIO m +extractMatchAny :: ( MonadIO m ) => [T.Text] -- ^ The path to match against -> RouterT r sec m a -- ^ The Router -> m (Maybe r) @@ -292,8 +290,7 @@ -- | Find the security tokens / authorization roles affiliated with -- a request for a set of routes. -extractAuthSym :: ( Monad m - , MonadIO m +extractAuthSym :: ( MonadIO m ) => [T.Text] -- ^ The path to match against -> RouterT x (SecurityToken sec) m a -- ^ The Router -> m [sec] @@ -309,8 +306,7 @@ {-# INLINEABLE extractAuthSym #-} -- | Extracts only the security handling logic, and turns it into a guard. -extractAuth :: ( Monad m - , MonadIO m +extractAuth :: ( MonadIO m , MonadThrow m ) => (Request -> [sec] -> m ()) -- ^ authorization method -> Request @@ -327,7 +323,6 @@ -- to the responses based on a /furthest-route-reached/ method, or like a -- greatest-lower-bound. extractNearestVia :: ( MonadIO m - , Monad m ) => [T.Text] -- ^ The path to match against -> (RouterT r sec m a -> m (RootedPredTrie T.Text r)) -> RouterT r sec m a diff --git a/src/Web/Routes/Nested/Match.hs b/src/Web/Routes/Nested/Match.hs --- a/src/Web/Routes/Nested/Match.hs +++ b/src/Web/Routes/Nested/Match.hs @@ -35,13 +35,13 @@ , UrlChunks ) where -import Prelude hiding (pred) -import Data.Attoparsec.Text -import Text.Regex -import qualified Data.Text as T -import Control.Monad -import Control.Error (hush) -import Data.Trie.Pred +import Prelude hiding (pred) +import Data.Attoparsec.Text (Parser, parseOnly) +import Text.Regex (Regex, matchRegex) +import qualified Data.Text as T +import Control.Monad (guard) +import Control.Error (hush) +import Data.Trie.Pred (PathChunk, PathChunks, pred, nil, only, (./)) o_, origin_ :: UrlChunks '[] diff --git a/src/Web/Routes/Nested/Types.hs b/src/Web/Routes/Nested/Types.hs --- a/src/Web/Routes/Nested/Types.hs +++ b/src/Web/Routes/Nested/Types.hs @@ -28,19 +28,20 @@ ExtrudeSoundly ) where -import Web.Routes.Nested.Match -import Network.Wai.Middleware.Verbs -import Network.Wai.Middleware.ContentType -import Network.Wai.Trans -import Data.Trie.Pred.Base (RootedPredTrie (..)) -import Data.Trie.Pred.Interface.Types (Extrude (..), CatMaybes) +import Web.Routes.Nested.Match (UrlChunks) +import Network.Wai.Middleware.Verbs (VerbListenerT, execVerbListenerT, lookupVerb, getVerb) +import Network.Wai.Middleware.ContentType (FileExtListenerT, fileExtsToMiddleware) +import Network.Wai.Trans (MiddlewareT) +import Data.Trie.Pred.Base (RootedPredTrie (..)) +import Data.Trie.Pred.Interface.Types (Extrude (..), CatMaybes) -import Data.Monoid -import qualified Data.Text as T -import Data.Function.Poly -import Data.Singleton.Class (Extractable) -import Control.Monad.Trans -import qualified Control.Monad.State as S +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Function.Poly (ArityTypeListIso) +import Data.Singleton.Class (Extractable) +import Control.Monad.Trans (MonadTrans) +import Control.Monad.IO.Class (MonadIO) +import qualified Control.Monad.State as S import Control.Monad.Trans.Control.Aligned (MonadBaseControl) @@ -94,8 +95,7 @@ -- | Run the content builder into a middleware that responds when the content -- is satisfiable (i.e. @Accept@ headers are O.K., etc.) -action :: Monad m - => MonadBaseControl IO m stM +action :: MonadBaseControl IO m stM => Extractable stM => ActionT m () -> MiddlewareT m action xs app req respond = do diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,9 +1,8 @@ module Main where -import Test.Hspec (hspec) import Spec (spec) -import Test.Tasty -import Test.Tasty.Hspec +import Test.Tasty (defaultMain) +import Test.Tasty.Hspec (testSpec) main :: IO () diff --git a/test/Web/Routes/NestedSpec.hs b/test/Web/Routes/NestedSpec.hs --- a/test/Web/Routes/NestedSpec.hs +++ b/test/Web/Routes/NestedSpec.hs @@ -4,10 +4,10 @@ module Web.Routes.NestedSpec (spec) where -import Web.Routes.NestedSpec.Basic +import Web.Routes.NestedSpec.Basic (app) -import Test.Hspec -import Test.Hspec.Wai as HW +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai (get, shouldRespondWith, with) diff --git a/test/Web/Routes/NestedSpec/Basic.hs b/test/Web/Routes/NestedSpec/Basic.hs --- a/test/Web/Routes/NestedSpec/Basic.hs +++ b/test/Web/Routes/NestedSpec/Basic.hs @@ -8,13 +8,13 @@ module Web.Routes.NestedSpec.Basic where -import Web.Routes.Nested -import Network.Wai.Trans -import Network.HTTP.Types -import Text.Regex -import Data.Attoparsec.Text hiding (match) -import Control.Monad.Catch -import GHC.Generics +import Web.Routes.Nested (o_, p_, l_, r_, (), match, matchHere, matchGroup, auth, AuthScope (..), textOnly, routeAuth) +import Network.Wai.Trans (Middleware, Application, Request, catchMiddlewareT) +import Network.HTTP.Types (status401, status404, status200) +import Text.Regex (mkRegex) +import Data.Attoparsec.Text (double) +import Control.Monad.Catch (Exception, MonadThrow (throwM)) +import GHC.Generics (Generic) data AuthRole = AuthRole deriving (Show, Eq)