Spock 0.5.0.1 → 0.5.1.0
raw patch · 7 files changed
+255/−216 lines, 7 files
Files
- Spock.cabal +53/−53
- src/Tests.hs +1/−1
- src/Tests/Routing.hs +63/−0
- src/Web/Spock/Core.hs +15/−4
- src/Web/Spock/Digestive.hs +6/−6
- src/Web/Spock/Routing.hs +89/−142
- src/Web/Spock/Wire.hs +28/−10
Spock.cabal view
@@ -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
src/Tests.hs view
@@ -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
+ src/Tests/Routing.hs view
@@ -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}]}]}
src/Web/Spock/Core.hs view
@@ -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 ()
src/Web/Spock/Digestive.hs view
@@ -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)
src/Web/Spock/Routing.hs view
@@ -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))
src/Web/Spock/Wire.hs view
@@ -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) }