yesod-core 0.9.3.6 → 0.9.4
raw patch · 8 files changed
+103/−322 lines, 8 filesdep +fast-loggerdep +shakespeare-i18ndep +wai-loggerdep −strict-concurrencydep ~aesondep ~basedep ~case-insensitive
Dependencies added: fast-logger, shakespeare-i18n, wai-logger
Dependencies removed: strict-concurrency
Dependency ranges changed: aeson, base, case-insensitive, hamlet, shakespeare-css, shakespeare-js, time, transformers-base
Files
- Yesod/Config.hs +1/−0
- Yesod/Core.hs +1/−0
- Yesod/Handler.hs +10/−8
- Yesod/Internal/Core.hs +11/−11
- Yesod/Logger.hs +70/−41
- Yesod/Message.hs +2/−256
- test.hs +1/−0
- yesod-core.cabal +7/−6
Yesod/Config.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Yesod.Config+ {-# DEPRECATED "This code has been moved to yesod-default. This module will be removed in the next major version bump." #-} ( AppConfig(..) , loadConfig , withYamlEnvironment
Yesod/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Yesod.Core ( -- * Type classes Yesod (..)
Yesod/Handler.hs view
@@ -377,7 +377,7 @@ -> master -> sub -> YesodApp-runHandler handler mrender sroute tomr ma sa =+runHandler handler mrender sroute tomr master sub = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of@@ -392,8 +392,8 @@ } let hd = HandlerData { handlerRequest = rr- , handlerSub = sa- , handlerMaster = ma+ , handlerSub = sub+ , handlerMaster = master , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr@@ -423,7 +423,7 @@ HCRedirect rt loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YARPlain- (getRedirectStatus rt) hs typePlain emptyContent+ (getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent finalSession HCSendFile ct fp p -> catchIter (sendFile' ct fp p)@@ -707,10 +707,12 @@ getStatus (PermissionDenied _) = H.status403 getStatus (BadMethod _) = H.status405 -getRedirectStatus :: RedirectType -> H.Status-getRedirectStatus RedirectPermanent = H.status301-getRedirectStatus RedirectTemporary = H.status302-getRedirectStatus RedirectSeeOther = H.status303+getRedirectStatus :: RedirectType -> W.Request -> H.Status+getRedirectStatus RedirectPermanent _ = H.status301+getRedirectStatus RedirectTemporary r+ | W.httpVersion r == H.http11 = H.status307+ | otherwise = H.status302+getRedirectStatus RedirectSeeOther _ = H.status303 -- | Different types of redirects. data RedirectType = RedirectPermanent
Yesod/Internal/Core.hs view
@@ -59,7 +59,7 @@ import qualified Data.Map as Map import Data.Time import Network.HTTP.Types (encodePath)-import qualified Data.Text as TS+import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TEE@@ -84,7 +84,7 @@ yesodVersion = showVersion Paths_yesod_core.version #else yesodVersion :: String-yesodVersion = "0.9.3.2"+yesodVersion = "0.9.4" #endif #if GHC7@@ -214,15 +214,15 @@ then Right s else Left corrected where- corrected = filter (not . TS.null) s+ corrected = filter (not . T.null) s -- | 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- -> [(TS.Text, TS.Text)] -- ^ query string+ -> T.Text -- ^ application root+ -> [T.Text] -- ^ path pieces+ -> [(T.Text, T.Text)] -- ^ query string -> Builder joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where@@ -261,7 +261,7 @@ maximumContentLength :: a -> Maybe (Route a) -> Int maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes - -- | Send a message to the log. By default, prints to stderr.+ -- | Send a message to the log. By default, prints to stdout. messageLogger :: a -> Loc -- ^ position in source code -> LogLevel@@ -294,7 +294,7 @@ lift LevelInfo = [|LevelInfo|] lift LevelWarn = [|LevelWarn|] lift LevelError = [|LevelError|]- lift (LevelOther x) = [|LevelOther $ TS.pack $(lift $ TS.unpack x)|]+ lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|] formatLogMessage :: Loc -> LogLevel@@ -303,13 +303,13 @@ formatLogMessage loc level msg = do now <- getCurrentTime return $ TB.toLazyText $- TB.fromText (TS.pack $ show now)+ TB.fromText (T.pack $ show now) `mappend` TB.fromText " ["- `mappend` TB.fromText (TS.pack $ drop 5 $ show level)+ `mappend` TB.fromText (T.pack $ drop 5 $ show level) `mappend` TB.fromText "] " `mappend` TB.fromText msg `mappend` TB.fromText " @("- `mappend` TB.fromText (TS.pack $ fileLocationToString loc)+ `mappend` TB.fromText (T.pack $ fileLocationToString loc) `mappend` TB.fromText ") " -- taken from file-location package
Yesod/Logger.hs view
@@ -1,68 +1,97 @@--- blantantly taken from hakyll--- http://hackage.haskell.org/packages/archive/hakyll/3.1.1.0/doc/html/src/Hakyll-Core-Logger.html------ | Produce pretty, thread-safe logs--- {-# LANGUAGE BangPatterns #-} module Yesod.Logger ( Logger , makeLogger+ , makeLoggerWithHandle+ , makeDefaultLogger , flushLogger , timed , logText , logLazyText , logString+ , logBS+ , logMsg+ , formatLogText ) where -import Control.Monad (forever)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Applicative ((<$>), (<*>))-import Control.Concurrent (forkIO)-import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan)-import Control.Concurrent.MVar.Strict (MVar, newEmptyMVar, takeMVar, putMVar)-import Text.Printf (printf)-import Data.Text+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 qualified Data.Text.Lazy.IO+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) -data Logger = Logger- { loggerChan :: Chan (Maybe TL.Text) -- Nothing marks the end- , loggerSync :: MVar () -- Used for sync on quit- }+-- for formatter+import Language.Haskell.TH.Syntax (Loc)+import Yesod.Core (LogLevel, fileLocationToString) +data Logger = Logger {+ loggerHandle :: Handle+ , loggerDateRef :: DateRef+ }+ makeLogger :: IO Logger-makeLogger = do- logger <- Logger <$> newChan <*> newEmptyMVar- _ <- forkIO $ loggerThread logger- return logger- where- loggerThread logger = forever $ do- msg <- readChan $ loggerChan logger- case msg of- -- Stop: sync- Nothing -> putMVar (loggerSync logger) ()- -- Print and continue- Just m -> Data.Text.Lazy.IO.putStrLn m+makeLogger = makeDefaultLogger+{-# DEPRECATED makeLogger "Use makeDefaultLogger instead" #-} --- | Flush the logger (blocks until flushed)---+makeLoggerWithHandle :: Handle -> IO Logger+makeLoggerWithHandle handle = dateInit >>= return . Logger handle++-- | uses stdout handle+makeDefaultLogger :: IO Logger+makeDefaultLogger = makeLoggerWithHandle stdout+ flushLogger :: Logger -> IO ()-flushLogger logger = do- writeChan (loggerChan logger) Nothing- () <- takeMVar $ loggerSync logger- return ()+flushLogger = hFlush . loggerHandle --- | Send a raw message to the logger--- Native format is lazy text+logMsg :: Logger -> [LogStr] -> IO ()+logMsg = hPutLogStr . loggerHandle+ logLazyText :: Logger -> TL.Text -> IO ()-logLazyText logger = writeChan (loggerChan logger) . Just+logLazyText logger msg = logMsg logger $+ map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine] logText :: Logger -> Text -> IO ()-logText logger = logLazyText logger . TL.fromStrict+logText logger = logBS logger . encodeUtf8 +logBS :: Logger -> ByteString -> IO ()+logBS logger msg = logMsg logger [LB msg, newLine]+ logString :: Logger -> String -> IO ()-logString logger = logLazyText logger . TL.pack+logString logger msg = logMsg 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 --
Yesod/Message.hs view
@@ -1,259 +1,5 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ExistentialQuantification #-} module Yesod.Message- ( mkMessage- , RenderMessage (..)- , ToMessage (..)- , SomeMessage (..)+ ( module Text.Shakespeare.I18N ) where -import Language.Haskell.TH.Syntax-import Data.Text (Text, pack, unpack)-import System.Directory-import Data.Maybe (catMaybes)-import Data.List (isSuffixOf, sortBy, foldl')-import qualified Data.ByteString as S-import Data.Text.Encoding (decodeUtf8)-import Data.Char (isSpace, toLower, toUpper)-import Data.Ord (comparing)-import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)-import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))-import Control.Arrow ((***))-import Data.Monoid (mempty, mappend)-import qualified Data.Text as T-import Data.String (IsString (fromString))--class ToMessage a where- toMessage :: a -> Text-instance ToMessage Text where- toMessage = id-instance ToMessage String where- toMessage = Data.Text.pack--class RenderMessage master message where- renderMessage :: master- -> [Text] -- ^ languages- -> message- -> Text--instance RenderMessage master Text where- renderMessage _ _ = id--type Lang = Text--mkMessage :: String- -> FilePath- -> Lang- -> Q [Dec]-mkMessage dt folder lang = do- files <- qRunIO $ getDirectoryContents folder- contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files- sdef <-- case lookup lang contents of- Nothing -> error $ "Did not find main language file: " ++ unpack lang- Just def -> toSDefs def- mapM_ (checkDef sdef) $ map snd contents- let dt' = ConT $ mkName dt- let mname = mkName $ dt ++ "Message"- c1 <- fmap concat $ mapM (toClauses dt) contents- c2 <- mapM (sToClause dt) sdef- c3 <- defClause- return- [ DataD [] mname [] (map (toCon dt) sdef) []- , InstanceD- []- (ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)- [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]- ]- ]--toClauses :: String -> (Lang, [Def]) -> Q [Clause]-toClauses dt (lang, defs) =- mapM go defs- where- go def = do- a <- newName "lang"- (pat, bod) <- mkBody dt (constr def) (map fst $ vars def) (content def)- guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]- return $ Clause- [WildP, ConP (mkName ":") [VarP a, WildP], pat]- (GuardedB [(guard, bod)])- []--mkBody :: String -- ^ datatype- -> String -- ^ constructor- -> [String] -- ^ variable names- -> [Content]- -> Q (Pat, Exp)-mkBody dt cs vs ct = do- vp <- mapM go vs- let pat = RecP (mkName $ "Msg" ++ cs) (map (varName dt *** VarP) vp)- let ct' = map (fixVars vp) ct- pack' <- [|Data.Text.pack|]- tomsg <- [|toMessage|]- let ct'' = map (toH pack' tomsg) ct'- mapp <- [|mappend|]- let app a b = InfixE (Just a) mapp (Just b)- e <-- case ct'' of- [] -> [|mempty|]- [x] -> return x- (x:xs) -> return $ foldl' app x xs- return (pat, e)- where- toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)- toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d- go x = do- let y = mkName $ '_' : x- return (x, y)- fixVars vp (Var d) = Var $ fixDeref vp d- fixVars _ (Raw s) = Raw s- fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i- fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)- fixDeref _ d = d- fixIdent vp i =- case lookup i vp of- Nothing -> i- Just y -> nameBase y--sToClause :: String -> SDef -> Q Clause-sToClause dt sdef = do- (pat, bod) <- mkBody dt (sconstr sdef) (map fst $ svars sdef) (scontent sdef)- return $ Clause- [WildP, ConP (mkName "[]") [], pat]- (NormalB bod)- []--defClause :: Q Clause-defClause = do- a <- newName "sub"- c <- newName "langs"- d <- newName "msg"- rm <- [|renderMessage|]- return $ Clause- [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]- (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)- []--toCon :: String -> SDef -> Con-toCon dt (SDef c vs _) =- RecC (mkName $ "Msg" ++ c) $ map go vs- where- go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)--varName :: String -> String -> Name-varName a y =- mkName $ concat [lower a, "Message", upper y]- where- lower (x:xs) = toLower x : xs- lower [] = []- upper (x:xs) = toUpper x : xs- upper [] = []--checkDef :: [SDef] -> [Def] -> Q ()-checkDef x y =- go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)- where- go _ [] = return ()- go [] (b:_) = error $ "Extra message constructor: " ++ constr b- go (a:as) (b:bs)- | sconstr a < constr b = go as (b:bs)- | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b- | otherwise = do- go' (svars a) (vars b)- go as bs- go' ((an, at):as) ((bn, mbt):bs)- | an /= bn = error "Mismatched variable names"- | otherwise =- case mbt of- Nothing -> go' as bs- Just bt- | at == bt -> go' as bs- | otherwise -> error "Mismatched variable types"- go' [] [] = return ()- go' _ _ = error "Mistmached variable count"--toSDefs :: [Def] -> Q [SDef]-toSDefs = mapM toSDef--toSDef :: Def -> Q SDef-toSDef d = do- vars' <- mapM go $ vars d- return $ SDef (constr d) vars' (content d)- where- go (a, Just b) = return (a, b)- go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)--data SDef = SDef- { sconstr :: String- , svars :: [(String, String)]- , scontent :: [Content]- }--data Def = Def- { constr :: String- , vars :: [(String, Maybe String)]- , content :: [Content]- }--loadLang :: FilePath -> FilePath -> IO (Maybe (Lang, [Def]))-loadLang folder file = do- let file' = folder ++ '/' : file- e <- doesFileExist file'- if e && ".msg" `isSuffixOf` file- then do- let lang = pack $ reverse $ drop 4 $ reverse file- bs <- S.readFile file'- let s = unpack $ decodeUtf8 bs- defs <- fmap catMaybes $ mapM parseDef $ lines s- return $ Just (lang, defs)- else return Nothing--parseDef :: String -> IO (Maybe Def)-parseDef "" = return Nothing-parseDef ('#':_) = return Nothing-parseDef s =- case end of- ':':end' -> do- content' <- fmap compress $ parseContent $ dropWhile isSpace end'- case words begin of- [] -> error $ "Missing constructor: " ++ s- (w:ws) -> return $ Just Def- { constr = w- , vars = map parseVar ws- , content = content'- }- _ -> error $ "Missing colon: " ++ s- where- (begin, end) = break (== ':') s--data Content = Var Deref | Raw String--compress :: [Content] -> [Content]-compress [] = []-compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest-compress (x:y) = x : compress y--parseContent :: String -> IO [Content]-parseContent s =- either (error . show) return $ parse go s s- where- go = do- x <- many go'- eof- return x- go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)--parseVar :: String -> (String, Maybe String)-parseVar s =- case break (== '@') s of- (x, '@':y) -> (x, Just y)- _ -> (s, Nothing)--data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg--instance IsString (SomeMessage master) where- fromString = SomeMessage . T.pack+import Text.Shakespeare.I18N
test.hs view
@@ -1,4 +1,5 @@ import Test.Hspec import qualified YesodCoreTest +main :: IO () main = hspecX $ descriptions $ YesodCoreTest.specs
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.9.3.6+version: 0.9.4 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -52,10 +52,11 @@ , text >= 0.7 && < 0.12 , template-haskell , path-pieces >= 0.0 && < 0.1- , hamlet >= 0.10 && < 0.11+ , hamlet >= 0.10.6 && < 0.11 , shakespeare >= 0.10 && < 0.11- , shakespeare-js >= 0.10 && < 0.11- , shakespeare-css >= 0.10 && < 0.11+ , shakespeare-js >= 0.10.4 && < 0.11+ , shakespeare-css >= 0.10.5 && < 0.11+ , shakespeare-i18n >= 0.0 && < 0.1 , blaze-builder >= 0.2.1.4 && < 0.4 , transformers >= 0.2.2 && < 0.3 , clientsession >= 0.7.3.1 && < 0.8@@ -75,10 +76,10 @@ , 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 >= 0.3+ , fast-logger >= 0.0.1+ , wai-logger >= 0.0.1 exposed-modules: Yesod.Content Yesod.Core