yesod-core 0.9.2 → 0.9.3

raw patch · 16 files changed

+784/−53 lines, 16 filesdep +aeson-nativedep +data-objectdep +data-object-yamldep ~hspecdep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-native, data-object, data-object-yaml, vector

Dependency ranges changed: hspec, random

API changes (from Hackage documentation)

Files

• Yesod/Config.hs +112/−0
• Yesod/Core.hs +2/−0
• Yesod/Dispatch.hs +2/−2
• Yesod/Internal/Core.hs +69/−14
• Yesod/Internal/Request.hs +43/−35
• Yesod/Internal/TestApi.hs +11/−0
• test/Test/CleanPath.hs +139/−0
• test/Test/Exceptions.hs +37/−0
• test/Test/InternalRequest.hs +91/−0
• test/Test/Links.hs +35/−0
• test/Test/Media.hs +59/−0
• test/Test/NoOverloadedStrings.hs +52/−0
• test/Test/Widget.hs +92/−0
• test/en.msg +1/−0
• test/main.hs +20/−0
• yesod-core.cabal +19/−2

@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Config+    ( AppConfig(..)+    , loadConfig+    , withYamlEnvironment+    ) where++import Control.Monad (join)+import Data.Maybe (fromMaybe)+import Data.Object+import Data.Object.Yaml++import Data.Text (Text)+import qualified Data.Text as T++-- | Dynamic per-environment configuration which can be loaded at+--   run-time negating the need to recompile between environments.+data AppConfig e = AppConfig+    { appEnv  :: e+    , appPort :: Int+    , appRoot :: Text+    } deriving (Show)++-- | Load an @'AppConfig'@ from @config\/settings.yml@.+--+--   Some examples:+--+--   > -- typical local development+--   > Development:+--   >   host: localhost+--   >   port: 3000+--   >+--   >   -- ssl: will default false+--   >   -- approot: will default to "http://localhost:3000"+--+--   > -- typical outward-facing production box+--   > Production:+--   >   host: www.example.com+--   >+--   >   -- ssl: will default false+--   >   -- port: will default 80+--   >   -- approot: will default "http://www.example.com"+--+--   > -- maybe you're reverse proxying connections to the running app+--   > -- on some other port+--   > Production:+--   >   port: 8080+--   >   approot: "http://example.com"+--   >+--   > -- approot is specified so that the non-80 port is not appended+--   > -- automatically.+--+loadConfig :: Show e => e -> IO (AppConfig e)+loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e' -> do+    e <- maybe (fail "Expected map") return $ fromMapping e'+    let mssl     = lookupScalar "ssl"     e+    let mhost    = lookupScalar "host"    e+    let mport    = lookupScalar "port"    e+    let mapproot = lookupScalar "approot" e++    -- set some default arguments+    let ssl = maybe False toBool mssl+    port <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport++    approot <- case (mhost, mapproot) of+        (_        , Just ar) -> return ar+        (Just host, _      ) -> return $ T.concat+            [ if ssl then "https://" else "http://"+            , host+            , addPort ssl port+            ]+        _                    -> fail "You must supply either a host or approot"++    return $ AppConfig+        { appEnv  = env+        , appPort = port+        , appRoot = approot+        }++    where+        toBool :: Text -> Bool+        toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])++        addPort :: Bool -> Int -> Text+        addPort True  443 = ""+        addPort False 80  = ""+        addPort _     p   = T.pack $ ':' : show p++-- | Loads the configuration block in the passed file named by the+--   passed environment, yeilds to the passed function as a mapping.+--+--   Errors in the case of a bad load or if your function returns+--   @Nothing@.+withYamlEnvironment :: Show e+                    => FilePath -- ^ the yaml file+                    -> e        -- ^ the environment you want to load+                    -> (TextObject -> IO a) -- ^ what to do with the mapping+                    -> IO a+withYamlEnvironment fp env f = do+    obj <- join $ decodeFile fp+    envs <- fromMapping obj+    conf <- maybe (fail $ "Could not find environment: " ++ show env) return+          $ lookup (T.pack $ show env) envs+    f conf++-- | Returns 'fail' if read fails+safeRead :: Monad m => String -> Text -> m Int+safeRead name t = case reads s of+    (i, _):_ -> return i+    []       -> fail $ concat ["Invalid value for ", name, ": ", s]+  where+    s = T.unpack t

@@ -33,6 +33,7 @@     , module Yesod.Request     , module Yesod.Widget     , module Yesod.Message+    , module Yesod.Config     ) where  import Yesod.Internal.Core@@ -42,6 +43,7 @@ import Yesod.Request import Yesod.Widget import Yesod.Message+import Yesod.Config  import Language.Haskell.TH.Syntax import Data.Text (Text)

@@ -173,10 +173,10 @@  -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes three--- middlewares: GZIP compression, JSON-P and path cleaning. This is the+-- middlewares: GZIP compression, JSON-P and autohead. This is the -- recommended approach for most users. toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application-toWaiApp y = gzip False . jsonp . autohead <$> toWaiAppPlain y+toWaiApp y = gzip (gzipCompressFiles y) . jsonp . autohead <$> toWaiAppPlain y  -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares.

@@ -52,7 +52,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius-import Text.Blaze ((!), customAttribute, textTag, toValue)+import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString) import qualified Text.Blaze.Html5 as TBH import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8)@@ -75,6 +75,9 @@ import qualified Data.Text.Lazy.Builder as TB import Language.Haskell.TH.Syntax (Loc (..), Lift (..)) import Text.Blaze (preEscapedLazyText)+import Data.Aeson (Value (Array, String))+import Data.Aeson.Encode (encode)+import qualified Data.Vector as Vector  #if GHC7 #define HAMLET hamlet@@ -205,8 +208,9 @@       where         corrected = filter (not . TS.null) s -    -- | Join the pieces of a path together into an absolute URL. This should-    -- be the inverse of 'splitPath'.+    -- | Builds an absolute URL by concatenating the application root with the  +    -- pieces of a path and a query string, if any. +    -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.     joinPath :: a              -> TS.Text -- ^ application root              -> [TS.Text] -- ^ path pieces@@ -259,6 +263,15 @@         formatLogMessage loc level msg >>=         Data.Text.Lazy.IO.putStrLn +    -- | Apply gzip compression to files. Default is false.+    gzipCompressFiles :: a -> Bool+    gzipCompressFiles _ = False++    -- | Location of yepnope.js, if any. If one is provided, then all+    -- Javascript files will be loaded asynchronously.+    yepnopeJs :: a -> Maybe (Either Text (Route a))+    yepnopeJs _ = Nothing+ messageLoggerHandler :: (Yesod m, MonadIO mo)                      => Loc -> LogLevel -> Text -> GGHandler s m mo () messageLoggerHandler loc level msg = do@@ -467,18 +480,22 @@     x <- isAuthorized r isWrite     return $ if x == Authorized then Just r else Nothing +jsToHtml :: Javascript -> Html+jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b++jelper :: JavascriptUrl url -> HtmlUrl url+jelper = fmap jsToHtml+ -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route master), Yesod master)                     => GWidget sub master ()                     -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do+    master <- getYesod     ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0     let title = maybe mempty unTitle mTitle     let scripts = runUniqueList scripts'     let stylesheets = runUniqueList stylesheets'-    let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b-        jelper :: JavascriptUrl url -> HtmlUrl url-        jelper = fmap jsToHtml      render <- getUrlRenderParams     let renderLoc x =@@ -531,16 +548,54 @@             <style media=#{media}>#{content}         $nothing             <style>#{content}-$forall s <- scripts-    ^{mkScriptTag s}-$maybe j <- jscript-    $maybe s <- jsLoc-        <script src="#{s}">-    $nothing-        <script>^{jelper j}+$maybe _ <- yepnopeJs master+$nothing+    $forall s <- scripts+        ^{mkScriptTag s}+    $maybe j <- jscript+        $maybe s <- jsLoc+            <script src="#{s}">+        $nothing+            <script>^{jelper j} \^{head'} |]-    return $ PageContent title head'' body+    let (mcomplete, ynscripts) = ynHelper render scripts jscript jsLoc+    let bodyYN = [HAMLET|+^{body}+$maybe eyn <- yepnopeJs master+    $maybe yn <- left eyn+        <script src=#{yn}>+    $maybe yn <- right eyn+        <script src=@{yn}>+    $maybe complete <- mcomplete+        <script>yepnope({load:#{ynscripts},complete:function(){^{complete}}})+    $nothing+        <script>yepnope({load:#{ynscripts}})+|]+    return $ PageContent title head'' bodyYN++ynHelper :: (url -> [x] -> Text)+         -> [Script (url)]+         -> Maybe (JavascriptUrl (url))+         -> Maybe Text+         -> (Maybe (HtmlUrl (url)), Html)+ynHelper render scripts jscript jsLoc =+    (mcomplete, unsafeLazyByteString $ encode $ Array $ Vector.fromList $ map String scripts'')+  where+    scripts' = map goScript scripts+    scripts'' =+        case jsLoc of+            Just s -> scripts' ++ [s]+            Nothing -> scripts'+    goScript (Script (Local url) _) = render url []+    goScript (Script (Remote s) _) = s+    mcomplete =+        case jsLoc of+            Just{} -> Nothing+            Nothing ->+                case jscript of+                    Nothing -> Nothing+                    Just j -> Just $ jelper j  yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version

@@ -1,23 +1,27 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Yesod.Internal.Request     ( parseWaiRequest     , Request (..)     , RequestBodyContents     , FileInfo (..)+    -- The below are exported for testing.+    , randomString+    , parseWaiRequest'     ) where -import Control.Arrow (first, second)+import Control.Applicative ((<$>))+import Control.Arrow (second) import qualified Network.Wai.Parse as NWP import Yesod.Internal import qualified Network.Wai as W-import System.Random (randomR, newStdGen)+import System.Random (RandomGen, newStdGen, randomRs) import Web.Cookie (parseCookiesText)-import Data.Monoid (mempty) import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText) import Control.Monad (join)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L  -- | The parsed request information.@@ -35,38 +39,42 @@                 -> [(Text, Text)] -- ^ session                 -> Maybe a                 -> IO Request-parseWaiRequest env session' key' = do-    let gets' = queryToQueryText $ W.queryString env-    let reqCookie = fromMaybe mempty $ lookup "Cookie"-                  $ W.requestHeaders env-        cookies' = parseCookiesText reqCookie-        acceptLang = lookup "Accept-Language" $ W.requestHeaders env-        langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang-        langs' = case lookup langKey session' of-                    Nothing -> langs-                    Just x -> x : langs-        langs'' = case lookup langKey cookies' of-                    Nothing -> langs'-                    Just x -> x : langs'-        langs''' = case join $ lookup langKey gets' of-                     Nothing -> langs''-                     Just x -> x : langs''-    nonce <- case (key', lookup nonceKey session') of-                (Nothing, _) -> return Nothing-                (_, Just x) -> return $ Just x-                (_, Nothing) -> do-                    g <- newStdGen-                    return $ Just $ pack $ fst $ randomString 10 g-    let gets'' = map (second $ fromMaybe "") gets'-    return $ Request gets'' cookies' env langs''' nonce+parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen++parseWaiRequest' :: RandomGen g+                 => W.Request+                 -> [(Text, Text)] -- ^ session+                 -> Maybe a+                 -> g+                 -> Request+parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonce   where-    randomString len =-        first (map toChar) . sequence' (replicate len (randomR (0, 61)))-    sequence' [] g = ([], g)-    sequence' (f:fs) g =-        let (f', g') = f g-            (fs', g'') = sequence' fs g'-         in (f' : fs', g'')+    gets' = queryToQueryText $ W.queryString env+    gets'' = map (second $ fromMaybe "") gets'+    reqCookie = lookup "Cookie" $ W.requestHeaders env+    cookies' = maybe [] parseCookiesText reqCookie+    acceptLang = lookup "Accept-Language" $ W.requestHeaders env+    langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang+    -- The language preferences are prioritized as follows:+    langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG+                       , lookup langKey cookies'     -- Cookie _LANG+                       , lookup langKey session'     -- Session _LANG+                       ] ++ langs                    -- Accept-Language(s)+    -- If sessions are disabled nonces should not be used (any+    -- nonceKey present in the session is ignored). If sessions+    -- are enabled and a session has no nonceKey a new one is+    -- generated.+    nonce = case (key', lookup nonceKey session') of+                (Nothing, _) -> Nothing+                (_, Just x)  -> Just x+                _            -> Just $ pack $ randomString 10 gen++-- | Generate a random String of alphanumerical characters+-- (a-z, A-Z, and 0-9) of the given length using the given+-- random number generator.+randomString :: RandomGen g => Int -> g -> String+randomString len = take len . map toChar . randomRs (0, 61)+  where     toChar i         | i < 26 = toEnum $ i + fromEnum 'A'         | i < 52 = toEnum $ i + fromEnum 'a' - 26

@@ -0,0 +1,11 @@+--+-- | WARNING: This module exposes internal interfaces solely for the+-- purpose of facilitating cabal-driven testing of said interfaces.+-- This module is NOT part of the public Yesod API and should NOT be+-- imported by library users.+--+module Yesod.Internal.TestApi+  ( randomString, parseWaiRequest'+  ) where++import Yesod.Internal.Request (randomString, parseWaiRequest')

@@ -0,0 +1,139 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.CleanPath (cleanPathTest, Widget) where++import Test.Hspec+import Test.Hspec.HUnit()++import Yesod.Core hiding (Request)++import Network.Wai+import Network.Wai.Test+import Network.HTTP.Types (status200, decodePathSegments)++import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.Text as TS++data Subsite = Subsite++getSubsite :: a -> Subsite+getSubsite = const Subsite++data SubsiteRoute = SubsiteRoute [TS.Text]+    deriving (Eq, Show, Read)+type instance Route Subsite = SubsiteRoute+instance RenderRoute SubsiteRoute where+    renderRoute (SubsiteRoute x) = (x, [])++instance YesodDispatch Subsite master where+    yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS+        status200+        [ ("Content-Type", "SUBSITE")+        ] $ L8.pack $ show pieces++data Y = Y+mkYesod "Y" [parseRoutes|+/foo FooR GET+/foo/#String FooStringR GET+/bar BarR GET+/subsite SubsiteR Subsite getSubsite+/plain PlainR GET+|]++instance Yesod Y where+    approot _ = "http://test"+    cleanPath _ ["bar", ""] = Right ["bar"]+    cleanPath _ ["bar"] = Left ["bar", ""]+    cleanPath _ s =+        if corrected == s+            then Right s+            else Left corrected+      where+        corrected = filter (not . TS.null) s++getFooR :: Handler RepPlain+getFooR = return $ RepPlain "foo"++getFooStringR :: String -> Handler RepPlain+getFooStringR = return . RepPlain . toContent++getBarR, getPlainR :: Handler RepPlain+getBarR = return $ RepPlain "bar"+getPlainR = return $ RepPlain "plain"++cleanPathTest :: [Spec]+cleanPathTest =+  describe "Test.CleanPath"+    [ it "remove trailing slash" removeTrailingSlash+    , it "noTrailingSlash" noTrailingSlash+    , it "add trailing slash" addTrailingSlash+    , it "has trailing slash" hasTrailingSlash+    , it "/foo/something" fooSomething+    , it "subsite dispatch" subsiteDispatch+    , it "redirect with query string" redQueryString+    ]++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++removeTrailingSlash :: IO ()+removeTrailingSlash = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/foo/"+                }+    assertStatus 301 res+    assertHeader "Location" "http://test/foo" res++noTrailingSlash :: IO ()+noTrailingSlash = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/foo"+                }+    assertStatus 200 res+    assertContentType "text/plain; charset=utf-8" res+    assertBody "foo" res++addTrailingSlash :: IO ()+addTrailingSlash = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/bar"+                }+    assertStatus 301 res+    assertHeader "Location" "http://test/bar/" res++hasTrailingSlash :: IO ()+hasTrailingSlash = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/bar/"+                }+    assertStatus 200 res+    assertContentType "text/plain; charset=utf-8" res+    assertBody "bar" res++fooSomething :: IO ()+fooSomething = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/foo/something"+                }+    assertStatus 200 res+    assertContentType "text/plain; charset=utf-8" res+    assertBody "something" res++subsiteDispatch :: IO ()+subsiteDispatch = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/subsite/1/2/3/"+                }+    assertStatus 200 res+    assertContentType "SUBSITE" res+    assertBody "[\"1\",\"2\",\"3\",\"\"]" res++redQueryString :: IO ()+redQueryString = runner $ do+    res <- request defaultRequest+                { pathInfo = decodePathSegments "/plain/"+                , rawQueryString = "?foo=bar"+                }+    assertStatus 301 res+    assertHeader "Location" "http://test/plain?foo=bar" res

@@ -0,0 +1,37 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Exceptions (exceptionsTest, Widget) where++import Test.Hspec+import Test.Hspec.HUnit ()++import Yesod.Core hiding (Request)+import Network.Wai.Test++data Y = Y+mkYesod "Y" [parseRoutes|+/ RootR GET+|]++instance Yesod Y where+    approot _ = "http://test"+    errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e+    errorHandler x = defaultErrorHandler x++getRootR :: Handler ()+getRootR = error "FOOBAR" >> return ()++exceptionsTest :: [Spec]+exceptionsTest = describe "Test.Exceptions"+    [ it "500" case500+    ]++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++case500 :: IO ()+case500 = runner $ do+    res <- request defaultRequest+    assertStatus 500 res+    assertBody "FOOBAR" res

@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+module Test.InternalRequest (internalRequestTest) where++import Data.List (nub)+import System.Random (StdGen, mkStdGen)++import Network.Wai as W+import Network.Wai.Test+import Yesod.Internal.TestApi (randomString, parseWaiRequest')+import Yesod.Request (Request (..))+import Test.Hspec++randomStringSpecs :: [Spec]+randomStringSpecs = describe "Yesod.Internal.Request.randomString"+  [ it "looks reasonably random" looksRandom+  , it "does not repeat itself" $ noRepeat 10 100+  ]++-- NOTE: this testcase may break on other systems/architectures if+-- mkStdGen is not identical everywhere (is it?).+looksRandom = randomString 20 (mkStdGen 0) == "VH9SkhtptqPs6GqtofVg"++noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n+++-- For convenience instead of "(undefined :: StdGen)".+g :: StdGen+g = undefined+++nonceSpecs :: [Spec]+nonceSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqNonce)"+  [ it "is Nothing if sessions are disabled" noDisabledNonce+  , it "ignores pre-existing nonce if sessions are disabled" ignoreDisabledNonce+  , it "uses preexisting nonce in session" useOldNonce+  , it "generates a new nonce for sessions without nonce" generateNonce+  ]++noDisabledNonce = reqNonce r == Nothing where+  r = parseWaiRequest' defaultRequest [] Nothing g++ignoreDisabledNonce = reqNonce r == Nothing where+  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] Nothing g++useOldNonce = reqNonce r == Just "old" where+  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g++generateNonce = reqNonce r /= Nothing where+  r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g+++langSpecs :: [Spec]+langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)"+  [ it "respects Accept-Language" respectAcceptLangs+  , it "respects sessions" respectSessionLang+  , it "respects cookies" respectCookieLang+  , it "respects queries" respectQueryLang+  , it "prioritizes correctly" prioritizeLangs+  ]++respectAcceptLangs = reqLangs r == ["accept1", "accept2"] where+  r = parseWaiRequest' defaultRequest+        { requestHeaders = [("Accept-Language", "accept1, accept2")] } [] Nothing g++respectSessionLang = reqLangs r == ["session"] where+  r = parseWaiRequest' defaultRequest [("_LANG", "session")] Nothing g++respectCookieLang = reqLangs r == ["cookie"] where+  r = parseWaiRequest' defaultRequest+        { requestHeaders = [("Cookie", "_LANG=cookie")]+        } [] Nothing g++respectQueryLang = reqLangs r == ["query"] where+  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "query")] } [] Nothing g++prioritizeLangs = reqLangs r == ["query", "cookie", "session", "accept1", "accept2"] where+  r = parseWaiRequest' defaultRequest+        { requestHeaders = [ ("Accept-Language", "accept1, accept2")+                           , ("Cookie", "_LANG=cookie")+                           ]+        , queryString = [("_LANG", Just "query")]+        } [("_LANG", "session")] Nothing g+++internalRequestTest :: [Spec]+internalRequestTest = descriptions [ randomStringSpecs+                                   , nonceSpecs+                                   , langSpecs+                                   ]++main = hspec internalRequestTest

@@ -0,0 +1,35 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Links (linksTest, Widget) where++import Test.Hspec+import Test.Hspec.HUnit ()++import Yesod.Core hiding (Request)+import Text.Hamlet+import Network.Wai.Test++data Y = Y+mkYesod "Y" [parseRoutes|+/ RootR GET+|]++instance Yesod Y where+    approot _ = ""++getRootR :: Handler RepHtml+getRootR = defaultLayout $ addHamlet [hamlet|<a href=@{RootR}>|]++linksTest :: [Spec]+linksTest = describe "Test.Links"+    [ it "linkToHome" case_linkToHome+    ]++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++case_linkToHome :: IO ()+case_linkToHome = runner $ do+    res <- request defaultRequest+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a></body></html>" res

@@ -0,0 +1,59 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Media (mediaTest, Widget) where++import Test.Hspec+import Test.Hspec.HUnit ()+import Yesod.Core hiding (Request)+import Network.Wai+import Network.Wai.Test+import Text.Lucius++data Y = Y+mkYesod "Y" [parseRoutes|+/ RootR GET+/static StaticR GET+|]++instance Yesod Y where+    approot _ = ""+    addStaticContent _ _ content = do+        tm <- getRouteToMaster+        route <- getCurrentRoute+        case fmap tm route of+            Just StaticR -> return $ Just $ Left $+                        if content == "foo2{bar:baz}"+                            then "screen.css"+                            else "all.css"+            _ -> return Nothing++getRootR :: Handler RepHtml+getRootR = defaultLayout $ do+    addCassius [lucius|foo1{bar:baz}|]+    addCassiusMedia "screen" [lucius|foo2{bar:baz}|]+    addCassius [lucius|foo3{bar:baz}|]++getStaticR :: Handler RepHtml+getStaticR = getRootR++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++caseMedia :: IO ()+caseMedia = runner $ do+    res <- request defaultRequest+    assertStatus 200 res+    flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><style>foo1{bar:baz}foo3{bar:baz}</style><style media=\"screen\">foo2{bar:baz}</style></head><body></body></html>"++caseMediaLink :: IO ()+caseMediaLink = runner $ do+    res <- request defaultRequest { pathInfo = ["static"] }+    assertStatus 200 res+    flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"++mediaTest :: [Spec]+mediaTest = describe "Test.Media"+    [ it "media" caseMedia+    , it "media link" caseMediaLink+    ]

@@ -0,0 +1,52 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.NoOverloadedStrings (noOverloadedTest, Widget) where++import Test.Hspec+import Test.Hspec.HUnit ()++import Yesod.Core hiding (Request)+import Network.Wai.Test+import Data.Monoid (mempty)+import Data.String (fromString)++data Subsite = Subsite++getSubsite :: a -> Subsite+getSubsite = const Subsite++mkYesodSub "Subsite" [] [parseRoutes|+/bar BarR GET+|]++getBarR :: GHandler Subsite m ()+getBarR = return ()++data Y = Y+mkYesod "Y" [parseRoutes|+/ RootR GET+/foo FooR GET+/subsite SubsiteR Subsite getSubsite+|]++instance Yesod Y where+    approot _ = fromString ""++getRootR :: Handler ()+getRootR = return ()++getFooR :: Handler ()+getFooR = return ()++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++case_sanity :: IO ()+case_sanity = runner $ do+    res <- request defaultRequest+    assertBody mempty res++noOverloadedTest :: [Spec]+noOverloadedTest = describe "Test.NoOverloadedStrings"+    [ it "sanity" case_sanity+    ]

@@ -0,0 +1,92 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Widget (widgetTest) where++import Test.Hspec+import Test.Hspec.HUnit ()++import Yesod.Core hiding (Request)+import Text.Julius+import Text.Lucius+import Text.Hamlet++import Network.Wai+import Network.Wai.Test++data Y = Y++mkMessage "Y" "test" "en"++type Strings = [String]++mkYesod "Y" [parseRoutes|+/ RootR GET+/foo/*Strings MultiR GET+/whamlet WhamletR GET+/towidget TowidgetR GET+|]++instance Yesod Y where+    approot _ = "http://test"++getRootR :: Handler RepHtml+getRootR = defaultLayout $ toWidgetBody [julius|<not escaped>|]++getMultiR :: [String] -> Handler ()+getMultiR _ = return ()++data Msg = Hello | Goodbye+instance RenderMessage Y Msg where+    renderMessage _ ("en":_) Hello = "Hello"+    renderMessage _ ("es":_) Hello = "Hola"+    renderMessage _ ("en":_) Goodbye = "Goodbye"+    renderMessage _ ("es":_) Goodbye = "Adios"+    renderMessage a (_:xs) y = renderMessage a xs y+    renderMessage a [] y = renderMessage a ["en"] y++getTowidgetR :: Handler RepHtml+getTowidgetR = defaultLayout $ do+    toWidget [julius|foo|] :: Widget+    toWidgetHead [julius|foo|]+    toWidgetBody [julius|foo|]++    toWidget [lucius|foo{bar:baz}|]+    toWidgetHead [lucius|foo{bar:baz}|]++    toWidget [hamlet|<foo>|] :: Widget+    toWidgetHead [hamlet|<foo>|]+    toWidgetBody [hamlet|<foo>|]++getWhamletR :: Handler RepHtml+getWhamletR = defaultLayout [whamlet|+<h1>Test+<h2>@{WhamletR}+<h3>_{Goodbye}+<h3>_{MsgAnother}+^{embed}+|]+  where+    embed = [whamlet|<h4>Embed|]++widgetTest :: [Spec]+widgetTest = describe "Test.Widget"+    [ it "addJuliusBody" case_addJuliusBody+    , it "whamlet" case_whamlet+    ]++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++case_addJuliusBody :: IO ()+case_addJuliusBody = runner $ do+    res <- request defaultRequest+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script><not escaped></script></body></html>" res++case_whamlet :: IO ()+case_whamlet = runner $ do+    res <- request defaultRequest+        { pathInfo = ["whamlet"]+        , requestHeaders = [("Accept-Language", "es")]+        }+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res

@@ -0,0 +1,1 @@+Another: String

@@ -0,0 +1,20 @@+import Test.Hspec++import Test.CleanPath+import Test.Exceptions+import Test.Widget+import Test.Media+import Test.Links+import Test.NoOverloadedStrings+import Test.InternalRequest++main :: IO ()+main = hspecX $ descriptions $+    [ cleanPathTest+    , exceptionsTest+    , widgetTest+    , mediaTest+    , linksTest+    , noOverloadedTest+    , internalRequestTest+    ]

@@ -1,5 +1,5 @@ name:            yesod-core-version:         0.9.2+version:         0.9.3 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -14,6 +14,16 @@ cabal-version:   >= 1.8 build-type:      Simple homepage:        http://www.yesodweb.com/+extra-source-files:+  test/en.msg+  test/Test/NoOverloadedStrings.hs+  test/Test/Media.hs+  test/Test/Exceptions.hs+  test/Test/Widget.hs+  test/Test/CleanPath.hs+  test/Test/Links.hs+  test/Test/InternalRequest.hs+  test/main.hs  flag test   description: Build the executable to run unit tests@@ -54,8 +64,12 @@                    , case-insensitive          >= 0.2      && < 0.4                    , parsec                    >= 2        && < 3.2                    , directory                 >= 1        && < 1.2+                   , data-object               >= 0.3      && < 0.4+                   , data-object-yaml          >= 0.3      && < 0.4                    -- for logger. Probably logger should be a separate package                    , strict-concurrency        >= 0.2.4    && < 0.2.5+                   , vector                    >= 0.9      && < 0.10+                   , aeson-native              >= 0.3.3.1  && < 0.4      exposed-modules: Yesod.Content                      Yesod.Core@@ -65,6 +79,8 @@                      Yesod.Request                      Yesod.Widget                      Yesod.Message+                     Yesod.Config+                     Yesod.Internal.TestApi     other-modules:   Yesod.Internal                      Yesod.Internal.Core                      Yesod.Internal.Session@@ -91,7 +107,7 @@         build-depends:   base                      >= 4        && < 4.3         main-is:         main.hs     cpp-options:   -DTEST-    build-depends: hspec >= 0.6.1 && < 0.7+    build-depends: hspec >= 0.8 && < 0.9                   ,wai-test                   ,wai                   ,yesod-core@@ -101,6 +117,7 @@                   ,shakespeare-js                   ,text                   ,http-types+                  , random                   ,HUnit                   ,QuickCheck >= 2 && < 3     ghc-options:     -Wall