From 255d71171c28d411d564b0d1e775959e4d55ccc9 Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 13 Jun 2012 09:26:21 +0300 Subject: [PATCH 01/30] Beginning of hierarchichal routes, not done --- yesod-routes/Yesod/Routes/Overlap.hs | 47 +++++++++++----- yesod-routes/Yesod/Routes/Parse.hs | 32 +++++++---- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 28 +++++++--- yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 62 +++++++++++++++++---- yesod-routes/Yesod/Routes/TH/Types.hs | 21 +++++++ yesod-routes/test/Hierarchy.hs | 23 ++++++++ yesod-routes/test/main.hs | 9 +-- yesod-routes/yesod-routes.cabal | 1 + 8 files changed, 175 insertions(+), 48 deletions(-) create mode 100644 yesod-routes/test/Hierarchy.hs diff --git a/yesod-routes/Yesod/Routes/Overlap.hs b/yesod-routes/Yesod/Routes/Overlap.hs index aa116b04..35406d4a 100644 --- a/yesod-routes/Yesod/Routes/Overlap.hs +++ b/yesod-routes/Yesod/Routes/Overlap.hs @@ -2,27 +2,41 @@ module Yesod.Routes.Overlap ( findOverlaps , findOverlapNames + , Overlap (..) ) where import Yesod.Routes.TH.Types -import Control.Arrow ((***)) -import Data.Maybe (mapMaybe) +import Data.List (intercalate) -findOverlaps :: [Resource t] -> [(Resource t, Resource t)] -findOverlaps [] = [] -findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs +data Overlap t = Overlap + { overlapParents :: [String] -> [String] -- ^ parent resource trees + , overlap1 :: ResourceTree t + , overlap2 :: ResourceTree t + } -findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t) -findOverlap x y - | overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y) - | otherwise = Nothing +findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t] +findOverlaps _ [] = [] +findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs -hasSuffix :: Resource t -> Bool -hasSuffix r = +findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t] +findOverlap front x y = + here rest + where + here + | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:) + | otherwise = id + rest = + case x of + ResourceParent name _ children -> findOverlaps (front . (name:)) children + ResourceLeaf{} -> [] + +hasSuffix :: ResourceTree t -> Bool +hasSuffix (ResourceLeaf r) = case resourceDispatch r of Subsite{} -> True Methods Just{} _ -> True Methods Nothing _ -> False +hasSuffix ResourceParent{} = True overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool @@ -50,9 +64,14 @@ piecesOverlap :: Piece t -> Piece t -> Bool piecesOverlap (Static x) (Static y) = x == y piecesOverlap _ _ = True -findOverlapNames :: [Resource t] -> [(String, String)] -findOverlapNames = map (resourceName *** resourceName) . findOverlaps - +findOverlapNames :: [ResourceTree t] -> [(String, String)] +findOverlapNames = + map go . findOverlaps id + where + go (Overlap front x y) = + (go' $ resourceTreeName x, go' $ resourceTreeName y) + where + go' = intercalate "/" . front . return {- -- n^2, should be a way to speed it up findOverlaps :: [Resource a] -> [[Resource a]] diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs index b17e5fec..fc16eef3 100644 --- a/yesod-routes/Yesod/Routes/Parse.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -10,7 +10,6 @@ module Yesod.Routes.Parse ) where import Language.Haskell.TH.Syntax -import Data.Maybe import Data.Char (isUpper) import Language.Haskell.TH.Quote import qualified System.IO as SIO @@ -55,18 +54,29 @@ parseRoutesNoCheck = QuasiQuoter -- | Convert 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 -> [Resource String] +resourcesFromString :: String -> [ResourceTree String] resourcesFromString = - mapMaybe go . lines + fst . parse 0 . lines where - go s = - case takeWhile (/= "--") $ words s of - (pattern:constr:rest) -> - let (pieces, mmulti) = piecesFromString $ drop1Slash pattern - disp = dispatchFromString rest mmulti - in Just $ Resource constr pieces disp - [] -> Nothing - _ -> error $ "Invalid resource line: " ++ s + parse _ [] = ([], []) + parse indent (thisLine:otherLines) + | length spaces < indent = ([], thisLine : otherLines) + | otherwise = (this others, remainder) + where + spaces = takeWhile (== ' ') thisLine + (others, remainder) = parse indent otherLines' + (this, otherLines') = + case takeWhile (/= "--") $ words thisLine of + [pattern, constr] | last constr == ':' -> + let (children, otherLines'') = parse (length spaces + 1) otherLines + (pieces, Nothing) = piecesFromString $ drop1Slash pattern + in ((ResourceParent (init constr) pieces children :), otherLines'') + (pattern:constr:rest) -> + let (pieces, mmulti) = piecesFromString $ drop1Slash pattern + disp = dispatchFromString rest mmulti + in ((ResourceLeaf (Resource constr pieces disp):), otherLines) + [] -> (id, otherLines) + _ -> error $ "Invalid resource line: " ++ thisLine dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index ab2424a7..e0bfdaaf 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -17,6 +17,16 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl') +data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a) + +flatten :: [ResourceTree a] -> [FlatResource a] +flatten = + concatMap (go id id) + where + go front1 front2 (ResourceLeaf (Resource a b c)) = [FlatResource front1 a (front2 b) c] + go front1 front2 (ResourceParent name pieces children) = + concatMap (go (front1 . (name:)) (front2 . (pieces++))) children + -- | -- -- This function will generate a single clause that will address all @@ -83,9 +93,9 @@ import Data.List (foldl') mkDispatchClause :: Q Exp -- ^ runHandler function -> Q Exp -- ^ dispatcher function -> Q Exp -- ^ fixHandler function - -> [Resource a] + -> [ResourceTree a] -> Q Clause -mkDispatchClause runHandler dispatcher fixHandler ress = do +mkDispatchClause runHandler dispatcher fixHandler ress' = do -- Allocate the names to be used. Start off with the names passed to the -- function itself (with a 0 suffix). -- @@ -130,16 +140,18 @@ mkDispatchClause runHandler dispatcher fixHandler ress = do Nothing -> $(return $ VarE app4040) |] return $ Clause pats (NormalB u) $ dispatchFun : methodMaps + where + ress = flatten ress' -- | Determine the name of the method map for a given resource name. methodMapName :: String -> Name methodMapName s = mkName $ "methods" ++ s buildMethodMap :: Q Exp -- ^ fixHandler - -> Resource a + -> FlatResource a -> Q (Maybe Dec) -buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function -buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do +buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function +buildMethodMap fixHandler (FlatResource names name pieces (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' @@ -156,11 +168,11 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do xs <- replicateM argCount $ newName "arg" let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs) return $ TupE [pack' `AppE` LitE (StringL method), rhs] -buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing +buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing -- | Build a single 'D.Route' expression. -buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp -buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do +buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp +buildRoute runHandler dispatcher fixHandler (FlatResource names name resPieces resDisp) = do -- First two arguments to D.Route routePieces <- ListE <$> mapM (convertPiece . snd) resPieces isMulti <- diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs index bc331ed4..3ba87b77 100644 --- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs @@ -14,17 +14,19 @@ import Control.Monad (replicateM) import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class +import Data.Monoid (mconcat) -- | Generate the constructors of a route data type. -mkRouteCons :: [Resource Type] -> [Con] +mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) mkRouteCons = - map mkRouteCon + mconcat . map mkRouteCon where - mkRouteCon res = - NormalC (mkName $ resourceName res) + mkRouteCon (ResourceLeaf res) = + ([con], []) + where + con = NormalC (mkName $ resourceName res) $ map (\x -> (NotStrict, x)) $ concat [singles, multi, sub] - where singles = concatMap (toSingle . snd) $ resourcePieces res toSingle Static{} = [] toSingle (Dynamic typ) = [typ] @@ -35,16 +37,53 @@ mkRouteCons = case resourceDispatch res of Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> [] + mkRouteCon (ResourceParent name pieces children) = + ([con], dec : decs) + where + (cons, decs) = mkRouteCons children + con = NormalC (mkName name) + $ map (\x -> (NotStrict, x)) + $ concat [singles, [ConT $ mkName name]] + dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] + + singles = concatMap (toSingle . snd) pieces + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] -- | Clauses for the 'renderRoute' method. -mkRenderRouteClauses :: [Resource Type] -> Q [Clause] +mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses = mapM go where isDynamic Dynamic{} = True isDynamic _ = False - go res = do + go (ResourceParent name pieces children) = do + let cnt = length $ filter (isDynamic . snd) pieces + dyns <- replicateM cnt $ newName "dyn" + child <- newName "child" + let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] + + pack' <- [|pack|] + tsp <- [|toPathPiece|] + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns + + childRender <- newName "childRender" + let rr = VarE childRender + childClauses <- mkRenderRouteClauses children + + a <- newName "a" + b <- newName "b" + + colon <- [|(:)|] + let cons y ys = InfixE (Just y) colon (Just ys) + let pieces = foldr cons (VarE a) piecesSingle + + let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE child) + + return $ Clause [pat] (NormalB body) [FunD childRender childClauses] + + go (ResourceLeaf res) = do let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" sub <- @@ -93,18 +132,19 @@ mkRenderRouteClauses = -- This includes both the 'Route' associated type and the -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. -mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec +mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance = mkRenderRouteInstance' [] -- | A more general version of 'mkRenderRouteInstance' which takes an -- additional context. -mkRenderRouteInstance' :: Cxt -> Type -> [Resource Type] -> Q Dec +mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance' cxt typ ress = do cls <- mkRenderRouteClauses ress + let (cons, decs) = mkRouteCons ress return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ) - [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes + [ DataInstD [] ''Route [typ] cons clazzes , FunD (mkName "renderRoute") cls - ] + ] : decs where clazzes = [''Show, ''Eq, ''Read] diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index e0a74b5c..52cd446f 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -2,16 +2,37 @@ module Yesod.Routes.TH.Types ( -- * Data types Resource (..) + , ResourceTree (..) , Piece (..) , Dispatch (..) , CheckOverlap -- ** Helper functions , resourceMulti + , resourceTreePieces + , resourceTreeName ) where import Language.Haskell.TH.Syntax import Control.Arrow (second) +data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ] + +resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)] +resourceTreePieces (ResourceLeaf r) = resourcePieces r +resourceTreePieces (ResourceParent _ x _) = x + +resourceTreeName :: ResourceTree typ -> String +resourceTreeName (ResourceLeaf r) = resourceName r +resourceTreeName (ResourceParent x _ _) = x + +instance Functor ResourceTree where + fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r) + fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c + +instance Lift t => Lift (ResourceTree t) where + lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] + lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|] + data Resource typ = Resource { resourceName :: String , resourcePieces :: [(CheckOverlap, Piece typ)] diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs new file mode 100644 index 00000000..e7bd3451 --- /dev/null +++ b/yesod-routes/test/Hierarchy.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Hierarchy (hierarchy) where + +import Test.Hspec.Monadic +import Test.Hspec.HUnit () +import Yesod.Routes.Parse +import Yesod.Routes.TH +import Yesod.Routes.Class +import Language.Haskell.TH.Syntax + +data Hierarchy = Hierarchy + +mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes| +/ HomeR GET +/admin/#Int AdminR: + / AdminRootR GET + /login LoginR GET POST +|] + +hierarchy :: Specs +hierarchy = return () diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index af73aa09..690e6795 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -20,6 +20,7 @@ import Yesod.Routes.Parse (parseRoutesNoCheck) import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax +import Hierarchy class ToText a where toText :: a -> Text @@ -126,7 +127,7 @@ class RunHandler sub master where do texts <- [t|[Text]|] - let ress = + let ress = map ResourceLeaf [ Resource "RootR" [] $ Methods Nothing ["GET"] , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"] , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) [] @@ -137,14 +138,13 @@ do rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress return - [ rrinst - , InstanceD + $ InstanceD [] (ConT ''Dispatcher `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]] - ] + : rrinst instance RunHandler MyApp master where runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) @@ -328,6 +328,7 @@ main = hspecX $ do /bar/baz Foo3 |] findOverlapNames routes @?= [] + hierarchy getRootR :: Text getRootR = pack "this is the root" diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 28d69eca..a523711c 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -36,6 +36,7 @@ test-suite runtests type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test + other-modules: Hierarchy build-depends: base >= 4.3 && < 5 , yesod-routes From 0e0880dfe4749a7bc61354549bbaf5da6f1bed2f Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 13 Jun 2012 10:00:20 +0300 Subject: [PATCH 02/30] Hierarchy dispatching --- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 44 ++++++++---- yesod-routes/test/Hierarchy.hs | 86 +++++++++++++++++++++++- yesod-routes/test/main.hs | 29 -------- 3 files changed, 114 insertions(+), 45 deletions(-) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index e0bfdaaf..338d1463 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -17,15 +17,15 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl') -data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a) +data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a) flatten :: [ResourceTree a] -> [FlatResource a] flatten = - concatMap (go id id) + concatMap (go id) where - go front1 front2 (ResourceLeaf (Resource a b c)) = [FlatResource front1 a (front2 b) c] - go front1 front2 (ResourceParent name pieces children) = - concatMap (go (front1 . (name:)) (front2 . (pieces++))) children + go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c] + go front (ResourceParent name pieces children) = + concatMap (go (front . ((name, pieces):))) children -- | -- @@ -151,13 +151,14 @@ buildMethodMap :: Q Exp -- ^ fixHandler -> FlatResource a -> Q (Maybe Dec) buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function -buildMethodMap fixHandler (FlatResource names name pieces (Methods mmulti methods)) = do +buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []] return $ Just fun where + pieces = concat $ map snd parents ++ [pieces'] go method = do fh <- fixHandler let func = VarE $ mkName $ map toLower method ++ name @@ -172,24 +173,27 @@ buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing -- | Build a single 'D.Route' expression. buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp -buildRoute runHandler dispatcher fixHandler (FlatResource names name resPieces resDisp) = do +buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do -- First two arguments to D.Route - routePieces <- ListE <$> mapM (convertPiece . snd) resPieces + routePieces <- ListE <$> mapM (convertPiece . snd) allPieces isMulti <- case resDisp of Methods Nothing _ -> [|False|] _ -> [|True|] - [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|] + [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|] + where + allPieces = concat $ map snd parents ++ [resPieces] routeArg3 :: Q Exp -- ^ runHandler -> Q Exp -- ^ dispatcher -> Q Exp -- ^ fixHandler + -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a -> Q Exp -routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do +routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do pieces <- newName "pieces" -- Allocate input piece variables (xs) and variables that have been @@ -228,7 +232,7 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do _ -> return ([], []) -- The final expression that actually uses the values we've computed - caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest' + caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest' -- Put together all the statements just <- [|Just|] @@ -251,11 +255,12 @@ buildCaller :: Q Exp -- ^ runHandler -> Q Exp -- ^ dispatcher -> Q Exp -- ^ fixHandler -> Name -- ^ xrest + -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys -> Q Exp -buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do +buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do master <- newName "master" sub <- newName "sub" toMaster <- newName "toMaster" @@ -266,7 +271,7 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do let pat = map VarP [master, sub, toMaster, app404, handler405, method] -- Create the route - let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys + let route = routeFromDynamics parents name ys exp <- case resDisp of @@ -321,3 +326,16 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do convertPiece :: Piece a -> Q Exp convertPiece (Static s) = [|D.Static (pack $(lift s))|] convertPiece (Dynamic _) = [|D.Dynamic|] + +routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents + -> String -- ^ constructor name + -> [Name] + -> Exp +routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys +routeFromDynamics ((parent, pieces):rest) name ys = + foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here + where + (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys + isDynamic Dynamic{} = True + isDynamic _ = False + here = map VarE here' ++ [routeFromDynamics rest name ys'] diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index e7bd3451..c272bb94 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -1,23 +1,103 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Hierarchy (hierarchy) where +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Hierarchy + ( hierarchy + , Dispatcher (..) + , RunHandler (..) + , Handler + , App + , toText + ) where import Test.Hspec.Monadic import Test.Hspec.HUnit () +import Test.HUnit import Yesod.Routes.Parse import Yesod.Routes.TH import Yesod.Routes.Class import Language.Haskell.TH.Syntax +import qualified Yesod.Routes.Class as YRC +import Data.Text (Text, pack, append) + +class ToText a where + toText :: a -> Text + +instance ToText Text where toText = id +instance ToText String where toText = pack + +type Handler sub master = Text +type App sub master = (Text, Maybe (YRC.Route master)) + +class Dispatcher sub master where + dispatcher + :: master + -> sub + -> (YRC.Route sub -> YRC.Route master) + -> App sub master -- ^ 404 page + -> (YRC.Route sub -> App sub master) -- ^ 405 page + -> Text -- ^ method + -> [Text] + -> App sub master + +class RunHandler sub master where + runHandler + :: Handler sub master + -> master + -> sub + -> Maybe (YRC.Route sub) + -> (YRC.Route sub -> YRC.Route master) + -> App sub master data Hierarchy = Hierarchy -mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes| +do + let resources = [parseRoutes| / HomeR GET /admin/#Int AdminR: / AdminRootR GET /login LoginR GET POST + /table/#Text TableR GET |] + rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources + dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources + return + $ InstanceD + [] + (ConT ''Dispatcher + `AppT` ConT ''Hierarchy + `AppT` ConT ''Hierarchy) + [FunD (mkName "dispatcher") [dispatch]] + : rrinst + +getHomeR :: Handler sub master +getHomeR = "home" + +getAdminRootR :: Int -> Handler sub master +getAdminRootR i = pack $ "admin root: " ++ show i + +getLoginR :: Int -> Handler sub master +getLoginR i = pack $ "login: " ++ show i + +postLoginR :: Int -> Handler sub master +postLoginR i = pack $ "post login: " ++ show i + +getTableR :: Int -> Text -> Handler sub master +getTableR _ t = append "TableR " t + +instance RunHandler Hierarchy master where + runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) hierarchy :: Specs -hierarchy = return () +hierarchy = describe "hierarchy" $ do + it "renders root correctly" $ + renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], []) + it "renders table correctly" $ + renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], []) + let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps) + it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR) + it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar") diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 690e6795..1eff36a4 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -22,12 +22,6 @@ import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax import Hierarchy -class ToText a where - toText :: a -> Text - -instance ToText Text where toText = id -instance ToText String where toText = pack - result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -102,29 +96,6 @@ instance RenderRoute MySubParam where getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam -type Handler sub master = Text -type App sub master = (Text, Maybe (YRC.Route master)) - -class Dispatcher sub master where - dispatcher - :: master - -> sub - -> (YRC.Route sub -> YRC.Route master) - -> App sub master -- ^ 404 page - -> (YRC.Route sub -> App sub master) -- ^ 405 page - -> Text -- ^ method - -> [Text] - -> App sub master - -class RunHandler sub master where - runHandler - :: Handler sub master - -> master - -> sub - -> Maybe (YRC.Route sub) - -> (YRC.Route sub -> YRC.Route master) - -> App sub master - do texts <- [t|[Text]|] let ress = map ResourceLeaf From ebc737a5cb244f9df2c84844cd0ee7da3499149a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 22 Jun 2012 15:28:14 +0300 Subject: [PATCH 03/30] conduit 0.5 --- yesod-auth/yesod-auth.cabal | 34 ++++++++------------- yesod-core/Yesod/Dispatch.hs | 20 ++++++------ yesod-core/Yesod/Handler.hs | 2 +- yesod-core/yesod-core.cabal | 24 +++++---------- yesod-default/yesod-default.cabal | 14 ++++----- yesod-form/yesod-form.cabal | 24 +++++---------- yesod-json/yesod-json.cabal | 14 ++++----- yesod-newsfeed/Yesod/AtomFeed.hs | 29 ++++++++---------- yesod-newsfeed/Yesod/RssFeed.hs | 33 +++++++++----------- yesod-newsfeed/yesod-newsfeed.cabal | 21 ++++--------- yesod-persistent/yesod-persistent.cabal | 8 ++--- yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 4 +-- yesod-routes/yesod-routes.cabal | 2 +- yesod-sitemap/Yesod/Sitemap.hs | 13 ++++---- yesod-sitemap/yesod-sitemap.cabal | 7 +++-- yesod-static/Yesod/Static.hs | 31 ++++++++----------- yesod-static/yesod-static.cabal | 14 +++++---- yesod-test/Yesod/Test/TransversingCSS.hs | 1 - yesod-test/test/main.hs | 23 +++++++------- yesod-test/yesod-test.cabal | 29 ++++++------------ yesod/yesod.cabal | 32 +++++++------------ 21 files changed, 155 insertions(+), 224 deletions(-) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 878a8724..cd7114c7 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.0.2.1 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -12,44 +12,34 @@ build-type: Simple homepage: http://www.yesodweb.com/ description: Authentication for Yesod. -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - library build-depends: base >= 4 && < 5 - , authenticate >= 1.2.1 && < 1.3 + , authenticate >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 - , yesod-core >= 1.0 && < 1.1 - , wai >= 1.2 && < 1.3 + , yesod-core >= 1.1 && < 1.2 + , wai >= 1.3 && < 1.4 , template-haskell , pureMD5 >= 2.0 && < 2.2 , random >= 1.0.0.2 && < 1.1 , text >= 0.7 && < 0.12 , mime-mail >= 0.3 && < 0.5 - , yesod-persistent >= 1.0 && < 1.1 + , yesod-persistent >= 1.1 && < 1.2 , hamlet >= 1.0 && < 1.1 , shakespeare-css >= 1.0 && < 1.1 - , yesod-json >= 1.0 && < 1.1 + , yesod-json >= 1.1 && < 1.2 , containers , unordered-containers - , yesod-form >= 1.0 && < 1.1 + , yesod-form >= 1.1 && < 1.2 , transformers >= 0.2.2 && < 0.4 - , persistent >= 0.9 && < 0.10 - , persistent-template >= 0.9 && < 0.10 + , persistent >= 1.0 && < 1.1 + , persistent-template >= 1.0 && < 1.1 , SHA >= 1.4.1.3 && < 1.6 - , http-conduit >= 1.4.1.1 && < 1.5 + , http-conduit >= 1.5 && < 1.6 , aeson >= 0.5 , pwstore-fast >= 2.2 && < 3 , lifted-base >= 0.1 && < 0.2 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , blaze-html >= 0.5 && < 0.6 + , blaze-markup >= 0.5.1 && < 0.6 exposed-modules: Yesod.Auth Yesod.Auth.BrowserId diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 2e8ce726..312bd212 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -60,7 +60,7 @@ type Texts = [Text] -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype - -> [Resource String] + -> [ResourceTree String] -> Q [Dec] mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False @@ -71,7 +71,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype -> Cxt - -> [Resource String] + -> [ResourceTree String] -> Q [Dec] mkYesodSub name clazzes = fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True @@ -82,28 +82,28 @@ mkYesodSub name clazzes = -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. -mkYesodData :: String -> [Resource String] -> Q [Dec] +mkYesodData :: String -> [ResourceTree String] -> Q [Dec] mkYesodData name res = mkYesodDataGeneral name [] False res -mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec] +mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec] mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res -mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec] +mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name clazzes isSub res = do let (name':rest) = words name (x, _) <- mkYesodGeneral name' rest clazzes isSub res let rname = mkName $ "resources" ++ name eres <- lift res - let y = [ SigD rname $ ListT `AppT` (ConT ''Resource `AppT` ConT ''String) + let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) , FunD rname [Clause [] (NormalB eres) []] ] return $ x ++ y -- | See 'mkYesodData'. -mkYesodDispatch :: String -> [Resource String] -> Q [Dec] +mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec] +mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec] mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True where (name':rest) = words name @@ -111,7 +111,7 @@ mkYesodGeneral :: String -- ^ foundation type -> [String] -> Cxt -- ^ classes -> Bool -- ^ is subsite? - -> [Resource String] + -> [ResourceTree String] -> Q ([Dec], [Dec]) mkYesodGeneral name args clazzes isSub resS = do let args' = map mkName args @@ -130,7 +130,7 @@ mkYesodGeneral name args clazzes isSub resS = do let yesodDispatch' = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]] - return (renderRouteDec : masterTypSyns, [yesodDispatch']) + return (renderRouteDec ++ masterTypSyns, [yesodDispatch']) where name' = mkName name masterTypSyns diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index a5cf5e54..181072eb 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -333,7 +333,7 @@ runRequestBody = do rbHelper :: W.Request -> ResourceT IO RequestBodyContents rbHelper req = - (map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req) + (map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsSink req) -- FIXME allow control over which backend to use where fix1 = go *** go fix2 (x, NWP.FileInfo a b c) = diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 642feded..a79d9079 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.0.1.2 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -40,10 +40,6 @@ flag test description: Build the executable to run unit tests default: False -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - library -- Work around a bug in cabal. Without this, wai-test doesn't get built and -- we have a missing dependency during --enable-tests builds. @@ -52,9 +48,9 @@ library build-depends: base >= 4.3 && < 5 , time >= 1.1.4 - , yesod-routes >= 1.0 && < 1.1 - , wai >= 1.2 && < 1.3 - , wai-extra >= 1.2 && < 1.3 + , yesod-routes >= 1.1 && < 1.2 + , wai >= 1.3 && < 1.4 + , wai-extra >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 , text >= 0.7 && < 0.12 , template-haskell @@ -83,17 +79,11 @@ library , aeson >= 0.5 , fast-logger >= 0.0.2 , wai-logger >= 0.0.1 - , conduit >= 0.4 && < 0.5 + , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , blaze-html >= 0.5 && < 0.6 + , blaze-markup >= 0.5.1 && < 0.6 exposed-modules: Yesod.Content Yesod.Core diff --git a/yesod-default/yesod-default.cabal b/yesod-default/yesod-default.cabal index c9335a5d..3ec93dc5 100644 --- a/yesod-default/yesod-default.cabal +++ b/yesod-default/yesod-default.cabal @@ -1,5 +1,5 @@ name: yesod-default -version: 1.0.1.1 +version: 1.1.0 license: MIT license-file: LICENSE author: Patrick Brisbin @@ -18,10 +18,10 @@ library cpp-options: -DWINDOWS build-depends: base >= 4 && < 5 - , yesod-core >= 1.0 && < 1.1 - , warp >= 1.2 && < 1.3 - , wai >= 1.2 && < 1.3 - , wai-extra >= 1.2 && < 1.3 + , yesod-core >= 1.1 && < 1.2 + , warp >= 1.3 && < 1.4 + , wai >= 1.3 && < 1.4 + , wai-extra >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 , transformers >= 0.2.2 && < 0.4 , text >= 0.9 @@ -29,8 +29,8 @@ library , shakespeare-css >= 1.0 && < 1.1 , shakespeare-js >= 1.0 && < 1.1 , template-haskell - , yaml >= 0.7 && < 0.8 - , network-conduit >= 0.4 && < 0.5 + , yaml >= 0.8 && < 0.9 + , network-conduit >= 0.5 && < 0.6 , unordered-containers if !os(windows) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index b5026b4e..d6c5129e 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.0.0.4 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -12,19 +12,15 @@ build-type: Simple homepage: http://www.yesodweb.com/ description: Form handling support for Yesod Web Framework -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - library build-depends: base >= 4 && < 5 - , yesod-core >= 1.0 && < 1.1 - , yesod-persistent >= 1.0 && < 1.1 + , yesod-core >= 1.1 && < 1.2 + , yesod-persistent >= 1.1 && < 1.2 , time >= 1.1.4 , hamlet >= 1.0 && < 1.1 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-js >= 1.0 && < 1.1 - , persistent >= 0.9 && < 0.10 + , persistent >= 1.0 && < 1.1 , template-haskell , transformers >= 0.2.2 && < 0.4 , data-default >= 0.3 && < 0.5 @@ -34,16 +30,10 @@ library , email-validate >= 0.2.6 && < 0.3 , bytestring >= 0.9.1.4 , text >= 0.9 && < 1.0 - , wai >= 1.2 && < 1.3 + , wai >= 1.3 && < 1.4 , containers >= 0.2 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , blaze-html >= 0.5 && < 0.6 + , blaze-markup >= 0.5.1 && < 0.6 exposed-modules: Yesod.Form Yesod.Form.Class diff --git a/yesod-json/yesod-json.cabal b/yesod-json/yesod-json.cabal index 9730795f..8d35343b 100644 --- a/yesod-json/yesod-json.cabal +++ b/yesod-json/yesod-json.cabal @@ -1,5 +1,5 @@ name: yesod-json -version: 1.0.0.1 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -14,19 +14,19 @@ description: Generate content for Yesod using the aeson package. library build-depends: base >= 4 && < 5 - , yesod-core >= 1.0 && < 1.1 - , yesod-routes >= 1.0 && < 1.1 + , yesod-core >= 1.1 && < 1.2 + , yesod-routes >= 1.1 && < 1.2 , aeson >= 0.5 , text >= 0.8 && < 1.0 , shakespeare-js >= 1.0 && < 1.1 , vector >= 0.9 , containers >= 0.2 , blaze-builder - , attoparsec-conduit >= 0.4 && < 0.5 - , conduit >= 0.4 && < 0.5 + , attoparsec-conduit >= 0.5 && < 0.6 + , conduit >= 0.5 && < 0.6 , transformers >= 0.2.2 && < 0.4 - , wai >= 1.2 && < 1.3 - , wai-extra >= 1.2 && < 1.3 + , wai >= 1.3 && < 1.4 + , wai-extra >= 1.3 && < 1.4 , bytestring >= 0.9 , safe >= 0.2 && < 0.4 exposed-modules: Yesod.Json diff --git a/yesod-newsfeed/Yesod/AtomFeed.hs b/yesod-newsfeed/Yesod/AtomFeed.hs index 0bd21eac..3e7e6425 100644 --- a/yesod-newsfeed/Yesod/AtomFeed.hs +++ b/yesod-newsfeed/Yesod/AtomFeed.hs @@ -31,11 +31,8 @@ import qualified Data.ByteString.Char8 as S8 import Data.Text (Text) import Data.Text.Lazy (toStrict) import Text.XML -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html.Renderer.Text (renderHtml) -#else -import Text.Blaze.Renderer.Text (renderHtml) -#endif +import qualified Data.Map as Map newtype RepAtom = RepAtom Content instance HasReps RepAtom where @@ -55,21 +52,21 @@ template Feed {..} render = addNS' n = n namespace = "http://www.w3.org/2005/Atom" - root = Element "feed" [] $ map NodeElement - $ Element "title" [] [NodeContent feedTitle] - : Element "link" [("rel", "self"), ("href", render feedLinkSelf)] [] - : Element "link" [("href", render feedLinkHome)] [] - : Element "updated" [] [NodeContent $ formatW3 feedUpdated] - : Element "id" [] [NodeContent $ render feedLinkHome] + root = Element "feed" Map.empty $ map NodeElement + $ Element "title" Map.empty [NodeContent feedTitle] + : Element "link" (Map.fromList [("rel", "self"), ("href", render feedLinkSelf)]) [] + : Element "link" (Map.singleton "href" $ render feedLinkHome) [] + : Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated] + : Element "id" Map.empty [NodeContent $ render feedLinkHome] : map (flip entryTemplate render) feedEntries entryTemplate :: FeedEntry url -> (url -> Text) -> Element -entryTemplate FeedEntry {..} render = Element "entry" [] $ map NodeElement - [ Element "id" [] [NodeContent $ render feedEntryLink] - , Element "link" [("href", render feedEntryLink)] [] - , Element "updated" [] [NodeContent $ formatW3 feedEntryUpdated] - , Element "title" [] [NodeContent feedEntryTitle] - , Element "content" [("type", "html")] [NodeContent $ toStrict $ renderHtml feedEntryContent] +entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElement + [ Element "id" Map.empty [NodeContent $ render feedEntryLink] + , Element "link" (Map.singleton "href" $ render feedEntryLink) [] + , Element "updated" Map.empty [NodeContent $ formatW3 feedEntryUpdated] + , Element "title" Map.empty [NodeContent feedEntryTitle] + , Element "content" (Map.singleton "type" "html") [NodeContent $ toStrict $ renderHtml feedEntryContent] ] -- | Generates a link tag in the head of a widget. diff --git a/yesod-newsfeed/Yesod/RssFeed.hs b/yesod-newsfeed/Yesod/RssFeed.hs index e0fca43d..a4b0eac1 100644 --- a/yesod-newsfeed/Yesod/RssFeed.hs +++ b/yesod-newsfeed/Yesod/RssFeed.hs @@ -27,11 +27,8 @@ import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack) import Data.Text.Lazy (toStrict) import Text.XML -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html.Renderer.Text (renderHtml) -#else -import Text.Blaze.Renderer.Text (renderHtml) -#endif +import qualified Data.Map as Map newtype RepRss = RepRss Content instance HasReps RepRss where @@ -47,26 +44,26 @@ template :: Feed url -> (url -> Text) -> Document template Feed {..} render = Document (Prologue [] Nothing []) root [] where - root = Element "rss" [("version", "2.0")] $ return $ NodeElement $ Element "channel" [] $ map NodeElement - $ Element "{http://www.w3.org/2005/Atom}link" + root = Element "rss" (Map.singleton "version" "2.0") $ return $ NodeElement $ Element "channel" Map.empty $ map NodeElement + $ Element "{http://www.w3.org/2005/Atom}link" (Map.fromList [ ("href", render feedLinkSelf) , ("rel", "self") , ("type", pack $ S8.unpack typeRss) - ] [] - : Element "title" [] [NodeContent feedTitle] - : Element "link" [] [NodeContent $ render feedLinkHome] - : Element "description" [] [NodeContent $ toStrict $ renderHtml feedDescription] - : Element "lastBuildDate" [] [NodeContent $ formatRFC822 feedUpdated] - : Element "language" [] [NodeContent feedLanguage] + ]) [] + : Element "title" Map.empty [NodeContent feedTitle] + : Element "link" Map.empty [NodeContent $ render feedLinkHome] + : Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedDescription] + : Element "lastBuildDate" Map.empty [NodeContent $ formatRFC822 feedUpdated] + : Element "language" Map.empty [NodeContent feedLanguage] : map (flip entryTemplate render) feedEntries entryTemplate :: FeedEntry url -> (url -> Text) -> Element -entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement - [ Element "title" [] [NodeContent feedEntryTitle] - , Element "link" [] [NodeContent $ render feedEntryLink] - , Element "guid" [] [NodeContent $ render feedEntryLink] - , Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated] - , Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent] +entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement + [ Element "title" Map.empty [NodeContent feedEntryTitle] + , Element "link" Map.empty [NodeContent $ render feedEntryLink] + , Element "guid" Map.empty [NodeContent $ render feedEntryLink] + , Element "pubDate" Map.empty [NodeContent $ formatRFC822 feedEntryUpdated] + , Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedEntryContent] ] -- | Generates a link tag in the head of a widget. diff --git a/yesod-newsfeed/yesod-newsfeed.cabal b/yesod-newsfeed/yesod-newsfeed.cabal index ea2ca24b..40788fe6 100644 --- a/yesod-newsfeed/yesod-newsfeed.cabal +++ b/yesod-newsfeed/yesod-newsfeed.cabal @@ -1,5 +1,5 @@ name: yesod-newsfeed -version: 1.0.0.2 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -12,26 +12,17 @@ build-type: Simple homepage: http://www.yesodweb.com/ description: Helper functions and data types for producing News feeds. -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - library build-depends: base >= 4 && < 5 - , yesod-core >= 1.0 && < 1.1 + , yesod-core >= 1.1 && < 1.2 , time >= 1.1.4 , hamlet >= 1.0 && < 1.1 , bytestring >= 0.9.1.4 , text >= 0.9 && < 0.12 - , xml-conduit >= 0.7 && < 0.8 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , xml-conduit >= 0.8 && < 0.9 + , blaze-html >= 0.5 && < 0.6 + , blaze-markup >= 0.5.1 && < 0.6 + , containers exposed-modules: Yesod.AtomFeed , Yesod.RssFeed diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index 6ba0fec3..170ffb96 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,5 +1,5 @@ name: yesod-persistent -version: 1.0.0.1 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -14,9 +14,9 @@ description: Some helpers for using Persistent from Yesod. library build-depends: base >= 4 && < 5 - , yesod-core >= 1.0 && < 1.1 - , persistent >= 0.9 && < 0.10 - , persistent-template >= 0.9 && < 0.10 + , yesod-core >= 1.1 && < 1.2 + , persistent >= 1.0 && < 1.1 + , persistent-template >= 1.0 && < 1.1 , transformers >= 0.2.2 && < 0.4 exposed-modules: Yesod.Persist ghc-options: -Wall diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs index 3ba87b77..b45b1b3a 100644 --- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs @@ -77,9 +77,9 @@ mkRenderRouteClauses = colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) - let pieces = foldr cons (VarE a) piecesSingle + let pieces' = foldr cons (VarE a) piecesSingle - let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE child) + let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child) return $ Clause [pat] (NormalB body) [FunD childRender childClauses] diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index a523711c..ddb039b2 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -1,5 +1,5 @@ name: yesod-routes -version: 1.0.1.2 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-sitemap/Yesod/Sitemap.hs b/yesod-sitemap/Yesod/Sitemap.hs index 083042a6..517e8cce 100644 --- a/yesod-sitemap/Yesod/Sitemap.hs +++ b/yesod-sitemap/Yesod/Sitemap.hs @@ -30,6 +30,7 @@ import Data.Time (UTCTime) import Data.Monoid (mappend) import Text.XML import Data.Text (Text, pack) +import qualified Data.Map as Map data SitemapChangeFreq = Always | Hourly @@ -66,13 +67,13 @@ template urls render = addNS' n = n namespace = "http://www.sitemaps.org/schemas/sitemap/0.9" - root = Element "urlset" [] $ map go urls + root = Element "urlset" Map.empty $ map go urls - go SitemapUrl {..} = NodeElement $ Element "url" [] $ map NodeElement - [ Element "loc" [] [NodeContent $ render sitemapLoc] - , Element "lastmod" [] [NodeContent $ formatW3 sitemapLastMod] - , Element "changefreq" [] [NodeContent $ showFreq sitemapChangeFreq] - , Element "priority" [] [NodeContent $ pack $ show sitemapPriority] + go SitemapUrl {..} = NodeElement $ Element "url" Map.empty $ map NodeElement + [ Element "loc" Map.empty [NodeContent $ render sitemapLoc] + , Element "lastmod" Map.empty [NodeContent $ formatW3 sitemapLastMod] + , Element "changefreq" Map.empty [NodeContent $ showFreq sitemapChangeFreq] + , Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority] ] sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml diff --git a/yesod-sitemap/yesod-sitemap.cabal b/yesod-sitemap/yesod-sitemap.cabal index 11dd3c14..77b06a2b 100644 --- a/yesod-sitemap/yesod-sitemap.cabal +++ b/yesod-sitemap/yesod-sitemap.cabal @@ -1,5 +1,5 @@ name: yesod-sitemap -version: 1.0.0.1 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -14,10 +14,11 @@ description: Generate XML sitemaps. library build-depends: base >= 4 && < 5 - , yesod-core >= 1.0 && < 1.1 + , yesod-core >= 1.1 && < 1.2 , time >= 1.1.4 - , xml-conduit >= 0.7 && < 0.8 + , xml-conduit >= 0.8 && < 0.9 , text + , containers exposed-modules: Yesod.Sitemap ghc-options: -Wall diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 3aa274a2..f7c02c39 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -78,19 +78,15 @@ import System.Posix.Types (EpochTime) import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import Data.Functor.Identity (runIdentity) +import qualified Filesystem.Path.CurrentOS as F import Network.Wai.Application.Static ( StaticSettings (..) - , defaultWebAppSettings , staticApp - , embeddedLookup - , toEmbedded - , toFilePath - , fromFilePath - , FilePath - , ETagLookup , webAppSettingsWithLookup + , embeddedSettings ) +import WaiAppStatic.Storage.Filesystem (ETagLookup) -- | Type used for the subsite with static contents. newtype Static = Static StaticSettings @@ -106,7 +102,7 @@ type StaticRoute = Route Static static :: Prelude.FilePath -> IO Static static dir = do hashLookup <- cachedETagLookup dir - return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup + return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup -- | Same as 'static', but does not assumes that the files do not -- change and checks their modification time whenever a request @@ -114,15 +110,12 @@ static dir = do staticDevel :: Prelude.FilePath -> IO Static staticDevel dir = do hashLookup <- cachedETagLookupDevel dir - return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup + return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup -- | Produce a 'Static' based on embedding all of the static -- files' contents in the executable at compile time. embed :: Prelude.FilePath -> Q Exp -embed fp = - [|Static (defaultWebAppSettings - { ssFolder = embeddedLookup (toEmbedded $(embedDir fp)) - })|] +embed fp = [|Static (embeddedSettings $(embedDir fp))|] instance RenderRoute Static where -- | A route on the static subsite (see also 'staticFiles'). @@ -226,18 +219,18 @@ publicFiles :: Prelude.FilePath -> Q [Dec] publicFiles dir = mkStaticFiles' dir "StaticRoute" False -mkHashMap :: Prelude.FilePath -> IO (M.Map FilePath S8.ByteString) +mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString) mkHashMap dir = do fs <- getFileListPieces dir hashAlist fs >>= return . M.fromList where - hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)] + hashAlist :: [[String]] -> IO [(F.FilePath, S8.ByteString)] hashAlist fs = mapM hashPair fs where - hashPair :: [String] -> IO (FilePath, S8.ByteString) + hashPair :: [String] -> IO (F.FilePath, S8.ByteString) hashPair pieces = do let file = pathFromRawPieces dir pieces h <- base64md5File file - return (toFilePath file, S8.pack h) + return (F.decodeString file, S8.pack h) pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath pathFromRawPieces = @@ -248,12 +241,12 @@ pathFromRawPieces = cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup cachedETagLookupDevel dir = do etags <- mkHashMap dir - mtimeVar <- newIORef (M.empty :: M.Map FilePath EpochTime) + mtimeVar <- newIORef (M.empty :: M.Map F.FilePath EpochTime) return $ \f -> case M.lookup f etags of Nothing -> return Nothing Just checksum -> do - fs <- getFileStatus $ fromFilePath f + fs <- getFileStatus $ F.encodeString f let newt = modificationTime fs mtimes <- readIORef mtimeVar oldt <- case M.lookup f mtimes of diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 6af96206..636404fa 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.0.0.3 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -19,22 +19,23 @@ library build-depends: base >= 4 && < 5 , containers >= 0.2 , old-time >= 1.0 - , yesod-core >= 1.0 && < 1.1 + , yesod-core >= 1.1 && < 1.2 , base64-bytestring >= 0.1.0.1 && < 0.2 , cereal >= 0.3 && < 0.4 , bytestring >= 0.9.1.4 , template-haskell , directory >= 1.0 && < 1.2 , transformers >= 0.2.2 && < 0.4 - , wai-app-static >= 1.2 && < 1.3 - , wai >= 1.2 && < 1.3 + , wai-app-static >= 1.3 && < 1.4 + , wai >= 1.3 && < 1.4 , text >= 0.9 && < 1.0 , file-embed >= 0.0.4.1 && < 0.5 , http-types >= 0.6.5 && < 0.7 , unix-compat >= 0.2 - , conduit >= 0.4 && < 0.5 - , crypto-conduit >= 0.3 && < 0.4 + , conduit >= 0.5 && < 0.6 + , crypto-conduit >= 0.4 && < 0.5 , cryptohash >= 0.6.1 + , system-filepath >= 0.4.6 && < 0.5 exposed-modules: Yesod.Static ghc-options: -Wall @@ -65,6 +66,7 @@ test-suite tests , conduit , crypto-conduit , cryptohash >= 0.6.1 + , system-filepath ghc-options: -Wall diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 28c1558a..d123a615 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -53,7 +53,6 @@ import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Blaze (toHtml) import Text.Blaze.Renderer.String (renderHtml) #endif -import Text.XML.Xml2Html () type Query = T.Text type Html = L.ByteString diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index e5031155..b7f605ad 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -9,6 +9,7 @@ import Yesod.Test.HtmlParse import Text.XML import Data.ByteString.Lazy.Char8 () +import qualified Data.Map as Map parseQuery_ = either error id . parseQuery findBySelector_ x = either error id . findBySelector x @@ -33,13 +34,13 @@ main = hspecX $ do it "XHTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] - root = Element "html" [] - [ NodeElement $ Element "head" [] - [ NodeElement $ Element "title" [] + root = Element "html" Map.empty + [ NodeElement $ Element "head" Map.empty + [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] - , NodeElement $ Element "body" [] - [ NodeElement $ Element "p" [] + , NodeElement $ Element "body" Map.empty + [ NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] @@ -47,14 +48,14 @@ main = hspecX $ do it "HTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] - root = Element "html" [] - [ NodeElement $ Element "head" [] - [ NodeElement $ Element "title" [] + root = Element "html" Map.empty + [ NodeElement $ Element "head" Map.empty + [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] - , NodeElement $ Element "body" [] - [ NodeElement $ Element "br" [] [] - , NodeElement $ Element "p" [] + , NodeElement $ Element "body" Map.empty + [ NodeElement $ Element "br" Map.empty [] + , NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 1d4805c5..3efa96c7 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 0.2.0.6 +version: 0.3.0 license: MIT license-file: LICENSE author: Nubis @@ -13,19 +13,14 @@ homepage: http://www.yesodweb.com description: Behaviour Oriented integration Testing for Yesod Applications extra-source-files: README.md, LICENSE, test/main.hs -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - - library build-depends: base >= 4.3 && < 5 , hxt >= 9.1.6 , attoparsec >= 0.10 && < 0.11 - , persistent >= 0.9 && < 0.10 + , persistent >= 1.0 && < 1.1 , transformers >= 0.2.2 && < 0.4 - , wai >= 1.2 && < 1.3 - , wai-test >= 1.2 && < 1.3 + , wai >= 1.3 && < 1.4 + , wai-test >= 1.3 && < 1.4 , network >= 2.2 && < 2.4 , http-types >= 0.6 && < 0.7 , HUnit >= 1.2 && < 1.3 @@ -33,19 +28,12 @@ library , bytestring >= 0.9 , case-insensitive >= 0.2 , text - , xml-conduit >= 0.7 && < 0.8 + , xml-conduit >= 0.8 && < 0.9 , xml-types >= 0.3 && < 0.4 , containers - , xml2html >= 0.1.2.3 && < 0.2 - , html-conduit >= 0.0.1 && < 0.1 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , html-conduit >= 0.1 && < 0.2 + , blaze-html >= 0.5 && < 0.6 + , blaze-markup >= 0.5.1 && < 0.6 exposed-modules: Yesod.Test Yesod.Test.CssQuery @@ -63,6 +51,7 @@ test-suite test , HUnit , xml-conduit , bytestring + , containers source-repository head type: git diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index c0e7227f..c9aa9230 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.0.1.6 +version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -62,34 +62,24 @@ extra-source-files: scaffold/config/mongoDB.yml.cg scaffold/devel.hs.cg -flag blaze_html_0_5 - description: use blaze-html 0.5 and blaze-markup 0.5 - default: True - library build-depends: base >= 4.3 && < 5 - , yesod-core >= 1.0 && < 1.1 - , yesod-auth >= 1.0 && < 1.1 - , yesod-json >= 1.0 && < 1.1 - , yesod-persistent >= 1.0 && < 1.1 - , yesod-form >= 1.0 && < 1.1 + , yesod-core >= 1.1 && < 1.2 + , yesod-auth >= 1.1 && < 1.2 + , yesod-json >= 1.1 && < 1.2 + , yesod-persistent >= 1.1 && < 1.2 + , yesod-form >= 1.1 && < 1.2 , monad-control >= 0.3 && < 0.4 , transformers >= 0.2.2 && < 0.4 - , wai >= 1.2 && < 1.3 - , wai-extra >= 1.2 && < 1.3 + , wai >= 1.3 && < 1.4 + , wai-extra >= 1.3 && < 1.4 , wai-logger >= 0.1.2 , hamlet >= 1.0 && < 1.1 , shakespeare-js >= 1.0 && < 1.1 , shakespeare-css >= 1.0 && < 1.1 - , warp >= 1.2 && < 1.3 - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 - , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , warp >= 1.3 && < 1.4 + , blaze-html >= 0.5 && < 0.6 + , blaze-markup >= 0.5.1 && < 0.6 exposed-modules: Yesod ghc-options: -Wall From 014732dac87a7e7192ca3264ad01de839b9bbdbc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jun 2012 10:56:50 +0300 Subject: [PATCH 04/30] hspec 1.2 --- yesod-core/yesod-core.cabal | 2 +- yesod-form/yesod-form.cabal | 2 +- yesod-routes/yesod-routes.cabal | 2 +- yesod-static/yesod-static.cabal | 2 +- yesod-test/Yesod/Test.hs | 4 ++-- yesod-test/yesod-test.cabal | 2 +- 6 files changed, 7 insertions(+), 7 deletions(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index a79d9079..1e83e064 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -109,7 +109,7 @@ test-suite tests cpp-options: -DTEST build-depends: base - ,hspec >= 1.1 && < 1.2 + ,hspec >= 1.2 && < 1.3 ,wai-test ,wai ,yesod-core diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index d6c5129e..549ab02a 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -23,7 +23,7 @@ library , persistent >= 1.0 && < 1.1 , template-haskell , transformers >= 0.2.2 && < 0.4 - , data-default >= 0.3 && < 0.5 + , data-default , xss-sanitize >= 0.3.0.1 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4 , network >= 2.2 && < 2.4 diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index ddb039b2..3fe03050 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -42,7 +42,7 @@ test-suite runtests , yesod-routes , text >= 0.5 && < 0.12 , HUnit >= 1.2 && < 1.3 - , hspec >= 0.6 && < 1.2 + , hspec >= 1.2 && < 1.3 , containers , template-haskell , path-pieces diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 636404fa..cf39f1c8 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -45,7 +45,7 @@ test-suite tests type: exitcode-stdio-1.0 cpp-options: -DTEST_EXPORT build-depends: base - , hspec >= 1.0 && < 1.2 + , hspec >= 1.2 && < 1.3 , HUnit -- copy from above , containers >= 0.2 diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index e8715d10..312eb889 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -133,10 +133,10 @@ type CookieValue = H.Ascii -- -- Look at the examples directory on this package to get an idea of the (small) amount of -- boilerplate code you'll need to write before calling this. -runTests :: Application -> ConnectionPool -> Specs -> IO a +runTests :: Application -> ConnectionPool -> Specs -> IO () runTests app connection specsDef = do (SpecsData _ _ specs) <- ST.execStateT specsDef (SpecsData app connection []) - Runner.hspecX specs + Runner.hspec specs -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 3efa96c7..550cecb8 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -24,7 +24,7 @@ library , network >= 2.2 && < 2.4 , http-types >= 0.6 && < 0.7 , HUnit >= 1.2 && < 1.3 - , hspec >= 1.1 && < 1.2 + , hspec >= 1.2 && < 1.3 , bytestring >= 0.9 , case-insensitive >= 0.2 , text From 4a6e027d291570be952b4f53dfccf91a51b0333a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jun 2012 22:52:56 +0300 Subject: [PATCH 05/30] maximumContentLength is Word64 (#365) --- yesod-core/Yesod/Internal/Core.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index ac175bc1..32f0ef86 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -47,6 +47,7 @@ import Yesod.Handler hiding (lift, getExpires) import Yesod.Routes.Class +import Data.Word (Word64) import Control.Arrow ((***)) import Control.Monad (forM) import Yesod.Widget @@ -290,7 +291,7 @@ $doctype 5 cookieDomain _ = Nothing -- | Maximum allowed length of the request body, in bytes. - maximumContentLength :: a -> Maybe (Route a) -> Int + maximumContentLength :: a -> Maybe (Route a) -> Word64 maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes -- | Send a message to the log. By default, prints to stdout. From d465d3086352233e1130e050adcecf3d8636c32e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jun 2012 22:54:12 +0300 Subject: [PATCH 06/30] Remove some blaze conditionals --- yesod-core/Yesod/Internal/Core.hs | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 32f0ef86..d99600c0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -85,11 +85,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO import qualified Data.Text.Lazy.Builder as TB import Language.Haskell.TH.Syntax (Loc (..), Lift (..)) -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze (preEscapedToMarkup) -#else -import Text.Blaze (preEscapedLazyText) -#endif import Data.Aeson (Value (Array, String)) import Data.Aeson.Encode (encode) import qualified Data.Vector as Vector @@ -97,11 +93,6 @@ import Network.Wai.Middleware.Gzip (GzipSettings, def) import qualified Paths_yesod_core import Data.Version (showVersion) -#if MIN_VERSION_blaze_html(0, 5, 0) -preEscapedLazyText :: TL.Text -> Html -preEscapedLazyText = preEscapedToMarkup -#endif - yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version @@ -522,7 +513,7 @@ maybeAuthorized r isWrite = do return $ if x == Authorized then Just r else Nothing jsToHtml :: Javascript -> Html -jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b +jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b jelper :: JavascriptUrl url -> HtmlUrl url jelper = fmap jsToHtml @@ -550,7 +541,7 @@ widgetToPageContent w = do $ encodeUtf8 rendered return (mmedia, case x of - Nothing -> Left $ preEscapedLazyText rendered + Nothing -> Left $ preEscapedToMarkup rendered Just y -> Right $ either id (uncurry render) y) jsLoc <- case jscript of From a5361e44f27a833aaf8b84021b634c33375a31fb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 30 Jun 2012 22:09:13 +0300 Subject: [PATCH 07/30] checkM' (need to rename it) --- yesod-form/Yesod/Form/Functions.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 0dfb3777..6e69986e 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -338,13 +338,21 @@ checkM :: RenderMessage master msg => (a -> GHandler sub master (Either msg a)) -> Field sub master a -> Field sub master a -checkM f field = field +checkM f = checkM' f id + +checkM' :: RenderMessage master msg + => (a -> GHandler sub master (Either msg b)) + -> (b -> a) + -> Field sub master a + -> Field sub master b +checkM' f inv field = field { fieldParse = \ts -> do e1 <- fieldParse field ts case e1 of Left msg -> return $ Left msg Right Nothing -> return $ Right Nothing Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a + , fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req } -- | Allows you to overwrite the error message on parse error. From 3ecbf43f5d2c2a94ac9b51d50acef608f96a4384 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 1 Jul 2012 20:59:37 +0300 Subject: [PATCH 08/30] $newline --- yesod-auth/Yesod/Auth.hs | 6 +++- yesod-auth/Yesod/Auth/BrowserId.hs | 1 + yesod-auth/Yesod/Auth/Dummy.hs | 1 + yesod-auth/Yesod/Auth/Email.hs | 13 ++++++-- yesod-auth/Yesod/Auth/GoogleEmail.hs | 5 ++- yesod-auth/Yesod/Auth/HashDB.hs | 7 ++-- yesod-auth/Yesod/Auth/OpenId.hs | 1 + yesod-auth/Yesod/Auth/Rpxnow.hs | 1 + yesod-auth/yesod-auth.cabal | 2 +- yesod-core/Yesod/Handler.hs | 1 + yesod-core/Yesod/Internal.hs | 9 +++-- yesod-core/Yesod/Internal/Core.hs | 10 ++++++ yesod-core/test/YesodCoreTest/Links.hs | 2 +- yesod-core/test/YesodCoreTest/Widget.hs | 9 +++-- yesod-core/yesod-core.cabal | 4 +-- yesod-form/Yesod/Form/Fields.hs | 44 ++++++++++++++++++++++--- yesod-form/Yesod/Form/Functions.hs | 13 ++++++-- yesod-form/Yesod/Form/Jquery.hs | 2 ++ yesod-form/Yesod/Form/MassInput.hs | 8 ++++- yesod-form/Yesod/Form/Nic.hs | 1 + yesod-form/yesod-form.cabal | 2 +- yesod-newsfeed/Yesod/AtomFeed.hs | 1 + yesod-newsfeed/Yesod/RssFeed.hs | 1 + yesod-newsfeed/yesod-newsfeed.cabal | 4 +-- yesod-sitemap/yesod-sitemap.cabal | 2 +- yesod-test/yesod-test.cabal | 2 +- yesod/yesod.cabal | 2 +- 27 files changed, 122 insertions(+), 32 deletions(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 6b284e7c..3e8d7106 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -149,7 +149,10 @@ setCreds doRedirects creds = do Nothing -> when doRedirects $ do case authRoute y of - Nothing -> do rh <- defaultLayout $ toWidget [shamlet|

Invalid login |] + Nothing -> do rh <- defaultLayout $ toWidget [shamlet| +$newline never +

Invalid login +|] sendResponse rh Just ar -> do setMessageI Msg.InvalidLogin redirect ar @@ -168,6 +171,7 @@ getCheckR = do where html' creds = [shamlet| +$newline never

Authentication Status $maybe _ <- creds

Logged in. diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index 4b3f7c88..be847acf 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -62,6 +62,7 @@ helper maudience = AuthPlugin , apLogin = \toMaster -> do addScriptRemote browserIdJs toWidget [hamlet| +$newline never

diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index e9ba805c..7ba931e5 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -24,6 +24,7 @@ authDummy = url = PluginR "dummy" [] login authToMaster = toWidget [hamlet| +$newline never

Your new identifier is: # diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 4e35f09a..5101ff0e 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -79,6 +79,7 @@ authEmail :: YesodAuthEmail m => AuthPlugin m authEmail = AuthPlugin "email" dispatch $ \tm -> [whamlet| +$newline never @@ -112,6 +113,7 @@ getRegisterR = do defaultLayout $ do setTitleI Msg.RegisterLong [whamlet| +$newline never

_{Msg.EnterEmail}

_{Msg.ConfirmationEmailSent email} |] + [whamlet| +$newline never +

_{Msg.ConfirmationEmailSent email} +|] getVerifyR :: YesodAuthEmail m => AuthEmailId m -> Text -> GHandler Auth m RepHtml @@ -161,7 +166,10 @@ getVerifyR lid key = do _ -> return () defaultLayout $ do setTitleI Msg.InvalidKey - [whamlet|

_{Msg.InvalidKey} |] + [whamlet| +$newline never +

_{Msg.InvalidKey} +|] postLoginR :: YesodAuthEmail master => GHandler Auth master () postLoginR = do @@ -200,6 +208,7 @@ getPasswordR = do defaultLayout $ do setTitleI Msg.SetPassTitle [whamlet| +$newline never

_{Msg.SetPass}

diff --git a/yesod-auth/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs index 6bc1578e..8f06abe3 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail.hs @@ -46,7 +46,10 @@ authGoogleEmail = where complete = PluginR pid ["complete"] login tm = - [whamlet|_{Msg.LoginGoogle}|] + [whamlet| +$newline never +_{Msg.LoginGoogle} +|] dispatch "GET" ["forward"] = do render <- getUrlRender toMaster <- getRouteToMaster diff --git a/yesod-auth/Yesod/Auth/HashDB.hs b/yesod-auth/Yesod/Auth/HashDB.hs index cbce0785..1e400aeb 100644 --- a/yesod-auth/Yesod/Auth/HashDB.hs +++ b/yesod-auth/Yesod/Auth/HashDB.hs @@ -76,7 +76,7 @@ import Yesod.Handler import Yesod.Form import Yesod.Auth import Yesod.Widget (toWidget) -import Text.Hamlet (hamlet, shamlet) +import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) import Control.Monad (replicateM,liftM) @@ -176,7 +176,7 @@ postLoginR uniq = do (validateUser <$> (uniq =<< mu) <*> mp) if isValid then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] - else do setMessage [shamlet| Invalid username/password |] + else do setMessage "Invalid username/password" toMaster <- getRouteToMaster redirect $ toMaster LoginR @@ -207,7 +207,7 @@ getAuthIdHashDB authR uniq creds = do -- user exists Just (Entity uid _) -> return $ Just uid Nothing -> do - setMessage [shamlet| User not found |] + setMessage "User not found" redirect $ authR LoginR -- | Prompt for username and password, validate that against a database @@ -221,6 +221,7 @@ authHashDB :: ( YesodAuth m, YesodPersist m , PersistUnique b (GHandler Auth m)) => (Text -> Maybe (Unique user b)) -> AuthPlugin m authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet| +$newline never