yesod-core 1.1.1.2 → 1.1.2
raw patch · 7 files changed
+102/−17 lines, 7 filesdep ~blaze-builderdep ~monad-loggerdep ~transformers
Dependency ranges changed: blaze-builder, monad-logger, transformers
Files
- Yesod/Core.hs +5/−0
- Yesod/Handler.hs +6/−5
- Yesod/Internal/Core.hs +38/−10
- Yesod/Widget.hs +1/−0
- test/YesodCoreTest/CleanPath.hs +13/−0
- test/YesodCoreTest/Links.hs +35/−0
- yesod-core.cabal +4/−2
Yesod/Core.hs view
@@ -26,6 +26,11 @@ , logWarn , logError , logOther+ , logDebugS+ , logInfoS+ , logWarnS+ , logErrorS+ , logOtherS -- * Sessions , SessionBackend (..) , defaultClientSessionBackend
Yesod/Handler.hs view
@@ -194,7 +194,7 @@ , handlerToMaster :: Route sub -> Route master , handlerState :: I.IORef GHState , handlerUpload :: Word64 -> FileUpload- , handlerLog :: Loc -> LogLevel -> LogStr -> IO ()+ , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () } handlerSubData :: (Route sub -> Route master)@@ -471,7 +471,7 @@ -> master -> sub -> (Word64 -> FileUpload)- -> (Loc -> LogLevel -> LogStr -> IO ())+ -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> YesodApp runHandler handler mrender sroute tomr master sub upload log' = YesodApp $ \eh rr cts initSession -> do@@ -881,7 +881,7 @@ => master -- ^ master site foundation -> sub -- ^ sub site foundation -> (Word64 -> FileUpload)- -> (Loc -> LogLevel -> LogStr -> IO ())+ -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a)@@ -1056,6 +1056,7 @@ #endif instance MonadLogger (GHandler sub master) where- monadLoggerLog a b c = do+ monadLoggerLog a c d = monadLoggerLogSource a "" c d+ monadLoggerLogSource a b c d = do hd <- ask- liftIO $ handlerLog hd a b (toLogStr c)+ liftIO $ handlerLog hd a b c (toLogStr d)
Yesod/Internal/Core.hs view
@@ -90,7 +90,7 @@ import qualified Paths_yesod_core import Data.Version (showVersion) import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)-import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther))+import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) import System.Log.FastLogger.Date (ZonedDate) import System.IO (stdout) @@ -227,10 +227,13 @@ cleanPath :: a -> [Text] -> Either [Text] [Text] cleanPath _ s = if corrected == s- then Right s+ then Right $ map dropDash s else Left corrected where corrected = filter (not . T.null) s+ dropDash t+ | T.all (== '-') t = T.drop 1 t+ | otherwise = t -- | Builds an absolute URL by concatenating the application root with the -- pieces of a path and a query string, if any.@@ -240,12 +243,16 @@ -> [T.Text] -- ^ path pieces -> [(T.Text, T.Text)] -- ^ query string -> Builder- joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs+ joinPath _ ar pieces' qs' =+ fromText ar `mappend` encodePath pieces qs where- pieces = if null pieces' then [""] else pieces'+ pieces = if null pieces' then [""] else map addDash pieces' qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ TE.encodeUtf8 x+ addDash t+ | T.all (== '-') t = T.cons '-' t+ | otherwise = t -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and@@ -298,17 +305,30 @@ getLogger _ = mkLogger True stdout -- | Send a message to the @Logger@ provided by @getLogger@.+ --+ -- Note: This method is no longer used. Instead, you should override+ -- 'messageLoggerSource'. messageLogger :: a -> Logger -> Loc -- ^ position in source code -> LogLevel -> LogStr -- ^ message -> IO ()- messageLogger a logger loc level msg =- if level < logLevel a- then return ()- else formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger+ messageLogger a logger loc = messageLoggerSource a logger loc "" + -- | Send a message to the @Logger@ provided by @getLogger@.+ messageLoggerSource :: a+ -> Logger+ -> Loc -- ^ position in source code+ -> LogSource+ -> LogLevel+ -> LogStr -- ^ message+ -> IO ()+ messageLoggerSource a logger loc source level msg =+ if shouldLog a source level+ then formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger+ else return ()+ -- | The logging level in place for this application. Any messages below -- this level will simply be ignored. logLevel :: a -> LogLevel@@ -346,6 +366,14 @@ | size > 50000 = FileUploadDisk tempFileBackEnd | otherwise = FileUploadMemory lbsBackEnd + -- | Should we log the given log source/level combination.+ --+ -- Default: Logs everything at or above 'logLevel'+ shouldLog :: a -> LogSource -> LogLevel -> Bool+ shouldLog a _ level = level >= logLevel a++{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}+ formatLogMessage :: IO ZonedDate -> Loc -> LogLevel@@ -417,7 +445,7 @@ handler let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session let ra = resolveApproot master req- let log' = messageLogger master logger+ let log' = messageLoggerSource master logger yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of@@ -795,7 +823,7 @@ master master (fileUpload master)- (messageLogger master $ logger master)+ (messageLoggerSource master $ logger master) errHandler err = YesodApp $ \_ _ _ session -> do liftIO $ I.writeIORef ret (Left err)
Yesod/Widget.hs view
@@ -352,3 +352,4 @@ instance MonadLogger (GWidget sub master) where monadLoggerLog a b = lift . monadLoggerLog a b+ monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c
test/YesodCoreTest/CleanPath.hs view
@@ -14,6 +14,11 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Text as TS+import qualified Data.Text.Encoding as TE+import Control.Arrow ((***))+import Network.HTTP.Types (encodePath)+import Data.Monoid (mappend)+import Blaze.ByteString.Builder.Char.Utf8 (fromText) data Subsite = Subsite @@ -51,6 +56,14 @@ else Left corrected where corrected = filter (not . TS.null) s++ joinPath Y ar pieces' qs' =+ fromText ar `mappend` encodePath pieces qs+ where+ pieces = if null pieces' then [""] else pieces'+ qs = map (TE.encodeUtf8 *** go) qs'+ go "" = Nothing+ go x = Just $ TE.encodeUtf8 x getFooR :: Handler RepPlain getFooR = return $ RepPlain "foo"
test/YesodCoreTest/Links.hs view
@@ -8,11 +8,17 @@ import Yesod.Core hiding (Request) import Text.Hamlet+import Network.Wai import Network.Wai.Test+import Data.Text (Text)+import Control.Monad.IO.Class (liftIO)+import Blaze.ByteString.Builder (toByteString) data Y = Y mkYesod "Y" [parseRoutes| / RootR GET+/single/#Text TextR GET+/multi/*Texts TextsR GET |] instance Yesod Y@@ -20,9 +26,16 @@ getRootR :: Handler RepHtml getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|] +getTextR :: Text -> Handler RepHtml+getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]++getTextsR :: [Text] -> Handler RepHtml+getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]+ linksTest :: Spec linksTest = describe "Test.Links" $ do it "linkToHome" case_linkToHome+ it "blank path pieces" case_blanks runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f@@ -31,3 +44,25 @@ case_linkToHome = runner $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res++case_blanks :: IO ()+case_blanks = runner $ do+ liftIO $ do+ let go r =+ let (ps, qs) = renderRoute r+ in toByteString $ joinPath Y "" ps qs+ (go $ TextR "-") `shouldBe` "/single/--"+ (go $ TextR "") `shouldBe` "/single/-"+ (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar"++ res1 <- request defaultRequest+ { pathInfo = ["single", "-"]+ , rawPathInfo = "dummy1"+ }+ assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%%</body></html>" res1++ res2 <- request defaultRequest+ { pathInfo = ["multi", "foo", "-", "bar"]+ , rawPathInfo = "dummy2"+ }+ assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%["foo","","bar"]%</body></html>" res2
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.1.1.2+version: 1.1.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -78,7 +78,7 @@ , vector >= 0.9 && < 0.10 , aeson >= 0.5 , fast-logger >= 0.2- , monad-logger >= 0.2 && < 0.3+ , monad-logger >= 0.2.1 && < 0.3 , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.5 , lifted-base >= 0.1 && < 0.2@@ -119,8 +119,10 @@ ,text ,http-types , random+ , blaze-builder ,HUnit ,QuickCheck >= 2 && < 3+ ,transformers ghc-options: -Wall source-repository head