diff --git a/Yesod/Config.hs b/Yesod/Config.hs --- a/Yesod/Config.hs +++ b/Yesod/Config.hs @@ -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 diff --git a/Yesod/Core.hs b/Yesod/Core.hs --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Yesod.Core ( -- * Type classes Yesod (..) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -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 diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -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 diff --git a/Yesod/Logger.hs b/Yesod/Logger.hs --- a/Yesod/Logger.hs +++ b/Yesod/Logger.hs @@ -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 -- diff --git a/Yesod/Message.hs b/Yesod/Message.hs --- a/Yesod/Message.hs +++ b/Yesod/Message.hs @@ -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 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,4 +1,5 @@ import Test.Hspec import qualified YesodCoreTest +main :: IO () main = hspecX $ descriptions $ YesodCoreTest.specs diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.9.3.6 +version: 0.9.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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