yesod-core 0.7.0 → 0.7.0.1
raw patch · 6 files changed
+61/−152 lines, 6 filesdep +wai-testdep ~web-routes-quasi
Dependencies added: wai-test
Dependency ranges changed: web-routes-quasi
Files
- Yesod/Core.hs +0/−63
- Yesod/Dispatch.hs +13/−61
- Yesod/Handler.hs +0/−16
- Yesod/Internal/Dispatch.hs +43/−3
- runtests.hs +2/−7
- yesod-core.cabal +3/−2
Yesod/Core.hs view
@@ -22,9 +22,6 @@ -- * Misc , yesodVersion , yesodRender-#if TEST- , coreTestSuite-#endif ) where import Yesod.Content@@ -59,15 +56,6 @@ import qualified Data.Map as Map import Data.Time -#if TEST-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit hiding (Test)-import qualified Data.Text-import qualified Data.Text.Encoding-#endif- #if GHC7 #define HAMLET hamlet #else@@ -486,54 +474,3 @@ (urlRenderOverride y u) where (ps, qs') = renderRoute u--#if TEST-coreTestSuite :: Test-coreTestSuite = testGroup "Yesod.Yesod"- [ testProperty "join/split path" propJoinSplitPath- , testCase "join/split path [\".\"]" caseJoinSplitPathDquote- , testCase "utf8 split path" caseUtf8SplitPath- , testCase "utf8 join path" caseUtf8JoinPath- ]--data TmpYesod = TmpYesod-data TmpRoute = TmpRoute deriving Eq-type instance Route TmpYesod = TmpRoute-instance Yesod TmpYesod where approot _ = ""--fromString :: String -> S8.ByteString-fromString = Data.Text.Encoding.encodeUtf8 . Data.Text.pack--propJoinSplitPath :: [String] -> Bool-propJoinSplitPath ss =- splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' [])- == Right ss'- where- ss' = filter (not . null) ss--caseJoinSplitPathDquote :: Assertion-caseJoinSplitPathDquote = do- splitPath TmpYesod (fromString "/x%2E/") @?= Right ["x."]- splitPath TmpYesod (fromString "/y./") @?= Right ["y."]- joinPath TmpYesod "" ["z."] [] @?= "/z./"- x @?= Right ss- where- x = splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' [])- ss' = filter (not . null) ss- ss = ["a."]--caseUtf8SplitPath :: Assertion-caseUtf8SplitPath = do- Right ["שלום"] @=?- splitPath TmpYesod (fromString "/שלום/")- Right ["page", "Fooé"] @=?- splitPath TmpYesod (fromString "/page/Fooé/")- Right ["\156"] @=?- splitPath TmpYesod (fromString "/\156/")- Right ["ð"] @=?- splitPath TmpYesod (fromString "/%C3%B0/")--caseUtf8JoinPath :: Assertion-caseUtf8JoinPath = do- "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []-#endif
Yesod/Dispatch.hs view
@@ -18,11 +18,9 @@ -- * Convert to WAI , toWaiApp , toWaiAppPlain-#if TEST- , dispatchTestSuite-#endif ) where +import Data.Either (partitionEithers) import Prelude hiding (exp) import Yesod.Core import Yesod.Handler@@ -38,7 +36,6 @@ import Network.Wai.Middleware.Gzip import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString as S import Data.ByteString.Lazy.Char8 () import Web.ClientSession@@ -46,13 +43,6 @@ import Web.Routes (decodePathInfo) -#if TEST-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck-import System.IO.Unsafe-#endif- -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's.@@ -126,7 +116,14 @@ [ FunD (mkName "renderRoute") render ] - yd <- mkYesodDispatch' th'+ let splitter :: (THResource, Maybe String)+ -> Either+ (THResource, Maybe String)+ (THResource, Maybe String)+ splitter a@((_, SubSite{}), _) = Left a+ splitter a = Right a+ let (resSub, resLoc) = partitionEithers $ map splitter th'+ yd <- mkYesodDispatch' resSub resLoc let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes@@ -181,54 +178,9 @@ -> Maybe Key -> W.Application toWaiApp' y key' env = do- let segments =- case decodePathInfo $ B.unpack $ W.pathInfo env of- "":x -> x- x -> x+ let dropSlash ('/':x) = x+ dropSlash x = x+ let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env case yesodDispatch y key' segments y id of Just app -> app env- Nothing ->- case cleanPath y segments of- Right segments' ->- case yesodDispatch y key' segments' y id of- Just app -> app env- Nothing -> yesodRunner y y id key' Nothing notFound env- Left segments' ->- let dest = joinPath y (approot y) segments' []- dest' =- if S.null (W.queryString env)- then dest- else dest ++ '?' : B.unpack (W.queryString env)- in return $ W.responseLBS W.status301- [ ("Content-Type", "text/plain")- , ("Location", B.pack $ dest')- ] "Redirecting"--#if TEST--dispatchTestSuite :: Test-dispatchTestSuite = testGroup "Yesod.Dispatch"- [ testProperty "encode/decode session" propEncDecSession- , testProperty "get/put time" propGetPutTime- ]--propEncDecSession :: [(String, String)] -> Bool-propEncDecSession session' = unsafePerformIO $ do- key <- getDefaultKey- now <- getCurrentTime- let expire = addUTCTime 1 now- let rhost = B.pack "some host"- let val = encodeSession key expire rhost session'- return $ Just session' == decodeSession key now rhost val--propGetPutTime :: UTCTime -> Bool-propGetPutTime t = Right t == runGet getTime (runPut $ putTime t)--instance Arbitrary UTCTime where- arbitrary = do- a <- arbitrary- b <- arbitrary- return $ addUTCTime (fromRational b)- $ UTCTime (ModifiedJulianDay a) 0--#endif+ Nothing -> yesodRunner y y id key' Nothing notFound env
Yesod/Handler.hs view
@@ -98,9 +98,6 @@ , handlerToYAR , yarToResponse , headerToPair-#if TEST- , handlerTestSuite-#endif ) where import Prelude hiding (catch)@@ -136,10 +133,6 @@ import Data.Enumerator (Iteratee (..)) import Network.Wai.Parse (parseHttpAccept) -#if TEST-import Test.Framework (testGroup, Test)-#endif- import Yesod.Content import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie)@@ -649,15 +642,6 @@ -- | Get all session variables. getSession :: Monad mo => GGHandler s m mo SessionMap getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get--#if TEST--handlerTestSuite :: Test-handlerTestSuite = testGroup "Yesod.Handler"- [- ]--#endif handlerToYAR :: (HasReps a, HasReps b) => m -- ^ master site foundation
Yesod/Internal/Dispatch.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-} -- | A bunch of Template Haskell used in the Yesod.Dispatch module. module Yesod.Internal.Dispatch ( mkYesodDispatch'@@ -17,6 +18,9 @@ import Data.List (foldl') import Data.Char (toLower) import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Lazy.Char8 ()+import qualified Data.ByteString as S+import Yesod.Core (Yesod (joinPath, approot, cleanPath)) {-| @@ -64,16 +68,52 @@ Obviously we would never want to write code by hand like this, but generating it is not too bad. This function generates a clause for the yesodDispatch function based on a set of routes.++NOTE: We deal with subsites first; if none of those match, we try to apply+cleanPath. If that indicates a redirect, we perform it. Otherwise, we match+local routes.+ -}-mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause-mkYesodDispatch' res = do++sendRedirect :: Yesod master => master -> [String] -> W.Application+sendRedirect y segments' env =+ return $ W.responseLBS W.status301+ [ ("Content-Type", "text/plain")+ , ("Location", S8.pack $ dest')+ ] "Redirecting"+ where+ dest = joinPath y (approot y) segments' []+ dest' =+ if S.null (W.queryString env)+ then dest+ else dest ++ '?' : S8.unpack (W.queryString env)++mkYesodDispatch' :: [((String, Pieces), Maybe String)]+ -> [((String, Pieces), Maybe String)]+ -> Q Clause+mkYesodDispatch' resSub resLoc = do sub <- newName "sub" master <- newName "master" mkey <- newName "mkey" segments <- newName "segments"+ segments' <- newName "segmentsClean" toMasterRoute <- newName "toMasterRoute" nothing <- [|Nothing|]- body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res+ bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc+ cp <- [|cleanPath|]+ sr <- [|sendRedirect|]+ just <- [|Just|]+ let bodyLoc' =+ CaseE (cp `AppE` VarE master `AppE` VarE segments)+ [ Match (ConP (mkName "Left") [VarP segments'])+ (NormalB $ just `AppE`+ (sr `AppE` VarE master `AppE` VarE segments'))+ []+ , Match (ConP (mkName "Right") [VarP segments'])+ (NormalB bodyLoc)+ []+ ]+ body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub return $ Clause [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] (NormalB body)
runtests.hs view
@@ -1,12 +1,7 @@ import Test.Framework (defaultMain)--import Yesod.Content-import Yesod.Dispatch-import Yesod.Handler+import Test.CleanPath main :: IO () main = defaultMain- [ contentTestSuite- , dispatchTestSuite- , handlerTestSuite+ [ cleanPathTest ]
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.7.0+version: 0.7.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -33,7 +33,7 @@ , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.5 && < 0.12 , template-haskell- , web-routes-quasi >= 0.6.3 && < 0.7+ , web-routes-quasi >= 0.6.3.1 && < 0.7 , hamlet >= 0.7 && < 0.8 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3@@ -74,6 +74,7 @@ test-framework-quickcheck2, test-framework-hunit, HUnit,+ wai-test, QuickCheck >= 2 && < 3 else Buildable: False