Spock 0.6.2.3 → 0.6.3.0
raw patch · 6 files changed
+145/−80 lines, 6 filesdep ~path-piecesdep ~resourcetPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: path-pieces, resourcet
API changes (from Hackage documentation)
+ Web.Spock: jumpNext :: MonadIO m => ActionT m a
Files
- Spock.cabal +4/−4
- src/Tests/Routing.hs +30/−7
- src/Web/Spock.hs +1/−1
- src/Web/Spock/Core.hs +17/−8
- src/Web/Spock/Routing.hs +35/−33
- src/Web/Spock/Wire.hs +58/−27
Spock.cabal view
@@ -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.*,
src/Tests/Routing.hs view
@@ -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 ()
src/Web/Spock.hs view
@@ -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
src/Web/Spock/Core.hs view
@@ -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 ()
src/Web/Spock/Routing.hs view
@@ -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)
src/Web/Spock/Wire.hs view
@@ -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 ()