yesod-core 1.0.1.3 → 1.1.0
raw patch · 26 files changed
+400/−453 lines, 26 filesdep +monad-loggerdep −wai-loggerdep ~blaze-htmldep ~clientsessiondep ~conduit
Dependencies added: monad-logger
Dependencies removed: wai-logger
Dependency ranges changed: blaze-html, clientsession, conduit, fast-logger, hamlet, hspec, http-types, wai, wai-extra, yesod-routes
Files
- Yesod/Content.hs +18/−7
- Yesod/Core.hs +2/−34
- Yesod/Dispatch.hs +26/−18
- Yesod/Handler.hs +69/−27
- Yesod/Internal.hs +15/−15
- Yesod/Internal/Core.hs +81/−71
- Yesod/Internal/Request.hs +36/−7
- Yesod/Logger.hs +0/−138
- Yesod/Request.hs +5/−1
- Yesod/Widget.hs +10/−6
- test.hs +1/−1
- test/YesodCoreTest.hs +14/−15
- test/YesodCoreTest/Cache.hs +2/−3
- test/YesodCoreTest/CleanPath.hs +9/−10
- test/YesodCoreTest/ErrorHandling.hs +37/−7
- test/YesodCoreTest/Exceptions.hs +3/−4
- test/YesodCoreTest/InternalRequest.hs +27/−31
- test/YesodCoreTest/JsLoader.hs +3/−4
- test/YesodCoreTest/Links.hs +3/−4
- test/YesodCoreTest/Media.hs +3/−4
- test/YesodCoreTest/NoOverloadedStrings.hs +2/−3
- test/YesodCoreTest/Redirect.hs +5/−6
- test/YesodCoreTest/WaiSubsite.hs +2/−3
- test/YesodCoreTest/Widget.hs +13/−9
- test/test.hs +1/−1
- yesod-core.cabal +13/−24
Yesod/Content.hs view
@@ -28,6 +28,8 @@ , typeOctet -- * Utilities , simpleContentType+ -- * Evaluation strategy+ , DontFullyEvaluate (..) -- * Representations , ChooseRep , HasReps (..)@@ -60,18 +62,15 @@ import Data.Monoid (mempty) import Text.Hamlet (Html)-#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)-#else-import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)-#endif import Data.String (IsString (fromString)) import Network.Wai (FilePart) import Data.Conduit (Source, ResourceT, Flush) -data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.- | ContentSource (Source (ResourceT IO) (Flush Builder))- | ContentFile FilePath (Maybe FilePart)+data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.+ | ContentSource !(Source (ResourceT IO) (Flush Builder))+ | ContentFile !FilePath !(Maybe FilePart)+ | ContentDontEvaluate !Content -- | Zero-length enumerator. emptyContent :: Content@@ -239,3 +238,15 @@ -- | Format as per RFC 822. formatRFC822 :: UTCTime -> T.Text formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"++-- | Prevents a response body from being fully evaluated before sending the+-- request.+--+-- Since 1.1.0+newtype DontFullyEvaluate a = DontFullyEvaluate a++instance HasReps a => HasReps (DontFullyEvaluate a) where+ chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a++instance ToContent a => ToContent (DontFullyEvaluate a) where+ toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
Yesod/Core.hs view
@@ -10,6 +10,7 @@ , breadcrumbs -- * Types , Approot (..)+ , FileUpload (..) -- * Utitlities , maybeAuthorized , widgetToPageContent@@ -20,8 +21,6 @@ , unauthorizedI -- * Logging , LogLevel (..)- , formatLogMessage- , fileLocationToString , logDebug , logInfo , logWarn@@ -59,38 +58,7 @@ import Yesod.Widget import Yesod.Message -import Language.Haskell.TH.Syntax-import qualified Language.Haskell.TH.Syntax as TH-import Data.Text (Text)--logTH :: LogLevel -> Q Exp-logTH level =- [|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|]- where- liftLoc :: Loc -> Q Exp- liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|]---- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:------ > $(logDebug) "This is a debug log message"-logDebug :: Q Exp-logDebug = logTH LevelDebug---- | See 'logDebug'-logInfo :: Q Exp-logInfo = logTH LevelInfo--- | See 'logDebug'-logWarn :: Q Exp-logWarn = logTH LevelWarn--- | See 'logDebug'-logError :: Q Exp-logError = logTH LevelError---- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:------ > $(logOther "My new level") "This is a log message"-logOther :: Text -> Q Exp-logOther = logTH . LevelOther+import Control.Monad.Logger -- | Return an 'Unauthorized' value, with the given i18n message. unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
Yesod/Dispatch.hs view
@@ -28,7 +28,7 @@ , WaiSubsite (..) ) where -import Data.Functor ((<$>))+import Control.Applicative ((<$>), (<*>)) import Prelude hiding (exp) import Yesod.Internal.Core import Yesod.Handler hiding (lift)@@ -53,6 +53,7 @@ import Yesod.Routes.TH import Yesod.Content (chooseRep) import Yesod.Routes.Parse+import System.Log.FastLogger (Logger) type Texts = [Text] @@ -60,7 +61,7 @@ -- 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 +72,7 @@ -- 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 +83,28 @@ -- 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 +112,7 @@ -> [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@@ -119,7 +120,13 @@ let res = map (fmap parseType) resS renderRouteDec <- mkRenderRouteInstance arg res - disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res+ let logger = mkName "logger"+ Clause pat body decs <- mkDispatchClause+ [|yesodRunner $(return $ VarE logger)|]+ [|yesodDispatch $(return $ VarE logger)|]+ [|fmap chooseRep|]+ res+ let disp = Clause (VarP logger : pat) body decs let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes@@ -130,7 +137,7 @@ let yesodDispatch' = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]] - return (renderRouteDec : masterTypSyns, [yesodDispatch'])+ return (renderRouteDec ++ masterTypSyns, [yesodDispatch']) where name' = mkName name masterTypSyns@@ -160,23 +167,24 @@ toWaiAppPlain :: ( Yesod master , YesodDispatch master master ) => master -> IO W.Application-toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a+toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a toWaiApp' :: ( Yesod master , YesodDispatch master master ) => master+ -> Logger -> Maybe (SessionBackend master) -> W.Application-toWaiApp' y sb env =+toWaiApp' y logger sb env = case cleanPath y $ W.pathInfo env of Left pieces -> sendRedirect y pieces env Right pieces ->- yesodDispatch y y id app404 handler405 method pieces sb env+ yesodDispatch logger y y id app404 handler405 method pieces sb env where- app404 = yesodRunner notFound y y Nothing id- handler405 route = yesodRunner badMethod y y (Just route) id+ app404 = yesodRunner logger notFound y y Nothing id+ handler405 route = yesodRunner logger badMethod y y (Just route) id method = decodeUtf8With lenientDecode $ W.requestMethod env sendRedirect :: Yesod master => master -> [Text] -> W.Application@@ -202,4 +210,4 @@ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance YesodDispatch WaiSubsite master where- yesodDispatch _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app+ yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
Yesod/Handler.hs view
@@ -138,11 +138,7 @@ import qualified Network.HTTP.Types as H import Text.Hamlet-#if MIN_VERSION_blaze_html(0, 5, 0) import qualified Text.Blaze.Html.Renderer.Text as RenderText-#else-import qualified Text.Blaze.Renderer.Text as RenderText-#endif import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)@@ -150,6 +146,7 @@ import qualified Data.Map as Map import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L import Network.Wai.Parse (parseHttpAccept) import Yesod.Content@@ -159,19 +156,19 @@ import qualified Network.Wai.Parse as NWP import Data.Monoid (mappend, mempty, Endo (..)) import qualified Data.ByteString.Char8 as S8+import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI-import Blaze.ByteString.Builder (toByteString)+import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString) import Data.Text (Text) import Yesod.Message (RenderMessage (..)) -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup-#else-import Text.Blaze (toHtml, preEscapedText)-#endif +import System.Log.FastLogger+import Control.Monad.Logger+ import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey, CacheKey) import Data.Typeable (Typeable)@@ -181,6 +178,8 @@ import Control.Monad.Trans.Resource import Control.Monad.Base import Yesod.Routes.Class+import Data.Word (Word64)+import Language.Haskell.TH.Syntax (Loc) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y@@ -193,6 +192,8 @@ , handlerRender :: Route master -> [(Text, Text)] -> Text , handlerToMaster :: Route sub -> Route master , handlerState :: I.IORef GHState+ , handlerUpload :: Word64 -> FileUpload+ , handlerLog :: Loc -> LogLevel -> LogStr -> IO () } handlerSubData :: (Route sub -> Route master)@@ -322,22 +323,36 @@ runRequestBody :: GHandler s m RequestBodyContents runRequestBody = do+ hd <- ask+ let getUpload = handlerUpload hd+ len = reqBodySize $ handlerRequest hd+ upload = getUpload len x <- get case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest- rbc <- lift $ rbHelper rr+ rbc <- lift $ rbHelper upload rr put x { ghsRBC = Just rbc } return rbc -rbHelper :: W.Request -> ResourceT IO RequestBodyContents-rbHelper req =- (map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req)+rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents+rbHelper upload =+ case upload of+ FileUploadMemory s -> rbHelper' s mkFileInfoLBS+ FileUploadDisk s -> rbHelper' s mkFileInfoFile+ FileUploadSource s -> rbHelper' s mkFileInfoSource++rbHelper' :: NWP.BackEnd x+ -> (Text -> Text -> x -> FileInfo)+ -> W.Request+ -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])+rbHelper' backend mkFI req =+ (map fix1 *** map fix2) <$> (NWP.parseRequestBody backend req) where fix1 = go *** go fix2 (x, NWP.FileInfo a b c) =- (go x, FileInfo (go a) (go b) c)+ (go x, mkFI (go a) (go b) c) go = decodeUtf8With lenientDecode -- | Get the sub application argument.@@ -378,8 +393,10 @@ -> (Route sub -> Route master) -> master -> sub+ -> (Word64 -> FileUpload)+ -> (Loc -> LogLevel -> LogStr -> IO ()) -> YesodApp-runHandler handler mrender sroute tomr master sub =+runHandler handler mrender sroute tomr master sub upload log' = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of@@ -400,6 +417,8 @@ , handlerRender = mrender , handlerToMaster = tomr , handlerState = istate+ , handlerUpload = upload+ , handlerLog = log' } contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id@@ -420,7 +439,10 @@ case contents of HCContent status a -> do (ct, c) <- liftIO $ a cts- return $ YARPlain status (appEndo headers []) ct c finalSession+ ec' <- liftIO $ evaluateContent c+ case ec' of+ Left e -> handleError e+ Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession HCError e -> handleError e HCRedirect status loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []@@ -440,6 +462,15 @@ finalSession HCWai r -> return $ YARWai r +evaluateContent :: Content -> IO (Either ErrorResponse Content)+evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do+ let lbs = toLazyByteString b+ L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)+ where+ f :: SomeException -> IO (Either ErrorResponse Content)+ f = return . Left . InternalError . T.pack . show+evaluateContent c = return (Right c)+ safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er@@ -772,6 +803,8 @@ handlerToYAR :: (HasReps a, HasReps b) => master -- ^ master site foundation -> sub -- ^ sub site foundation+ -> (Word64 -> FileUpload)+ -> (Loc -> LogLevel -> LogStr -> IO ()) -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a)@@ -780,28 +813,31 @@ -> SessionMap -> GHandler sub master b -> ResourceT IO YesodAppResult-handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =+handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where- ya = runHandler h render murl toMasterRoute y s- eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s+ ya = runHandler h render murl toMasterRoute y s upload log'+ eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler -yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response+yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response yarToResponse (YARWai a) _ = a yarToResponse (YARPlain s hs _ c _) extraHeaders =- case c of- ContentBuilder b mlen ->- let hs' = maybe finalHeaders finalHeaders' mlen- in W.ResponseBuilder s hs' b- ContentFile fp p -> W.ResponseFile s finalHeaders fp p- ContentSource body -> W.ResponseSource s finalHeaders body+ go c where finalHeaders = extraHeaders ++ map headerToPair hs finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders + go (ContentBuilder b mlen) =+ W.ResponseBuilder s hs' b+ where+ hs' = maybe finalHeaders finalHeaders' mlen+ go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p+ go (ContentSource body) = W.ResponseSource s finalHeaders body+ go (ContentDontEvaluate c') = go c'+ httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept . fromMaybe mempty@@ -810,7 +846,7 @@ -- | Convert Header to a key/value pair. headerToPair :: Header- -> (CI H.Ascii, H.Ascii)+ -> (CI ByteString, ByteString) headerToPair (AddCookie sc) = ("Set-Cookie", toByteString $ renderSetCookie $ sc) headerToPair (DeleteCookie key path) =@@ -842,6 +878,7 @@ redirectToPost url = do urlText <- toTextUrl url hamletToRepHtml [hamlet|+$newline never $doctype 5 <html>@@ -936,3 +973,8 @@ register = lift . register release = lift . release resourceMask = lift . resourceMask++instance MonadLogger (GHandler sub master) where+ monadLoggerLog a b c = do+ hd <- ask+ liftIO $ handlerLog hd a b (toLogStr c)
Yesod/Internal.hs view
@@ -27,7 +27,8 @@ , tokenKey ) where -import Text.Hamlet (HtmlUrl, hamlet, Html)+import Text.Hamlet (HtmlUrl, Html)+import Text.Blaze.Html (toHtml) import Text.Julius (JavascriptUrl) import Data.Monoid (Monoid (..), Last) import Data.List (nub)@@ -41,8 +42,8 @@ import Data.String (IsString) import qualified Data.Map as Map import Data.Text.Lazy.Builder (Builder)-import Network.HTTP.Types (Ascii) import Web.Cookie (SetCookie (..))+import Data.ByteString (ByteString) -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages.@@ -59,8 +60,8 @@ -- | Headers to be added to a 'Result'. data Header = AddCookie SetCookie- | DeleteCookie Ascii Ascii- | Header Ascii Ascii+ | DeleteCookie ByteString ByteString+ | Header ByteString ByteString deriving (Eq, Show) langKey :: IsString a => a@@ -69,10 +70,8 @@ data Location url = Local url | Remote Text deriving (Show, Eq) locationToHtmlUrl :: Location url -> HtmlUrl url-locationToHtmlUrl (Local url) = [hamlet|\@{url}-|]-locationToHtmlUrl (Remote s) = [hamlet|\#{s}-|]+locationToHtmlUrl (Local url) render = toHtml $ render url []+locationToHtmlUrl (Remote s) _ = toHtml s newtype UniqueList x = UniqueList ([x] -> [x]) instance Monoid (UniqueList x) where@@ -100,13 +99,14 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder data GWData a = GWData- !(Body a)- !(Last Title)- !(UniqueList (Script a))- !(UniqueList (Stylesheet a))- !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type- !(Maybe (JavascriptUrl a))- !(Head a)+ { gwdBody :: !(Body a)+ , gwdTitle :: !(Last Title)+ , gwdScripts :: !(UniqueList (Script a))+ , gwdStylesheets :: !(UniqueList (Stylesheet a))+ , gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type+ , gwdJavascript :: !(Maybe (JavascriptUrl a))+ , gwdHead :: !(Head a)+ } instance Monoid (GWData a) where mempty = GWData mempty mempty mempty mempty mempty mempty mempty mappend (GWData a1 a2 a3 a4 a5 a6 a7)
Yesod/Internal/Core.hs view
@@ -20,11 +20,6 @@ , defaultErrorHandler -- * Data types , AuthResult (..)- -- * Logging- , LogLevel (..)- , formatLogMessage- , fileLocationToString- , messageLoggerHandler -- * Sessions , SessionBackend (..) , defaultClientSessionBackend@@ -40,6 +35,7 @@ , yesodRender , resolveApproot , Approot (..)+ , FileUpload (..) ) where import Yesod.Content@@ -47,6 +43,7 @@ import Yesod.Routes.Class +import Data.Word (Word64) import Control.Arrow ((***)) import Control.Monad (forM) import Yesod.Widget@@ -80,26 +77,19 @@ import Data.List (foldl') import qualified Network.HTTP.Types as H import Web.Cookie (SetCookie (..))-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 Language.Haskell.TH.Syntax (Loc (..)) 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 import Network.Wai.Middleware.Gzip (GzipSettings, def)+import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd) import qualified Paths_yesod_core import Data.Version (showVersion)--#if MIN_VERSION_blaze_html(0, 5, 0)-preEscapedLazyText :: TL.Text -> Html-preEscapedLazyText = preEscapedToMarkup-#endif+import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)+import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther))+import System.Log.FastLogger.Date (ZonedDate)+import System.IO (stdout) yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version@@ -109,7 +99,8 @@ class YesodDispatch sub master where yesodDispatch :: Yesod master- => master+ => Logger+ -> master -> sub -> (Route sub -> Route master) -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler@@ -120,7 +111,8 @@ -> W.Application yesodRunner :: Yesod master- => GHandler sub master ChooseRep+ => Logger+ -> GHandler sub master ChooseRep -> master -> sub -> Maybe (Route sub)@@ -170,6 +162,7 @@ p <- widgetToPageContent w mmsg <- getMessage hamletToRepHtml [hamlet|+$newline never $doctype 5 <html>@@ -290,21 +283,28 @@ cookieDomain _ = Nothing -- | Maximum allowed length of the request body, in bytes.- maximumContentLength :: a -> Maybe (Route a) -> Int+ --+ -- Default: 2 megabytes.+ maximumContentLength :: a -> Maybe (Route a) -> Word64 maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes - -- | Send a message to the log. By default, prints to stdout.+ -- | Returns a @Logger@ to use for log messages.+ --+ -- Default: Sends to stdout and automatically flushes on each write.+ getLogger :: a -> IO Logger+ getLogger _ = mkLogger True stdout++ -- | Send a message to the @Logger@ provided by @getLogger@. messageLogger :: a+ -> Logger -> Loc -- ^ position in source code -> LogLevel- -> Text -- ^ message+ -> LogStr -- ^ message -> IO ()- messageLogger a loc level msg =+ messageLogger a logger loc level msg = if level < logLevel a then return ()- else- formatLogMessage loc level msg >>=- Data.Text.Lazy.IO.putStrLn+ else formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger -- | The logging level in place for this application. Any messages below -- this level will simply be ignored.@@ -332,38 +332,37 @@ key <- CS.getKey CS.defaultKeyFile return $ Just $ clientSessionBackend key 120 --messageLoggerHandler :: Yesod m- => Loc -> LogLevel -> Text -> GHandler s m ()-messageLoggerHandler loc level msg = do- y <- getYesod- liftIO $ messageLogger y loc level msg--data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text- deriving (Eq, Show, Read, Ord)--instance Lift LogLevel where- lift LevelDebug = [|LevelDebug|]- lift LevelInfo = [|LevelInfo|]- lift LevelWarn = [|LevelWarn|]- lift LevelError = [|LevelError|]- lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]+ -- | How to store uploaded files.+ --+ -- Default: Whe nthe request body is greater than 50kb, store in a temp+ -- file. Otherwise, store in memory.+ fileUpload :: a+ -> Word64 -- ^ request body size+ -> FileUpload+ fileUpload _ size+ | size > 50000 = FileUploadDisk tempFileBackEnd+ | otherwise = FileUploadMemory lbsBackEnd -formatLogMessage :: Loc+formatLogMessage :: IO ZonedDate+ -> Loc -> LogLevel- -> Text -- ^ message- -> IO TL.Text-formatLogMessage loc level msg = do- now <- getCurrentTime- return $ TB.toLazyText $- TB.fromText (T.pack $ show now)- `mappend` TB.fromText " ["- `mappend` TB.fromText (T.pack $ drop 5 $ show level)- `mappend` TB.fromText "] "- `mappend` TB.fromText msg- `mappend` TB.fromText " @("- `mappend` TB.fromText (T.pack $ fileLocationToString loc)- `mappend` TB.fromText ") "+ -> LogStr -- ^ message+ -> IO [LogStr]+formatLogMessage getdate loc level msg = do+ now <- getdate+ return+ [ LB now+ , LB " ["+ , LS $+ case level of+ LevelOther t -> T.unpack t+ _ -> drop 5 $ show level+ , LB "] "+ , msg+ , LB " @("+ , LS $ fileLocationToString loc+ , LB ")\n"+ ] -- taken from file-location package -- turn the TH Loc loaction information into a human readable string@@ -376,31 +375,26 @@ char = show . snd . loc_start defaultYesodRunner :: Yesod master- => GHandler sub master ChooseRep+ => Logger+ -> GHandler sub master ChooseRep -> master -> sub -> Maybe (Route sub) -> (Route sub -> Route master) -> Maybe (SessionBackend master) -> W.Application-defaultYesodRunner _ master _ murl toMaster _ req- | maximumContentLength master (fmap toMaster murl) < len =+defaultYesodRunner logger handler master sub murl toMasterRoute msb req+ | maximumContentLength master (fmap toMasterRoute murl) < len = return $ W.responseLBS (H.Status 413 "Too Large") [("Content-Type", "text/plain")] "Request body too large to be processed."- where- len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay- readMay s =- case reads $ S8.unpack s of- [] -> Nothing- (x, _):_ -> Just x-defaultYesodRunner handler master sub murl toMasterRoute msb req = do+ | otherwise = do now <- liftIO getCurrentTime let dontSaveSession _ _ = return [] (session, saveSession) <- liftIO $ maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb- rr <- liftIO $ parseWaiRequest req session (isJust msb)+ rr <- liftIO $ parseWaiRequest req session (isJust msb) len let h = {-# SCC "h" #-} do case murl of Nothing -> handler@@ -420,7 +414,8 @@ handler let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session let ra = resolveApproot master req- yar <- handlerToYAR master sub toMasterRoute+ let log' = messageLogger master logger+ yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of (YARPlain _ _ ct _ newSess) -> do@@ -432,6 +427,12 @@ return $ ("Content-Type", ct) : map headerToPair sessionHeaders _ -> return [] return $ yarToResponse yar extraHeaders+ where+ len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay+ readMay s =+ case reads $ S8.unpack s of+ [] -> Nothing+ (x, _):_ -> Just x data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text deriving (Eq, Show, Read)@@ -478,18 +479,21 @@ let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r applyLayout' "Not Found" [hamlet|+$newline never <h1>Not Found <p>#{path'} |] defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" [hamlet|+$newline never <h1>Permission denied <p>#{msg} |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" [hamlet|+$newline never <h1>Invalid Arguments <ul> $forall msg <- ia@@ -498,12 +502,14 @@ defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" [hamlet|+$newline never <h1>Internal Server Error <p>#{e} |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" [hamlet|+$newline never <h1>Method Not Supported <p>Method "#{S8.unpack m}" not supported |]@@ -521,7 +527,7 @@ 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@@ -549,7 +555,7 @@ $ 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@@ -563,6 +569,7 @@ -- the asynchronous loader means your page doesn't have to wait for all the js to load let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc regularScriptLoad = [hamlet|+$newline never $forall s <- scripts ^{mkScriptTag s} $maybe j <- jscript@@ -573,6 +580,7 @@ |] headAll = [hamlet|+$newline never \^{head'} $forall s <- stylesheets ^{mkLinkTag s}@@ -595,6 +603,7 @@ ^{regularScriptLoad} |] let bodyScript = [hamlet|+$newline never ^{body} ^{regularScriptLoad} |]@@ -641,6 +650,7 @@ loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master)) loadJsYepnope eyn scripts mcomplete = [hamlet|+$newline never $maybe yn <- left eyn <script src=#{yn}> $maybe yn <- right eyn
Yesod/Internal/Request.hs view
@@ -4,7 +4,15 @@ ( parseWaiRequest , Request (..) , RequestBodyContents- , FileInfo (..)+ , FileInfo+ , fileName+ , fileContentType+ , fileSource+ , fileMove+ , mkFileInfoLBS+ , mkFileInfoFile+ , mkFileInfoSource+ , FileUpload (..) -- The below are exported for testing. , randomString , parseWaiRequest'@@ -28,6 +36,10 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)+import Data.Conduit+import Data.Conduit.List (sourceList)+import Data.Conduit.Binary (sourceFile, sinkFile)+import Data.Word (Word64) -- | The parsed request information. data Request = Request@@ -38,23 +50,27 @@ , reqLangs :: [Text] -- | A random, session-specific token used to prevent CSRF attacks. , reqToken :: Maybe Text+ -- | Size of the request body.+ , reqBodySize :: Word64 } parseWaiRequest :: W.Request -> [(Text, ByteString)] -- ^ session -> Bool+ -> Word64 -> IO Request-parseWaiRequest env session' useToken =- parseWaiRequest' env session' useToken <$> newStdGen+parseWaiRequest env session' useToken bodySize =+ parseWaiRequest' env session' useToken bodySize <$> newStdGen parseWaiRequest' :: RandomGen g => W.Request -> [(Text, ByteString)] -- ^ session -> Bool+ -> Word64 -> g -> Request-parseWaiRequest' env session' useToken gen = - Request gets'' cookies' env langs'' token+parseWaiRequest' env session' useToken bodySize gen =+ Request gets'' cookies' env langs'' token bodySize where gets' = queryToQueryText $ W.queryString env gets'' = map (second $ fromMaybe "") gets'@@ -116,6 +132,19 @@ data FileInfo = FileInfo { fileName :: Text , fileContentType :: Text- , fileContent :: L.ByteString+ , fileSource :: Source (ResourceT IO) ByteString+ , fileMove :: FilePath -> IO () }- deriving (Eq, Show)++mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo+mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)++mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)++mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)++data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)+ | FileUploadDisk (NWP.BackEnd FilePath)+ | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
− Yesod/Logger.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Yesod.Logger- ( Logger- , handle- , developmentLogger, productionLogger- , defaultDevelopmentLogger, defaultProductionLogger- , toProduction- , flushLogger- , logText- , logLazyText- , logString- , logBS- , logMsg- , formatLogText- , timed- -- * Deprecated- , makeLoggerWithHandle- , makeDefaultLogger- ) where--import System.IO (Handle, stdout, hFlush)-import Data.ByteString (ByteString)-import Data.ByteString.Char8 (pack)-import Data.ByteString.Lazy (toChunks)-import qualified Data.Text.Lazy as TL-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)-import qualified Data.Text.Lazy.Encoding as TLE-import System.Log.FastLogger-import Network.Wai.Logger.Date (DateRef, dateInit, getDate)---- for timed logging-import Data.Time (getCurrentTime, diffUTCTime)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Text.Printf (printf)-import Data.Text (unpack)---- for formatter-import Language.Haskell.TH.Syntax (Loc)-import Yesod.Core (LogLevel, fileLocationToString)--data Logger = Logger {- loggerLogFun :: [LogStr] -> IO ()- , loggerHandle :: Handle- , loggerDateRef :: DateRef- }--handle :: Logger -> Handle-handle = loggerHandle--flushLogger :: Logger -> IO ()-flushLogger = hFlush . loggerHandle--makeDefaultLogger :: IO Logger-makeDefaultLogger = defaultDevelopmentLogger-{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-}--makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger-makeLoggerWithHandle = productionLogger-{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-}---- | uses stdout handle-defaultProductionLogger, defaultDevelopmentLogger :: IO Logger-defaultProductionLogger = productionLogger stdout-defaultDevelopmentLogger = developmentLogger stdout---productionLogger h = mkLogger h (handleToLogFun h)--- | a development logger gets automatically flushed-developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)--mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger-mkLogger h logFun = do- initHandle h- dateInit >>= return . Logger logFun h---- convert (a development) logger to production settings-toProduction :: Logger -> Logger-toProduction (Logger _ h d) = Logger (handleToLogFun h) h d--handleToLogFun :: Handle -> ([LogStr] -> IO ())-handleToLogFun = hPutLogStr--logMsg :: Logger -> [LogStr] -> IO ()-logMsg = hPutLogStr . handle--logLazyText :: Logger -> TL.Text -> IO ()-logLazyText logger msg = loggerLogFun logger $- map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]--logText :: Logger -> Text -> IO ()-logText logger = logBS logger . encodeUtf8--logBS :: Logger -> ByteString -> IO ()-logBS logger msg = loggerLogFun logger $ [LB msg, newLine]--logString :: Logger -> String -> IO ()-logString logger msg = loggerLogFun logger $ [LS msg, newLine]--formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr]-formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)--toLB :: Text -> LogStr-toLB = LB . encodeUtf8--formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr]-formatLogMsg logger loc level msg = do- date <- liftIO $ getDate $ loggerDateRef logger- return- [ LB date- , LB $ pack" ["- , LS (drop 5 $ show level)- , LB $ pack "] "- , msg- , LB $ pack " @("- , LS (fileLocationToString loc)- , LB $ pack ") "- ]--newLine :: LogStr-newLine = LB $ pack "\n"---- | Execute a monadic action and log the duration----timed :: MonadIO m- => Logger -- ^ Logger- -> Text -- ^ Message- -> m a -- ^ Action- -> m a -- ^ Timed and logged action-timed logger msg action = do- start <- liftIO getCurrentTime- !result <- action- stop <- liftIO getCurrentTime- let diff = fromEnum $ diffUTCTime stop start- ms = diff `div` 10 ^ (9 :: Int)- formatted = printf " [%4dms] %s" ms (unpack msg)- liftIO $ logString logger formatted- return result
Yesod/Request.hs view
@@ -16,7 +16,11 @@ -- * Request datatype RequestBodyContents , Request (..)- , FileInfo (..)+ , FileInfo+ , fileName+ , fileContentType+ , fileSource+ , fileMove -- * Convenience functions , languages -- * Lookup parameters
Yesod/Widget.hs view
@@ -53,6 +53,7 @@ , addScriptEither -- * Internal , unGWidget+ , whamletFileWithSettings ) where import Data.Monoid@@ -80,20 +81,16 @@ import Control.Exception (throwIO) import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText)-#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL-#else-import Text.Blaze (toHtml, preEscapedLazyText)-#endif import Control.Monad.Base (MonadBase (liftBase)) import Control.Arrow (first) import Control.Monad.Trans.Resource -#if MIN_VERSION_blaze_html(0, 5, 0)+import Control.Monad.Logger+ preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup-#endif -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for@@ -171,6 +168,7 @@ {-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-} {-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-} {-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}+{-# DEPRECATED addWidget "addWidget can be omitted" #-} -- | Add a 'Hamlet' to the head tag. addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()@@ -272,6 +270,9 @@ whamletFile :: FilePath -> Q Exp whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings +whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp+whamletFileWithSettings = NP.hamletFileWithSettings rules+ rules :: Q NP.HamletRules rules = do ah <- [|toWidget|]@@ -344,3 +345,6 @@ register = lift . register release = lift . release resourceMask = lift . resourceMask++instance MonadLogger (GWidget sub master) where+ monadLoggerLog a b = lift . monadLoggerLog a b
test.hs view
@@ -2,4 +2,4 @@ import qualified YesodCoreTest main :: IO ()-main = hspecX $ YesodCoreTest.specs+main = hspec YesodCoreTest.specs
test/YesodCoreTest.hs view
@@ -15,18 +15,17 @@ import Test.Hspec -specs :: [Spec]-specs = - [ cleanPathTest- , exceptionsTest- , widgetTest- , mediaTest- , linksTest- , noOverloadedTest- , internalRequestTest- , errorHandlingTest- , cacheTest- , WaiSubsite.specs- , Redirect.specs- , JsLoader.specs- ]+specs :: Spec+specs = do+ cleanPathTest+ exceptionsTest+ widgetTest+ mediaTest+ linksTest+ noOverloadedTest+ internalRequestTest+ errorHandlingTest+ cacheTest+ WaiSubsite.specs+ Redirect.specs+ JsLoader.specs
test/YesodCoreTest/Cache.hs view
@@ -37,9 +37,8 @@ cacheTest :: Spec cacheTest =- describe "Test.Cache"- [ it "works" works- ]+ describe "Test.Cache" $ do+ it "works" works runner :: Session () -> IO () runner f = toWaiApp C >>= runSession f
test/YesodCoreTest/CleanPath.hs view
@@ -26,7 +26,7 @@ renderRoute (SubsiteRoute x) = (x, []) instance YesodDispatch Subsite master where- yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS+ yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show pieces@@ -64,15 +64,14 @@ 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- ]+ describe "Test.CleanPath" $ do+ 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
test/YesodCoreTest/ErrorHandling.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget@@ -11,6 +12,7 @@ import Text.Hamlet (hamlet) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8+import Control.Exception (SomeException, try) data App = App @@ -19,12 +21,16 @@ /not_found NotFoundR POST /first_thing FirstThingR POST /after_runRequestBody AfterRunRequestBodyR POST+/error-in-body ErrorInBodyR GET+/error-in-body-noeval ErrorInBodyNoEvalR GET |] instance Yesod App getHomeR :: Handler RepHtml-getHomeR = defaultLayout $ toWidget [hamlet|+getHomeR = do+ $logDebug "Testing logging"+ defaultLayout $ toWidget [hamlet| $doctype 5 <html>@@ -49,15 +55,24 @@ postAfterRunRequestBodyR = do x <- runRequestBody- _ <- error $ show x+ _ <- error $ show $ fst x getHomeR +getErrorInBodyR :: Handler RepHtml+getErrorInBodyR = do+ let foo = error "error in body 19328" :: String+ defaultLayout [whamlet|#{foo}|]++getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate RepHtml)+getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR+ errorHandlingTest :: Spec-errorHandlingTest = describe "Test.ErrorHandling"- [ it "says not found" caseNotFound- , it "says 'There was an error' before runRequestBody" caseBefore- , it "says 'There was an error' after runRequestBody" caseAfter- ]+errorHandlingTest = describe "Test.ErrorHandling" $ do+ it "says not found" caseNotFound+ it "says 'There was an error' before runRequestBody" caseBefore+ it "says 'There was an error' after runRequestBody" caseAfter+ it "error in body == 500" caseErrorInBody+ it "error in body, no eval == 200" caseErrorInBodyNoEval runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f@@ -96,3 +111,18 @@ } assertStatus 500 res assertBodyContains "bin12345" res++caseErrorInBody :: IO ()+caseErrorInBody = runner $ do+ res <- request defaultRequest { pathInfo = ["error-in-body"] }+ assertStatus 500 res+ assertBodyContains "error in body 19328" res++caseErrorInBodyNoEval :: IO ()+caseErrorInBodyNoEval = do+ eres <- try $ runner $ do+ _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }+ return ()+ case eres of+ Left (_ :: SomeException) -> return ()+ Right _ -> error "Expected an exception"
test/YesodCoreTest/Exceptions.hs view
@@ -31,10 +31,9 @@ redirectWith status301 RootR exceptionsTest :: Spec-exceptionsTest = describe "Test.Exceptions"- [ it "500" case500- , it "redirect keeps headers" caseRedirect- ]+exceptionsTest = describe "Test.Exceptions" $ do+ it "500" case500+ it "redirect keeps headers" caseRedirect runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f
test/YesodCoreTest/InternalRequest.hs view
@@ -11,10 +11,9 @@ import Test.Hspec randomStringSpecs :: Spec-randomStringSpecs = describe "Yesod.Internal.Request.randomString"- [ it "looks reasonably random" looksRandom- , it "does not repeat itself" $ noRepeat 10 100- ]+randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do+ 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?).@@ -31,57 +30,55 @@ tokenSpecs :: Spec-tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)"- [ it "is Nothing if sessions are disabled" noDisabledToken- , it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken- , it "uses preexisting token in session" useOldToken- , it "generates a new token for sessions without token" generateToken- ]+tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do+ it "is Nothing if sessions are disabled" noDisabledToken+ it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken+ it "uses preexisting token in session" useOldToken+ it "generates a new token for sessions without token" generateToken noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where- r = parseWaiRequest' defaultRequest [] False g+ r = parseWaiRequest' defaultRequest [] False 0 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False g+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g generateToken :: Bool generateToken = reqToken r /= Nothing where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 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- ]+langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do+ it "respects Accept-Language" respectAcceptLangs+ it "respects sessions" respectSessionLang+ it "respects cookies" respectCookieLang+ it "respects queries" respectQueryLang+ it "prioritizes correctly" prioritizeLangs respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [("Accept-Language", "en-US, es")] } [] False g+ { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where- r = parseWaiRequest' defaultRequest [("_LANG", "en")] False g+ r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")]- } [] False g+ } [] False 0 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where- r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False g+ r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where@@ -90,12 +87,11 @@ , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")]- } [("_LANG", "en-SESSION")] False g+ } [("_LANG", "en-SESSION")] False 0 g internalRequestTest :: Spec-internalRequestTest = describe "Test.InternalRequestTest" - [ randomStringSpecs- , tokenSpecs- , langSpecs- ]+internalRequestTest = describe "Test.InternalRequestTest" $ do+ randomStringSpecs+ tokenSpecs+ langSpecs
test/YesodCoreTest/JsLoader.hs view
@@ -23,19 +23,18 @@ getHeadR = defaultLayout $ addScriptRemote "load.js" specs :: Spec-specs = describe "Test.JsLoader" [+specs = describe "Test.JsLoader" $ do it "link from head" $ runner H $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"load.js\"></script></head><body></body></html>" res - , it "link from head async" $ runner HA $ do+ it "link from head async" $ runner HA $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"yepnope.js\"></script><script>yepnope({load:[\"load.js\"]});</script></head><body></body></html>" res - , it "link from bottom" $ runner B $ do+ it "link from bottom" $ runner B $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script src=\"load.js\"></script></body></html>" res- ] runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO () runner app f = toWaiApp app >>= runSession f
test/YesodCoreTest/Links.hs view
@@ -21,9 +21,8 @@ getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|] linksTest :: Spec-linksTest = describe "Test.Links"- [ it "linkToHome" case_linkToHome- ]+linksTest = describe "Test.Links" $ do+ it "linkToHome" case_linkToHome runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f@@ -31,4 +30,4 @@ 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+ assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res
test/YesodCoreTest/Media.hs view
@@ -50,7 +50,6 @@ 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- ]+mediaTest = describe "Test.Media" $ do+ it "media" caseMedia+ it "media link" caseMediaLink
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -45,6 +45,5 @@ assertBody mempty res noOverloadedTest :: Spec-noOverloadedTest = describe "Test.NoOverloadedStrings"- [ it "sanity" case_sanity- ]+noOverloadedTest = describe "Test.NoOverloadedStrings" $ do+ it "sanity" case_sanity
test/YesodCoreTest/Redirect.hs view
@@ -27,33 +27,32 @@ getRRegular = redirect RootR specs :: Spec-specs = describe "Redirect" [+specs = describe "Redirect" $ do it "301 redirect" $ app $ do res <- request defaultRequest { pathInfo = ["r301"] } assertStatus 301 res assertBodyContains "" res - , it "303 redirect" $ app $ do+ it "303 redirect" $ app $ do res <- request defaultRequest { pathInfo = ["r303"] } assertStatus 303 res assertBodyContains "" res - , it "307 redirect" $ app $ do+ it "307 redirect" $ app $ do res <- request defaultRequest { pathInfo = ["r307"] } assertStatus 307 res assertBodyContains "" res - , it "303 redirect for regular, HTTP 1.1" $ app $ do+ it "303 redirect for regular, HTTP 1.1" $ app $ do res <- request defaultRequest { pathInfo = ["rregular"] } assertStatus 303 res assertBodyContains "" res- , it "302 redirect for regular, HTTP 1.0" $ app $ do+ it "302 redirect for regular, HTTP 1.0" $ app $ do res <- request defaultRequest { pathInfo = ["rregular"] , httpVersion = H.http10 } assertStatus 302 res assertBodyContains "" res- ]
test/YesodCoreTest/WaiSubsite.hs view
@@ -26,14 +26,13 @@ getRootR = return () specs :: Spec-specs = describe "WaiSubsite" [+specs = describe "WaiSubsite" $ do it "root" $ app $ do res <- request defaultRequest { pathInfo = [] } assertStatus 200 res assertBodyContains "" res - , it "subsite" $ app $ do+ it "subsite" $ app $ do res <- request defaultRequest { pathInfo = ["sub", "foo"] } assertStatus 200 res assertBodyContains "WAI" res- ]
test/YesodCoreTest/Widget.hs view
@@ -56,12 +56,13 @@ toWidget [lucius|foo{bar:baz}|] toWidgetHead [lucius|foo{bar:baz}|] - toWidget [hamlet|<foo>|] :: Widget+ toWidget [hamlet|<foo>|] toWidgetHead [hamlet|<foo>|] toWidgetBody [hamlet|<foo>|] getWhamletR :: Handler RepHtml getWhamletR = defaultLayout [whamlet|+$newline never <h1>Test <h2>@{WhamletR} <h3>_{Goodbye}@@ -69,10 +70,14 @@ ^{embed} |] where- embed = [whamlet|<h4>Embed|]+ embed = [whamlet|+$newline never+<h4>Embed+|] getAutoR :: Handler RepHtml getAutoR = defaultLayout [whamlet|+$newline never ^{someHtml} |] where@@ -82,13 +87,12 @@ getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|] widgetTest :: Spec-widgetTest = describe "Test.Widget"- [ it "addJuliusBody" case_addJuliusBody- , it "whamlet" case_whamlet- , it "two letter lang codes" case_two_letter_lang- , it "automatically applies toWidget" case_auto- , it "toWidgetHead puts JS in head" case_jshead- ]+widgetTest = describe "Test.Widget" $ do+ it "addJuliusBody" case_addJuliusBody+ it "whamlet" case_whamlet+ it "two letter lang codes" case_two_letter_lang+ it "automatically applies toWidget" case_auto+ it "toWidgetHead puts JS in head" case_jshead runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f
test/test.hs view
@@ -2,4 +2,4 @@ import qualified YesodCoreTest main :: IO ()-main = hspecX $ YesodCoreTest.specs+main = hspec YesodCoreTest.specs
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.0.1.3+version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -40,10 +40,6 @@ 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,21 +48,21 @@ 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 , path-pieces >= 0.1 && < 0.2- , hamlet >= 1.0 && < 1.1+ , hamlet >= 1.1 && < 1.2 , shakespeare >= 1.0 && < 1.1 , shakespeare-js >= 1.0 && < 1.1 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-i18n >= 1.0 && < 1.1 , blaze-builder >= 0.2.1.4 && < 0.4 , transformers >= 0.2.2 && < 0.4- , clientsession >= 0.7.3.1 && < 0.8+ , clientsession >= 0.8 && < 0.9 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.3 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1@@ -75,31 +71,24 @@ , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4 , cookie >= 0.4 && < 0.5- , http-types >= 0.6.5 && < 0.7+ , http-types >= 0.7 && < 0.8 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 , directory >= 1 && < 1.2 , vector >= 0.9 && < 0.10 , aeson >= 0.5- , fast-logger >= 0.0.2- , wai-logger >= 0.0.1- , conduit >= 0.4 && < 0.5+ , fast-logger >= 0.2 && < 0.3+ , monad-logger >= 0.2 && < 0.3+ , 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 Yesod.Dispatch Yesod.Handler- Yesod.Logger Yesod.Request Yesod.Widget Yesod.Message@@ -119,7 +108,7 @@ cpp-options: -DTEST build-depends: base- ,hspec >= 1.1 && < 1.2+ ,hspec >= 1.3 && < 1.4 ,wai-test ,wai ,yesod-core