diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,5 +1,5 @@ name: Spock -version: 0.6.2.3 +version: 0.6.3.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 @@ -39,7 +39,7 @@ monad-control ==0.3.*, mtl ==2.1.*, old-locale ==1.*, - path-pieces ==0.1.*, + path-pieces >=0.1.4, pool-conduit ==0.1.*, random ==1.*, regex-compat ==0.95.*, @@ -80,12 +80,12 @@ monad-control ==0.3.*, mtl ==2.1.*, old-locale ==1.*, - path-pieces ==0.1.*, + path-pieces >=0.1.4, pool-conduit ==0.1.*, random ==1.*, regex-compat ==0.95.*, resource-pool ==0.2.*, - resourcet ==0.4.*, + resourcet >= 0.4 && < 1.2, stm ==2.4.*, text >= 0.11.3.1 && < 1.2, time ==1.4.*, diff --git a/src/Tests/Routing.hs b/src/Tests/Routing.hs --- a/src/Tests/Routing.hs +++ b/src/Tests/Routing.hs @@ -16,21 +16,44 @@ 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) + do assertEqual noMatches (matchRoute "random" routingTree) + assertEqual (oneMatch emptyParamMap [1]) (matchRoute "/" routingTree) + assertEqual noMatches (matchRoute "/baz" routingTree) + assertEqual (oneMatch emptyParamMap [2]) (matchRoute "/bar" routingTree) + assertEqual (oneMatch (vMap [("baz", "5")]) [3]) (matchRoute "/bar/5" routingTree) + assertEqual multiMatch (matchRoute "/bar/bingo" routingTree) + assertEqual (oneMatch (vMap [("baz", "23")]) [4]) (matchRoute "/bar/23/baz" routingTree) + assertEqual (oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]) (matchRoute "/bar/23/baz/100" routingTree) + assertEqual (oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]) (matchRoute "/ba/23/100" routingTree) + assertEqual (oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6]) (matchRoute "/entry/344/2014-20-14T12:23" routingTree) + assertEqual (oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7]) (matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree) + assertEqual multiMatch' (matchRoute "/entry/1/audit" routingTree) + assertEqual (oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9]) (matchRoute "/entry/2/rel/3" routingTree) where + vMap kv = + HM.fromList $ map (\(k, v) -> (CaptureVar k, v)) kv + multiMatch = + ((oneMatch emptyParamMap [5]) + ++ oneMatch (vMap [("baz", "bingo")]) [3]) + multiMatch' = + ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6]) + ++ (oneMatch (vMap [("eid", "1")]) [8])) + noMatches = [] + oneMatch pm m = [(pm, m)] routingTree = foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes routes = [ ("/", [1]) , ("/bar", [2 :: Int]) , ("/bar/:baz", [3]) + , ("/bar/bingo", [5]) , ("/bar/:baz/baz", [4]) + , ("/bar/:baz/baz/:bim", [4]) + , ("/ba/:baz/:bim", [4]) + , ("/entry/:cid/:since", [6]) + , ("/entry/bytags/:cid/:since", [7]) + , ("/entry/:eid/audit", [8]) + , ("/entry/:eid/rel/:cid", [9]) ] test_parseRouteNode :: IO () diff --git a/src/Web/Spock.hs b/src/Web/Spock.hs --- a/src/Web/Spock.hs +++ b/src/Web/Spock.hs @@ -15,7 +15,7 @@ , request, header, cookie, body, jsonBody, files, UploadedFile (..) , params, param -- * Sending responses - , setStatus, setHeader, redirect, setCookie, setCookie', bytes, lazyBytes + , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes , text, html, file, json, blaze -- * Adding middleware , middleware 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 @@ -6,6 +6,7 @@ , defRoute, get, post, head, put, delete, patch , request, header, cookie, body, jsonBody , files, params, param, setStatus, setHeader, redirect + , jumpNext , setCookie, setCookie' , bytes, lazyBytes, text, html, file, json, blaze , combineRoute, subcomponent @@ -14,6 +15,7 @@ import Control.Arrow (first) import Control.Monad +import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State hiding (get, put) import Data.Time @@ -121,12 +123,16 @@ param k = 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 + case HM.lookup (CaptureVar k) p of + Just val -> + case fromPathPiece val of + Nothing -> + do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!") + jumpNext + Just pathPieceVal -> + return $ Just pathPieceVal + Nothing -> + return $ join $ fmap fromPathPiece (lookup k qp) -- | Set a response status setStatus :: MonadIO m => Status -> ActionT m () @@ -138,10 +144,13 @@ setHeader k v = modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) } +-- | Abort the current action and jump the next one matching the route +jumpNext :: MonadIO m => ActionT m a +jumpNext = throwError ActionTryNext + -- | Redirect to a given url redirect :: MonadIO m => T.Text -> ActionT m () -redirect url = - modify $ \rs -> rs { rs_responseBody = ResponseRedirect url } +redirect = throwError . ActionRedirect -- | Set a cookie living for a given number of seconds setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m () 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 @@ -3,6 +3,7 @@ module Web.Spock.Routing where import Data.Hashable +import Data.Maybe import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM @@ -116,46 +117,47 @@ emptyParamMap :: ParamMap emptyParamMap = HM.empty -matchRoute :: T.Text -> RoutingTree a -> Maybe (ParamMap, a) +matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)] matchRoute route globalTree = matchRoute' (T.splitOn "/" route) globalTree -matchRoute' :: [T.Text] -> RoutingTree a -> Maybe (ParamMap, a) +matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)] matchRoute' routeParts globalTree = case filter (not . T.null) routeParts of - [] -> fmap (\d -> (emptyParamMap, d)) $ rd_data $ rt_node globalTree + [] -> + case rd_data $ rt_node globalTree of + Nothing -> [] + Just action -> [(emptyParamMap, action)] xs -> - case findRoute xs globalTree emptyParamMap of - (_, Nothing) -> Nothing - (pmap, Just x) -> Just (pmap, x) + findRoute xs (rt_children globalTree) where - applyParams :: Maybe (CaptureVar, T.Text) -> ParamMap -> ParamMap - applyParams Nothing x = x - applyParams (Just (var, t)) x = HM.insert var t x - - 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) + findRoute :: [T.Text] -> V.Vector (RoutingTree a) -> [(ParamMap, a)] + findRoute fullPath trees = + let foundPaths = V.foldl' (matchTree fullPath emptyParamMap) V.empty trees + in V.toList foundPaths + where + matchTree :: [T.Text] -> ParamMap -> V.Vector (ParamMap, a) -> RoutingTree a -> V.Vector (ParamMap, a) + matchTree [] _ vec _ = vec + matchTree (textNode : xs) paramMap vec rt = + case matchNode textNode (rd_node $ rt_node rt) of + (False, _) -> + vec + (True, mCapture) -> + let paramMap' = + case mCapture of + Nothing -> paramMap + Just (var, value) -> + HM.insert var value paramMap + nodeData = rd_data $ rt_node rt + nodeChildren = rt_children rt + in case xs of + [] | isJust nodeData -> + V.snoc vec (paramMap', fromJust nodeData) + | otherwise -> + vec + _ -> + let foundPaths = V.foldl' (matchTree xs paramMap') V.empty nodeChildren + in V.concat [foundPaths, vec] matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text)) matchNode _ RouteNodeRoot = (False, Nothing) 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 @@ -12,6 +12,7 @@ import Control.Applicative import Control.Exception import Control.Monad.RWS.Strict +import Control.Monad.Error import Control.Monad.Reader.Class () import Control.Monad.Trans.Resource import Data.Hashable @@ -78,10 +79,23 @@ type BaseRoute = T.Text +data ActionInterupt + = ActionRedirect T.Text + | ActionTryNext + | ActionError String + deriving (Show) + +instance Error ActionInterupt where + noMsg = ActionError "Unkown Internal Action Error" + strMsg = ActionError + newtype ActionT m a - = ActionT { runActionT :: RWST RequestInfo () ResponseState m a } - deriving (Monad, Functor, Applicative, MonadIO, MonadTrans, MonadReader RequestInfo, MonadState ResponseState) + = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a } + deriving (Monad, Functor, Applicative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt) +instance MonadTrans ActionT where + lift = ActionT . lift . lift + newtype SpockT (m :: * -> *) a = SpockT { runSpockT :: RWST BaseRoute () (SpockState m) m a } deriving (Monad, Functor, Applicative, MonadIO, MonadReader BaseRoute, MonadState (SpockState m)) @@ -140,7 +154,8 @@ , ss_spockLift = spockLift } (spockState, ()) <- spockLift $ execRWST (runSpockT spockActions) "/" initState - let routingTreeMap = buildRoutingTree (ss_treeMap spockState) + let spockMiddleware = foldl (.) id (ss_middleware spockState) + routingTreeMap = buildRoutingTree (ss_treeMap spockState) app :: Wai.Application app req respond = case parseMethod $ Wai.requestMethod req of @@ -149,39 +164,55 @@ Right stdMethod -> case HM.lookup stdMethod routingTreeMap of Just routeTree -> - case matchRoute' (Wai.pathInfo req) routeTree of - Just (captures, action) -> - runResourceT $ - withInternalState $ \st -> - do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req - let uploadedFiles = - HM.fromList $ + runResourceT $ + withInternalState $ \st -> + do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req + let uploadedFiles = + HM.fromList $ map (\(k, fileInfo) -> ( T.decodeUtf8 k , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo) ) ) bodyFiles - 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, _) <- liftIO $ - (spockLift $ execRWST (runActionT action) env resp) + 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 + resp = errorResponse status200 "" + allActions = matchRoute' (Wai.pathInfo req) routeTree + + applyAction :: [(ParamMap, ActionT m ())] -> m ResponseState + applyAction [] = + return $ errorResponse status404 "404 - File not found" + applyAction ((captures, selectedAction) : xs) = + do let env = RequestInfo req captures queryParams uploadedFiles + (r, respState, _) <- + runRWST (runErrorT $ runActionT $ selectedAction) env resp + case r of + Left (ActionRedirect loc) -> + return $ ResponseState [] status302 (ResponseRedirect loc) + Left ActionTryNext -> + applyAction xs + Left (ActionError errorMsg) -> + do liftIO $ putStrLn $ "Spock Error while handeling " + ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg + return serverError + Right () -> + return respState + respState <- + liftIO $ + (spockLift $ applyAction allActions) `catch` \(e :: SomeException) -> do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e - return (serverError, ()) - forM_ (HM.elems uploadedFiles) $ \uploadedFile -> - do stillThere <- doesFileExist (uf_tempLocation uploadedFile) - when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile) - liftIO $ respond $ respStateToResponse respState - Nothing -> - respond notFound + return serverError + forM_ (HM.elems uploadedFiles) $ \uploadedFile -> + do stillThere <- doesFileExist (uf_tempLocation uploadedFile) + when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile) + liftIO $ respond $ respStateToResponse respState Nothing -> respond notFound - return $ foldl (.) id (ss_middleware spockState) $ app + return $ spockMiddleware $ app -- | Hook up a 'Wai.Middleware' middleware :: MonadIO m => Wai.Middleware -> SpockT m ()