diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -7,18 +7,15 @@ module Main where -import Network.Wai +import Web.Routes.Nested +import Network.Wai.Trans import Network.Wai.Handler.Warp import Network.HTTP.Types -import Web.Routes.Nested -import Data.Attoparsec.Text -import Text.Regex -import Data.Monoid +import Text.Regex import qualified Data.Text.Lazy as LT -import Control.Monad.Error.Class -import Control.Monad.IO.Class - -import Debug.Trace +import Data.Attoparsec.Text +import Data.Monoid +import Control.Monad.Except data AuthRole = AuthRole deriving (Show, Eq) @@ -45,16 +42,16 @@ main :: IO () main = - let app = routeAuth authorize routes + let app = routeActionAuth authorize routes routes = - handle o (Just rootHandle) $ Just $ do - handle fooRoute (Just fooHandle) $ Just $ do + handleAction o (Just rootHandle) $ Just $ do + handleAction fooRoute (Just fooHandle) $ Just $ do auth AuthRole unauthHandle ProtectChildren - handle barRoute (Just barHandle) Nothing - handle doubleRoute (Just doubleHandle) Nothing - handle emailRoute (Just emailHandle) Nothing - handle bazRoute (Just bazHandle) Nothing - notFound o (Just notFoundHandle) Nothing + handleAction barRoute (Just barHandle) Nothing + handleAction doubleRoute (Just doubleHandle) Nothing + handleAction emailRoute (Just emailHandle) Nothing + handleAction bazRoute (Just bazHandle) Nothing + notFoundAction o (Just notFoundHandle) Nothing in run 3000 $ app defApp where rootHandle = get $ text "Home" @@ -69,7 +66,7 @@ text "bar!" json ("json bar!" :: LT.Text) - -- `/foo/1234e12` + -- `/foo/1234e12`, uses attoparsec doubleRoute = p ("double", double) o doubleHandle d = get $ text $ LT.pack (show d) <> " foos" @@ -77,14 +74,15 @@ emailRoute = r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") o emailHandle e = get $ text $ LT.pack (show e) <> " email" - -- `/baz` + -- `/baz`, uses regex-compat bazRoute = l "baz" o bazHandle = do get $ text "baz!" let uploader req = do liftIO $ print =<< strictRequestBody req - return $ Just () - uploadHandle Nothing = text "Upload Failed" - uploadHandle (Just ()) = text "Woah! Upload content!" + return () + uploadHandle (Left Nothing) = text "Upload Failed" + uploadHandle (Left (Just _)) = text "Impossible - no errors thrown in uploader" + uploadHandle (Right ()) = text "Woah! Upload content!" post uploader uploadHandle unauthHandle NeedsAuth = get $ textStatus status401 "Unauthorized!" diff --git a/examples/STM.hs b/examples/STM.hs --- a/examples/STM.hs +++ b/examples/STM.hs @@ -10,13 +10,11 @@ import STM.Auth import STM.Templates -import Network.Wai +import Network.Wai.Trans import Network.Wai.Handler.Warp -import Network.Wai.Session import Network.Wai.Parse import Network.HTTP.Types import Web.Routes.Nested -import Web.Cookie import Data.Attoparsec.Text import Text.Regex import Data.Monoid @@ -24,8 +22,6 @@ import qualified Data.ByteString as BS import qualified Data.IntMap as IntMap import Data.ByteArray (convert) -import Data.Time -import Data.Maybe import Data.Function.Syntax import Control.Concurrent.STM @@ -35,13 +31,10 @@ import Control.Monad.Reader import Control.Monad.Trans.Maybe import Crypto.Random -import Crypto.Random.Types import Crypto.Hash -data LoginError a = InvalidLoginAttempt - | Success a - +data LoginError = InvalidLoginAttempt defApp :: Application defApp _ respond = respond $ textOnlyStatus status404 "404 :(" @@ -54,22 +47,19 @@ let n' = hash n :: Digest SHA512 n'' = convert n' :: BS.ByteString return n'' - let app a r1 r2 = runReaderT (routeAuth authenticate routes (liftIO .* a) r1 r2) $ AuthEnv cacheVar uIdVar salt - -- routes :: ( MonadReader AuthEnv m - -- , MonadIO m - -- ) => RoutesT (LoginError (UserSession BS.ByteString)) SecurityLayer AuthenticationError m () + let app a r1 r2 = runReaderT (routeActionAuth authenticate routes (liftIO .* a) r1 r2) $ AuthEnv cacheVar uIdVar salt routes = do - handle o (Just rootHandle) Nothing - handle fooRoute (Just fooHandle) $ Just $ do + handleAction o (Just rootHandle) Nothing + handleAction fooRoute (Just fooHandle) $ Just $ do auth ShouldBeLoggedIn unauthHandle ProtectChildren - handle barRoute (Just barHandle) Nothing - handle doubleRoute (Just doubleHandle) Nothing - handle emailRoute (Just emailHandle) Nothing - handle bazRoute (Just bazHandle) Nothing - handle loginRoute (Just loginHandle) Nothing - handle logoutRoute (Just logoutHandle) $ Just $ + handleAction barRoute (Just barHandle) Nothing + handleAction doubleRoute (Just doubleHandle) Nothing + handleAction emailRoute (Just emailHandle) Nothing + handleAction bazRoute (Just bazHandle) Nothing + handleAction loginRoute (Just loginHandle) Nothing + handleAction logoutRoute (Just logoutHandle) $ Just $ auth ShouldBeLoggedIn unauthHandle ProtectParent - notFound o (Just notFoundHandle) Nothing + notFoundAction o (Just notFoundHandle) Nothing run 3000 $ app defApp where rootHandle = get $ text "Home" @@ -97,9 +87,11 @@ bazHandle = do get $ text "baz!" let uploader req = do liftIO $ print =<< strictRequestBody req - return Nothing - uploadHandle Nothing = text "Upload Failed" - uploadHandle (Just _) = text "Woah! Upload content!" + return undefined + uploadHandle (Left Nothing) = text "Upload Failed" + uploadHandle (Left (Just _)) = text "Should never happen" + uploadHandle (Right _) = text "Woah! Upload content!" + -- Hidden flaw ^ UserSession & LoginError are only options post uploader uploadHandle loginRoute = "login" o @@ -107,16 +99,16 @@ get $ lucid loginPage postReq (login 128) loginResp where - loginResp _ Nothing = textStatus status500 "Server malfunction :E" - loginResp _ (Just InvalidLoginAttempt) = textStatusWith clearSessionResponse status403 "Bad login" - loginResp _ (Just (Success u)) = textWith (mapResponseHeaders (++ makeSessionCookies u)) "logged-in" + loginResp _ (Left Nothing) = textStatus status500 "Server malfunction :E" + loginResp _ (Left (Just InvalidLoginAttempt)) = textStatusWith clearSessionResponse status403 "Bad login" + loginResp _ (Right u) = textWith (mapResponseHeaders (++ makeSessionCookies u)) "logged-in" login s req = case requestBodyLength req of KnownLength b | b <= s -> do (ps,_) <- liftIO $ parseRequestBody (const $ const $ const $ return ()) req if firstIs (\(x,y) -> BS.null x || BS.null y) ps || length ps < 2 - then return $ Just InvalidLoginAttempt + then throwError $ Just InvalidLoginAttempt else do mSuccess <- runMaybeT $ do user <- hoistMaybe $ lookup "user" ps @@ -124,9 +116,9 @@ liftIO $ putStrLn $ "<~!~> Attempted Login: " ++ show user ++ ", " ++ show pass ++ "\n" nUserSess <- newUserSession lift $ writeUserSession nUserSess - return $ Success nUserSess - return $ Just $ fromMaybe InvalidLoginAttempt mSuccess - _ -> return $ Just InvalidLoginAttempt + return nUserSess + note' (Just InvalidLoginAttempt) mSuccess + _ -> throwError $ Just InvalidLoginAttempt where firstIs _ [] = True firstIs f (x:_) = f x @@ -147,3 +139,4 @@ unauthHandle InvalidRequestNonce = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - you're doing something sneaky!" unauthHandle NoSessionHeaders = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - are you sure you're logged in?" notFoundHandle = get $ textStatus status404 "Not Found :(" + diff --git a/examples/STM/Auth.hs b/examples/STM/Auth.hs --- a/examples/STM/Auth.hs +++ b/examples/STM/Auth.hs @@ -5,7 +5,7 @@ module STM.Auth where -import Network.Wai +import Network.Wai.Trans import Network.Wai.Handler.Warp import Network.Wai.Session import Network.HTTP.Types diff --git a/nested-routes.cabal b/nested-routes.cabal --- a/nested-routes.cabal +++ b/nested-routes.cabal @@ -1,5 +1,5 @@ Name: nested-routes -Version: 4.0.0 +Version: 5.0.0 Author: Athan Clark Maintainer: Athan Clark License: BSD3 @@ -43,84 +43,57 @@ Exposed-Modules: Web.Routes.Nested Web.Routes.Nested.Types Web.Routes.Nested.Types.UrlChunks - Web.Routes.Nested.VerbListener - Web.Routes.Nested.FileExtListener - Web.Routes.Nested.FileExtListener.Types - Web.Routes.Nested.FileExtListener.Text - Web.Routes.Nested.FileExtListener.Json - Web.Routes.Nested.FileExtListener.Builder - Web.Routes.Nested.FileExtListener.Blaze - Web.Routes.Nested.FileExtListener.ByteString - Web.Routes.Nested.FileExtListener.Lucid - Web.Routes.Nested.FileExtListener.Clay - Web.Routes.Nested.FileExtListener.Julius - Web.Routes.Nested.FileExtListener.Lucius - Web.Routes.Nested.FileExtListener.Cassius Build-Depends: base >= 4.6 && < 5 - , wai - , wai-extra - , wai-util - , http-types - , http-media - , mtl - , transformers - , witherable - , composition + , attoparsec + , bytestring , composition-extra >= 2.0.0 - , semigroups - , constraints , containers - , text - , aeson - , blaze-html - , lucid - , shakespeare - , clay - , bytestring - , bifunctors - , attoparsec - , regex-compat + , mtl + , poly-arity >= 0.0.7 , pred-trie >= 0.3 + , regex-compat + , semigroups + , text + , transformers , tries - , poly-arity >= 0.0.6 - , sets >= 0.0.5 - , errors + , wai-transformers + , wai-middleware-content-type >= 0.0.3 + , wai-middleware-verbs >= 0.0.4 -Test-Suite spec - Type: exitcode-stdio-1.0 + +Test-Suite test + Type: exitcode-stdio-1.0 Default-Language: Haskell2010 - Hs-Source-Dirs: src + HS-Source-Dirs: src , test - Ghc-Options: -Wall - Main-Is: Spec.hs + GHC-Options: -Wall -threaded + Main-Is: Test.hs + Other-Modules: Spec + Web.Routes.NestedSpec + Web.Routes.NestedSpec.Basic + Web.Routes.Nested + Web.Routes.Nested.Types + Web.Routes.Nested.Types.UrlChunks Build-Depends: base - , hspec - , hspec-wai - , shakespeare - , lucid + , nested-routes , attoparsec - , regex-compat - , containers - , composition - , composition-extra - , semigroups - , text - , aeson - , wai-util - , blaze-html , bytestring + , composition-extra + , containers + , http-types + , mtl , poly-arity - , witherable - , constraints , pred-trie - , mtl - , wai - , warp + , regex-compat + , semigroups + , text , transformers - , http-media - , http-types - , sets - , errors + , tries + , wai-transformers + , wai-middleware-content-type + , wai-middleware-verbs + , hspec + , hspec-wai Executable example @@ -133,36 +106,30 @@ , examples GHC-Options: -Wall Main-Is: Main.hs + Other-Modules: Web.Routes.Nested + Web.Routes.Nested.Types + Web.Routes.Nested.Types.UrlChunks Build-Depends: base - , wai - , wai-extra - , wai-util - , warp + , nested-routes + , attoparsec + , bytestring + , composition-extra + , containers , http-types - , http-media , mtl - , transformers - , witherable - , composition - , composition-extra + , poly-arity + , pred-trie + , regex-compat , semigroups - , constraints - , containers , text - , aeson - , blaze-html - , lucid - , shakespeare - , clay - , bytestring - , attoparsec - , regex-compat - , pred-trie + , transformers , tries - , poly-arity - , sets - , errors + , wai-transformers + , wai-middleware-content-type + , wai-middleware-verbs + , warp + Executable example-stm if flag(Example-STM) Buildable: True @@ -175,59 +142,41 @@ Main-Is: STM.hs Other-Modules: STM.Auth Web.Routes.Nested - Web.Routes.Nested.FileExtListener - Web.Routes.Nested.FileExtListener.Blaze - Web.Routes.Nested.FileExtListener.Builder - Web.Routes.Nested.FileExtListener.ByteString - Web.Routes.Nested.FileExtListener.Json - Web.Routes.Nested.FileExtListener.Lucid - Web.Routes.Nested.FileExtListener.Text - Web.Routes.Nested.FileExtListener.Types Web.Routes.Nested.Types Web.Routes.Nested.Types.UrlChunks - Web.Routes.Nested.VerbListener Build-Depends: base - , wai - , wai-extra - , wai-session + , base64-bytestring + , blaze-builder + , nested-routes + , attoparsec + , bytestring + , composition-extra + , containers , cookie - , wai-util - , warp + , cryptonite + , data-default + , errors , http-types - , http-media + , iso8601-time + , lucid + , memory , mtl - , transformers - , witherable - , composition - , composition-extra + , poly-arity + , pred-trie + , regex-compat , semigroups - , constraints - , containers + , stm , text - , aeson - , blaze-html - , lucid - , shakespeare - , clay - , bytestring - , attoparsec - , regex-compat - , pred-trie - , tries - , poly-arity - , sets - , errors - , cryptonite - , memory , time - , iso8601-time + , transformers + , tries + , wai-extra + , wai-middleware-content-type + , wai-middleware-verbs + , wai-transformers + , wai-session + , warp , utf8-string - , stm - , errors - , cookie - , data-default - , blaze-builder - , base64-bytestring Source-Repository head Type: git 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 @@ -1,297 +1,413 @@ {-# LANGUAGE - DeriveFunctor - , GADTs - , GeneralizedNewtypeDeriving - , ScopedTypeVariables + GADTs + , PolyKinds + , TypeFamilies + , DeriveFunctor , TypeOperators - , OverloadedStrings , TupleSections + , DoAndIfThenElse + , ConstraintKinds , FlexibleContexts - , TypeFamilies - , PolyKinds - , UndecidableInstances + , OverloadedStrings + , ScopedTypeVariables + , GeneralizedNewtypeDeriving #-} +-- | +-- Module : Web.Routes.Nested +-- Copyright : (c) 2015 Athan Clark +-- +-- License : BSD-style +-- Maintainer : athan.clark@gmail.com +-- Stability : experimental +-- Portability : GHC +-- +-- This module exports most of what you'll need for sophisticated routing - +-- all the tools from +-- (routing for the incoming HTTP method) and +-- +-- (routing for the incoming Accept header, and implied file extension), +-- itself, and +-- - some simple +-- type aliases wrapped around WAI's @Application@ and @Middleware@ types, allowing us +-- to embed monad transformer stacks for our applications. +-- +-- The routing system lets you embed these complicated HTTP verb / content-type +-- sensative responses just as easily as a WAI @Middleware@. There is enough +-- tooling provided to use one paradigm or the other. Note - nested-routes +-- does not affect the @pathInfo@ of the incoming @Request@ in any way, but merely +-- matches on it and passes control to the designated response. +-- +-- To match a route, you have a few options - you can match against a string literal, +-- a regular expression (via ), +-- or an parser. This list +-- will most likely grow in the future, depending on demand. +-- +-- There is also support for embedding security layers in your routes, in the same +-- nested manner. By "tagging" a set of routes with an authorization role (with @auth@), +-- you populate a list of roles breached during any request. In the authentication +-- parameter in @routeAuth@ and @routeActionAuth@, the function +-- keeps the session integrity in-place, while @auth@ lets you create your authorization +-- boundaries. Both are symbiotic and neccessary for establishing security, and both allow +-- you to tap into the monad transformer stack to do logging, STM, database queries, +-- etc. +-- +-- To use your set of routes in a WAI application, you need to "extract" the +-- functionality from your route set - using the @route@, @routeAuth@, @routeAction@, +-- and @routeActionAuth@ +-- functions, you can create monolithic apps very easily. +-- But, if you would like to extract the security middleware to place before +-- say, a /static/ middleware you already have in place, use the @extractAuth@ +-- functions, and others for their respective purposes. This way, you can decompose +-- the routing system into each subject matter, and re-compose (@.@) them in whichever +-- order you like for your application. + + + module Web.Routes.Nested - ( -- * Types - module X + ( module X + -- * Types , Tries , HandlerT (..) + , execHandlerT , ActionT - , RoutesT - , ApplicationT - , MiddlewareT + , RoutableT + , RoutableActionT , AuthScope (..) + , ExtrudeSoundly -- * Combinators , handle + , handleAction , parent , auth , notFound - -- * Entry Point + , notFoundAction + , action + -- * Routing , route , routeAuth + , routeAction + , routeActionAuth -- * Extraction , extractContent , extractNotFound , extractAuthSym , extractAuth , extractNearestVia - -- * Utilities , actionToMiddleware - , lookupVerb - , lookupFileExt - , lookupUpload - , lookupResponse - -- ** File Extensions - , possibleFileExts - , trimFileExt - , getFileExt - , httpMethodToMSym ) where -import Web.Routes.Nested.Types as X -import Web.Routes.Nested.FileExtListener as X -import Web.Routes.Nested.FileExtListener.Types as X -import Web.Routes.Nested.VerbListener as X - -import Network.HTTP.Types -import Network.HTTP.Media -import Network.Wai +import Web.Routes.Nested.Types as X +import Network.Wai.Trans as X +import Network.Wai.Middleware.Verbs as X +import Network.Wai.Middleware.ContentType as X -import Data.Trie.Pred (RootedPredTrie (..), PredTrie (..)) -import qualified Data.Trie.Pred as PT -- only using lookups -import Data.Trie.Pred.Step (PredSteps (..), PredStep (..)) -import qualified Data.Trie.Class as TC -import qualified Data.Text as T -import qualified Data.Map as Map -import Data.Trie.Map (MapStep (..)) -import qualified Data.ByteString as B -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) -import Data.Witherable hiding (filter) +import Data.Trie.Pred (RootedPredTrie (..), PredTrie (..)) +import qualified Data.Trie.Pred as PT -- only using lookups +import Data.Trie.Pred.Step (PredStep (..), PredSteps (..)) +import qualified Data.Trie.Class as TC +import Data.Trie.Map (MapStep (..)) +import qualified Data.Map as Map +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Foldable import Data.Functor.Syntax import Data.Function.Poly -import Data.List hiding (filter) -import Control.Error.Util import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans import Control.Monad.Trans.Except -import Control.Monad.Trans.Maybe -import Control.Monad.Writer +import qualified Control.Monad.State as S -type Tries x s e e' = ( RootedPredTrie T.Text x - , RootedPredTrie T.Text x - , RootedPredTrie T.Text s - , RootedPredTrie T.Text e - ) +type Tries x s e = ( RootedPredTrie T.Text x + , RootedPredTrie T.Text x + , RootedPredTrie T.Text s + , RootedPredTrie T.Text e + ) -newtype HandlerT x sec err errSym uploadSym m a = HandlerT - { runHandlerT :: WriterT (Tries x sec err errSym) m a } +newtype HandlerT x sec err aux m a = HandlerT + { runHandlerT :: S.StateT (Tries x sec err) m a } deriving ( Functor , Applicative , Monad , MonadIO , MonadTrans - , MonadWriter (Tries x sec err errSym) + , S.MonadState (Tries x sec err) ) -execHandlerT :: Monad m => HandlerT x sec err errSym uploadSym m a -> m (Tries x sec err errSym) -execHandlerT = execWriterT . runHandlerT +execHandlerT :: Monad m => HandlerT x sec err aux m a -> m (Tries x sec err) +execHandlerT hs = S.execStateT (runHandlerT hs) mempty -type ActionT u m a = VerbListenerT (FileExtListenerT Response m a) u m a +type ActionT e u m a = VerbListenerT (FileExtListenerT (MiddlewareT m) m a) e u m a -type RoutesT u s e m a = HandlerT (ActionT u m a) (s, AuthScope) (e -> ActionT u m a) e u m a +-- | Turn an @ActionT@ into a @MiddlewareT@ - could be used to make middleware-based +-- route sets cooperate with the content-type and verb combinators. +action :: MonadIO m => ActionT e u m () -> MiddlewareT m +action xs = verbsToMiddleware $ mapVerbs fileExtsToMiddleware xs --- | For routes ending with a literal. + +type RoutableT s e u ue m a = + HandlerT (MiddlewareT m) (s, AuthScope) (e -> MiddlewareT m) (e,u,ue) m a + +type RoutableActionT s e u ue m a = + HandlerT (ActionT ue u m ()) (s, AuthScope) (e -> ActionT ue u m ()) (e,u,ue) m a + +type ExtrudeSoundly cleanxs xs c r = + ( cleanxs ~ CatMaybes xs + , ArityTypeListIso c cleanxs r + , Extrude (UrlChunks xs) + (RootedPredTrie T.Text c) + (RootedPredTrie T.Text r) + ) + + +-- | Embed an @ActionT@ into a set of routes directly, without first converting +-- it to a @MiddlewareT@. +handleAction :: ( Monad m + , Functor m + , cleanxs ~ CatMaybes xs + , HasResult childContent (ActionT ue u m ()) + , HasResult childErr (e -> ActionT ue u m ()) + , ExpectArity cleanxs childContent + , ExpectArity cleanxs childSec + , ExpectArity cleanxs childErr + , Singleton (UrlChunks xs) + childContent + (RootedPredTrie T.Text resultContent) + , ExtrudeSoundly cleanxs xs childContent resultContent + , ExtrudeSoundly cleanxs xs childSec resultSec + , ExtrudeSoundly cleanxs xs childErr resultErr + ) => UrlChunks xs + -> Maybe childContent + -> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ()) + -> HandlerT resultContent resultSec resultErr (e,u,ue) m () +handleAction ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty) +handleAction ts mvl (Just cs) = do + (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs + tell' ( extrude ts $ RootedPredTrie mvl trieContent + , extrude ts trieNotFound + , extrude ts trieSec + , extrude ts trieErr + ) +handleAction _ Nothing Nothing = return () + +-- | Embed a @MiddlewareT@ into a set of routes. handle :: ( Monad m , Functor m , cleanxs ~ CatMaybes xs - , HasResult childContent (ActionT u m ()) - , HasResult childErr (e -> ActionT u m ()) + , HasResult childContent (MiddlewareT m) + , HasResult childErr (e -> MiddlewareT m) , ExpectArity cleanxs childContent , ExpectArity cleanxs childSec , ExpectArity cleanxs childErr , Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childContent) - (RootedPredTrie T.Text resultContent) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childSec) - (RootedPredTrie T.Text resultSec) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childErr) - (RootedPredTrie T.Text resultErr) - , (ArityMinusTypeList childContent cleanxs) ~ resultContent - , (ArityMinusTypeList childSec cleanxs) ~ resultSec - , (ArityMinusTypeList childErr cleanxs) ~ resultErr - , childContent ~ TypeListToArity cleanxs resultContent - , childSec ~ TypeListToArity cleanxs resultSec - , childErr ~ TypeListToArity cleanxs resultErr + , ExtrudeSoundly cleanxs xs childContent resultContent + , ExtrudeSoundly cleanxs xs childSec resultSec + , ExtrudeSoundly cleanxs xs childErr resultErr ) => UrlChunks xs -> Maybe childContent - -> Maybe (HandlerT childContent childSec childErr e u m ()) - -> HandlerT resultContent resultSec resultErr e u m () -handle ts (Just vl) Nothing = tell (singleton ts vl, mempty, mempty, mempty) + -> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ()) + -> HandlerT resultContent resultSec resultErr (e,u,ue) m () +handle ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty) handle ts mvl (Just cs) = do (RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs - tell ( extrude ts $ RootedPredTrie mvl trieContent - , extrude ts trieNotFound - , extrude ts trieSec - , extrude ts trieErr - ) + tell' ( extrude ts $ RootedPredTrie mvl trieContent + , extrude ts trieNotFound + , extrude ts trieSec + , extrude ts trieErr + ) handle _ Nothing Nothing = return () +-- | Prepend a path to an existing set of routes. parent :: ( Monad m , Functor m , cleanxs ~ CatMaybes xs , Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childContent) - (RootedPredTrie T.Text resultContent) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childErr) - (RootedPredTrie T.Text resultErr) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childSec) - (RootedPredTrie T.Text resultSec) - , (ArityMinusTypeList childContent cleanxs) ~ resultContent - , (ArityMinusTypeList childSec cleanxs) ~ resultSec - , (ArityMinusTypeList childErr cleanxs) ~ resultErr - , childContent ~ TypeListToArity cleanxs resultContent - , childSec ~ TypeListToArity cleanxs resultSec - , childErr ~ TypeListToArity cleanxs resultErr + , ExtrudeSoundly cleanxs xs childContent resultContent + , ExtrudeSoundly cleanxs xs childSec resultSec + , ExtrudeSoundly cleanxs xs childErr resultErr ) => UrlChunks xs - -> HandlerT childContent childSec childErr e u m () - -> HandlerT resultContent resultSec resultErr e u m () + -> HandlerT childContent childSec childErr aux m () + -> HandlerT resultContent resultSec resultErr aux m () parent ts cs = do (trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs - tell ( extrude ts trieContent - , extrude ts trieNotFound - , extrude ts trieSec - , extrude ts trieErr - ) + tell' ( extrude ts trieContent + , extrude ts trieNotFound + , extrude ts trieSec + , extrude ts trieErr + ) +-- | Designate the scope of security to the set of routes - either only the adjacent +-- routes, or the adjacent /and/ the parent container node (root node if not +-- declared). data AuthScope = ProtectParent | ProtectChildren deriving (Show, Eq) --- | Sets the security role and error handler for a scope of routes. +-- | Sets the security role and error handler for a set of routes, optionally +-- including its parent route. auth :: ( Monad m , Functor m ) => sec -> err -> AuthScope - -> HandlerT content (sec, AuthScope) err e u m () + -> HandlerT content (sec, AuthScope) err aux m () auth token handleFail scope = - tell ( mempty - , mempty - , RootedPredTrie (Just (token,scope)) mempty - , RootedPredTrie (Just handleFail) mempty - ) + tell' ( mempty + , mempty + , RootedPredTrie (Just (token,scope)) mempty + , RootedPredTrie (Just handleFail) mempty + ) +-- | Embed an @ActionT@ as a not-found handler into a set of routes, without first converting +-- it to a @MiddlewareT@. +notFoundAction :: ( Monad m + , Functor m + , cleanxs ~ CatMaybes xs + , HasResult childContent (ActionT ue u m ()) + , HasResult childErr (e -> ActionT ue u m ()) + , ExpectArity cleanxs childContent + , ExpectArity cleanxs childSec + , ExpectArity cleanxs childErr + , Singleton (UrlChunks xs) + childContent + (RootedPredTrie T.Text resultContent) + , ExtrudeSoundly cleanxs xs childContent resultContent + , ExtrudeSoundly cleanxs xs childSec resultSec + , ExtrudeSoundly cleanxs xs childErr resultErr + ) => UrlChunks xs + -> Maybe childContent + -> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ()) + -> HandlerT resultContent resultSec resultErr (e,u,ue) m () +notFoundAction ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty) +notFoundAction ts mvl (Just cs) = do + (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs + tell' ( extrude ts trieContent + , extrude ts $ RootedPredTrie mvl trieNotFound + , extrude ts trieSec + , extrude ts trieErr + ) +notFoundAction _ Nothing Nothing = return () + +-- | Embed a @MiddlewareT@ as a not-found handler into a set of routes. notFound :: ( Monad m , Functor m , cleanxs ~ CatMaybes xs - , HasResult childContent (ActionT u m ()) - , HasResult childErr (e -> ActionT u m ()) + , HasResult childContent (MiddlewareT m) + , HasResult childErr (e -> MiddlewareT m) , ExpectArity cleanxs childContent , ExpectArity cleanxs childSec , ExpectArity cleanxs childErr , Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childContent) - (RootedPredTrie T.Text resultContent) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childSec) - (RootedPredTrie T.Text resultSec) - , Extrude (UrlChunks xs) - (RootedPredTrie T.Text childErr) - (RootedPredTrie T.Text resultErr) - , (ArityMinusTypeList childContent cleanxs) ~ resultContent - , (ArityMinusTypeList childSec cleanxs) ~ resultSec - , (ArityMinusTypeList childErr cleanxs) ~ resultErr - , childContent ~ TypeListToArity cleanxs resultContent - , childSec ~ TypeListToArity cleanxs resultSec - , childErr ~ TypeListToArity cleanxs resultErr + , ExtrudeSoundly cleanxs xs childContent resultContent + , ExtrudeSoundly cleanxs xs childSec resultSec + , ExtrudeSoundly cleanxs xs childErr resultErr ) => UrlChunks xs -> Maybe childContent - -> Maybe (HandlerT childContent childSec childErr e u m ()) - -> HandlerT resultContent resultSec resultErr e u m () -notFound ts (Just vl) Nothing = tell (mempty, singleton ts vl, mempty, mempty) + -> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ()) + -> HandlerT resultContent resultSec resultErr (e,u,ue) m () +notFound ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty) notFound ts mvl (Just cs) = do (trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs - tell ( extrude ts trieContent - , extrude ts $ RootedPredTrie mvl trieNotFound - , extrude ts trieSec - , extrude ts trieErr - ) + tell' ( extrude ts trieContent + , extrude ts $ RootedPredTrie mvl trieNotFound + , extrude ts trieSec + , extrude ts trieErr + ) notFound _ Nothing Nothing = return () - - -type ApplicationT m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived -type MiddlewareT m = ApplicationT m -> ApplicationT m - -type AcceptHeader = B.ByteString - +-- * Routing --------------------------------------- --- | Turns a @HandlerT@ into a Wai @Application@ +-- | Turns a @HandlerT@ containing @MiddlewareT@s into a @MiddlewareT@. route :: ( Functor m , Monad m , MonadIO m - ) => HandlerT (ActionT u m ()) sec err e u m a -- ^ Assembled @handle@ calls + ) => HandlerT (MiddlewareT m) sec err aux m () -- ^ Assembled @handle@ calls -> MiddlewareT m route hs = extractContent hs . extractNotFound hs --- | Given a security verification function which returns an updating function, --- turn a set of routes into a middleware, where a session is secured before --- responding. +-- | Given a security verification function that returns a method to updating the session, +-- turn a set of routes containing @MiddlewareT@s into a @MiddlewareT@, where a session +-- is secured before responding. routeAuth :: ( Functor m , Monad m , MonadIO m ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize - -> RoutesT u sec e m () -- ^ Assembled @handle@ calls + -> RoutableT sec e u ue m () -- ^ Assembled @handle@ calls -> MiddlewareT m routeAuth authorize hs = extractAuth authorize hs . route hs --- | Turn the trie carrying the main content into a middleware. +-- | Exactly like @route@, except specialized to route sets that contain @ActionT@s - +-- essentially @fmap@ing @action@ to each element. +routeAction :: ( Functor m + , Monad m + , MonadIO m + ) => RoutableActionT sec e u ue m () + -> MiddlewareT m +routeAction = route . actionToMiddleware + +-- | Exactly like @routeAuth@, but specialized for @ActionT@. +routeActionAuth :: ( Functor m + , Monad m + , MonadIO m + ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize + -> RoutableActionT sec e u ue m () -- ^ Assembled @handle@ calls + -> MiddlewareT m +routeActionAuth authorize = routeAuth authorize . actionToMiddleware + + +-- | Turns a @HandlerT@ containing @ActionT@s into a @HandlerT@ containing @MiddlewareT@s. +actionToMiddleware :: MonadIO m => + RoutableActionT sec e u ue m () + -> RoutableT sec e u ue m () +actionToMiddleware hs = do + (rtrie,nftrie,strie,errtrie) <- lift $ execHandlerT hs + tell' ( action <$> rtrie + , action <$> nftrie + , strie + , (action .) <$> errtrie + ) + + +-- * Extraction ------------------------------- + +-- | Extracts only the normal @handle@ (content) routes into +-- a @MiddlewareT@, disregarding security and not-found responses. extractContent :: ( Functor m , Monad m , MonadIO m - ) => HandlerT (ActionT u m ()) sec err e u m a -- ^ Assembled @handle@ calls + ) => HandlerT (MiddlewareT m) sec err aux m a -> MiddlewareT m extractContent hs app req respond = do - (rtrie,_,_,_) <- execHandlerT hs - let mAcceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req - fe = getFileExt req - v = getVerb req - case lookupWithLRPT trimFileExt (pathInfo req) rtrie of + (trie,_,_,_) <- execHandlerT hs + case lookupWithLRPT trimFileExt (pathInfo req) trie of Nothing -> fromMaybe (app req respond) $ do - guard $ not $ null $ pathInfo req + guard $ not . null $ pathInfo req guard $ trimFileExt (last $ pathInfo req) == "index" - found <- TC.lookup (init $ pathInfo req) rtrie - Just $ actionToMiddleware mAcceptBS fe v found app req respond - Just found -> actionToMiddleware mAcceptBS fe v found app req respond + mid <- TC.lookup (init $ pathInfo req) trie + Just $ mid app req respond + Just mid -> mid app req respond --- | Manually fetch the security tokens / authorization roles affiliated with --- a request and your routing system. +-- | Find the security tokens / authorization roles affiliated with +-- a request for a set of routes. extractAuthSym :: ( Functor m , Monad m - ) => HandlerT x (sec, AuthScope) err e u m a + ) => HandlerT x (sec, AuthScope) err aux m a -> Request -> m [sec] extractAuthSym hs req = do @@ -299,192 +415,103 @@ return $ foldl go [] (PT.matchesRPT (pathInfo req) trie) where go ys (_,(_,ProtectChildren),[]) = ys - go ys (_,(x,_),_) = ys ++ [x] - + go ys (_,(x,_ ),_ ) = ys ++ [x] +-- | Extracts only the security handling logic into a @MiddlewareT@. extractAuth :: ( Functor m - , Monad m - , MonadIO m - ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- authorization method - -> HandlerT x (sec, AuthScope) (e -> ActionT u m ()) e u m a - -> MiddlewareT m + , Monad m + , MonadIO m + ) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- authorization method + -> HandlerT x (sec, AuthScope) (e -> MiddlewareT m) aux m a + -> MiddlewareT m extractAuth authorize hs app req respond = do (_,_,_,trie) <- execHandlerT hs ss <- extractAuthSym hs req ef <- runExceptT $ authorize req ss - let acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req - fe = getFileExt req - v = getVerb req either (\e -> maybe (app req respond) - (\action -> actionToMiddleware acceptBS fe v action app req respond) + (\mid -> mid app req respond) $ (getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie) <$~> e) (\f -> app req (respond . f)) ef --- | Turns the not-found trie into a final application, matching all routes under --- each @notFound@ node. If there is no nearest parent (querying above the head --- of the tree), control is passed down the middlware chain. +-- | Extracts only the @notFound@ responses into a @MiddlewareT@. extractNotFound :: ( Functor m , Monad m , MonadIO m - ) => HandlerT (ActionT u m ()) sec err e u m a + ) => HandlerT (MiddlewareT m) sec err aux m a -> MiddlewareT m extractNotFound = extractNearestVia (execHandlerT >=> \(_,t,_,_) -> return t) --- | Only return content, do not handle uploads. Also, the extraction should be --- flat, in that the values contained in our trie are only @ActionT@, without arity. +-- | Given a way to draw out a special-purpose trie from our route set, route +-- to the responses based on a /furthest-reached/ method. extractNearestVia :: ( Functor m , Monad m , MonadIO m - ) => (HandlerT (ActionT u m ()) sec err e u m a -> m (RootedPredTrie T.Text (ActionT u m ()))) - -> HandlerT (ActionT u m ()) sec err e u m a + ) => (HandlerT (MiddlewareT m) sec err aux m a -> m (RootedPredTrie T.Text (MiddlewareT m))) + -> HandlerT (MiddlewareT m) sec err aux m a -> MiddlewareT m extractNearestVia extr hs app req respond = do trie <- extr hs - let acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req - fe = getFileExt req - v = getVerb req maybe (app req respond) - (\action -> actionToMiddleware acceptBS fe v action app req respond) + (\mid -> mid app req respond) $ getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie +getResultsFromMatch :: ([s],a,[s]) -> a +getResultsFromMatch (_,x,_) = x --- | Turn an @ActionT@ into a @Middleware@ by providing a @FileExt@ and @Verb@ --- to lookup, returning the response and utilizing the upload handler encoded --- in the action. -actionToMiddleware :: MonadIO m => - Maybe AcceptHeader -- @Accept@ header - -> FileExt - -> Verb - -> ActionT u m () - -> MiddlewareT m -actionToMiddleware mAcceptBS f v found app req respond = do - mApp <- runMaybeT $ do - mContinue <- lift $ lookupUpload v req found - (reqbodyf, continue) <- hoistMaybe mContinue - mUploadData <- lift reqbodyf - mResponse <- lift $ lookupResponse mAcceptBS f $ continue mUploadData - response <- hoistMaybe mResponse - return $ liftIO $ respond response - fromMaybe (app req respond) mApp -lookupUpload :: Monad m => - Verb - -> Request - -> VerbListenerT r u m () - -> m (Maybe (m (Maybe u), Maybe u -> r)) -lookupUpload v req action = runMaybeT $ do - vmap <- lift $ execVerbListenerT action - hoistMaybe $ lookupVerb v req vmap - -lookupResponse :: Monad m => - Maybe AcceptHeader - -> FileExt - -> FileExtListenerT a m () - -> m (Maybe a) -lookupResponse mAcceptBS f fexts = runMaybeT $ do - femap <- lift $ execFileExtListenerT fexts - hoistMaybe $ lookupFileExt mAcceptBS f femap - - -lookupVerb :: Verb -> Request -> Verbs u m r -> Maybe (m (Maybe u), Maybe u -> r) -lookupVerb v req vmap = Map.lookup v $ supplyReq req $ unVerbs vmap - - --- | Given a possible @Accept@ header and file extension key, lookup the contents --- of a map. -lookupFileExt :: Maybe AcceptHeader -> FileExt -> FileExts a -> Maybe a -lookupFileExt mAccept k (FileExts xs) = - let attempts = maybe [Html,Text,Json,JavaScript,Css] - (possibleFileExts k) mAccept - in getFirst $ foldMap (First . flip Map.lookup xs) attempts - - --- | Takes a subject file extension and an @Accept@ header, and returns the other --- types of file types handleable, in order of prescedence. -possibleFileExts :: FileExt -> AcceptHeader -> [FileExt] -possibleFileExts fe accept = - let computed = sortFE fe $ nub $ concat $ - catMaybes [ mapAccept [ ("application/json" :: B.ByteString, [Json]) - , ("application/javascript" :: B.ByteString, [Json,JavaScript]) - ] accept - , mapAccept [ ("text/html" :: B.ByteString, [Html]) - ] accept - , mapAccept [ ("text/plain" :: B.ByteString, [Text]) - ] accept - , mapAccept [ ("text/css" :: B.ByteString, [Css]) - ] accept - ] - - wildcard = concat $ - catMaybes [ mapAccept [ ("*/*" :: B.ByteString, [Html,Text,Json,JavaScript,Css]) - ] accept - ] - in if not (null wildcard) then wildcard else computed - where - sortFE Html xs = [Html, Text] `intersect` xs - sortFE JavaScript xs = [JavaScript, Text] `intersect` xs - sortFE Json xs = [Json, JavaScript, Text] `intersect` xs - sortFE Css xs = [Css, Text] `intersect` xs - sortFE Text xs = [Text] `intersect` xs - - ------ Internal Utilities ----------------------------------- +-- * Pred-Trie related ----------------- -- | Removes @.txt@ from @foo.txt@ trimFileExt :: T.Text -> T.Text -trimFileExt s = if endsWithAny (T.unpack s) - then T.pack $ takeWhile (/= '.') $ T.unpack s - else s +trimFileExt s = + let lastExt = getLastExt (T.unpack s) + in if lastExt `elem` possibleExts + then T.pack lastExt + else s where possibleExts = [ ".html",".htm",".txt",".json",".lucid" , ".julius",".css",".cassius",".lucius" ] - endsWithAny s' = dropWhile (/= '.') s' `Prelude.elem` possibleExts - - -getFileExt :: Request -> FileExt -getFileExt req = fromMaybe Html $ case pathInfo req of - [] -> Just Html -- TODO: Override default file extension for `/foo/bar` - xs -> toExt $ T.dropWhile (/= '.') $ last xs - -getVerb :: Request -> Verb -getVerb req = fromMaybe GET $ httpMethodToMSym $ requestMethod req - - --- | Turns a @ByteString@ into a @StdMethod@. -httpMethodToMSym :: Method -> Maybe Verb -httpMethodToMSym x | x == methodGet = Just GET - | x == methodPost = Just POST - | x == methodPut = Just PUT - | x == methodDelete = Just DELETE - | otherwise = Nothing + getLastExt ts = S.evalState (foldrM go [] ts) False + where + go c soFar = do + sawPeriod <- S.get + if sawPeriod + then return soFar + else if c == '.' + then do S.put True + return ('.' : soFar) + else return (c : soFar) --- * Pred-Trie related ----------------- - -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches. lookupWithLPT :: Ord s => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe a lookupWithLPT f (t:|ts) (PredTrie (MapStep ls) (PredSteps ps)) - | null ts = getFirst $ First (goLit (f t) ls) <> foldMap (First . goPred) ps - | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps + | null ts = getFirst $ First (goLit (f t) ls) <> foldMap (First . goPred) ps + | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps where - goLit t' xs = do (mx,mxs) <- Map.lookup t' xs - if null ts then mx - else lookupWithLPT f (NE.fromList ts) =<< mxs + goLit t' xs = do + (mx,mxs) <- Map.lookup t' xs + if null ts + then mx + else lookupWithLPT f (NE.fromList ts) =<< mxs goPred (PredStep _ predicate mx xs) = do d <- predicate t - if null ts then mx <$~> d - else lookupWithLPT f (NE.fromList ts) xs <$~> d + if null ts + then mx <$~> d + else lookupWithLPT f (NE.fromList ts) xs <$~> d lookupWithLRPT :: Ord s => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe a lookupWithLRPT _ [] (RootedPredTrie mx _) = mx lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (NE.fromList ts) xs -getResultsFromMatch :: ([s],a,[s]) -> a -getResultsFromMatch (_,x,_) = x +tell' :: (Monoid w, S.MonadState w m) => w -> m () +tell' x = do + xs <- S.get + S.put $ xs <> x diff --git a/src/Web/Routes/Nested/FileExtListener.hs b/src/Web/Routes/Nested/FileExtListener.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Web.Routes.Nested.FileExtListener - ( module X - ) where - -import Web.Routes.Nested.FileExtListener.Types as X hiding (FileExt (..)) -import Web.Routes.Nested.FileExtListener.Builder as X -import Web.Routes.Nested.FileExtListener.ByteString as X -import Web.Routes.Nested.FileExtListener.Blaze as X -import Web.Routes.Nested.FileExtListener.Lucid as X -import Web.Routes.Nested.FileExtListener.Text as X -import Web.Routes.Nested.FileExtListener.Json as X diff --git a/src/Web/Routes/Nested/FileExtListener/Blaze.hs b/src/Web/Routes/Nested/FileExtListener/Blaze.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Blaze.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module Web.Routes.Nested.FileExtListener.Blaze where - -import Web.Routes.Nested.FileExtListener.Types -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import qualified Data.Text.Lazy.Encoding as LT -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai -import qualified Text.Blaze.Html as H -import qualified Text.Blaze.Html.Renderer.Text as H - -import Control.Monad.Writer - - --- | Uses @Html@ as the key in the map, and @"text/html"@ as the content type. -blaze :: Monad m => H.Html -> FileExtListenerT Response m () -blaze = blazeStatusHeaders status200 [("Content-Type", "text/html")] - -blazeWith :: Monad m => (Response -> Response) -> H.Html -> FileExtListenerT Response m () -blazeWith f = blazeStatusHeadersWith f status200 [("Content-Type", "text/html")] - -blazeStatus :: Monad m => Status -> H.Html -> FileExtListenerT Response m () -blazeStatus s = blazeStatusHeaders s [("Content-Type", "text/html")] - -blazeStatusWith :: Monad m => (Response -> Response) -> Status -> H.Html -> FileExtListenerT Response m () -blazeStatusWith f s = blazeStatusHeadersWith f s [("Content-Type", "text/html")] - -blazeHeaders :: Monad m => RequestHeaders -> H.Html -> FileExtListenerT Response m () -blazeHeaders = blazeStatusHeaders status200 - -blazeHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> H.Html -> FileExtListenerT Response m () -blazeHeadersWith f = blazeStatusHeadersWith f status200 - -blazeStatusHeaders :: Monad m => Status -> RequestHeaders -> H.Html -> FileExtListenerT Response m () -blazeStatusHeaders = blazeStatusHeadersWith id - -blazeStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> H.Html -> FileExtListenerT Response m () -blazeStatusHeadersWith f s hs i = - let r = blazeOnlyStatusHeaders s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton Html $ f r - - - -blazeOnly :: H.Html -> Response -blazeOnly = blazeOnlyStatusHeaders status200 [("Content-Type", "text/html")] - -blazeOnlyHeaders :: RequestHeaders -> H.Html -> Response -blazeOnlyHeaders = blazeOnlyStatusHeaders status200 - -blazeOnlyStatus :: Status -> H.Html -> Response -blazeOnlyStatus s = blazeOnlyStatusHeaders s [("Content-Type", "text/html")] - -blazeOnlyStatusHeaders :: Status -> RequestHeaders -> H.Html -> Response -blazeOnlyStatusHeaders s hs i = - bytestringOnlyStatus s hs $ LT.encodeUtf8 $ H.renderHtml i diff --git a/src/Web/Routes/Nested/FileExtListener/Builder.hs b/src/Web/Routes/Nested/FileExtListener/Builder.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Builder.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module Web.Routes.Nested.FileExtListener.Builder where - -import Web.Routes.Nested.FileExtListener.Types - -import qualified Data.ByteString.Builder as BU -import Data.Map -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | A builder is ambiguous, therefore we require @RequestHeaders@ and a @FileExt@ to be explicitly --- supplied. -builder :: Monad m => FileExt -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m () -builder e = builderStatus e status200 - -builderWith :: Monad m => (Response -> Response) -> FileExt -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m () -builderWith f e = builderStatusWith f e status200 - -builderStatus :: Monad m => FileExt -> Status -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m () -builderStatus = builderStatusWith id - -builderStatusWith :: Monad m => (Response -> Response) -> FileExt -> Status -> RequestHeaders -> BU.Builder -> FileExtListenerT Response m () -builderStatusWith f e s hs i = - let r = builderOnlyStatus s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton e $ f r - - - -builderOnly :: RequestHeaders -> BU.Builder -> Response -builderOnly = builderOnlyStatus status200 - --- | The exact same thing as @Network.Wai.responseBuilder@. -builderOnlyStatus :: Status -> RequestHeaders -> BU.Builder -> Response -builderOnlyStatus = responseBuilder diff --git a/src/Web/Routes/Nested/FileExtListener/ByteString.hs b/src/Web/Routes/Nested/FileExtListener/ByteString.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/ByteString.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module Web.Routes.Nested.FileExtListener.ByteString where - -import Web.Routes.Nested.FileExtListener.Types - -import qualified Data.ByteString.Lazy as B -import Data.Map -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai -import qualified Network.Wai.Util as U - -import Control.Monad.Writer - - --- | @ByteString@ is ambiguous - we need to know what @RequestHeaders@ and @FileExt@ should be associated. -bytestring :: Monad m => FileExt -> RequestHeaders -> B.ByteString -> FileExtListenerT Response m () -bytestring e = bytestringStatus e status200 - -bytestringWith :: Monad m => (Response -> Response) -> FileExt -> RequestHeaders -> B.ByteString -> FileExtListenerT Response m () -bytestringWith f e = bytestringStatusWith f e status200 - -bytestringStatus :: Monad m => FileExt -> Status -> RequestHeaders -> B.ByteString - -> FileExtListenerT Response m () -bytestringStatus = bytestringStatusWith id - -bytestringStatusWith :: Monad m => - (Response -> Response) - -> FileExt -> Status -> RequestHeaders -> B.ByteString - -> FileExtListenerT Response m () -bytestringStatusWith f e s hs i = do - r <- lift $ U.bytestring s hs i - FileExtListenerT $ tell $ - FileExts $ singleton e $ f r - - -bytestringOnly :: RequestHeaders -> B.ByteString -> Response -bytestringOnly = bytestringOnlyStatus status200 - --- | The exact same thing as @Network.Wai.responseLBS@. -bytestringOnlyStatus :: Status -> RequestHeaders -> B.ByteString -> Response -bytestringOnlyStatus = responseLBS diff --git a/src/Web/Routes/Nested/FileExtListener/Cassius.hs b/src/Web/Routes/Nested/FileExtListener/Cassius.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Cassius.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - - -module Web.Routes.Nested.FileExtListener.Cassius where - -import Web.Routes.Nested.FileExtListener.Types as FE -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import Text.Cassius -import qualified Data.Text.Lazy.Encoding as LT -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | Uses @cassius@ as the key in the map, and @"cassius/plain"@ as the content type. -cassius :: Monad m => Css -> FileExtListenerT Response m () -cassius = cassiusStatusHeaders status200 [("Content-Type", "cassius/css")] - -cassiusWith :: Monad m => (Response -> Response) -> Css -> FileExtListenerT Response m () -cassiusWith f = cassiusStatusHeadersWith f status200 [("Content-Type", "cassius/css")] - -cassiusStatus :: Monad m => Status -> Css -> FileExtListenerT Response m () -cassiusStatus s = cassiusStatusHeaders s [("Content-Type", "cassius/css")] - -cassiusStatusWith :: Monad m => (Response -> Response) -> Status -> Css -> FileExtListenerT Response m () -cassiusStatusWith f s = cassiusStatusHeadersWith f s [("Content-Type", "cassius/css")] - -cassiusHeaders :: Monad m => RequestHeaders -> Css -> FileExtListenerT Response m () -cassiusHeaders = cassiusStatusHeaders status200 - -cassiusHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> Css -> FileExtListenerT Response m () -cassiusHeadersWith f = cassiusStatusHeadersWith f status200 - -cassiusStatusHeaders :: Monad m => Status -> RequestHeaders -> Css -> FileExtListenerT Response m () -cassiusStatusHeaders = cassiusStatusHeadersWith id - -cassiusStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m () -cassiusStatusHeadersWith f s hs i = - let r = cassiusOnlyStatusHeaders s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton Css $ f r - - - - -cassiusOnly :: Css -> Response -cassiusOnly = cassiusOnlyStatusHeaders status200 [("Content-Type", "cassius/css")] - -cassiusOnlyStatus :: Status -> Css -> Response -cassiusOnlyStatus s = cassiusOnlyStatusHeaders s [("Content-Type", "cassius/css")] - -cassiusOnlyHeaders :: RequestHeaders -> Css -> Response -cassiusOnlyHeaders = cassiusOnlyStatusHeaders status200 - -cassiusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response -cassiusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i diff --git a/src/Web/Routes/Nested/FileExtListener/Clay.hs b/src/Web/Routes/Nested/FileExtListener/Clay.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Clay.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - - -module Web.Routes.Nested.FileExtListener.Clay where - -import Web.Routes.Nested.FileExtListener.Types -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import Clay.Render -import Clay.Stylesheet -import qualified Data.Text.Lazy.Encoding as LT -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | Uses @Text@ as the key in the map, and @"text/css"@ as the content type. -clay :: Monad m => Config -> [App] -> Css -> FileExtListenerT Response m () -clay c as = clayStatusHeaders c as status200 [("Content-Type", "text/css")] - -clayWith :: Monad m => (Response -> Response) -> Config -> [App] -> Css -> FileExtListenerT Response m () -clayWith f c as = clayStatusHeadersWith f c as status200 [("Content-Type", "text/css")] - -clayStatus :: Monad m => Config -> [App] -> Status -> Css -> FileExtListenerT Response m () -clayStatus c as s = clayStatusHeaders c as s [("Content-Type", "text/css")] - -clayStatusWith :: Monad m => (Response -> Response) -> Config -> [App] -> Status -> Css -> FileExtListenerT Response m () -clayStatusWith f c as s = clayStatusHeadersWith f c as s [("Content-Type", "text/css")] - -clayHeaders :: Monad m => Config -> [App] -> RequestHeaders -> Css -> FileExtListenerT Response m () -clayHeaders c as = clayStatusHeaders c as status200 - -clayHeadersWith :: Monad m => (Response -> Response) -> Config -> [App] -> RequestHeaders -> Css -> FileExtListenerT Response m () -clayHeadersWith f c as = clayStatusHeadersWith f c as status200 - -clayStatusHeaders :: Monad m => Config -> [App] -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m () -clayStatusHeaders = clayStatusHeadersWith id - -clayStatusHeadersWith :: Monad m => (Response -> Response) -> Config -> [App] -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m () -clayStatusHeadersWith f c as s hs i = - let r = clayOnlyStatusHeaders c as s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton Css $ f r - - - - -clayOnly :: Config -> [App] -> Css -> Response -clayOnly c as = clayOnlyStatusHeaders c as status200 [("Content-Type", "text/css")] - -clayOnlyStatus :: Config -> [App] -> Status -> Css -> Response -clayOnlyStatus c as s = clayOnlyStatusHeaders c as s [("Content-Type", "text/css")] - -clayOnlyHeaders :: Config -> [App] -> RequestHeaders -> Css -> Response -clayOnlyHeaders c as = clayOnlyStatusHeaders c as status200 - -clayOnlyStatusHeaders :: Config -> [App] -> Status -> RequestHeaders -> Css -> Response -clayOnlyStatusHeaders c as s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderWith c as i diff --git a/src/Web/Routes/Nested/FileExtListener/Json.hs b/src/Web/Routes/Nested/FileExtListener/Json.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Json.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module Web.Routes.Nested.FileExtListener.Json where - -import Web.Routes.Nested.FileExtListener.Types -import Web.Routes.Nested.FileExtListener.ByteString - -import qualified Data.Aeson as A -import Data.Map -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - - --- | Uses @Json@ as the key in the map, and @"application/json"@ as the content type. -json :: ( A.ToJSON j - , Monad m - ) => j -> FileExtListenerT Response m () -json = jsonStatusHeaders status200 [("Content-Type", "application/json")] - -jsonWith :: ( A.ToJSON j - , Monad m - ) => (Response -> Response) -> j -> FileExtListenerT Response m () -jsonWith f = jsonStatusHeadersWith f status200 [("Content-Type", "application/json")] - -jsonStatus :: ( A.ToJSON j - , Monad m - ) => Status -> j -> FileExtListenerT Response m () -jsonStatus s = jsonStatusHeaders s [("Content-Type", "application/json")] - -jsonStatusWith :: ( A.ToJSON j - , Monad m - ) => (Response -> Response) -> Status -> j -> FileExtListenerT Response m () -jsonStatusWith f s = jsonStatusHeadersWith f s [("Content-Type", "application/json")] - --- | Uses @Json@ as the key in the map, and @"application/javascript"@ as the content type. -jsonp :: ( A.ToJSON j - , Monad m - ) => j -> FileExtListenerT Response m () -jsonp = jsonStatusHeaders status200 [("Content-Type", "application/javascript")] - -jsonpWith :: ( A.ToJSON j - , Monad m - ) => (Response -> Response) -> j -> FileExtListenerT Response m () -jsonpWith f = jsonStatusHeadersWith f status200 [("Content-Type", "application/javascript")] - -jsonpStatus :: ( A.ToJSON j - , Monad m - ) => Status -> j -> FileExtListenerT Response m () -jsonpStatus s = jsonStatusHeaders s [("Content-Type", "application/javascript")] - -jsonpStatusWith :: ( A.ToJSON j - , Monad m - ) => (Response -> Response) -> Status -> j -> FileExtListenerT Response m () -jsonpStatusWith f s = jsonStatusHeadersWith f s [("Content-Type", "application/javascript")] - -jsonHeaders :: ( A.ToJSON j - , Monad m - ) => RequestHeaders -> j -> FileExtListenerT Response m () -jsonHeaders = jsonStatusHeaders status200 - -jsonHeadersWith :: ( A.ToJSON j - , Monad m - ) => (Response -> Response) -> RequestHeaders -> j -> FileExtListenerT Response m () -jsonHeadersWith f = jsonStatusHeadersWith f status200 - -jsonStatusHeaders :: ( A.ToJSON j - , Monad m - ) => Status -> RequestHeaders -> j -> FileExtListenerT Response m () -jsonStatusHeaders = jsonStatusHeadersWith id - -jsonStatusHeadersWith :: ( A.ToJSON j - , Monad m - ) => (Response -> Response) -> Status -> RequestHeaders -> j -> FileExtListenerT Response m () -jsonStatusHeadersWith f s hs i = - let r = jsonOnlyStatusHeaders s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton Json $ f r - - - - -jsonOnly :: A.ToJSON j => - j -> Response -jsonOnly = jsonOnlyStatusHeaders status200 [("Content-Type", "application/json")] - -jsonOnlyStatus :: A.ToJSON j => - Status -> j -> Response -jsonOnlyStatus s = jsonOnlyStatusHeaders s [("Content-Type", "application/json")] - -jsonpOnly :: A.ToJSON j => - j -> Response -jsonpOnly = jsonOnlyStatusHeaders status200 [("Content-Type", "application/javascript")] - -jsonpOnlyStatus :: A.ToJSON j => - Status -> j -> Response -jsonpOnlyStatus s = jsonOnlyStatusHeaders s [("Content-Type", "application/javascript")] - -jsonOnlyHeaders :: A.ToJSON j => - RequestHeaders -> j -> Response -jsonOnlyHeaders = jsonOnlyStatusHeaders status200 - -jsonOnlyStatusHeaders :: A.ToJSON j => - Status -> RequestHeaders -> j -> Response -jsonOnlyStatusHeaders s hs i = - bytestringOnlyStatus s hs $ A.encode i diff --git a/src/Web/Routes/Nested/FileExtListener/Julius.hs b/src/Web/Routes/Nested/FileExtListener/Julius.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Julius.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - - -module Web.Routes.Nested.FileExtListener.Julius where - -import Web.Routes.Nested.FileExtListener.Types -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import Text.Julius -import qualified Data.Text.Lazy.Encoding as LT -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | Uses @julius@ as the key in the map, and @"application/javascript"@ as the content type. -julius :: Monad m => Javascript -> FileExtListenerT Response m () -julius = juliusStatusHeaders status200 [("Content-Type", "application/javascript")] - -juliusWith :: Monad m => (Response -> Response) -> Javascript -> FileExtListenerT Response m () -juliusWith f = juliusStatusHeadersWith f status200 [("Content-Type", "application/javascript")] - -juliusStatus :: Monad m => Status -> Javascript -> FileExtListenerT Response m () -juliusStatus s = juliusStatusHeaders s [("Content-Type", "application/javascript")] - -juliusStatusWith :: Monad m => (Response -> Response) -> Status -> Javascript -> FileExtListenerT Response m () -juliusStatusWith f s = juliusStatusHeadersWith f s [("Content-Type", "application/javascript")] - -juliusHeaders :: Monad m => RequestHeaders -> Javascript -> FileExtListenerT Response m () -juliusHeaders = juliusStatusHeaders status200 - -juliusHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> Javascript -> FileExtListenerT Response m () -juliusHeadersWith f = juliusStatusHeadersWith f status200 - -juliusStatusHeaders :: Monad m => Status -> RequestHeaders -> Javascript -> FileExtListenerT Response m () -juliusStatusHeaders = juliusStatusHeadersWith id - -juliusStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> Javascript -> FileExtListenerT Response m () -juliusStatusHeadersWith f s hs i = - let r = juliusOnlyStatusHeaders s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton JavaScript $ f r - - - - -juliusOnly :: Javascript -> Response -juliusOnly = juliusOnlyStatusHeaders status200 [("Content-Type", "application/javascript")] - -juliusOnlyStatus :: Status -> Javascript -> Response -juliusOnlyStatus s = juliusOnlyStatusHeaders s [("Content-Type", "application/javascript")] - -juliusOnlyHeaders :: RequestHeaders -> Javascript -> Response -juliusOnlyHeaders = juliusOnlyStatusHeaders status200 - -juliusOnlyStatusHeaders :: Status -> RequestHeaders -> Javascript -> Response -juliusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderJavascript i diff --git a/src/Web/Routes/Nested/FileExtListener/Lucid.hs b/src/Web/Routes/Nested/FileExtListener/Lucid.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Lucid.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module Web.Routes.Nested.FileExtListener.Lucid where - -import Web.Routes.Nested.FileExtListener.Types -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import qualified Lucid.Base as L -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | Uses the @Html@ key in the map, and @"text/html"@ as the content type. -lucid :: Monad m => L.HtmlT m () -> FileExtListenerT Response m () -lucid = lucidStatusHeaders status200 [("Content-Type", "text/html")] - -lucidWith :: Monad m => (Response -> Response) -> L.HtmlT m () -> FileExtListenerT Response m () -lucidWith f = lucidStatusHeadersWith f status200 [("Content-Type", "text/html")] - -lucidStatus :: Monad m => Status -> L.HtmlT m () -> FileExtListenerT Response m () -lucidStatus s = lucidStatusHeaders s [("Content-Type", "text/html")] - -lucidStatusWith :: Monad m => (Response -> Response) -> Status -> L.HtmlT m () -> FileExtListenerT Response m () -lucidStatusWith f s = lucidStatusHeadersWith f s [("Content-Type", "text/html")] - -lucidHeaders :: Monad m => RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m () -lucidHeaders = lucidStatusHeaders status200 - -lucidHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m () -lucidHeadersWith f = lucidStatusHeadersWith f status200 - -lucidStatusHeaders :: Monad m => Status -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m () -lucidStatusHeaders = lucidStatusHeadersWith id - -lucidStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> L.HtmlT m () -> FileExtListenerT Response m () -lucidStatusHeadersWith f s hs i = do - r <- lift $ lucidOnlyStatusHeaders s hs i - FileExtListenerT $ tell $ - FileExts $ singleton Html $ f r - - - - -lucidOnly :: Monad m => - L.HtmlT m () -> m Response -lucidOnly = lucidOnlyStatusHeaders status200 [("Content-Type", "text/html")] - -lucidOnlyStatus :: Monad m => - Status -> L.HtmlT m () -> m Response -lucidOnlyStatus s = lucidOnlyStatusHeaders s [("Content-Type", "text/html")] - -lucidOnlyHeaders :: Monad m => - RequestHeaders -> L.HtmlT m () -> m Response -lucidOnlyHeaders = lucidOnlyStatusHeaders status200 - -lucidOnlyStatusHeaders :: Monad m => - Status -> RequestHeaders -> L.HtmlT m () -> m Response -lucidOnlyStatusHeaders s hs i = liftM (bytestringOnlyStatus s hs) $ L.renderBST i diff --git a/src/Web/Routes/Nested/FileExtListener/Lucius.hs b/src/Web/Routes/Nested/FileExtListener/Lucius.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Lucius.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - - -module Web.Routes.Nested.FileExtListener.Lucius where - -import Web.Routes.Nested.FileExtListener.Types as FE -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import Text.Lucius -import qualified Data.Text.Lazy.Encoding as LT -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | Uses @lucius@ as the key in the map, and @"lucius/css"@ as the content type. -lucius :: Monad m => Css -> FileExtListenerT Response m () -lucius = luciusStatusHeaders status200 [("Content-Type", "lucius/css")] - -luciusWith :: Monad m => (Response -> Response) -> Css -> FileExtListenerT Response m () -luciusWith f = luciusStatusHeadersWith f status200 [("Content-Type", "lucius/css")] - -luciusStatus :: Monad m => Status -> Css -> FileExtListenerT Response m () -luciusStatus s = luciusStatusHeaders s [("Content-Type", "lucius/css")] - -luciusStatusWith :: Monad m => (Response -> Response) -> Status -> Css -> FileExtListenerT Response m () -luciusStatusWith f s = luciusStatusHeadersWith f s [("Content-Type", "lucius/css")] - -luciusHeaders :: Monad m => RequestHeaders -> Css -> FileExtListenerT Response m () -luciusHeaders = luciusStatusHeaders status200 - -luciusHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> Css -> FileExtListenerT Response m () -luciusHeadersWith f = luciusStatusHeadersWith f status200 - -luciusStatusHeaders :: Monad m => Status -> RequestHeaders -> Css -> FileExtListenerT Response m () -luciusStatusHeaders = luciusStatusHeadersWith id - -luciusStatusHeadersWith :: Monad m => (Response -> Response) -> Status -> RequestHeaders -> Css -> FileExtListenerT Response m () -luciusStatusHeadersWith f s hs i = - let r = luciusOnlyStatusHeaders s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton FE.Css $ f r - - - - -luciusOnly :: Css -> Response -luciusOnly = luciusOnlyStatusHeaders status200 [("Content-Type", "lucius/css")] - -luciusOnlyStatus :: Status -> Css -> Response -luciusOnlyStatus s = luciusOnlyStatusHeaders s [("Content-Type", "lucius/css")] - -luciusOnlyHeaders :: RequestHeaders -> Css -> Response -luciusOnlyHeaders = luciusOnlyStatusHeaders status200 - -luciusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response -luciusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i diff --git a/src/Web/Routes/Nested/FileExtListener/Text.hs b/src/Web/Routes/Nested/FileExtListener/Text.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Text.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - - -module Web.Routes.Nested.FileExtListener.Text where - -import Web.Routes.Nested.FileExtListener.Types -import Web.Routes.Nested.FileExtListener.ByteString - -import Data.Map -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Network.HTTP.Types (RequestHeaders, - Status, status200) -import Network.Wai - -import Control.Monad.Writer - - --- | Uses @Text@ as the key in the map, and @"text/plain"@ as the content type. -text :: Monad m => LT.Text -> FileExtListenerT Response m () -text = textStatusHeaders status200 [("Content-Type", "text/plain")] - -textWith :: Monad m => (Response -> Response) -> LT.Text -> FileExtListenerT Response m () -textWith f = textStatusHeadersWith f status200 [("Content-Type", "text/plain")] - -textStatus :: Monad m => Status -> LT.Text -> FileExtListenerT Response m () -textStatus s = textStatusHeaders s [("Content-Type", "text/plain")] - -textStatusWith :: Monad m => (Response -> Response) -> Status -> LT.Text -> FileExtListenerT Response m () -textStatusWith f s = textStatusHeadersWith f s [("Content-Type", "text/plain")] - -textHeaders :: Monad m => RequestHeaders -> LT.Text -> FileExtListenerT Response m () -textHeaders = textStatusHeaders status200 - -textHeadersWith :: Monad m => (Response -> Response) -> RequestHeaders -> LT.Text -> FileExtListenerT Response m () -textHeadersWith f = textStatusHeadersWith f status200 - -textStatusHeaders :: Monad m => Status -> RequestHeaders -> LT.Text -> FileExtListenerT Response m () -textStatusHeaders = textStatusHeadersWith id - -textStatusHeadersWith :: Monad m => - (Response -> Response) -> Status -> RequestHeaders -> LT.Text - -> FileExtListenerT Response m () -textStatusHeadersWith f s hs i = - let r = textOnlyStatusHeaders s hs i in - FileExtListenerT $ tell $ - FileExts $ singleton Text $ f r - - - - -textOnly :: LT.Text -> Response -textOnly = textOnlyStatusHeaders status200 [("Content-Type", "text/plain")] - -textOnlyStatus :: Status -> LT.Text -> Response -textOnlyStatus s = textOnlyStatusHeaders s [("Content-Type", "text/plain")] - -textOnlyHeaders :: RequestHeaders -> LT.Text -> Response -textOnlyHeaders = textOnlyStatusHeaders status200 - -textOnlyStatusHeaders :: Status -> RequestHeaders -> LT.Text -> Response -textOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 i diff --git a/src/Web/Routes/Nested/FileExtListener/Types.hs b/src/Web/Routes/Nested/FileExtListener/Types.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/FileExtListener/Types.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE - DeriveFunctor - , DeriveTraversable - , GeneralizedNewtypeDeriving - , OverloadedStrings - , StandaloneDeriving - , FlexibleInstances - , MultiParamTypeClasses - #-} - - -module Web.Routes.Nested.FileExtListener.Types where - -import qualified Data.Text as T - -import Control.Monad.Trans -import Control.Monad.Writer -import Data.Map - - --- | Supported file extensions -data FileExt = Html - | Css - | JavaScript - | Json - | Text - deriving (Show, Eq, Ord) - - -toExt :: T.Text -> Maybe FileExt -toExt x | x `elem` htmls = Just Html - | x `elem` csss = Just Css - | x `elem` javascripts = Just JavaScript - | x `elem` jsons = Just Json - | x `elem` texts = Just Text - | otherwise = Nothing - where - htmls = [".htm", ".html"] - csss = [".css"] - javascripts = [".js", ".javascript"] - jsons = [".json"] - texts = [".txt"] - -newtype FileExts a = FileExts { unFileExts :: Map FileExt a } - deriving (Show, Eq, Monoid, Functor, Foldable, Traversable) - -newtype FileExtListenerT r m a = - FileExtListenerT { runFileExtListenerT :: WriterT (FileExts r) m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, - MonadWriter (FileExts r)) - -execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExts r) -execFileExtListenerT = execWriterT . runFileExtListenerT diff --git a/src/Web/Routes/Nested/Types/UrlChunks.hs b/src/Web/Routes/Nested/Types/UrlChunks.hs --- a/src/Web/Routes/Nested/Types/UrlChunks.hs +++ b/src/Web/Routes/Nested/Types/UrlChunks.hs @@ -20,14 +20,18 @@ (:~) :: (T.Text, Parser r) -> EitherUrlChunk ('Just r) (:*) :: (T.Text, Regex) -> EitherUrlChunk ('Just [String]) --- | Match against a /Literal/ chunk -l :: T.Text -> EitherUrlChunk 'Nothing -l = (:=) - -- | Use raw strings instead of prepending @l@ instance x ~ 'Nothing => IsString (EitherUrlChunk x) where fromString = l . T.pack +-- | The /Origin/ chunk - the equivalent to @[]@ +o :: UrlChunks '[] +o = Root + +-- | Match against a /Literal/ chunk +l :: T.Text -> EitherUrlChunk 'Nothing +l = (:=) + -- | Match against a /Parsed/ chunk p :: (T.Text, Parser r) -> EitherUrlChunk ('Just r) p = (:~) @@ -36,17 +40,13 @@ r :: (T.Text, Regex) -> EitherUrlChunk ('Just [String]) r = (:*) --- | Container when defining route paths -data UrlChunks (xs :: [Maybe *]) where - Cons :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -- stack is left-to-right - Root :: UrlChunks '[] - -- | Glue two chunks together () :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) () = Cons infixr 9 --- | The /new-Origin/ chunk - the equivalent to @[]@ -o :: UrlChunks '[] -o = Root +-- | Container when defining route paths +data UrlChunks (xs :: [Maybe *]) where + Cons :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -- stack is left-to-right + Root :: UrlChunks '[] diff --git a/src/Web/Routes/Nested/VerbListener.hs b/src/Web/Routes/Nested/VerbListener.hs deleted file mode 100644 --- a/src/Web/Routes/Nested/VerbListener.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE - GeneralizedNewtypeDeriving - , ScopedTypeVariables - , MultiParamTypeClasses - , TupleSections - #-} - -module Web.Routes.Nested.VerbListener where - -import Network.Wai (Request) -import Network.HTTP.Types (StdMethod (..)) - -import Data.Function.Syntax -import Data.Bifunctor -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set.Class as Sets -import Control.Monad.Trans -import Control.Monad.Writer - - -type Verb = StdMethod - -type HandleUpload m u = Request -> m (Maybe u) -type Respond u r = Request -> Maybe u -> r -type ResponseSpec u m r = (HandleUpload m u, Respond u r) - - --- * Verb Map - -newtype Verbs u m r = Verbs - { unVerbs :: Map Verb (ResponseSpec u m r) - } deriving (Monoid, HasUnion, HasEmpty) - --- | To compensate for responses that want to peek into the @Request@ object. -supplyReq :: Request - -> Map Verb (ResponseSpec u m r) - -> Map Verb (m (Maybe u), Maybe u -> r) -supplyReq req xs = bimap ($ req) ($ req) <$> xs - -instance Functor (Verbs u m) where - fmap f (Verbs xs) = Verbs $ fmap (second (f .*)) xs - --- instance Foldable (Verbs u m) where --- foldMap f (Verbs xs) = foldMap go xs --- where go (_, Left r) = f r -- can only take left cases --- go _ = mempty - - --- * Verb Writer - -newtype VerbListenerT r u m a = - VerbListenerT { runVerbListenerT :: WriterT (Union (Verbs u m r)) m a } - deriving ( Functor - , Applicative - , Monad - , MonadWriter (Union (Verbs u m r)) - , MonadIO - ) - -execVerbListenerT :: Monad m => VerbListenerT r u m a -> m (Verbs u m r) -execVerbListenerT verbs = do uVerbs <- execWriterT $ runVerbListenerT verbs - return $ unUnion uVerbs - -instance MonadTrans (VerbListenerT r u) where - lift ma = VerbListenerT $ lift ma - - -foldMWithKey :: Monad m => (acc -> Verb -> a -> m acc) -> acc -> Map Verb a -> m acc -foldMWithKey f i = Map.foldlWithKey (\macc k a -> (\mer -> f mer k a) =<< macc) (return i) - - --- | For simple @GET@ responses -get :: ( Monad m - ) => r -> VerbListenerT r u m () -get r = tell $ Union $ Verbs $ Map.singleton GET ( const $ return Nothing - , const $ const r - ) - --- | Inspect the @Request@ object supplied by WAI -getReq :: ( Monad m - ) => (Request -> r) -> VerbListenerT r u m () -getReq r = tell $ Union $ Verbs $ Map.singleton GET ( const $ return Nothing - , const . r) - - --- | For simple @POST@ responses -post :: ( Monad m - , MonadIO m - ) => HandleUpload m u -> (Maybe u -> r) -> VerbListenerT r u m () -post handle r = tell $ Union $ Verbs $ Map.singleton POST ( handle - , const r - ) - --- | Inspect the @Request@ object supplied by WAI -postReq :: ( Monad m - , MonadIO m - ) => HandleUpload m u -> (Request -> Maybe u -> r) -> VerbListenerT r u m () -postReq handle r = tell $ Union $ Verbs $ Map.singleton POST ( handle - , r - ) - - --- | For simple @PUT@ responses -put :: ( Monad m - , MonadIO m - ) => HandleUpload m u -> (Maybe u -> r) -> VerbListenerT r u m () -put handle r = tell $ Union $ Verbs $ Map.singleton PUT ( handle - , const r - ) - --- | Inspect the @Request@ object supplied by WAI -putReq :: ( Monad m - , MonadIO m - ) => HandleUpload m u -> (Request -> Maybe u -> r) -> VerbListenerT r u m () -putReq handle r = tell $ Union $ Verbs $ Map.singleton PUT ( handle - , r - ) - - --- | For simple @DELETE@ responses -delete :: ( Monad m - ) => r -> VerbListenerT r u m () -delete r = tell $ Union $ Verbs $ Map.singleton DELETE ( const $ return Nothing - , const $ const r - ) - --- | Inspect the @Request@ object supplied by WAI -deleteReq :: ( Monad m - ) => (Request -> r) -> VerbListenerT r u m () -deleteReq r = tell $ Union $ Verbs $ Map.singleton DELETE ( const $ return Nothing - , const . r - ) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,5 @@ +import Test.Hspec (hspec) +import Spec (spec) + +main :: IO () +main = hspec spec diff --git a/test/Web/Routes/NestedSpec.hs b/test/Web/Routes/NestedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Routes/NestedSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE + OverloadedStrings + #-} + +module Web.Routes.NestedSpec (spec) where + +import Web.Routes.NestedSpec.Basic +import Network.Wai.Trans + +import Test.Hspec +import Test.Hspec.Wai as HW + + + +spec :: Spec +spec = do + describe "Literal Routes" $ + with (return app) $ do + describe "GET /" $ + it "should respond with 200" $ + get "/" `shouldRespondWith` + 200 + describe "GET /foo" $ + it "should respond with 200 and 'foo!'" $ + get "/foo" `shouldRespondWith` + "" { matchStatus = 200 + , matchBody = Just "foo!" + } + describe "GET /baz" $ + it "should respond with 200 and 'baz!'" $ + get "/baz" `shouldRespondWith` + "" { matchStatus = 200 + , matchBody = Just "baz!" + } + describe "GET /borked" $ + it "should respond with 404" $ + get "/borked" `shouldRespondWith` + 404 + describe "Regex Routes" $ + with (return app) $ do + describe "GET /athan@emails.com" $ + it "should respond with 200 and '[\"athan@emails.com\"] email'" $ + get "/athan@emails.com" `shouldRespondWith` + "" { matchStatus = 200 + , matchBody = Just "[\"athan@emails.com\"] email" + } + describe "Upload Routes" $ + with (return app) $ do + describe "POST /baz" $ + it "should respond with 200 and 'Woah! Upload content!'" $ + post "/baz" "anything" `shouldRespondWith` + "" { matchStatus = 200 + , matchBody = Just "Woah! Upload content!" + } + describe "Secure Routes" $ + with (return app) $ do + describe "GET /foo/bar" $ + it "should respond with 401 and 'Unauthorized!'" $ + get "/foo/bar" `shouldRespondWith` + "" { matchStatus = 401 + , matchBody = Just "Unauthorized!" + } + + diff --git a/test/Web/Routes/NestedSpec/Basic.hs b/test/Web/Routes/NestedSpec/Basic.hs new file mode 100644 --- /dev/null +++ b/test/Web/Routes/NestedSpec/Basic.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE + OverloadedStrings + , ScopedTypeVariables + , FlexibleContexts + #-} + + +module Web.Routes.NestedSpec.Basic where + +import Web.Routes.Nested +import Network.Wai.Trans +import Network.HTTP.Types +import Text.Regex +import qualified Data.Text.Lazy as LT +import Data.Attoparsec.Text +import Data.Monoid +import Control.Monad.Except + + +data AuthRole = AuthRole deriving (Show, Eq) +data AuthErr = NeedsAuth deriving (Show, Eq) + +-- | If you fail here and throw an AuthErr, then the user was not authorized to +-- under the conditions set by @ss :: [AuthRole]@, and based on the authentication +-- of that user's session from the @Request@ object. Note that we could have a +-- shared cache of authenticated sessions, by adding more constraints on @m@ like +-- @MonadIO@. +-- For instance, even if there are [] auth roles, we could still include a header/timestamp +-- pair to uniquely identify the guest. Or, we could equally change @Checksum ~ Maybe Token@, +-- so a guest just returns Nothing, and we could handle the case in @putAuth@ to +-- not do anything. +authorize :: ( Monad m + , MonadError AuthErr m + ) => Request -> [AuthRole] -> m (Response -> Response) +-- authorize _ _ = return id -- uncomment to force constant authorization +authorize req ss | null ss = return id + | otherwise = throwError NeedsAuth + +defApp :: Application +defApp _ respond = respond $ textOnlyStatus status404 "404 :(" + +app :: Application +app = + let yoDawgIHeardYouLikeYoDawgsYo = routeActionAuth authorize routes + routes = + handleAction o (Just rootHandle) $ Just $ do + handleAction fooRoute (Just fooHandle) $ Just $ do + auth AuthRole unauthHandle ProtectChildren + handleAction barRoute (Just barHandle) Nothing + handleAction doubleRoute (Just doubleHandle) Nothing + handleAction emailRoute (Just emailHandle) Nothing + handleAction bazRoute (Just bazHandle) Nothing + notFoundAction o (Just notFoundHandle) Nothing + in yoDawgIHeardYouLikeYoDawgsYo defApp + where + rootHandle = get $ text "Home" + + -- `/foo` + fooRoute = l "foo" o + fooHandle = get $ text "foo!" + + -- `/foo/bar` + barRoute = l "bar" o + barHandle = get $ do + text "bar!" + json ("json bar!" :: LT.Text) + + -- `/foo/1234e12`, uses attoparsec + doubleRoute = p ("double", double) o + doubleHandle d = get $ text $ LT.pack (show d) <> " foos" + + -- `/athan@foo.com` + emailRoute = r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") o + emailHandle e = get $ text $ LT.pack (show e) <> " email" + + -- `/baz`, uses regex-compat + bazRoute = l "baz" o + bazHandle = do + get $ text "baz!" + let uploader req = do liftIO $ print =<< strictRequestBody req + return () + uploadHandle (Left Nothing) = text "Upload Failed" + uploadHandle (Left (Just _)) = text "Impossible - no errors thrown in uploader" + uploadHandle (Right ()) = text "Woah! Upload content!" + post uploader uploadHandle + + unauthHandle NeedsAuth = get $ textStatus status401 "Unauthorized!" + notFoundHandle = get $ textStatus status404 "Not Found :("