nested-routes 2.1.0 → 2.2.0
raw patch · 2 files changed
+44/−24 lines, 2 filesdep +hspec-waidep +warpdep −QuickCheckdep −quickcheck-instancesdep ~poly-aritydep ~pred-triePVP ok
version bump matches the API change (PVP)
Dependencies added: hspec-wai, warp
Dependencies removed: QuickCheck, quickcheck-instances
Dependency ranges changed: poly-arity, pred-trie
API changes (from Hackage documentation)
Files
- nested-routes.cabal +25/−4
- src/Web/Routes/Nested.hs +19/−20
nested-routes.cabal view
@@ -1,5 +1,5 @@ Name: nested-routes-Version: 2.1.0+Version: 2.2.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -145,7 +145,7 @@ , bytestring , attoparsec , regex-compat- , pred-trie >= 0.1+ , pred-trie >= 0.2 , poly-arity >= 0.0.4 Test-Suite spec@@ -157,8 +157,29 @@ Main-Is: Spec.hs Build-Depends: base , hspec- , QuickCheck- , quickcheck-instances+ , hspec-wai+ , shakespeare+ , lucid+ , attoparsec+ , regex-compat+ , containers+ , composition+ , semigroups+ , text+ , aeson+ , wai-util+ , blaze-html+ , bytestring+ , poly-arity+ , witherable+ , constraints+ , pred-trie+ , mtl+ , wai+ , warp+ , transformers+ , http-media+ , http-types Source-Repository head Type: git
src/Web/Routes/Nested.hs view
@@ -93,7 +93,7 @@ handle ts (Just vl) Nothing = HandlerT $ tell (singleton ts vl, mempty) handle ts mvl (Just cs) = do- ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs+ (Rooted _ ctrie,_) <- lift $ execWriterT $ runHandler cs HandlerT $ tell (extrude ts $ Rooted mvl ctrie, mempty) handle _ Nothing Nothing = return () @@ -113,7 +113,7 @@ -> HandlerT z childType m () -- ^ Potential child routes -> HandlerT z result m () parent ts cs = do- ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs+ (Rooted _ ctrie,_) <- lift $ execWriterT $ runHandler cs HandlerT $ tell (extrude ts $ Rooted Nothing ctrie, mempty) notFound :: ( Monad m@@ -134,10 +134,10 @@ -> Maybe childType -> Maybe (HandlerT z childType m ()) -> HandlerT z result m ()-notFound ts (Just vl) Nothing = do+notFound ts (Just vl) Nothing = HandlerT $ tell (mempty, singleton ts vl) notFound ts mvl (Just cs) = do- ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs+ (Rooted _ ctrie,_) <- lift $ execWriterT $ runHandler cs HandlerT $ tell (mempty, extrude ts $ Rooted mvl ctrie) notFound _ Nothing Nothing = return () @@ -169,7 +169,7 @@ let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req fail = liftIO $ respond404 menf - case P.lookup cleanedPathInfo rtrie of+ case P.lookupWithL trimFileExt (pathInfo req) rtrie of Nothing -> case pathInfo req of [] -> fail _ -> case trimFileExt $ last $ pathInfo req of@@ -181,7 +181,7 @@ where onJustM :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)- onJustM f mx = maybe (return Nothing) f mx+ onJustM = maybe (return Nothing) handleNotFound :: MonadIO m =>@@ -224,25 +224,24 @@ maybe fail (\(mreqbodyf, femonad) -> do femap <- execWriterT $ runFileExtListenerT femonad- maybe fail (\r -> do+ maybe fail (\r -> case mreqbodyf of Nothing -> liftIO $ respond r- Just (reqbf,Nothing) -> do- body <- liftIO $ strictRequestBody req- (runReaderT $ reqbf) body- liftIO $ respond r- Just (reqbf,Just bl) -> do+ Just (reqbf,Nothing) -> handleUpload req reqbf respond r+ Just (reqbf,Just bl) -> case requestBodyLength req of KnownLength bl' -> if bl' <= bl- then do body <- liftIO $ strictRequestBody req- (runReaderT $ reqbf) body- liftIO $ respond r+ then handleUpload req reqbf respond r else fail _ -> fail) $ lookupProper acceptBS f $ unFileExts femap) $ M.lookup v vmap + handleUpload req reqbf respond r = do+ body <- liftIO $ strictRequestBody req+ runReaderT reqbf body+ liftIO $ respond r respond404 :: Maybe Response -> IO ResponseReceived respond404 mr = respond $ fromMaybe plain404 mr@@ -254,7 +253,7 @@ lookupProper maccept k map = let attempts = maybe [Html,Text,Json,JavaScript,Css]- (\accept -> possibleFileExts k accept)+ (possibleFileExts k) maccept in foldr (go map) Nothing attempts@@ -281,7 +280,7 @@ ] accept ] in- if length wildcard /= 0 then wildcard else computed+ if not (null wildcard) then wildcard else computed sortFE Html xs = [Html, Text] `intersect` xs sortFE JavaScript xs = [JavaScript, Text] `intersect` xs@@ -291,18 +290,18 @@ applyToLast :: (a -> a) -> [a] -> [a] applyToLast _ [] = []- applyToLast f (x:[]) = f x : []+ applyToLast f [x] = [f x] applyToLast f (x:xs) = x : applyToLast f xs trimFileExt :: T.Text -> T.Text- trimFileExt s = if (T.unpack s) `endsWithAny` possibleExts+ trimFileExt s = if T.unpack s `endsWithAny` possibleExts then T.pack $ takeWhile (/= '.') $ T.unpack s else s where possibleExts = [ ".html",".htm",".txt",".json",".lucid" , ".julius",".css",".cassius",".lucius" ]- endsWithAny s xs = (dropWhile (/= '.') s) `elem` xs+ endsWithAny s xs = dropWhile (/= '.') s `elem` xs httpMethodToMSym :: Method -> Maybe Verb httpMethodToMSym x | x == methodGet = Just Get