yesod-core 0.8.3.2 → 0.9.1
raw patch · 13 files changed
+623/−143 lines, 13 filesdep +hspecdep +path-piecesdep +shakespearedep −test-frameworkdep −test-framework-hunitdep −test-framework-quickcheck2dep ~bytestringdep ~clientsessiondep ~hamlet
Dependencies added: hspec, path-pieces, shakespeare, shakespeare-css, shakespeare-js, strict-concurrency, yesod-core
Dependencies removed: test-framework, test-framework-hunit, test-framework-quickcheck2, web-routes-quasi
Dependency ranges changed: bytestring, clientsession, hamlet, http-types, text, time, wai, wai-extra
Files
- Yesod/Core.hs +1/−0
- Yesod/Dispatch.hs +19/−7
- Yesod/Handler.hs +4/−2
- Yesod/Internal.hs +11/−11
- Yesod/Internal/Core.hs +33/−47
- Yesod/Internal/Dispatch.hs +2/−3
- Yesod/Internal/RouteParsing.hs +348/−0
- Yesod/Internal/Session.hs +3/−2
- Yesod/Logger.hs +82/−0
- Yesod/Message.hs +10/−1
- Yesod/Widget.hs +71/−31
- runtests.hs +0/−17
- yesod-core.cabal +39/−22
Yesod/Core.hs view
@@ -17,6 +17,7 @@ -- * Logging , LogLevel (..) , formatLogMessage+ , fileLocationToString , logDebug , logInfo , logWarn
Yesod/Dispatch.hs view
@@ -15,7 +15,6 @@ -- ** Path pieces , SinglePiece (..) , MultiPiece (..)- , Strings , Texts -- * Convert to WAI , toWaiApp@@ -28,10 +27,10 @@ import Yesod.Internal.Core import Yesod.Handler import Yesod.Internal.Dispatch+import Yesod.Widget (GWidget) -import Web.Routes.Quasi (SinglePiece (..), MultiPiece (..), Strings)-import Web.Routes.Quasi.Parse (Resource (..), parseRoutes, parseRoutesFile)-import Web.Routes.Quasi.TH (THResource, Pieces (..), createRoutes, createRender)+import Web.PathPieces (SinglePiece (..), MultiPiece (..))+import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesFile) import Language.Haskell.TH.Syntax import qualified Network.Wai as W@@ -105,8 +104,7 @@ -> [Resource] -> Q ([Dec], [Dec]) mkYesodGeneral name args clazzes isSub res = do- let name' = mkName name- args' = map mkName args+ let args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' th' <- mapM thResourceFromResource res let th = map fst th'@@ -136,7 +134,21 @@ then ConT ''YesodDispatch `AppT` arg `AppT` VarT master else ConT ''YesodDispatch `AppT` arg `AppT` arg let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]- return ([w, x, x'], [y])+ return ([w, x, x'] ++ masterTypSyns, [y])+ where+ name' = mkName name+ masterTypSyns+ | isSub = []+ | otherwise =+ [ TySynD+ (mkName "Handler")+ []+ (ConT ''GHandler `AppT` ConT name' `AppT` ConT name')+ , TySynD+ (mkName "Widget")+ []+ (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)+ ] thResourceFromResource :: Resource -> Q (THResource, Maybe String) thResourceFromResource (Resource n ps atts)
Yesod/Handler.hs view
@@ -163,6 +163,8 @@ import Data.Text (Text) import Yesod.Message (RenderMessage (..)) +import Text.Blaze (toHtml, preEscapedText)+ -- | The type-safe URLs associated with a site argument. type family Route a @@ -881,14 +883,14 @@ -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. hamletToContent :: Monad mo- => Hamlet (Route master) -> GGHandler sub master mo Content+ => HtmlUrl (Route master) -> GGHandler sub master mo Content hamletToContent h = do render <- getUrlRenderParams return $ toContent $ h render -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: Monad mo- => Hamlet (Route master) -> GGHandler sub master mo RepHtml+ => HtmlUrl (Route master) -> GGHandler sub master mo RepHtml hamletToRepHtml = liftM RepHtml . hamletToContent -- | Get the request\'s 'W.Request' value.
Yesod/Internal.hs view
@@ -20,7 +20,7 @@ , Title (..) , Head (..) , Body (..)- , locationToHamlet+ , locationToHtmlUrl , runUniqueList , toUnique -- * Names@@ -28,9 +28,9 @@ , nonceKey ) where -import Text.Hamlet (Hamlet, hamlet, Html)-import Text.Cassius (Cassius)-import Text.Julius (Julius)+import Text.Hamlet (HtmlUrl, hamlet, Html)+import Text.Cassius (CssUrl)+import Text.Julius (JavascriptUrl) import Data.Monoid (Monoid (..), Last) import Data.List (nub) @@ -75,10 +75,10 @@ data Location url = Local url | Remote Text deriving (Show, Eq)-locationToHamlet :: Location url -> Hamlet url-locationToHamlet (Local url) = [HAMLET|\@{url}+locationToHtmlUrl :: Location url -> HtmlUrl url+locationToHtmlUrl (Local url) = [HAMLET|\@{url} |]-locationToHamlet (Remote s) = [HAMLET|\#{s}+locationToHtmlUrl (Remote s) = [HAMLET|\#{s} |] newtype UniqueList x = UniqueList ([x] -> [x])@@ -96,9 +96,9 @@ deriving (Show, Eq) newtype Title = Title { unTitle :: Html } -newtype Head url = Head (Hamlet url)+newtype Head url = Head (HtmlUrl url) deriving Monoid-newtype Body url = Body (Hamlet url)+newtype Body url = Body (HtmlUrl url) deriving Monoid nonceKey :: IsString a => a@@ -112,8 +112,8 @@ !(Last Title) !(UniqueList (Script a)) !(UniqueList (Stylesheet a))- !(Map.Map (Maybe Text) (Cassius a)) -- media type- !(Maybe (Julius a))+ !(Map.Map (Maybe Text) (CssUrl a)) -- media type+ !(Maybe (JavascriptUrl a)) !(Head a) instance Monoid (GWData a) where mempty = GWData mempty mempty mempty mempty mempty mempty mempty
Yesod/Internal/Core.hs view
@@ -23,6 +23,7 @@ -- * Logging , LogLevel (..) , formatLogMessage+ , fileLocationToString , messageLoggerHandler -- * Misc , yesodVersion@@ -71,9 +72,9 @@ import qualified Network.HTTP.Types as H import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO-import qualified System.IO import qualified Data.Text.Lazy.Builder as TB import Language.Haskell.TH.Syntax (Loc (..), Lift (..))+import Text.Blaze (preEscapedLazyText) #if GHC7 #define HAMLET hamlet@@ -256,7 +257,7 @@ -> IO () messageLogger _ loc level msg = formatLogMessage loc level msg >>=- Data.Text.Lazy.IO.hPutStrLn System.IO.stderr+ Data.Text.Lazy.IO.putStrLn messageLoggerHandler :: (Yesod m, MonadIO mo) => Loc -> LogLevel -> Text -> GGHandler s m mo ()@@ -282,15 +283,24 @@ now <- getCurrentTime return $ TB.toLazyText $ TB.fromText (TS.pack $ show now)- `mappend` TB.fromText ": "- `mappend` TB.fromText (TS.pack $ show level)- `mappend` TB.fromText "@("- `mappend` TB.fromText (TS.pack $ loc_filename loc)- `mappend` TB.fromText ":"- `mappend` TB.fromText (TS.pack $ show $ fst $ loc_start loc)- `mappend` TB.fromText ") "+ `mappend` TB.fromText " ["+ `mappend` TB.fromText (TS.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 ") " +-- taken from file-location package+-- turn the TH Loc loaction information into a human readable string+-- leaving out the loc_end parameter+fileLocationToString :: Loc -> String+fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ + ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)+ where+ line = show . fst . loc_start+ char = show . snd . loc_start+ defaultYesodRunner :: Yesod master => a -> master@@ -346,15 +356,16 @@ $ filter (\(x, _) -> x /= nonceKey) session' yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h let mnonce = reqNonce rr- return $ yarToResponse (hr mnonce getExpires host exp') yar+ iv <- liftIO CS.randomIV+ return $ yarToResponse (hr iv mnonce getExpires host exp') yar where- hr mnonce getExpires host exp' hs ct sm =+ hr iv mnonce getExpires host exp' hs ct sm = hs''' where sessionVal = case (mkey, mnonce) of (Just key, Just nonce)- -> encodeSession key exp' host+ -> encodeSession key iv exp' host $ Map.toList $ Map.insert nonceKey nonce sm _ -> mempty@@ -401,7 +412,7 @@ applyLayout' :: Yesod master => Html -- ^ title- -> Hamlet (Route master) -- ^ body+ -> HtmlUrl (Route master) -- ^ body -> GHandler sub master ChooseRep applyLayout' title body = fmap chooseRep $ defaultLayout $ do setTitle title@@ -413,31 +424,19 @@ r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r applyLayout' "Not Found"-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [HAMLET| <h1>Not Found <p>#{path'} |] defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied"-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [HAMLET| <h1>Permission denied <p>#{msg} |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments"-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [HAMLET| <h1>Invalid Arguments <ul> $forall msg <- ia@@ -445,21 +444,13 @@ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error"-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [HAMLET| <h1>Internal Server Error <p>#{e} |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method"-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [HAMLET| <h1>Method Not Supported <p>Method "#{S8.unpack m}" not supported |]@@ -486,7 +477,7 @@ let scripts = runUniqueList scripts' let stylesheets = runUniqueList stylesheets' let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b- jelper :: Julius url -> Hamlet url+ jelper :: JavascriptUrl url -> HtmlUrl url jelper = fmap jsToHtml render <- getUrlRenderParams@@ -496,7 +487,7 @@ Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p css <- forM (Map.toList style) $ \(mmedia, content) -> do- let rendered = renderCassius render content+ let rendered = renderCssUrl render content x <- addStaticContent "css" "text/css; charset=utf-8" $ encodeUtf8 rendered return (mmedia,@@ -508,7 +499,7 @@ Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8"- $ encodeUtf8 $ renderJulius render s+ $ encodeUtf8 $ renderJavascriptUrl render s return $ renderLoc x let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)@@ -526,12 +517,7 @@ left _ = Nothing right (Right x) = Just x right _ = Nothing- let head'' =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ let head'' = [HAMLET| $forall s <- stylesheets ^{mkLinkTag s} $forall s <- css
Yesod/Internal/Dispatch.hs view
@@ -7,9 +7,8 @@ import Prelude hiding (exp) import Language.Haskell.TH.Syntax-import Web.Routes.Quasi-import Web.Routes.Quasi.Parse-import Web.Routes.Quasi.TH+import Web.PathPieces+import Yesod.Internal.RouteParsing import Control.Monad (foldM) import Yesod.Handler (badMethod) import Yesod.Content (chooseRep)
+ Yesod/Internal/RouteParsing.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+module Yesod.Internal.RouteParsing+ ( createRoutes+ , createRender+ , createParse+ , createDispatch+ , Pieces (..)+ , THResource+ , parseRoutes+ , parseRoutesFile+ , parseRoutesNoCheck+ , parseRoutesFileNoCheck+ , Resource (..)+ , Piece (..)+ ) where++import Web.PathPieces+import Language.Haskell.TH.Syntax+import Data.Maybe+import Data.Either+import Data.List+import Data.Char (toLower)+import qualified Data.Text+import Language.Haskell.TH.Quote+import Data.Data+import qualified System.IO as SIO++data Pieces =+ SubSite+ { ssType :: Type+ , ssParse :: Exp+ , ssRender :: Exp+ , ssDispatch :: Exp+ , ssToMasterArg :: Exp+ , ssPieces :: [Piece]+ }+ | Simple [Piece] [String] -- ^ methods+ deriving Show+type THResource = (String, Pieces)++createRoutes :: [THResource] -> Q [Con]+createRoutes res =+ return $ map go res+ where+ go (n, SubSite{ssType = s, ssPieces = pieces}) =+ NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]+ go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces+ go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)+ go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)+ go' (StaticPiece _) = Nothing++-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.+createParse :: [THResource] -> Q [Clause]+createParse res = do+ final' <- final+ clauses <- mapM go res+ return $ if areResourcesComplete res+ then clauses+ else clauses ++ [final']+ where+ cons x y = ConP (mkName ":") [x, y]+ go (constr, SubSite{ssParse = p, ssPieces = ps}) = do+ ri <- [|Right|]+ be <- [|ape|]+ (pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)+ + x <- newName "x"+ let pat = init pat' ++ [VarP x]++ --let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces+ let eitherSub = p `AppE` VarE x+ let bod = be `AppE` parse `AppE` eitherSub+ --let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub+ return $ Clause [foldr1 cons pat] (NormalB bod) []+ go (n, Simple ps _) = do+ ri <- [|Right|]+ be <- [|ape|]+ (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)+ return $ Clause [foldr1 cons pat] (NormalB parse) []+ final = do+ no <- [|Left "Invalid URL"|]+ return $ Clause [WildP] (NormalB no) []+ mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)+ mkPat' be [MultiPiece s] parse = do+ v <- newName $ "var" ++ s+ fmp <- [|fromMultiPiece|]+ let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v+ return ([VarP v], parse')+ mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"+ mkPat' be (StaticPiece s:rest) parse = do+ (x, parse') <- mkPat' be rest parse+ let sp = LitP $ StringL s+ return (sp : x, parse')+ mkPat' be (SinglePiece s:rest) parse = do+ fsp <- [|fromSinglePiece|]+ v <- newName $ "var" ++ s+ let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v+ (x, parse'') <- mkPat' be rest parse'+ return (VarP v : x, parse'')+ mkPat' _ [] parse = return ([ListP []], parse)++-- | 'ap' for 'Either'+ape :: Either String (a -> b) -> Either String a -> Either String b+ape (Left e) _ = Left e+ape (Right _) (Left e) = Left e+ape (Right f) (Right a) = Right $ f a++-- | Generates the set of clauses necesary to render the given 'Resource's. See+-- 'quasiRender'.+createRender :: [THResource] -> Q [Clause]+createRender = mapM go+ where+ go (n, Simple ps _) = do+ let ps' = zip [1..] ps+ let pat = ConP (mkName n) $ mapMaybe go' ps'+ bod <- mkBod ps'+ return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []+ go (n, SubSite{ssRender = r, ssPieces = pieces}) = do+ cons' <- [|\a (b, c) -> (a ++ b, c)|]+ let cons a b = cons' `AppE` a `AppE` b+ x <- newName "x"+ let r' = r `AppE` VarE x+ let pieces' = zip [1..] pieces+ let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]+ bod <- mkBod pieces'+ return $ Clause [pat] (NormalB $ cons bod r') []+ go' (_, StaticPiece _) = Nothing+ go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)+ mkBod :: (Show t) => [(t, Piece)] -> Q Exp+ mkBod [] = lift ([] :: [String])+ mkBod ((_, StaticPiece x):xs) = do+ x' <- lift x+ pack <- [|Data.Text.pack|]+ xs' <- mkBod xs+ return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'+ mkBod ((i, SinglePiece _):xs) = do+ let x' = VarE $ mkName $ "var" ++ show i+ tsp <- [|toSinglePiece|]+ let x'' = tsp `AppE` x'+ xs' <- mkBod xs+ return $ ConE (mkName ":") `AppE` x'' `AppE` xs'+ mkBod ((i, MultiPiece _):_) = do+ let x' = VarE $ mkName $ "var" ++ show i+ tmp <- [|toMultiPiece|]+ return $ tmp `AppE` x'++-- | Whether the set of resources cover all possible URLs.+areResourcesComplete :: [THResource] -> Bool+areResourcesComplete res =+ let (slurps, noSlurps) = partitionEithers $ mapMaybe go res+ in case slurps of+ [] -> False+ _ -> let minSlurp = minimum slurps+ in helper minSlurp $ reverse $ sort noSlurps+ where+ go :: THResource -> Maybe (Either Int Int)+ go (_, Simple ps _) =+ case reverse ps of+ [] -> Just $ Right 0+ (MultiPiece _:rest) -> go' Left rest+ x -> go' Right x+ go (n, SubSite{ssPieces = ps}) =+ go (n, Simple (ps ++ [MultiPiece ""]) [])+ go' b x = if all isSingle x then Just (b $ length x) else Nothing+ helper 0 _ = True+ helper _ [] = False+ helper m (i:is)+ | i >= m = helper m is+ | i + 1 == m = helper i is+ | otherwise = False+ isSingle (SinglePiece _) = True+ isSingle _ = False++notStatic :: Piece -> Bool+notStatic StaticPiece{} = False+notStatic _ = True++createDispatch :: Exp -- ^ modify a master handler+ -> Exp -- ^ convert a subsite handler to a master handler+ -> [THResource]+ -> Q [Clause]+createDispatch modMaster toMaster = mapM go+ where+ go :: (String, Pieces) -> Q Clause+ go (n, Simple ps methods) = do+ meth <- newName "method"+ xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"+ let pat = [ ConP (mkName n) $ map VarP xs+ , if null methods then WildP else VarP meth+ ]+ bod <- go' n meth xs methods+ return $ Clause pat (NormalB bod) []+ go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do+ meth <- newName "method"+ x <- newName "x"+ xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"+ let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]+ let bod = d `AppE` VarE x `AppE` VarE meth+ fmap' <- [|fmap|]+ let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs+ tma' = foldl AppE tma $ map VarE xs+ let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x+ let bod' = InfixE (Just toMaster') fmap' (Just bod)+ let bod'' = InfixE (Just modMaster) fmap' (Just bod')+ return $ Clause pat (NormalB bod'') []+ go' n _ xs [] = do+ jus <- [|Just|]+ let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs+ return $ jus `AppE` (modMaster `AppE` bod)+ go' n meth xs methods = do+ noth <- [|Nothing|]+ j <- [|Just|]+ let noMatch = Match WildP (NormalB noth) []+ return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]+ go'' n xs j method =+ let pat = LitP $ StringL method+ func = map toLower method ++ n+ bod = foldl AppE (VarE $ mkName func) $ map VarE xs+ in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []++-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for+-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the+-- checking. See documentation site for details on syntax.+parseRoutes :: QuasiQuoter+parseRoutes = QuasiQuoter+ { quoteExp = x+ , quotePat = y+ }+ where+ x s = do+ let res = resourcesFromString s+ case findOverlaps res of+ [] -> lift res+ z -> error $ "Overlapping routes: " ++ unlines (map show z)+ y = dataToPatQ (const Nothing) . resourcesFromString++parseRoutesFile :: FilePath -> Q Exp+parseRoutesFile fp = do+ s <- qRunIO $ readUtf8File fp+ quoteExp parseRoutes s++parseRoutesFileNoCheck :: FilePath -> Q Exp+parseRoutesFileNoCheck fp = do+ s <- qRunIO $ readUtf8File fp+ quoteExp parseRoutesNoCheck s++readUtf8File :: FilePath -> IO String+readUtf8File fp = do+ h <- SIO.openFile fp SIO.ReadMode+ SIO.hSetEncoding h SIO.utf8_bom+ SIO.hGetContents h++-- | Same as 'parseRoutes', but performs no overlap checking.+parseRoutesNoCheck :: QuasiQuoter+parseRoutesNoCheck = QuasiQuoter+ { quoteExp = x+ , quotePat = y+ }+ where+ x = lift . resourcesFromString+ y = dataToPatQ (const Nothing) . resourcesFromString++instance Lift Resource where+ lift (Resource s ps h) = do+ r <- [|Resource|]+ s' <- lift s+ ps' <- lift ps+ h' <- lift h+ return $ r `AppE` s' `AppE` ps' `AppE` h'++-- | A single resource pattern.+--+-- First argument is the name of the constructor, second is the URL pattern to+-- match, third is how to dispatch.+data Resource = Resource String [Piece] [String]+ deriving (Read, Show, Eq, Data, Typeable)++-- | A single piece of a URL, delimited by slashes.+--+-- In the case of StaticPiece, the argument is the value of the piece; for the+-- other constructors, it is the name of the parameter represented by this+-- piece. That value is not used here, but may be useful elsewhere.+data Piece = StaticPiece String+ | SinglePiece String+ | MultiPiece String+ deriving (Read, Show, Eq, Data, Typeable)++instance Lift Piece where+ lift (StaticPiece s) = do+ c <- [|StaticPiece|]+ s' <- lift s+ return $ c `AppE` s'+ lift (SinglePiece s) = do+ c <- [|SinglePiece|]+ s' <- lift s+ return $ c `AppE` s'+ lift (MultiPiece s) = do+ c <- [|MultiPiece|]+ s' <- lift s+ return $ c `AppE` s'++-- | Convert a multi-line string to a set of resources. See documentation for+-- the format of this string. This is a partial function which calls 'error' on+-- invalid input.+resourcesFromString :: String -> [Resource]+resourcesFromString =+ mapMaybe go . lines+ where+ go s =+ case takeWhile (/= "--") $ words s of+ (pattern:constr:rest) ->+ let pieces = piecesFromString $ drop1Slash pattern+ in Just $ Resource constr pieces rest+ [] -> Nothing+ _ -> error $ "Invalid resource line: " ++ s++drop1Slash :: String -> String+drop1Slash ('/':x) = x+drop1Slash x = x++piecesFromString :: String -> [Piece]+piecesFromString "" = []+piecesFromString x =+ let (y, z) = break (== '/') x+ in pieceFromString y : piecesFromString (drop1Slash z)++pieceFromString :: String -> Piece+pieceFromString ('#':x) = SinglePiece x+pieceFromString ('*':x) = MultiPiece x+pieceFromString x = StaticPiece x++findOverlaps :: [Resource] -> [(Resource, Resource)]+findOverlaps = gos . map justPieces+ where+ justPieces r@(Resource _ ps _) = (ps, r)+ gos [] = []+ gos (x:xs) = mapMaybe (go x) xs ++ gos xs+ go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)+ | x == y = go (xs, xr) (ys, yr)+ | otherwise = Nothing+ go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)+ go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)+ go ([], xr) ([], yr) = Just (xr, yr)+ go ([], _) (_, _) = Nothing+ go (_, _) ([], _) = Nothing+ go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)
Yesod/Internal/Session.hs view
@@ -12,12 +12,13 @@ import Control.Arrow ((***)) encodeSession :: CS.Key+ -> CS.IV -> UTCTime -- ^ expire time -> ByteString -- ^ remote host -> [(Text, Text)] -- ^ session -> ByteString -- ^ cookie value-encodeSession key expire rhost session' =- CS.encrypt key $ encode $ SessionCookie expire rhost session'+encodeSession key iv expire rhost session' =+ CS.encrypt key iv $ encode $ SessionCookie expire rhost session' decodeSession :: CS.Key -> UTCTime -- ^ current time
+ Yesod/Logger.hs view
@@ -0,0 +1,82 @@+-- 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+ , flushLogger+ , timed+ , logText+ , logLazyText+ , logString+ ) 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 qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO+import Data.Time (getCurrentTime, diffUTCTime)++data Logger = Logger+ { loggerChan :: Chan (Maybe TL.Text) -- Nothing marks the end+ , loggerSync :: MVar () -- Used for sync on quit+ }++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++-- | Flush the logger (blocks until flushed)+--+flushLogger :: Logger -> IO ()+flushLogger logger = do+ writeChan (loggerChan logger) Nothing+ () <- takeMVar $ loggerSync logger+ return ()++-- | Send a raw message to the logger+-- Native format is lazy text+logLazyText :: Logger -> TL.Text -> IO ()+logLazyText logger = writeChan (loggerChan logger) . Just++logText :: Logger -> Text -> IO ()+logText logger = logLazyText logger . TL.fromStrict++logString :: Logger -> String -> IO ()+logString logger = logLazyText logger . TL.pack++-- | 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/Message.hs view
@@ -2,10 +2,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ExistentialQuantification #-} module Yesod.Message ( mkMessage , RenderMessage (..) , ToMessage (..)+ , SomeMessage (..) ) where import Language.Haskell.TH.Syntax@@ -17,10 +19,12 @@ import Data.Text.Encoding (decodeUtf8) import Data.Char (isSpace, toLower, toUpper) import Data.Ord (comparing)-import Text.Shakespeare (Deref (..), Ident (..), parseHash, derefToExp)+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@@ -248,3 +252,8 @@ 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
Yesod/Widget.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Widget@@ -14,6 +15,10 @@ , whamlet , whamletFile , ihamletToRepHtml+ -- * Convert to Widget+ , ToWidget (..)+ , ToWidgetHead (..)+ , ToWidgetBody (..) -- * Creating -- ** Head of page , setTitle@@ -54,7 +59,6 @@ import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius-import Text.Lucius (Lucius) import Text.Julius import Text.Coffee import Yesod.Handler@@ -74,8 +78,9 @@ import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName) import Control.Monad.IO.Control (MonadControlIO)-import qualified Text.Hamlet.NonPoly as NP+import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText)+import Text.Blaze (toHtml, preEscapedLazyText) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of@@ -93,19 +98,6 @@ mempty = return () mappend x y = x >> y -instance (Monad monad, a ~ ()) => HamletValue (GGWidget m monad a) where- newtype HamletMonad (GGWidget m monad a) b =- GWidget' { runGWidget' :: GGWidget m monad b }- type HamletUrl (GGWidget m monad a) = Route m- toHamletValue = runGWidget'- htmlToHamletMonad = GWidget' . addHtml- urlToHamletMonad url params = GWidget' $- addHamlet $ \r -> preEscapedText (r url params)- fromHamletValue = GWidget'-instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget m monad a)) where- return = GWidget' . return- x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y- addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a addSubWidget sub (GWidget w) = do master <- lift getYesod@@ -116,6 +108,54 @@ GWidget $ tell w' return a +class ToWidget sub master a where+ toWidget :: a -> GWidget sub master ()++-- FIXME At some point in the future, deprecate all the+-- addHamlet/Cassius/Lucius/Julius stuff. For the most part, toWidget* will be+-- sufficient. For somethings, like addLuciusMedia, create addCssUrlMedia.++type RY master = Route master -> [(Text, Text)] -> Text++instance render ~ RY master => ToWidget sub master (render -> Html) where+ toWidget = addHamlet+instance render ~ RY master => ToWidget sub master (render -> Css) where+ toWidget = addCassius+instance render ~ RY master => ToWidget sub master (render -> Javascript) where+ toWidget = addJulius+instance ToWidget sub master (GWidget sub master ()) where+ toWidget = id+instance ToWidget sub master Html where+ toWidget = addHtml+instance render ~ RY master => ToWidget sub master (render -> Coffeescript) where+ toWidget = addCoffee++class ToWidgetBody sub master a where+ toWidgetBody :: a -> GWidget sub master ()++instance render ~ RY master => ToWidgetBody sub master (render -> Html) where+ toWidgetBody = addHamlet+instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where+ toWidgetBody = addJuliusBody+instance ToWidgetBody sub master Html where+ toWidgetBody = addHtml+instance render ~ RY master => ToWidgetBody sub master (render -> Coffeescript) where+ toWidgetBody = addCoffeeBody++class ToWidgetHead sub master a where+ toWidgetHead :: a -> GWidget sub master ()++instance render ~ RY master => ToWidgetHead sub master (render -> Html) where+ toWidgetHead = addHamletHead+instance render ~ RY master => ToWidgetHead sub master (render -> Css) where+ toWidgetHead = addCassius+instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where+ toWidgetHead = addJulius+instance ToWidgetHead sub master Html where+ toWidgetHead = addHtmlHead+instance render ~ RY master => ToWidgetHead sub master (render -> Coffeescript) where+ toWidgetHead = addCoffee+ -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: Monad m => Html -> GGWidget master m ()@@ -129,7 +169,7 @@ setTitle $ toHtml $ mr msg -- | Add a 'Hamlet' to the head tag.-addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()+addHamletHead :: Monad m => HtmlUrl (Route master) -> GGWidget master m () addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head -- | Add a 'Html' to the head tag.@@ -137,7 +177,7 @@ addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag.-addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m ()+addHamlet :: Monad m => HtmlUrl (Route master) -> GGWidget master m () addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -- | Add a 'Html' to the body tag.@@ -150,19 +190,19 @@ addWidget = id -- | Add some raw CSS to the style tag. Applies to all media types.-addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()+addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m () addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty -- | Identical to 'addCassius'.-addLucius :: Monad m => Lucius (Route master) -> GGWidget master m ()+addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m () addLucius = addCassius -- | Add some raw CSS to the style tag, for a specific media type.-addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()+addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m () addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty -- | Identical to 'addCassiusMedia'.-addLuciusMedia :: Monad m => Text -> Lucius (Route master) -> GGWidget master m ()+addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m () addLuciusMedia = addCassiusMedia -- | Link to the specified local stylesheet.@@ -204,17 +244,17 @@ addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag.-addJulius :: Monad m => Julius (Route master) -> GGWidget master m ()+addJulius :: Monad m => JavascriptUrl (Route master) -> GGWidget master m () addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -- | Add a new script tag to the body with the contents of this 'Julius' -- template.-addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m ()-addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j+addJuliusBody :: Monad m => JavascriptUrl (Route master) -> GGWidget master m ()+addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j -- | Add Coffesscript to the page's script tag. Requires the coffeescript -- executable to be present at runtime.-addCoffee :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()+addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) () addCoffee c = do render <- lift getUrlRenderParams t <- liftIO $ renderCoffee render c@@ -222,7 +262,7 @@ -- | Add a new script tag to the body with the contents of this Coffesscript -- template. Requires the coffeescript executable to be present at runtime.-addCoffeeBody :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()+addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) () addCoffeeBody c = do render <- lift getUrlRenderParams t <- liftIO $ renderCoffee render c@@ -230,7 +270,7 @@ -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.-extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m))+extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (HtmlUrl (Route m)) extractBody (GWidget w) = GWidget $ mapRWST (liftM go) w where@@ -239,11 +279,11 @@ -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: ----- > PageContent url -> Hamlet url+-- > PageContent url -> HtmlUrl url data PageContent url = PageContent { pageTitle :: Html- , pageHead :: Hamlet url- , pageBody :: Hamlet url+ , pageHead :: HtmlUrl url+ , pageBody :: HtmlUrl url } whamlet :: QuasiQuoter@@ -271,7 +311,7 @@ -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. ihamletToRepHtml :: (Monad mo, RenderMessage master message)- => NP.IHamlet message (Route master)+ => HtmlUrlI18n message (Route master) -> GGHandler sub master mo RepHtml ihamletToRepHtml ih = do urender <- getUrlRenderParams
− runtests.hs
@@ -1,17 +0,0 @@-import Test.Framework (defaultMain)-import Test.CleanPath-import Test.Exceptions-import Test.Widget-import Test.Media-import Test.Links-import Test.NoOverloadedStrings--main :: IO ()-main = defaultMain- [ cleanPathTest- , exceptionsTest- , widgetTest- , mediaTest- , linksTest- , noOverloadedTest- ]
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.8.3.2+version: 0.9.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -11,7 +11,7 @@ The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and Persistent. category: Web, Yesod stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ @@ -27,17 +27,20 @@ cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3- build-depends: time >= 1.1.4 && < 1.3+ build-depends: time >= 1.1.4 && < 1.4 , wai >= 0.4 && < 0.5- , wai-extra >= 0.4 && < 0.5+ , wai-extra >= 0.4.1 && < 0.5 , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.5 && < 0.12 , template-haskell- , web-routes-quasi >= 0.7.0.1 && < 0.8- , hamlet >= 0.8.1 && < 0.9+ , path-pieces >= 0.0 && < 0.1+ , hamlet >= 0.10 && < 0.11+ , shakespeare >= 0.10 && < 0.11+ , shakespeare-js >= 0.10 && < 0.11+ , shakespeare-css >= 0.10 && < 0.11 , blaze-builder >= 0.2.1 && < 0.4 , transformers >= 0.2 && < 0.3- , clientsession >= 0.6 && < 0.7+ , clientsession >= 0.7 && < 0.8 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.2 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1@@ -47,14 +50,18 @@ , enumerator >= 0.4.7 && < 0.5 , cookie >= 0.3 && < 0.4 , blaze-html >= 0.4 && < 0.5- , http-types >= 0.6 && < 0.7+ , http-types >= 0.6.5 && < 0.7 , case-insensitive >= 0.2 && < 0.4 , parsec >= 2 && < 3.2 , directory >= 1 && < 1.2+ -- for logger. Probably logger should be a separate package+ , strict-concurrency >= 0.2.4 && < 0.2.5+ exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch Yesod.Handler+ Yesod.Logger Yesod.Request Yesod.Widget Yesod.Message@@ -63,31 +70,41 @@ Yesod.Internal.Session Yesod.Internal.Request Yesod.Internal.Dispatch+ Yesod.Internal.RouteParsing Paths_yesod_core ghc-options: -Wall if flag(test) Buildable: False -executable runtests+test-suite runtests+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ if flag(ghc7)+ type: exitcode-stdio-1.0 build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7+ main-is: runtests.hs else+ type: exitcode-stdio-1.0 build-depends: base >= 4 && < 4.3- if flag(test)- Buildable: True- cpp-options: -DTEST- build-depends: test-framework,- test-framework-quickcheck2,- test-framework-hunit,- HUnit,- wai-test,- QuickCheck >= 2 && < 3- else- Buildable: False+ main-is: runtests.hs+ cpp-options: -DTEST+ build-depends: hspec >= 0.6.1 && < 0.7+ ,wai-test+ ,wai+ ,yesod-core+ ,bytestring+ ,hamlet+ ,shakespeare-css+ ,shakespeare-js+ ,text+ ,http-types+ ,HUnit+ ,QuickCheck >= 2 && < 3 ghc-options: -Wall- main-is: runtests.hs source-repository head type: git- location: git://github.com/snoyberg/yesod-core.git+ location: git://github.com/yesodweb/yesod.git