diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.9.10-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) +[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.10.0-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) ==================================== Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs. @@ -114,6 +114,7 @@ Changelog ========= +* 0.10.0: Allow aeson v1.2. Routing improvements. Remove wai-app-static dependency. Add nix expression. * 0.9.10: Aeson and hspec version bump. * 0.9.9 : GHC 8 compatibility. Change namespace from Network.Wai.Middleware.Routes -> Wai.Routes * 0.9.8 : Allow Data.Default-0.1.0. Allow comments in route definitions. Some other minor changes. diff --git a/src/Routes/Parse.hs b/src/Routes/Parse.hs --- a/src/Routes/Parse.hs +++ b/src/Routes/Parse.hs @@ -13,7 +13,7 @@ ) where import Language.Haskell.TH.Syntax -import Data.Char (isUpper) +import Data.Char (isUpper, isSpace) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Routes.TH @@ -58,12 +58,12 @@ { quoteExp = lift . resourcesFromString } --- | Convert a multi-line string to a set of resources. See documentation for +-- | Converts a multi-line string to a set of resources. See documentation for -- the format of this string. This is a partial function which calls 'error' on -- invalid input. resourcesFromString :: String -> [ResourceTree String] resourcesFromString = - fst . parse 0 . filter (not . all (== ' ')) . lines + fst . parse 0 . filter (not . all (== ' ')) . lines . filter (/= '\r') where parse _ [] = ([], []) parse indent (thisLine:otherLines) @@ -86,7 +86,7 @@ spaces = takeWhile (== ' ') thisLine (others, remainder) = parse indent otherLines' (this, otherLines') = - case takeWhile (not . isPrefixOf "--") $ words thisLine of + case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of (pattern:rest0) | Just (constr:rest) <- stripColonLast rest0 , Just attrs <- mapM parseAttr rest -> @@ -102,6 +102,26 @@ [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine +-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive). +splitSpaces :: String -> [String] +splitSpaces "" = [] +splitSpaces str = + let (rest, piece) = parse $ dropWhile isSpace str in + piece:(splitSpaces rest) + + where + parse :: String -> ( String, String) + parse ('{':s) = fmap ('{':) $ parseBracket s + parse (c:s) | isSpace c = (s, []) + parse (c:s) = fmap (c:) $ parse s + parse "" = ("", "") + + parseBracket :: String -> ( String, String) + parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str + parseBracket ('}':s) = fmap ('}':) $ parse s + parseBracket (c:s) = fmap (c:) $ parseBracket s + parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str + piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) piecesFromStringCheck s0 = (pieces, mmulti, check) @@ -181,7 +201,7 @@ parseTypeTree orig = toTypeTree pieces where - pieces = filter (not . null) $ splitOn '-' $ addDashes orig + pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig addDashes [] = [] addDashes (x:xs) = front $ addDashes xs @@ -194,7 +214,7 @@ _:y -> x : splitOn c y [] -> [x] where - (x, y') = break (== c) s + (x, y') = break c s data TypeTree = TTTerm String | TTApp TypeTree TypeTree @@ -237,9 +257,9 @@ ttToType (TTList t) = ListT `AppT` ttToType t pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) -pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) -pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 -pieceFromString ('#':x) = Right $ (True, Dynamic x) +pieceFromString ('#':'!':x) = Right $ (False, dynamicPieceFromString x) +pieceFromString ('!':'#':x) = Right $ (False, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652 +pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x) pieceFromString ('*':'!':x) = Left (False, x) pieceFromString ('+':'!':x) = Left (False, x) @@ -252,3 +272,10 @@ pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x) + +dynamicPieceFromString :: String -> Piece String +dynamicPieceFromString str@('{':x) = case break (== '}') x of + (s, "}") -> Dynamic s + _ -> error $ "Invalid path piece: " ++ str +dynamicPieceFromString x = Dynamic x +-- JP: Should we check if there are curly brackets or other invalid characters? diff --git a/src/Routes/TH/ParseRoute.hs b/src/Routes/TH/ParseRoute.hs --- a/src/Routes/TH/ParseRoute.hs +++ b/src/Routes/TH/ParseRoute.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module Routes.TH.ParseRoute ( -- ** ParseRoute mkParseRouteInstance diff --git a/src/Routes/TH/RenderRoute.hs b/src/Routes/TH/RenderRoute.hs --- a/src/Routes/TH/RenderRoute.hs +++ b/src/Routes/TH/RenderRoute.hs @@ -46,7 +46,9 @@ mkRouteCon (ResourceParent name _check pieces children) = do (cons, decs) <- mkRouteCons children -#if MIN_VERSION_template_haskell(2,11,0) +#if MIN_VERSION_template_haskell(2,12,0) + dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq]) +#elif MIN_VERSION_template_haskell(2,11,0) dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq] #else let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] @@ -55,7 +57,7 @@ where con = NormalC (mkName name) $ map (\x -> (notStrict, x)) - $ concat [singles, [ConT $ mkName name]] + $ singles ++ [ConT $ mkName name] singles = concatMap toSingle pieces toSingle Static{} = [] @@ -99,7 +101,7 @@ dyns <- replicateM cnt $ newName "dyn" sub <- case resourceDispatch res of - Subsite{} -> fmap return $ newName "sub" + Subsite{} -> return <$> newName "sub" _ -> return [] let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub @@ -136,7 +138,7 @@ mkPieces _ _ [] _ = [] mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns - mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120" + mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120" -- | Generate the 'RenderRoute' instance. -- @@ -153,7 +155,9 @@ mkRenderRouteInstance' cxt typ ress = do cls <- mkRenderRouteClauses ress (cons, decs) <- mkRouteCons ress -#if MIN_VERSION_template_haskell(2,11,0) +#if MIN_VERSION_template_haskell(2,12,0) + did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes) +#elif MIN_VERSION_template_haskell(2,11,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes #else let did = DataInstD [] ''Route [typ] cons clazzes diff --git a/src/Routes/TH/RouteAttrs.hs b/src/Routes/TH/RouteAttrs.hs --- a/src/Routes/TH/RouteAttrs.hs +++ b/src/Routes/TH/RouteAttrs.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Routes.TH.RouteAttrs ( mkRouteAttrsInstance @@ -9,6 +10,9 @@ import Language.Haskell.TH.Syntax import Data.Set (fromList) import Data.Text (pack) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance typ ress = do @@ -18,11 +22,11 @@ ] goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] -goTree front (ResourceLeaf res) = fmap return $ goRes front res +goTree front (ResourceLeaf res) = return <$> goRes front res goTree front (ResourceParent name _check pieces trees) = - fmap concat $ mapM (goTree front') trees + concat <$> mapM (goTree front') trees where - ignored = ((replicate toIgnore WildP ++) . return) + ignored = (replicate toIgnore WildP ++) . return toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False diff --git a/src/Routes/TH/Types.hs b/src/Routes/TH/Types.hs --- a/src/Routes/TH/Types.hs +++ b/src/Routes/TH/Types.hs @@ -53,11 +53,11 @@ deriving Show instance Functor Piece where - fmap _ (Static s) = (Static s) + fmap _ (Static s) = Static s fmap f (Dynamic t) = Dynamic (f t) instance Lift t => Lift (Piece t) where - lift (Static s) = [|Static $(lift s)|] + lift (Static s) = [|Static $(lift s)|] lift (Dynamic t) = [|Dynamic $(lift t)|] data Dispatch typ = diff --git a/src/Wai/Routes.hs b/src/Wai/Routes.hs --- a/src/Wai/Routes.hs +++ b/src/Wai/Routes.hs @@ -109,15 +109,10 @@ -- * Bare Handlers , Env(..) - , RequestData -- | An abstract representation of the request data. You can get the wai request object by using `waiReq` - , waiReq -- | Extract the wai `Request` object from `RequestData` - , nextApp -- | Extract the next Application in the stack , currentRoute -- | Extract the current `Route` from `RequestData` - , runNext -- | Run the next application in the stack , module Network.HTTP.Types.Status , module Network.Wai.Middleware.RequestLogger - , module Network.Wai.Application.Static ) where @@ -126,4 +121,3 @@ import Routes.Handler import Network.HTTP.Types.Status import Network.Wai.Middleware.RequestLogger -import Network.Wai.Application.Static diff --git a/test/HelloSpec.hs b/test/HelloSpec.hs --- a/test/HelloSpec.hs +++ b/test/HelloSpec.hs @@ -20,11 +20,12 @@ data SubRoute = SubRoute Text -class MasterContract master where +class RenderRoute master => MasterContract master where getMasterName :: master -> Text mkRouteSub "SubRoute" "MasterContract" [parseRoutes| -/ SubHomeR GET +/ SubHomeR GET +/route SubRouteR GET |] getSubHomeR :: MasterContract master => HandlerS SubRoute master @@ -33,6 +34,11 @@ m <- master plain $ T.concat ["subsite-", s, "-", getMasterName m] +getSubRouteR :: MasterContract master => HandlerS SubRoute master +getSubRouteR = runHandlerM $ do + showRouteS <- showRouteSub + plain $ T.concat ["this route as sub:", showRouteS SubRouteR, ", this route as master:", showRoute SubRouteR] + getSubRoute :: master -> Text -> SubRoute getSubRoute = const SubRoute @@ -92,7 +98,10 @@ application = return $ waiApp $ do handler handleInfoRequest route MyRoute - catchall $ staticApp $ defaultFileServerSettings "test/static" + handler $ runHandlerM $ do + Just (DefaultRoute (route,_)) <- maybeRoute + plain $ T.pack $ show route + -- catchall $ plain "This will never be reached" ---- THE TESTS ---- @@ -123,6 +132,10 @@ it "can access the subsite correctly" $ get "/subsite" `shouldRespondWith` "subsite-default-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + describe "GET /subsite/route" $ + it "can handle routing across subsite correctly" $ + get "/subsite/route" `shouldRespondWith` "this route as sub:/subsite/route, this route as master:/route" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + describe "GET /nested" $ it "can access nested routes root correctly" $ get "/nested" `shouldRespondWith` "Nested ROOT" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} @@ -139,6 +152,6 @@ it "can pass route arguments to the nested subsite correctly" $ get "/nested/nested2/nested3/helloworld/argsub" `shouldRespondWith` "subsite-helloworld-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} - describe "GET /lambda.png" $ - it "returns a file correctly" $ - get "/lambda.png" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "image/png"]} + describe "GET /does/not/exist" $ + it "handles catch all routes correctly" $ + get "/does/not/exist" `shouldRespondWith` "[\"does\",\"not\",\"exist\"]" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} diff --git a/test/static/lambda.png b/test/static/lambda.png deleted file mode 100644 Binary files a/test/static/lambda.png and /dev/null differ diff --git a/wai-routes.cabal b/wai-routes.cabal --- a/wai-routes.cabal +++ b/wai-routes.cabal @@ -1,5 +1,5 @@ name : wai-routes -version : 0.9.10 +version : 0.10.0 cabal-version : >=1.18 build-type : Simple license : MIT @@ -13,7 +13,6 @@ author : Anupam Jain data-dir : "" extra-source-files : README.md - , test/static/lambda.png source-repository head type : git @@ -21,18 +20,17 @@ source-repository this type : git - location : http://github.com/ajnsit/wai-routes/tree/v0.9.10 - tag : v0.9.10 + location : http://github.com/ajnsit/wai-routes/tree/v0.10.0 + tag : v0.10.0 library build-depends : base >= 4.7 && < 4.10 , wai >= 3.0 && < 3.3 , wai-extra >= 3.0 && < 3.1 - , wai-app-static >= 3.0 && < 3.2 , text >= 1.2 && < 1.3 , template-haskell >= 2.9 && < 2.12 , mtl >= 2.1 && < 2.3 - , aeson >= 0.8 && < 1.2 + , aeson >= 0.8 && < 1.3 , containers >= 0.5 && < 0.6 , random >= 1.1 && < 1.2 , path-pieces >= 0.2 && < 0.3 @@ -78,7 +76,7 @@ build-depends : base >= 4.7 && < 4.10 , wai >= 3.0 && < 3.3 - , aeson >= 0.8 && < 1.2 + , aeson >= 0.8 && < 1.3 , hspec >= 2.1 && < 2.5 , hspec-wai >= 0.6 && < 0.9 , hspec-wai-json >= 0.6 && < 0.9