diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,5 +1,5 @@ name: Spock -version: 0.5.0.1 +version: 0.5.1.0 synopsis: Another Haskell web framework for rapid development description: This toolbox provides everything you need to get a quick start into web hacking with haskell: routing, middleware, json, blaze, sessions, cookies, database helper, csrf-protection, global state Homepage: https://github.com/agrafix/Spock @@ -23,82 +23,82 @@ Web.Spock.Core, Web.Spock.Wire, Web.Spock.Routing - build-depends: base >= 4 && < 5, - wai >=2.0, - wai-util ==0.7, - http-types ==0.8.*, - text >= 0.11.3.1 && < 1.2, - containers ==0.5.*, + build-depends: aeson >= 0.6.2.1 && < 0.8, + base >= 4 && < 5, + base64-bytestring ==1.*, + blaze-html ==0.7.*, bytestring ==0.10.*, + case-insensitive ==1.1.*, + conduit >= 1.0 && < 1.2, + containers ==0.5.*, + digestive-functors ==0.7.*, + directory ==1.2.*, + hashable ==1.2.*, + http-types ==0.8.*, + monad-control ==0.3.*, mtl ==2.1.*, - wai-extra >=2.0.0.1, + old-locale ==1.*, + path-pieces ==0.1.*, + pool-conduit ==0.1.*, + random ==1.*, + regex-compat ==0.95.*, + resource-pool ==0.2.*, resourcet ==0.4.*, stm ==2.4.*, - unordered-containers ==0.2.*, - old-locale ==1.*, - base64-bytestring ==1.*, + text >= 0.11.3.1 && < 1.2, time ==1.4.*, - monad-control ==0.3.*, transformers ==0.3.*, transformers-base ==0.4.*, - xsd ==0.4.*, - resource-pool ==0.2.*, - random ==1.*, - pool-conduit ==0.1.*, + unordered-containers ==0.2.*, vault ==0.3.*, - path-pieces ==0.1.*, - hashable ==1.2.*, - blaze-html ==0.7.*, - digestive-functors ==0.7.*, - HTF ==0.11.*, - regex-compat ==0.95.*, vector ==0.10.*, - case-insensitive ==1.1.*, - conduit >= 1.0 && < 1.2, - aeson >= 0.6.2.1 && < 0.8, - directory ==1.2.*, - warp >= 2.0.0.1 && < 2.1 + wai-extra >=2.0.0.1, + wai-util ==0.7, + warp >= 2.0.0.1 && < 2.1, + xsd ==0.4.*, + wai >=2.0 ghc-options: -Wall -fno-warn-orphans test-suite spocktests type: exitcode-stdio-1.0 hs-source-dirs: src main-is: Tests.hs - build-depends: base >= 4 && < 5, - wai >=2.0, - wai-util ==0.7, - http-types ==0.8.*, - text >= 0.11.3.1 && < 1.2, - containers ==0.5.*, + other-modules: Tests.Routing + build-depends: HTF ==0.11.*, + aeson >= 0.6.2.1 && < 0.8, + base >= 4 && < 5, + base64-bytestring ==1.*, + blaze-html ==0.7.*, bytestring ==0.10.*, + case-insensitive ==1.1.*, + conduit >= 1.0 && < 1.2, + containers ==0.5.*, + digestive-functors ==0.7.*, + directory ==1.2.*, + hashable ==1.2.*, + http-types ==0.8.*, + monad-control ==0.3.*, mtl ==2.1.*, - wai-extra >=2.0.0.1, + old-locale ==1.*, + path-pieces ==0.1.*, + pool-conduit ==0.1.*, + random ==1.*, + regex-compat ==0.95.*, + resource-pool ==0.2.*, resourcet ==0.4.*, stm ==2.4.*, - unordered-containers ==0.2.*, - old-locale ==1.*, - base64-bytestring ==1.*, + text >= 0.11.3.1 && < 1.2, time ==1.4.*, - monad-control ==0.3.*, transformers ==0.3.*, transformers-base ==0.4.*, - xsd ==0.4.*, - resource-pool ==0.2.*, - random ==1.*, - pool-conduit ==0.1.*, + unordered-containers ==0.2.*, vault ==0.3.*, - path-pieces ==0.1.*, - hashable ==1.2.*, - blaze-html ==0.7.*, - digestive-functors ==0.7.*, - HTF ==0.11.*, - regex-compat ==0.95.*, vector ==0.10.*, - case-insensitive ==1.1.*, - conduit >= 1.0 && < 1.2, - aeson >= 0.6.2.1 && < 0.8, - directory ==1.2.*, - warp >= 2.0.0.1 && < 2.1 + wai >=2.0, + wai-extra >=2.0.0.1, + wai-util ==0.7, + warp >= 2.0.0.1 && < 2.1, + xsd ==0.4.* ghc-options: -Wall -fno-warn-orphans source-repository head diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -2,7 +2,7 @@ module Main where import Test.Framework -import {-@ HTF_TESTS @-} Web.Spock.Routing +import {-@ HTF_TESTS @-} Tests.Routing main :: IO () main = htfMain htf_importedTests diff --git a/src/Tests/Routing.hs b/src/Tests/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Tests/Routing.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE OverloadedStrings #-} +module Tests.Routing (htf_thisModulesTests) where + +import Test.Framework + +import Web.Spock.Routing +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM + +test_matchNode :: IO () +test_matchNode = + do assertEqual (False, Nothing) (matchNode "foo" (RouteNodeRoot)) + assertEqual (True, Just (CaptureVar "x", "123")) (matchNode "123" (RouteNodeCapture (CaptureVar "x"))) + assertEqual (True, Just (CaptureVar "x", "123")) (matchNode "123" (RouteNodeRegex (CaptureVar "x") (buildRegex "^[0-9]+$"))) + +test_matchRoute :: IO () +test_matchRoute = + do assertEqual Nothing (matchRoute "random" routingTree) + assertEqual (Just (emptyParamMap, [1])) (matchRoute "/" routingTree) + assertEqual Nothing (matchRoute "/baz" routingTree) + assertEqual (Just (emptyParamMap, [2])) (matchRoute "/bar" routingTree) + assertEqual (Just (HM.fromList [(CaptureVar "baz", "5")], [3])) (matchRoute "/bar/5" routingTree) + assertEqual (Just (HM.fromList [(CaptureVar "baz", "5")], [3])) (matchRoute "/bar/5" routingTree) + assertEqual (Just (HM.fromList [(CaptureVar "baz", "23")], [4])) (matchRoute "/bar/23/baz" routingTree) + where + routingTree = + foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes + routes = + [ ("/", [1]) + , ("/bar", [2 :: Int]) + , ("/bar/:baz", [3]) + , ("/bar/:baz/baz", [4]) + ] + +test_parseRouteNode :: IO () +test_parseRouteNode = + do assertEqual (RouteNodeText "foo") (parseRouteNode "foo") + assertEqual (RouteNodeCapture (CaptureVar "bar")) (parseRouteNode ":bar") + assertEqual (RouteNodeRegex (CaptureVar "bar") (buildRegex "^[0-9]$")) (parseRouteNode "{bar:^[0-9]$}") + +test_addToRoutingTree :: IO () +test_addToRoutingTree = + do assertEqual baseRoute (addToRoutingTree "/" [True] emptyT) + assertEqual (fooBar []) (addToRoutingTree "/foo/:bar" [True] emptyT) + assertEqual (fooBar baz) (addToRoutingTree "/foo/:bar/baz" [True] (fooBar [])) + where + emptyT = emptyRoutingTree + baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty} + baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }] + fooBar xs = + RoutingTree + { rt_node = + RouteData {rd_node = RouteNodeRoot, rd_data = Nothing } + , rt_children = + V.fromList + [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing} + , rt_children = + V.fromList + [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (CaptureVar "bar") + , rd_data = Just [True] + } + , rt_children = V.fromList xs}]}]} diff --git a/src/Web/Spock/Core.hs b/src/Web/Spock/Core.hs --- a/src/Web/Spock/Core.hs +++ b/src/Web/Spock/Core.hs @@ -24,6 +24,7 @@ import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Web.PathPieces +import Web.Spock.Routing import Web.Spock.Wire import qualified Data.Aeson as A import qualified Data.ByteString as BS @@ -35,6 +36,8 @@ import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp +-- | Run a raw spock server on a defined port. If you don't need +-- a custom base monad you can just supply 'id' as lift function. spockT :: MonadIO m => Warp.Port -> (forall a. m a -> IO a) @@ -108,15 +111,23 @@ asks ri_files -- | Get all request params -params :: MonadIO m => ActionT m (HM.HashMap T.Text T.Text) +params :: MonadIO m => ActionT m [(T.Text, T.Text)] params = - asks ri_params + do p <- asks ri_params + qp <- asks ri_queryParams + return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p)) -- | Read a request param. Spock looks in route captures first, then in POST variables and at last in GET variables param :: (PathPiece p, MonadIO m) => T.Text -> ActionT m (Maybe p) param k = - do p <- params - return $ join $ fmap fromPathPiece (HM.lookup k p) + do p <- asks ri_params + qp <- asks ri_queryParams + let findP f wrapK x = join $ fmap fromPathPiece (f (wrapK k) x) + paramVal = findP HM.lookup CaptureVar p + queryVal = findP lookup id qp + case paramVal of + Just pVal -> return (Just pVal) + Nothing -> return queryVal -- | Set a response status setStatus :: MonadIO m => Status -> ActionT m () diff --git a/src/Web/Spock/Digestive.hs b/src/Web/Spock/Digestive.hs --- a/src/Web/Spock/Digestive.hs +++ b/src/Web/Spock/Digestive.hs @@ -3,10 +3,10 @@ ( runForm ) where -import Web.Spock.Types import Web.Spock.Core import Control.Applicative +import Control.Monad.Trans import Network.HTTP.Types import Network.Wai import Text.Digestive.Form @@ -16,9 +16,10 @@ import qualified Data.Text as T -- | Run a digestive functors form -runForm :: T.Text -- ^ form name - -> Form v (SpockAction conn sess st) a - -> SpockAction conn sess st (View v, Maybe a) +runForm :: (Functor m, MonadIO m) + => T.Text -- ^ form name + -> Form v (ActionT m) a + -> ActionT m (View v, Maybe a) runForm formName form = do httpMethod <- requestMethod <$> request if httpMethod == methodGet @@ -26,11 +27,10 @@ return (f, Nothing) else postForm formName form (const $ return localEnv) where - localEnv :: Env (SpockAction conn sess st) localEnv path = do let name = fromPath $ path applyParam f = map (f . snd) . filter ((== name) . fst) - vars <- (applyParam (TextInput) . HM.toList) <$> params + vars <- (applyParam (TextInput)) <$> params sentFiles <- (applyParam (FileInput . T.unpack . uf_name) . HM.toList) <$> files return (vars ++ sentFiles) diff --git a/src/Web/Spock/Routing.hs b/src/Web/Spock/Routing.hs --- a/src/Web/Spock/Routing.hs +++ b/src/Web/Spock/Routing.hs @@ -1,12 +1,6 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Web.Spock.Routing - ( matchRoute - , RoutingTree, CaptureVar (..), ParamMap, addToRoutingTree, emptyRoutingTree - , htf_thisModulesTests - ) -where +module Web.Spock.Routing where import Data.Hashable import qualified Data.Text as T @@ -15,8 +9,6 @@ import qualified Text.Regex as Regex import qualified Data.HashMap.Strict as HM -import Test.Framework - type ParamMap = HM.HashMap CaptureVar T.Text newtype CaptureVar @@ -30,11 +22,11 @@ } instance Eq RegexWrapper where - r1 == r2 = - rw_original r1 == rw_original r2 + r1 == r2 = + rw_original r1 == rw_original r2 instance Show RegexWrapper where - show (RegexWrapper _ x) = show x + show (RegexWrapper _ x) = show x data RouteNode = RouteNodeRegex !CaptureVar !RegexWrapper @@ -59,10 +51,11 @@ buildRegex :: T.Text -> RegexWrapper buildRegex t = - RegexWrapper (Regex.mkRegex $ T.unpack t) t + RegexWrapper (Regex.mkRegex $ T.unpack t) t emptyRoutingTree :: RoutingTree a -emptyRoutingTree = RoutingTree (RouteData RouteNodeRoot Nothing) V.empty +emptyRoutingTree = + RoutingTree (RouteData RouteNodeRoot Nothing) V.empty mergeData :: Maybe a -> Maybe a -> Maybe a mergeData (Just _) (Just _) = @@ -73,148 +66,102 @@ addToRoutingTree :: T.Text -> a -> RoutingTree a -> RoutingTree a addToRoutingTree route dat currTree = - let applyTree [] tree = tree - applyTree (current:xs) tree = - let children = V.map (\(RoutingTree d _) -> rd_node d) (rt_children tree) - currentDat = - case xs of - [] -> Just dat - _ -> Nothing - children' = - case V.findIndex (==current) children of - Nothing -> - V.cons (applyTree xs $ RoutingTree (RouteData current currentDat) V.empty) (rt_children tree) - Just idx -> - let origNode = (V.!) (rt_children tree) idx - matchingNode = rt_node $ origNode - appliedNode = matchingNode { rd_data = mergeData (rd_data matchingNode) currentDat } - in V.modify (\v -> VM.write v idx (applyTree xs $ RoutingTree appliedNode (rt_children origNode))) (rt_children tree) - in tree { rt_children = children' } - in case filter (not . T.null) $ T.splitOn "/" route of - [] -> - let currNode = rt_node currTree - currNode' = currNode { rd_data = mergeData (rd_data currNode) (Just dat) } - in currTree { rt_node = currNode' } - xs -> applyTree (map parseRouteNode xs) currTree + let applyTree [] tree = tree + applyTree (current:xs) tree = + let children = V.map (\(RoutingTree d _) -> rd_node d) (rt_children tree) + currentDat = + case xs of + [] -> Just dat + _ -> Nothing + children' = + case V.findIndex (==current) children of + Nothing -> + let h = applyTree xs $ RoutingTree (RouteData current currentDat) V.empty + in V.cons h (rt_children tree) + Just idx -> + let origNode = (V.!) (rt_children tree) idx + matchingNode = rt_node $ origNode + appliedNode = matchingNode { rd_data = mergeData (rd_data matchingNode) currentDat } + in V.modify (\v -> VM.write v idx (applyTree xs $ RoutingTree appliedNode (rt_children origNode))) (rt_children tree) + in tree { rt_children = children' } + in case filter (not . T.null) $ T.splitOn "/" route of + [] -> + let currNode = rt_node currTree + currNode' = currNode { rd_data = mergeData (rd_data currNode) (Just dat) } + in currTree { rt_node = currNode' } + xs -> applyTree (map parseRouteNode xs) currTree parseRouteNode :: T.Text -> RouteNode parseRouteNode node = - case T.uncons node of - Just (':', var) -> - RouteNodeCapture $ CaptureVar var - Just ('{', rest) -> - case T.uncons (T.reverse rest) of - Just ('}', def) -> - let (var, xs) = T.breakOn ":" (T.reverse def) - in case T.uncons xs of - Just (':', regex) -> - RouteNodeRegex (CaptureVar var) (buildRegex regex) - _ -> - nodeError - _ -> nodeError - Just _ -> - RouteNodeText node - Nothing -> - nodeError - where - nodeError = error ("Spock route error: " ++ (show node) ++ " is not a valid route node.") + case T.uncons node of + Just (':', var) -> + RouteNodeCapture $ CaptureVar var + Just ('{', rest) -> + case T.uncons (T.reverse rest) of + Just ('}', def) -> + let (var, xs) = T.breakOn ":" (T.reverse def) + in case T.uncons xs of + Just (':', regex) -> + RouteNodeRegex (CaptureVar var) (buildRegex regex) + _ -> + nodeError + _ -> nodeError + Just _ -> + RouteNodeText node + Nothing -> + nodeError + where + nodeError = error ("Spock route error: " ++ (show node) ++ " is not a valid route node.") emptyParamMap :: ParamMap emptyParamMap = HM.empty matchRoute :: T.Text -> RoutingTree a -> Maybe (ParamMap, a) matchRoute route globalTree = - case filter (not . T.null) $ T.splitOn "/" route of - [] -> fmap (\d -> (emptyParamMap, d)) $ rd_data $ rt_node globalTree - xs -> - case findRoute xs globalTree emptyParamMap of - (_, Nothing) -> Nothing - (pmap, Just x) -> Just (pmap, x) - where - applyParams :: Maybe (CaptureVar, T.Text) -> ParamMap -> ParamMap - applyParams Nothing x = x - applyParams (Just (var, t)) x = HM.insert var t x + matchRoute' (T.splitOn "/" route) globalTree - handleChildren xs children pmap = - V.foldl' (\st@(accumParams, res) child -> - case res of - Nothing -> findRoute xs child accumParams - Just _ -> st - ) (pmap, Nothing) children +matchRoute' :: [T.Text] -> RoutingTree a -> Maybe (ParamMap, a) +matchRoute' routeParts globalTree = + case filter (not . T.null) routeParts of + [] -> fmap (\d -> (emptyParamMap, d)) $ rd_data $ rt_node globalTree + xs -> + case findRoute xs globalTree emptyParamMap of + (_, Nothing) -> Nothing + (pmap, Just x) -> Just (pmap, x) + where + applyParams :: Maybe (CaptureVar, T.Text) -> ParamMap -> ParamMap + applyParams Nothing x = x + applyParams (Just (var, t)) x = HM.insert var t x - findRoute :: [T.Text] -> RoutingTree a -> ParamMap -> (ParamMap, Maybe a) - findRoute [] _ pmap = (pmap, Nothing) - findRoute xs (RoutingTree (RouteData RouteNodeRoot _) children) pmap = - handleChildren xs children pmap - findRoute (x:xs) tree pmap = - case matchNode x (rd_node $ rt_node tree) of - (True, params) -> - let params' = applyParams params pmap - in case xs of - [] -> (params', rd_data $ rt_node tree) - _ -> handleChildren xs (rt_children tree) params' - (False, _) -> - (pmap, Nothing) + handleChildren xs children pmap = + let loop st [] = st + loop (st@(accumParams, res)) (child:leftoverChildren) = + case res of + Nothing -> + loop (findRoute xs child accumParams) leftoverChildren + Just _ -> + st + in loop (pmap, Nothing) $ V.toList children + findRoute :: [T.Text] -> RoutingTree a -> ParamMap -> (ParamMap, Maybe a) + findRoute [] _ pmap = (pmap, Nothing) + findRoute xs (RoutingTree (RouteData RouteNodeRoot _) children) pmap = + handleChildren xs children pmap + findRoute (x:xs) tree pmap = + case matchNode x (rd_node $ rt_node tree) of + (True, params) -> + let params' = applyParams params pmap + in case xs of + [] -> (params', rd_data $ rt_node tree) + _ -> handleChildren xs (rt_children tree) params' + (False, _) -> + (pmap, Nothing) + matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text)) matchNode _ RouteNodeRoot = (False, Nothing) matchNode t (RouteNodeText m) = (m == t, Nothing) matchNode t (RouteNodeCapture var) = (True, Just (var, t)) matchNode t (RouteNodeRegex var regex) = - case Regex.matchRegex (rw_regex regex) (T.unpack t) of - Nothing -> (False, Nothing) - Just _ -> (True, Just (var, t)) - -test_matchNode :: IO () -test_matchNode = - do assertEqual (False, Nothing) (matchNode "foo" (RouteNodeRoot)) - assertEqual (True, Just (CaptureVar "x", "123")) (matchNode "123" (RouteNodeCapture (CaptureVar "x"))) - assertEqual (True, Just (CaptureVar "x", "123")) (matchNode "123" (RouteNodeRegex (CaptureVar "x") (buildRegex "^[0-9]+$"))) - -test_matchRoute :: IO () -test_matchRoute = - do assertEqual Nothing (matchRoute "random" routingTree) - assertEqual (Just (emptyParamMap, [1])) (matchRoute "/" routingTree) - assertEqual Nothing (matchRoute "/baz" routingTree) - assertEqual (Just (emptyParamMap, [2])) (matchRoute "/bar" routingTree) - assertEqual (Just (HM.fromList [(CaptureVar "baz", "5")], [3])) (matchRoute "/bar/5" routingTree) - assertEqual (Just (HM.fromList [(CaptureVar "baz", "5")], [3])) (matchRoute "/bar/5" routingTree) - assertEqual (Just (HM.fromList [(CaptureVar "baz", "23")], [4])) (matchRoute "/bar/23/baz" routingTree) - where - routingTree = - foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes - routes = - [ ("/", [1]) - , ("/bar", [2 :: Int]) - , ("/bar/:baz", [3]) - , ("/bar/:baz/baz", [4]) - ] - -test_parseRouteNode :: IO () -test_parseRouteNode = - do assertEqual (RouteNodeText "foo") (parseRouteNode "foo") - assertEqual (RouteNodeCapture (CaptureVar "bar")) (parseRouteNode ":bar") - assertEqual (RouteNodeRegex (CaptureVar "bar") (buildRegex "^[0-9]$")) (parseRouteNode "{bar:^[0-9]$}") - -test_addToRoutingTree :: IO () -test_addToRoutingTree = - do assertEqual baseRoute (addToRoutingTree "/" [True] emptyT) - assertEqual (fooBar []) (addToRoutingTree "/foo/:bar" [True] emptyT) - assertEqual (fooBar baz) (addToRoutingTree "/foo/:bar/baz" [True] (fooBar [])) - where - emptyT = emptyRoutingTree - baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty} - baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }] - fooBar xs = - RoutingTree - { rt_node = - RouteData {rd_node = RouteNodeRoot, rd_data = Nothing } - , rt_children = - V.fromList - [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing} - , rt_children = - V.fromList - [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (CaptureVar "bar") - , rd_data = Just [True] - } - , rt_children = V.fromList xs}]}]} + case Regex.matchRegex (rw_regex regex) (T.unpack t) of + Nothing -> (False, Nothing) + Just _ -> (True, Just (var, t)) diff --git a/src/Web/Spock/Wire.hs b/src/Web/Spock/Wire.hs --- a/src/Web/Spock/Wire.hs +++ b/src/Web/Spock/Wire.hs @@ -3,11 +3,13 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Wire where import Web.Spock.Routing import Control.Applicative +import Control.Exception import Control.Monad.RWS.Strict import Control.Monad.Reader.Class () import Control.Monad.State.Strict @@ -16,6 +18,8 @@ import Data.Maybe import Network.HTTP.Types.Method import Network.HTTP.Types.Status +import Prelude hiding (catch) +import System.Directory import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.CaseInsensitive as CI @@ -24,7 +28,6 @@ import qualified Data.Text.Encoding as T import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P -import System.Directory instance Hashable StdMethod where hashWithSalt = hashUsing fromEnum @@ -48,7 +51,8 @@ data RequestInfo = RequestInfo { ri_request :: Wai.Request - , ri_params :: HM.HashMap T.Text T.Text + , ri_params :: HM.HashMap CaptureVar T.Text + , ri_queryParams :: [(T.Text, T.Text)] , ri_files :: HM.HashMap T.Text UploadedFile } @@ -117,6 +121,10 @@ invalidReq = respStateToResponse $ errorResponse status400 "400 - Bad request" +serverError :: ResponseState +serverError = + errorResponse status500 "500 - Internal Server Error!" + buildApp :: forall m. (MonadIO m) => (forall a. m a -> IO a) -> SpockT m () @@ -130,9 +138,12 @@ Right stdMethod -> case HM.lookup stdMethod $ ss_treeMap spockState of Just routeTree -> - case matchRoute (T.intercalate "/" $ Wai.pathInfo req) routeTree of + case matchRoute' (Wai.pathInfo req) routeTree of Just (captures, action) -> - do (bodyParams, bodyFiles) <- runResourceT $ withInternalState $ \st -> P.parseRequestBody (P.tempFileBackEnd st) req + do (bodyParams, bodyFiles) <- + runResourceT $ + withInternalState $ \st -> + P.parseRequestBody (P.tempFileBackEnd st) req let uploadedFiles = HM.fromList $ map (\(k, fileInfo) -> @@ -140,13 +151,18 @@ , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo) ) ) bodyFiles - captureParams = map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList captures - postParams = map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams - getParams = map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req - params = HM.fromList $ captureParams ++ postParams ++ getParams - env = RequestInfo req params uploadedFiles + postParams = + map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams + getParams = + map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req + queryParams = postParams ++ getParams + env = RequestInfo req captures queryParams uploadedFiles resp = errorResponse status200 "" - (respState, _) <- spockLift $ execRWST (runActionT action) env resp + (respState, _) <- + (spockLift $ execRWST (runActionT action) env resp) + `catch` \(e :: SomeException) -> + do putStrLn $ "Spock Error: " ++ show e + return (serverError, ()) forM_ (HM.elems uploadedFiles) $ \uploadedFile -> do stillThere <- doesFileExist (uf_tempLocation uploadedFile) when stillThere $ removeFile (uf_tempLocation uploadedFile) @@ -157,10 +173,12 @@ return notFound return $ ss_middleware spockState $ app +-- | Hook up a 'Wai.Middleware' middleware :: MonadIO m => Wai.Middleware -> SpockT m () middleware mw = modify $ \st -> st { ss_middleware = mw . (ss_middleware st) } +-- | Define a route matching a provided 'StdMethod' and route defRoute :: (MonadIO m) => StdMethod -> T.Text -> ActionT m () -> SpockT m () defRoute method route action = modify $ \st -> st { ss_treeMap = HM.insertWith updFun method (addToTree emptyRoutingTree) (ss_treeMap st) }