yesod 0.2.0 → 0.3.0
raw patch · 17 files changed
+866/−390 lines, 17 filesdep +persistentdep +utf8-stringdep −MonadCatchIO-transformersdep −convertible-textdep ~hamletdep ~transformersdep ~web-routes-quasi
Dependencies added: persistent, utf8-string
Dependencies removed: MonadCatchIO-transformers, convertible-text
Dependency ranges changed: hamlet, transformers, web-routes-quasi
Files
- Yesod.hs +3/−7
- Yesod/Content.hs +94/−89
- Yesod/Dispatch.hs +79/−41
- Yesod/Form.hs +5/−6
- Yesod/Formable.hs +319/−0
- Yesod/Hamlet.hs +8/−25
- Yesod/Handler.hs +55/−79
- Yesod/Helpers/AtomFeed.hs +10/−12
- Yesod/Helpers/Auth.hs +26/−28
- Yesod/Helpers/Crud.hs +164/−0
- Yesod/Helpers/Sitemap.hs +6/−6
- Yesod/Helpers/Static.hs +5/−4
- Yesod/Internal.hs +1/−1
- Yesod/Json.hs +42/−52
- Yesod/Request.hs +0/−4
- Yesod/Yesod.hs +40/−19
- yesod.cabal +9/−17
Yesod.hs view
@@ -10,8 +10,8 @@ , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json+ , module Yesod.Formable , Application- , cs , liftIO , Routes ) where@@ -27,15 +27,11 @@ #endif import Yesod.Request-import Yesod.Form+import Yesod.Form hiding (Form)+import Yesod.Formable import Yesod.Yesod import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet-import Data.Convertible.Text (cs)-#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class (liftIO)-#else-import "transformers" Control.Monad.Trans (liftIO)-#endif import Web.Routes.Quasi (Routes)
Yesod/Content.hs view
@@ -9,12 +9,24 @@ module Yesod.Content ( -- * Content Content (..)- , toContent+ , emptyContent+ , ToContent (..) -- * Mime types -- ** Data type- , ContentType (..)- , contentTypeFromString- , contentTypeToString+ , ContentType+ , typeHtml+ , typePlain+ , typeJson+ , typeXml+ , typeAtom+ , typeJpeg+ , typePng+ , typeGif+ , typeJavascript+ , typeCss+ , typeFlv+ , typeOgv+ , typeOctet -- ** File extensions , typeByExt , ext@@ -42,15 +54,17 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text) import qualified Data.Text as T-import Data.Convertible.Text import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -import Data.Function (on) import Data.Time import System.Locale +import qualified Data.Text.Encoding+import qualified Data.Text.Lazy.Encoding+import qualified Data.ByteString.Lazy.UTF8+ #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit@@ -71,23 +85,23 @@ -> a -> IO (Either a a)) -instance ConvertSuccess B.ByteString Content where- convertSuccess bs = ContentEnum $ \f a -> f a bs-instance ConvertSuccess L.ByteString Content where- convertSuccess = swapEnum . WE.fromLBS-instance ConvertSuccess T.Text Content where- convertSuccess t = cs (cs t :: B.ByteString)-instance ConvertSuccess Text Content where- convertSuccess lt = cs (cs lt :: L.ByteString)-instance ConvertSuccess String Content where- convertSuccess s = cs (cs s :: Text)-instance ConvertSuccess (IO Text) Content where- convertSuccess = swapEnum . WE.fromLBS' . fmap cs+emptyContent :: Content+emptyContent = ContentEnum $ \_ -> return . Right --- | A synonym for 'convertSuccess' to make the desired output type explicit.-toContent :: ConvertSuccess x Content => x -> Content-toContent = cs+class ToContent a where+ toContent :: a -> Content +instance ToContent B.ByteString where+ toContent bs = ContentEnum $ \f a -> f a bs+instance ToContent L.ByteString where+ toContent = swapEnum . WE.fromLBS+instance ToContent T.Text where+ toContent = toContent . Data.Text.Encoding.encodeUtf8+instance ToContent Text where+ toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8+instance ToContent String where+ toContent = toContent . Data.ByteString.Lazy.UTF8.fromString+ -- | A function which gives targetted representations of content based on the -- content-types the user accepts. type ChooseRep =@@ -124,7 +138,7 @@ chooseRep = id instance HasReps () where- chooseRep = defChooseRep [(TypePlain, const $ return $ cs "")]+ chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] instance HasReps [(ContentType, Content)] where chooseRep a cts = return $@@ -134,74 +148,68 @@ (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" where- go = simpleContentType . contentTypeToString+ go = simpleContentType newtype RepHtml = RepHtml Content instance HasReps RepHtml where- chooseRep (RepHtml c) _ = return (TypeHtml, c)+ chooseRep (RepHtml c) _ = return (typeHtml, c) newtype RepJson = RepJson Content instance HasReps RepJson where- chooseRep (RepJson c) _ = return (TypeJson, c)+ chooseRep (RepJson c) _ = return (typeJson, c) data RepHtmlJson = RepHtmlJson Content Content instance HasReps RepHtmlJson where chooseRep (RepHtmlJson html json) = chooseRep- [ (TypeHtml, html)- , (TypeJson, json)+ [ (typeHtml, html)+ , (typeJson, json) ] newtype RepPlain = RepPlain Content instance HasReps RepPlain where- chooseRep (RepPlain c) _ = return (TypePlain, c)+ chooseRep (RepPlain c) _ = return (typePlain, c) newtype RepXml = RepXml Content instance HasReps RepXml where- chooseRep (RepXml c) _ = return (TypeXml, c)+ chooseRep (RepXml c) _ = return (typeXml, c) --- | Equality is determined by converting to a 'String' via--- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the--- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not*--- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8--- encoded. See 'contentTypeToString'.-data ContentType =- TypeHtml- | TypePlain- | TypeJson- | TypeXml- | TypeAtom- | TypeJpeg- | TypePng- | TypeGif- | TypeJavascript- | TypeCss- | TypeFlv- | TypeOgv- | TypeOctet- | TypeOther String- deriving (Show)+type ContentType = String --- | This is simply a synonym for 'TypeOther'. However, equality works as--- expected; see 'ContentType'.-contentTypeFromString :: String -> ContentType-contentTypeFromString = TypeOther+typeHtml :: ContentType+typeHtml = "text/html; charset=utf-8" --- | This works as expected, with one caveat: the builtin textual content types--- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of--- their basic content-type. If another encoding is desired, please use--- 'TypeOther'.-contentTypeToString :: ContentType -> String-contentTypeToString TypeHtml = "text/html; charset=utf-8"-contentTypeToString TypePlain = "text/plain; charset=utf-8"-contentTypeToString TypeJson = "application/json; charset=utf-8"-contentTypeToString TypeXml = "text/xml"-contentTypeToString TypeAtom = "application/atom+xml"-contentTypeToString TypeJpeg = "image/jpeg"-contentTypeToString TypePng = "image/png"-contentTypeToString TypeGif = "image/gif"-contentTypeToString TypeJavascript = "text/javascript; charset=utf-8"-contentTypeToString TypeCss = "text/css; charset=utf-8"-contentTypeToString TypeFlv = "video/x-flv"-contentTypeToString TypeOgv = "video/ogg"-contentTypeToString TypeOctet = "application/octet-stream"-contentTypeToString (TypeOther s) = s+typePlain :: ContentType+typePlain = "text/plain; charset=utf-8" +typeJson :: ContentType+typeJson = "application/json; charset=utf-8"++typeXml :: ContentType+typeXml = "text/xml"++typeAtom :: ContentType+typeAtom = "application/atom+xml"++typeJpeg :: ContentType+typeJpeg = "image/jpeg"++typePng :: ContentType+typePng = "image/png"++typeGif :: ContentType+typeGif = "image/gif"++typeJavascript :: ContentType+typeJavascript = "text/javascript; charset=utf-8"++typeCss :: ContentType+typeCss = "text/css; charset=utf-8"++typeFlv :: ContentType+typeFlv = "video/x-flv"++typeOgv :: ContentType+typeOgv = "video/ogg"++typeOctet :: ContentType+typeOctet = "application/octet-stream"+ -- | Removes \"extra\" information at the end of a content type string. In -- particular, removes everything after the semicolon, if present. --@@ -210,22 +218,19 @@ simpleContentType :: String -> String simpleContentType = fst . span (/= ';') -instance Eq ContentType where- (==) = (==) `on` contentTypeToString- -- | Determine a mime-type based on the file extension. typeByExt :: String -> ContentType-typeByExt "jpg" = TypeJpeg-typeByExt "jpeg" = TypeJpeg-typeByExt "js" = TypeJavascript-typeByExt "css" = TypeCss-typeByExt "html" = TypeHtml-typeByExt "png" = TypePng-typeByExt "gif" = TypeGif-typeByExt "txt" = TypePlain-typeByExt "flv" = TypeFlv-typeByExt "ogv" = TypeOgv-typeByExt _ = TypeOctet+typeByExt "jpg" = typeJpeg+typeByExt "jpeg" = typeJpeg+typeByExt "js" = typeJavascript+typeByExt "css" = typeCss+typeByExt "html" = typeHtml+typeByExt "png" = typePng+typeByExt "gif" = typeGif+typeByExt "txt" = typePlain+typeByExt "flv" = typeFlv+typeByExt "ogv" = typeOgv+typeByExt _ = typeOctet -- | Get a file extension (everything after last period). ext :: String -> String@@ -246,8 +251,8 @@ caseTypeByExt :: Assertion caseTypeByExt = do- TypeJavascript @=? typeByExt (ext "foo.js")- TypeHtml @=? typeByExt (ext "foo.html")+ typeJavascript @=? typeByExt (ext "foo.js")+ typeHtml @=? typeByExt (ext "foo.html") #endif -- | Format a 'UTCTime' in W3 format; useful for setting cookies.
Yesod/Dispatch.hs view
@@ -33,7 +33,6 @@ import Language.Haskell.TH.Syntax import qualified Network.Wai as W-import qualified Network.Wai.Enumerator as W import Network.Wai.Middleware.CleanPath import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip@@ -45,17 +44,20 @@ import qualified Data.ByteString.Char8 as B import Web.Routes (encodePathInfo) +import qualified Data.ByteString.UTF8 as S+ import Control.Concurrent.MVar import Control.Arrow ((***))-import Data.Convertible.Text (cs) import Data.Time import Control.Monad import Data.Maybe import Web.ClientSession+import qualified Web.ClientSession as CS import Data.Serialize+import qualified Data.Serialize as Ser import Network.Wai.Parse #if TEST@@ -76,7 +78,7 @@ mkYesod :: String -- ^ name of the argument datatype -> [Resource] -> Q [Dec]-mkYesod name = fmap (\(x, y) -> x ++ y) . mkYesodGeneral name [] False+mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating subsites, *not* sites. See 'mkYesod' for the latter.@@ -84,11 +86,13 @@ -- executable by itself, but instead provides functionality to -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype- -> [Name] -- ^ a list of classes the master datatype must be an instance of+ -> [(String, [Name])] -> [Resource] -> Q [Dec] mkYesodSub name clazzes =- fmap (\(x, y) -> x ++ y) . mkYesodGeneral name clazzes True+ fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True+ where+ (name':rest) = words name -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a@@ -96,7 +100,7 @@ -- 'mkYesodDispatch', do just that. mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData name res = do- (x, _) <- mkYesodGeneral name [] False res+ (x, _) <- mkYesodGeneral name [] [] False res let rname = mkName $ "resources" ++ name eres <- liftResources res let y = [ SigD rname $ ListT `AppT` ConT ''Resource@@ -106,7 +110,7 @@ -- | See 'mkYesodData'. mkYesodDispatch :: String -> [Resource] -> Q [Dec]-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False explodeHandler :: HasReps c => GHandler sub master c@@ -120,25 +124,44 @@ -> YesodApp explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f -mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q ([Dec], [Dec])-mkYesodGeneral name clazzes isSub res = do+mkYesodGeneral :: String -- ^ argument name+ -> [String] -- ^ parameters for site argument+ -> [(String, [Name])] -- ^ classes+ -> Bool -- ^ is subsite?+ -> [Resource]+ -> Q ([Dec], [Dec])+mkYesodGeneral name args clazzes isSub res = do let name' = mkName name+ args' = map mkName args+ arg = foldl AppT (ConT name') $ map VarT args' let site = mkName $ "site" ++ name let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']+ let clazzes' = compact+ $ map (\x -> (x, [])) ("master" : args) +++ clazzes explode <- [|explodeHandler|] QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp- , crArgument = ConT $ mkName name+ , crArgument = arg , crExplode = explode , crResources = res , crSite = site- , crMaster = if isSub then Right clazzes else Left (ConT name')+ , crMaster = if isSub+ then Right clazzes'+ else Left (ConT name') } return ([w, x], (if isSub then id else (:) yes) [y, z]) +compact :: [(String, [a])] -> [(String, [a])]+compact [] = []+compact ((x, x'):rest) =+ let ys = filter (\(y, _) -> y == x) rest+ zs = filter (\(z, _) -> z /= x) rest+ in (x, x' ++ concatMap snd ys) : compact zs+ sessionName :: String sessionName = "_SESSION" @@ -176,14 +199,18 @@ (urlRenderOverride y u) rr <- parseWaiRequest env session' onRequest y rr- let ya = case eurl of- Left _ -> runHandler (errorHandler y NotFound)- render- Nothing- id- y- id- Right url -> quasiDispatch site+ ya <-+ case eurl of+ Left _ -> return $ runHandler (errorHandler y NotFound)+ render+ Nothing+ id+ y+ id+ Right url -> do+ auth <- isAuthorized y url+ case auth of+ Nothing -> return $ quasiDispatch site render url id@@ -191,19 +218,26 @@ id (badMethodApp method) method+ Just msg ->+ return $ runHandler+ (errorHandler y $ PermissionDenied msg)+ render+ (Just url)+ id+ y+ id let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName- (cs sessionVal)+ (S.toString sessionVal) : hs hs'' = map (headerToPair getExpires) hs'- hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs''+ hs''' = (W.ContentType, S.fromString ct) : hs'' return $ W.Response s hs''' $ case c of ContentFile fp -> Left fp- ContentEnum e -> Right $ W.buffer- $ W.Enumerator e+ ContentEnum e -> Right $ W.Enumerator e -- | Fully render a route to an absolute URL. Since Yesod does this for you -- internally, you will rarely need access to this. However, if you need to@@ -219,7 +253,7 @@ ar ++ '/' : encodePathInfo (fixSegs $ render route) httpAccept :: W.Request -> [ContentType]-httpAccept = map (contentTypeFromString . B.unpack)+httpAccept = map B.unpack . parseHttpAccept . fromMaybe B.empty . lookup W.Accept@@ -252,11 +286,13 @@ -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do- let gets' = map (cs *** cs) $ parseQueryString $ W.queryString env- let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env- cookies' = map (cs *** cs) $ parseCookies reqCookie+ let gets' = map (S.toString *** S.toString)+ $ parseQueryString $ W.queryString env+ let reqCookie = fromMaybe B.empty $ lookup W.Cookie+ $ W.requestHeaders env+ cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env- langs = map cs $ maybe [] parseHttpAccept acceptLang+ langs = map S.toString $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey cookies' of Nothing -> langs Just x -> x : langs@@ -268,8 +304,9 @@ rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where- fix1 = map (cs *** cs)- fix2 (x, FileInfo a b c) = (cs x, FileInfo (cs a) (cs b) c)+ fix1 = map (S.toString *** S.toString)+ fix2 (x, FileInfo a b c) =+ (S.toString x, FileInfo a b c) -- | Produces a \"compute on demand\" value. The computation will be run once -- it is requested, and then the result will be stored. This will happen only@@ -290,14 +327,16 @@ -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes- in (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="+ in (W.SetCookie, S.fromString+ $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) =- (W.SetCookie, cs $+ (W.SetCookie, S.fromString $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")-headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value)+headerToPair _ (Header key value) =+ (W.responseHeaderFromBS $ S.fromString key, S.fromString value) -encodeSession :: Key+encodeSession :: CS.Key -> UTCTime -- ^ expire time -> B.ByteString -- ^ remote host -> [(String, String)] -- ^ session@@ -305,7 +344,7 @@ encodeSession key expire rhost session' = encrypt key $ encode $ SessionCookie expire rhost session' -decodeSession :: Key+decodeSession :: CS.Key -> UTCTime -- ^ current time -> B.ByteString -- ^ remote host field -> B.ByteString -- ^ cookie value@@ -324,8 +363,8 @@ put (SessionCookie a b c) = putTime a >> put b >> put c get = do a <- getTime- b <- get- c <- get+ b <- Ser.get+ c <- Ser.get return $ SessionCookie a b c putTime :: Putter UTCTime@@ -336,8 +375,8 @@ getTime :: Get UTCTime getTime = do- d <- get- ndt <- get+ d <- Ser.get+ ndt <- Ser.get return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 #if TEST@@ -355,8 +394,7 @@ let expire = addUTCTime 1 now let rhost = B.pack "some host" let val = encodeSession key expire rhost session'- return $ Just session' ==- decodeSession key now rhost (B.pack val)+ return $ Just session' == decodeSession key now rhost val propGetPutTime :: UTCTime -> Bool propGetPutTime t = Right t == runGet getTime (runPut $ putTime t)
Yesod/Form.hs view
@@ -24,13 +24,8 @@ import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day)-import Data.Convertible.Text import Data.Maybe (fromMaybe)-#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class-#else-import "transformers" Control.Monad.Trans-#endif import Yesod.Internal import Control.Monad.Attempt @@ -111,7 +106,11 @@ else Right pv checkDay :: Form ParamValue -> Form Day-checkDay = applyForm $ attempt (const (Left "Invalid day")) Right . ca+checkDay = applyForm $ maybe (Left "Invalid day") Right . readMay+ where+ readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing checkBool :: Form [ParamValue] -> Form Bool checkBool = applyForm $ \pv -> Right $ case pv of
+ Yesod/Formable.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Yesod.Formable+ ( Form (..)+ , Formlet+ , FormResult (..)+ , runForm+ , incr+ , Formable (..)+ , deriveFormable+ , share2+ , wrapperRow+ , sealFormlet+ , sealForm+ , Slug (..)+ , sealRow+ , check+ ) where++import Text.Hamlet+import Data.Time (Day)+import Control.Applicative+import Database.Persist (PersistField)+import Database.Persist.Helper (EntityDef (..))+import Data.Char (isAlphaNum, toUpper, isUpper)+import Language.Haskell.TH.Syntax+import Control.Monad (liftM, join)+import Control.Arrow (first)+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid (mempty, mappend)+import qualified Data.ByteString.Lazy.UTF8+import Yesod.Request+import Yesod.Handler+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.State+import Web.Routes.Quasi (Routes, SinglePiece)+import Data.Int (Int64)++sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b+sealRow label getVal val =+ sealForm (wrapperRow label) $ formable $ fmap getVal val++runForm :: Form sub y a+ -> GHandler sub y (FormResult a, Hamlet (Routes y))+runForm f = do+ req <- getRequest+ (pp, _) <- liftIO $ reqRequestBody req+ evalStateT (deform f pp) 1++type Env = [(String, String)]++type Incr = StateT Int++incr :: Monad m => Incr m Int+incr = do+ i <- get+ let i' = i + 1+ put i'+ return i'++data FormResult a = FormMissing+ | FormFailure [String]+ | FormSuccess a+instance Functor FormResult where+ fmap _ FormMissing = FormMissing+ fmap _ (FormFailure errs) = FormFailure errs+ fmap f (FormSuccess a) = FormSuccess $ f a+instance Applicative FormResult where+ pure = FormSuccess+ (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g+ (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y+ (FormFailure x) <*> _ = FormFailure x+ _ <*> (FormFailure y) = FormFailure y+ _ <*> _ = FormMissing++newtype Form sub y a = Form+ { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))+ }+type Formlet sub y a = Maybe a -> Form sub y a++instance Functor (Form sub url) where+ fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)++instance Applicative (Form sub url) where+ pure a = Form $ const $ return (pure a, mempty)+ (Form f) <*> (Form g) = Form $ \env -> do+ (f1, f2) <- f env+ (g1, g2) <- g env+ return (f1 <*> g1, f2 `mappend` g2)++sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))+ -> Form sub y a -> Form sub y a+sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)+ where+ go (res, xml) = (res, wrapper (toList res) xml)+ toList (FormFailure errs) = errs+ toList _ = []++sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))+ -> Formlet sub y a -> Formlet sub y a+sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal++input' :: (String -> String -> Hamlet (Routes y))+ -> Maybe String+ -> Form sub y String+input' mkXml val = Form $ \env -> do+ i <- incr+ let i' = show i+ let param = lookup i' env+ let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param+ return (maybe FormMissing FormSuccess param, xml)++check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b+check (Form form) f = Form $ \env -> liftM (first go) (form env)+ where+ go FormMissing = FormMissing+ go (FormFailure x) = FormFailure x+ go (FormSuccess a) =+ case f a of+ Left errs -> FormFailure errs+ Right b -> FormSuccess b++class Formable a where+ formable :: Formlet sub master a++wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url+wrapperRow label errs control = [$hamlet|+%tr+ %th $string.label$+ %td ^control^+ $if not.null.errs+ %td.errors+ %ul+ $forall errs err+ %li $string.err$+|]++instance Formable String where+ formable x = input' go x `check` notEmpty+ where+ go name val = [$hamlet|+%input!type=text!name=$string.name$!value=$string.val$+|]+ notEmpty s+ | null s = Left ["Value required"]+ | otherwise = Right s++instance Formable (Maybe String) where+ formable x = input' go (join x) `check` isEmpty+ where+ go name val = [$hamlet|+%input!type=text!name=$string.name$!value=$string.val$+|]+ isEmpty s+ | null s = Right Nothing+ | otherwise = Right $ Just s++instance Formable (Html ()) where+ formable = fmap preEscapedString+ . input' go+ . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)+ where+ go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]++instance Formable Day where+ formable x = input' go (fmap show x) `check` asDay+ where+ go name val = [$hamlet|+%input!type=date!name=$string.name$!value=$string.val$+|]+ asDay s = case reads s of+ (y, _):_ -> Right y+ [] -> Left ["Invalid day"]++instance Formable Int64 where+ formable x = input' go (fmap show x) `check` asInt+ where+ go name val = [$hamlet|+%input!type=number!name=$string.name$!value=$string.val$+|]+ asInt s = case reads s of+ (y, _):_ -> Right y+ [] -> Left ["Invalid integer"]++instance Formable Double where+ formable x = input' go (fmap numstring x) `check` asDouble+ where+ go name val = [$hamlet|+%input!type=number!name=$string.name$!value=$string.val$+|]+ asDouble s = case reads s of+ (y, _):_ -> Right y+ [] -> Left ["Invalid double"]+ numstring d =+ let s = show d+ in case reverse s of+ '0':'.':y -> reverse y+ _ -> s++instance Formable (Maybe Day) where+ formable x = input' go (fmap show $ join x) `check` asDay+ where+ go name val = [$hamlet|+%input!type=date!name=$string.name$!value=$string.val$+|]+ asDay "" = Right Nothing+ asDay s = case reads s of+ (y, _):_ -> Right $ Just y+ [] -> Left ["Invalid day"]++instance Formable (Maybe Int) where+ formable x = input' go (fmap show $ join x) `check` asInt+ where+ go name val = [$hamlet|+%input!type=number!name=$string.name$!value=$string.val$+|]+ asInt "" = Right Nothing+ asInt s = case reads s of+ (y, _):_ -> Right $ Just y+ [] -> Left ["Invalid integer"]++instance Formable (Maybe Int64) where+ formable x = input' go (fmap show $ join x) `check` asInt+ where+ go name val = [$hamlet|+%input!type=number!name=$string.name$!value=$string.val$+|]+ asInt "" = Right Nothing+ asInt s = case reads s of+ (y, _):_ -> Right $ Just y+ [] -> Left ["Invalid integer"]++instance Formable Bool where+ formable x = Form $ \env -> do+ i <- incr+ let i' = show i+ let param = lookup i' env+ let def = if null env then fromMaybe False x else isJust param+ return (FormSuccess $ isJust param, go i' def)+ where+ go name val = [$hamlet|+%input!type=checkbox!name=$string.name$!:val:checked+|]++instance Formable Int where+ formable x = input' go (fmap show x) `check` asInt+ where+ go name val = [$hamlet|+%input!type=number!name=$string.name$!value=$string.val$+|]+ asInt s = case reads s of+ (y, _):_ -> Right y+ [] -> Left ["Invalid integer"]++newtype Slug = Slug { unSlug :: String }+ deriving (Read, Eq, Show, SinglePiece, PersistField)++instance Formable Slug where+ formable x = input' go (fmap unSlug x) `check` asSlug+ where+ go name val = [$hamlet|+%input!type=text!name=$string.name$!value=$string.val$+|]+ asSlug [] = Left ["Slug must be non-empty"]+ asSlug x'+ | all (\c -> c `elem` "-_" || isAlphaNum c) x' =+ Right $ Slug x'+ | otherwise = Left ["Slug must be alphanumeric, - and _"]++share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+share2 f g a = do+ f' <- f a+ g' <- g a+ return $ f' ++ g'++deriveFormable :: [EntityDef] -> Q [Dec]+deriveFormable = mapM derive+ where+ derive :: EntityDef -> Q Dec+ derive t = do+ let fst3 (x, _, _) = x+ let cols = map (toLabel . fst3) $ entityColumns t+ ap <- [|(<*>)|]+ just <- [|pure|]+ nothing <- [|Nothing|]+ let just' = just `AppE` ConE (mkName $ entityName t)+ let c1 = Clause [ ConP (mkName "Nothing") []+ ]+ (NormalB $ go ap just' $ zip cols $ map (const nothing) cols)+ []+ xs <- mapM (const $ newName "x") cols+ let xs' = map (AppE just . VarE) xs+ let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)+ $ map VarP xs]]+ (NormalB $ go ap just' $ zip cols xs')+ []+ return $ InstanceD [] (ConT ''Formable+ `AppT` ConT (mkName $ entityName t))+ [FunD (mkName "formable") [c1, c2]]+ go ap just' = foldl (ap' ap) just' . map go'+ go' (label, ex) =+ VarE (mkName "sealForm") `AppE`+ (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`+ (VarE (mkName "formable") `AppE` ex)+ ap' ap x y = InfixE (Just x) ap (Just y)++toLabel :: String -> String+toLabel "" = ""+toLabel (x:rest) = toUpper x : go rest+ where+ go "" = ""+ go (c:cs)+ | isUpper c = ' ' : c : go cs+ | otherwise = c : go cs
Yesod/Hamlet.hs view
@@ -5,10 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet ( -- * Hamlet library- Hamlet- , hamlet- , HtmlContent (..)- , htmlContentToText+ module Text.Hamlet -- * Convert to something displayable , hamletToContent , hamletToRepHtml@@ -18,41 +15,27 @@ where import Text.Hamlet-import Text.Hamlet.Monad (outputHtml, htmlContentToText) import Yesod.Content import Yesod.Handler-import Data.Convertible.Text import Web.Routes.Quasi (Routes) -- | 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 IO ()+-- > PageContent url -> Hamlet url data PageContent url = PageContent- { pageTitle :: HtmlContent- , pageHead :: Hamlet url IO ()- , pageBody :: Hamlet url IO ()+ { pageTitle :: Html ()+ , pageHead :: Hamlet url+ , pageBody :: Hamlet url } -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'.-hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content+hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRender- return $ ContentEnum $ go render- where- go render iter seed = do- res <- runHamlet h render seed $ iter' iter- case res of- Left x -> return $ Left x- Right ((), x) -> return $ Right x- iter' iter seed text = iter seed $ cs text+ return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-hamletToRepHtml :: Hamlet (Routes master) IO () -> GHandler sub master RepHtml+hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent--instance Monad m => ConvertSuccess String (Hamlet url m ()) where- convertSuccess = outputHtml . Unencoded . cs-instance ConvertSuccess String HtmlContent where- convertSuccess = Unencoded . cs
Yesod/Handler.hs view
@@ -70,27 +70,23 @@ import Yesod.Internal import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate)-import Text.Hamlet.Monad (htmlContentToText) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E import Control.Applicative -#if MIN_VERSION_transformers(0,2,0)-import "transformers" Control.Monad.IO.Class-#else-import "transformers" Control.Monad.Trans-#endif-import qualified Control.Monad.CatchIO as C-import Control.Monad.CatchIO (catch)-import Control.Monad (liftM, ap)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Cont import System.IO-import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W import Control.Monad.Attempt+import Data.ByteString.UTF8 (toString)+import qualified Data.ByteString.Lazy.UTF8 as L -import Data.Convertible.Text (cs) import Text.Hamlet import Numeric (showIntAtBase) import Data.Char (ord, chr)@@ -107,11 +103,16 @@ -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of reader for basic arguments, a writer -- for headers, and an error-type monad for handling special responses.-newtype GHandler sub master a = Handler {- unHandler :: HandlerData sub master- -> IO ([Header], [(String, Maybe String)], HandlerContents a)-}+type GHandler sub master =+ ReaderT (HandlerData sub master) (+ ContT HandlerContents (+ WriterT (Endo [Header]) (+ WriterT (Endo [(String, Maybe String)]) (+ IO+ )))) +type Endo a = a -> a+ -- | A 'GHandler' limited to the case where the master and sub sites are the -- same. This is the usual case for application writing; only code written -- specifically as a subsite need been concerned with the more general variety.@@ -128,67 +129,38 @@ -> IO (W.Status, [Header], ContentType, Content, [(String, String)]) } -data HandlerContents a =- HCContent a+data HandlerContents =+ HCContent ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String -instance Functor (GHandler sub master) where- fmap = liftM-instance Applicative (GHandler sub master) where- pure = return- (<*>) = ap-instance Monad (GHandler sub master) where- fail = failure . InternalError -- We want to catch all exceptions anyway- return x = Handler $ \_ -> return ([], [], HCContent x)- (Handler handler) >>= f = Handler $ \rr -> do- (headers, session', c) <- handler rr- (headers', session'', c') <-- case c of- HCContent a -> unHandler (f a) rr- HCError e -> return ([], [], HCError e)- HCSendFile ct fp -> return ([], [], HCSendFile ct fp)- HCRedirect rt url -> return ([], [], HCRedirect rt url)- return (headers ++ headers', session' ++ session'', c')-instance MonadIO (GHandler sub master) where- liftIO i = Handler $ \_ -> i >>= \i' -> return ([], [], HCContent i')-instance C.MonadCatchIO (GHandler sub master) where- catch (Handler m) f =- Handler $ \d -> E.catch (m d) (\e -> unHandler (f e) d)- block (Handler m) =- Handler $ E.block . m- unblock (Handler m) =- Handler $ E.unblock . m instance Failure ErrorResponse (GHandler sub master) where- failure e = Handler $ \_ -> return ([], [], HCError e)+ failure = lift . ContT . const . return . HCError instance RequestReader (GHandler sub master) where- getRequest = handlerRequest <$> getData--getData :: GHandler sub master (HandlerData sub master)-getData = Handler $ \r -> return ([], [], HCContent r)+ getRequest = handlerRequest <$> ask -- | Get the sub application argument. getYesodSub :: GHandler sub master sub-getYesodSub = handlerSub <$> getData+getYesodSub = handlerSub <$> ask -- | Get the master site appliation argument. getYesod :: GHandler sub master master-getYesod = handlerMaster <$> getData+getYesod = handlerMaster <$> ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Routes master -> String)-getUrlRender = handlerRender <$> getData+getUrlRender = handlerRender <$> ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getRoute :: GHandler sub master (Maybe (Routes sub))-getRoute = handlerRoute <$> getData+getRoute = handlerRoute <$> ask -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: GHandler sub master (Routes sub -> Routes master)-getRouteToMaster = handlerToMaster <$> getData+getRouteToMaster = handlerToMaster <$> ask modifySession :: [(String, String)] -> (String, Maybe String) -> [(String, String)]@@ -214,32 +186,36 @@ let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String)- (headers, session', contents) <- E.catch- (unHandler handler HandlerData+ let hd = HandlerData { handlerRequest = rr , handlerSub = tosa ma , handlerMaster = ma , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr- })- (\e -> return ([], [], HCError $ toErrorHandler e))- let finalSession = foldl' modifySession (reqSession rr) session'+ }+ ((contents, headers), session') <- E.catch (+ runWriterT+ $ runWriterT+ $ flip runContT (return . HCContent . chooseRep)+ $ flip runReaderT hd handler+ ) (\e -> return ((HCError $ toErrorHandler e, id), id))+ let finalSession = foldl' modifySession (reqSession rr) $ session' [] let handleError e = do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts- let hs' = headers ++ hs+ let hs' = headers hs return (getStatus e, hs', ct, c, sess)- let sendFile' ct fp = do- c <- BL.readFile fp- return (W.Status200, headers, ct, cs c, finalSession)+ let sendFile' ct fp =+ return (W.Status200, headers [], ct, ContentFile fp, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts- return (W.Status200, headers, ct, c, finalSession)+ return (W.Status200, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do- let hs = Header "Location" loc : headers- return (getRedirectStatus rt, hs, TypePlain, cs "", finalSession)+ let hs = Header "Location" loc : headers []+ return (getRedirectStatus rt, hs, typePlain, emptyContent,+ finalSession) HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler)@@ -247,7 +223,7 @@ safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er- return (W.Status500, [], TypePlain, cs "Internal Server Error", [])+ return (W.Status500, [], typePlain, toContent "Internal Server Error", []) -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a@@ -274,7 +250,7 @@ | c == ' ' = "+" | otherwise = '%' : myShowHex (ord c) "" myShowHex :: Int -> ShowS- myShowHex n r = case showIntAtBase 16 (toChrHex) n r of+ myShowHex n r = case showIntAtBase 16 toChrHex n r of [] -> "00" [c] -> ['0',c] s -> s@@ -284,7 +260,7 @@ -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a-redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url)+redirectString rt url = lift $ ContT $ const $ return $ HCRedirect rt url ultDestKey :: String ultDestKey = "_ULT"@@ -330,24 +306,24 @@ -- | Sets a message in the user's session. -- -- See 'getMessage'.-setMessage :: HtmlContent -> GHandler sub master ()-setMessage = setSession msgKey . cs . htmlContentToText+setMessage :: Html () -> GHandler sub master ()+setMessage = setSession msgKey . L.toString . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. -- -- See 'setMessage'.-getMessage :: GHandler sub master (Maybe HtmlContent)+getMessage :: GHandler sub master (Maybe (Html ())) getMessage = do clearSession msgKey- fmap (fmap $ Encoded . cs) $ lookupSession msgKey+ fmap (fmap preEscapedString) $ lookupSession msgKey -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a-sendFile ct fp = Handler $ \_ -> return ([], [], HCSendFile ct fp)+sendFile ct fp = lift $ ContT $ const $ return $ HCSendFile ct fp -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a@@ -357,11 +333,11 @@ badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest- failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w+ failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => m a-permissionDenied = failure PermissionDenied+permissionDenied = failure $ PermissionDenied "Permission denied" -- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a@@ -395,20 +371,20 @@ setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master ()-setSession k v = Handler $ \_ -> return ([], [(k, Just v)], HCContent ())+setSession k v = lift . lift . lift . tell $ (:) (k, Just v) -- | Unsets a session variable. See 'setSession'. clearSession :: String -> GHandler sub master ()-clearSession k = Handler $ \_ -> return ([], [(k, Nothing)], HCContent ())+clearSession k = lift . lift . lift . tell $ (:) (k, Nothing) addHeader :: Header -> GHandler sub master ()-addHeader h = Handler $ \_ -> return ([h], [], HCContent ())+addHeader = lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 getStatus (InternalError _) = W.Status500 getStatus (InvalidArgs _) = W.Status400-getStatus PermissionDenied = W.Status403+getStatus (PermissionDenied _) = W.Status403 getStatus (BadMethod _) = W.Status405 getRedirectStatus :: RedirectType -> W.Status
Yesod/Helpers/AtomFeed.hs view
@@ -24,12 +24,10 @@ import Yesod import Data.Time.Clock (UTCTime)-import Text.Hamlet.Monad-import Text.Hamlet.Quasi newtype RepAtom = RepAtom Content instance HasReps RepAtom where- chooseRep (RepAtom c) _ = return (TypeAtom, c)+ chooseRep (RepAtom c) _ = return (typeAtom, c) atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom atomFeed = fmap RepAtom . hamletToContent . template@@ -46,31 +44,31 @@ { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String- , atomEntryContent :: HtmlContent+ , atomEntryContent :: Html () } -xmlns :: AtomFeed url -> HtmlContent-xmlns _ = cs "http://www.w3.org/2005/Atom"+xmlns :: AtomFeed url -> Html ()+xmlns _ = preEscapedString "http://www.w3.org/2005/Atom" -template :: AtomFeed url -> Hamlet url IO ()+template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| <?xml version="1.0" encoding="utf-8"?> %feed!xmlns=$xmlns.arg$- %title $cs.atomTitle.arg$+ %title $string.atomTitle.arg$ %link!rel=self!href=@atomLinkSelf.arg@ %link!href=@atomLinkHome.arg@- %updated $cs.formatW3.atomUpdated.arg$+ %updated $string.formatW3.atomUpdated.arg$ %id @atomLinkHome.arg@ $forall atomEntries.arg entry ^entryTemplate.entry^ |] -entryTemplate :: AtomFeedEntry url -> Hamlet url IO ()+entryTemplate :: AtomFeedEntry url -> Hamlet url entryTemplate arg = [$xhamlet| %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@- %updated $cs.formatW3.atomEntryUpdated.arg$- %title $cs.atomEntryTitle.arg$+ %updated $string.formatW3.atomEntryUpdated.arg$+ %title $string.atomEntryTitle.arg$ %content!type=html $cdata.atomEntryContent.arg$ |]
Yesod/Helpers/Auth.hs view
@@ -49,6 +49,8 @@ import Control.Concurrent.MVar import System.IO import Control.Monad.Attempt+import Data.Monoid (mempty)+import Data.ByteString.Lazy.UTF8 (fromString) class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other@@ -130,14 +132,14 @@ -- | Retrieves user credentials, if user is authenticated. maybeCreds :: RequestReader r => r (Maybe Creds) maybeCreds = do- mcs <- lookupSession credsKey- return $ mcs >>= readMay+ mstring <- lookupSession credsKey+ return $ mstring >>= readMay where readMay x = case reads x of (y, _):_ -> Just y _ -> Nothing -mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|+mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET@@ -165,7 +167,7 @@ (x:_) -> setUltDestString x rtom <- getRouteToMaster message <- getMessage- applyLayout "Log in via OpenID" (return ()) [$hamlet|+ applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForward@@@ -187,7 +189,7 @@ res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt (\err -> do- setMessage $ cs $ show err+ setMessage $ string $ show err redirect RedirectTemporary $ toMaster OpenIdR) (redirectString RedirectTemporary) res@@ -200,7 +202,7 @@ res <- runAttemptT $ OpenId.authenticate gets' toMaster <- getRouteToMaster let onFailure err = do- setMessage $ cs $ show err+ setMessage $ string $ show err redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do y <- getYesod@@ -247,20 +249,19 @@ getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do creds <- maybeCreds- applyLayoutJson "Authentication Status"- (return ()) (html creds) (json creds)+ applyLayoutJson "Authentication Status" mempty (html creds) (json creds) where html creds = [$hamlet| %h1 Authentication Status $if isNothing.creds %p Not logged in $maybe creds c- %p Logged in as $cs.credsIdent.c$+ %p Logged in as $string.credsIdent.c$ |] json creds = jsonMap- [ ("ident", jsonScalar $ maybe (cs "") (cs . credsIdent) creds)- , ("displayName", jsonScalar $ cs $ fromMaybe ""+ [ ("ident", jsonScalar $ maybe (string "") (string . credsIdent) creds)+ , ("displayName", jsonScalar $ string $ fromMaybe "" $ creds >>= credsDisplayName) ] @@ -289,7 +290,7 @@ getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster- applyLayout "Register a new account" (return ()) [$hamlet|+ applyLayout "Register a new account" mempty [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.EmailRegisterR@ %label!for=email E-mail@@ -300,7 +301,7 @@ postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings- email <- runFormPost $ checkEmail $ required $ input "email"+ email <- runFormPost $ notEmpty $ required $ input "email" -- FIXME checkEmail y <- getYesod mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <-@@ -314,13 +315,10 @@ tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey liftIO $ sendVerifyEmail ae email verKey verUrl- applyLayout "Confirmation e-mail sent" (return ()) [$hamlet|-%p A confirmation e-mail has been sent to $cs.email$.+ applyLayout "Confirmation e-mail sent" mempty [$hamlet|+%p A confirmation e-mail has been sent to $string.email$. |] -checkEmail :: Form ParamValue -> Form ParamValue-checkEmail = notEmpty -- FIXME consider including e-mail validation- getEmailVerifyR :: YesodAuth master => Integer -> String -> GHandler Auth master RepHtml getEmailVerifyR lid key = do@@ -333,7 +331,7 @@ setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR- _ -> applyLayout "Invalid verification key" (return ()) [$hamlet|+ _ -> applyLayout "Invalid verification key" mempty [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -342,7 +340,7 @@ _ae <- getAuthEmailSettings toMaster <- getRouteToMaster msg <- getMessage- applyLayout "Login" (return ()) [$hamlet|+ applyLayout "Login" mempty [$hamlet| $maybe msg ms %p.message $ms$ %p Please log in to your account.@@ -367,7 +365,7 @@ postEmailLoginR = do ae <- getAuthEmailSettings (email, pass) <- runFormPost $ (,)- <$> checkEmail (required $ input "email")+ <$> notEmpty (required $ input "email") -- FIXME valid e-mail? <*> required (input "password") y <- getYesod mecreds <- liftIO $ getEmailCreds ae email@@ -381,7 +379,7 @@ setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] redirectUltDest RedirectTemporary $ defaultDest y Nothing -> do- setMessage $ cs "Invalid email/password combination"+ setMessage $ string "Invalid email/password combination" toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailLoginR @@ -393,10 +391,10 @@ case mcreds of Just (Creds _ AuthEmail _ _ (Just _)) -> return () _ -> do- setMessage $ cs "You must be logged in to set a password"+ setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR msg <- getMessage- applyLayout "Set password" (return ()) [$hamlet|+ applyLayout "Set password" mempty [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password@@ -423,17 +421,17 @@ <*> notEmpty (required $ input "confirm") toMaster <- getRouteToMaster when (new /= confirm) $ do- setMessage $ cs "Passwords did not match, please try again"+ setMessage $ string "Passwords did not match, please try again" redirect RedirectTemporary $ toMaster EmailPasswordR mcreds <- maybeCreds lid <- case mcreds of Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid _ -> do- setMessage $ cs "You must be logged in to set a password"+ setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR salted <- liftIO $ saltPass new liftIO $ setPassword ae lid salted- setMessage $ cs "Password updated"+ setMessage $ string "Password updated" redirect RedirectTemporary $ toMaster EmailLoginR saltLength :: Int@@ -453,7 +451,7 @@ return $ saltPass' salt pass saltPass' :: String -> String -> String-saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass)+saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) inMemoryEmailSettings :: IO AuthEmailSettings inMemoryEmailSettings = do
+ Yesod/Helpers/Crud.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}+module Yesod.Helpers.Crud+ ( Item (..)+ , Crud (..)+ , CrudRoutes (..)+ , defaultCrud+ , siteCrud+ ) where++import Yesod.Yesod+import Yesod.Dispatch+import Yesod.Content+import Yesod.Handler+import Text.Hamlet+import Yesod.Formable+import Data.Monoid (mempty)++class Formable a => Item a where+ itemTitle :: a -> String++data Crud master item = Crud+ { crudSelect :: GHandler (Crud master item) master [(Key item, item)]+ , crudReplace :: Key item -> item -> GHandler (Crud master item) master ()+ , crudInsert :: item -> GHandler (Crud master item) master (Key item)+ , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)+ , crudDelete :: Key item -> GHandler (Crud master item) master ()+ }++mkYesodSub "Crud master item"+ [ ("master", [''Yesod])+ , ("item", [''Item])+ , ("Key item", [''SinglePiece])+ ] [$parseRoutes|+/ CrudListR GET+/add CrudAddR GET POST+/edit/#String CrudEditR GET POST+/delete/#String CrudDeleteR GET POST+|]++getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))+ => GHandler (Crud master item) master RepHtml+getCrudListR = do+ items <- getYesodSub >>= crudSelect+ toMaster <- getRouteToMaster+ applyLayout "Items" mempty [$hamlet|+%h1 Items+%ul+ $forall items item+ %li+ %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@+ $string.itemTitle.snd.item$+%p+ %a!href=@toMaster.CrudAddR@ Add new item+|]++getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item))+ => GHandler (Crud master item) master RepHtml+getCrudAddR = crudHelper+ "Add new"+ (Nothing :: Maybe (Key item, item))+ False++postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item))+ => GHandler (Crud master item) master RepHtml+postCrudAddR = crudHelper+ "Add new"+ (Nothing :: Maybe (Key item, item))+ True++getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item))+ => String -> GHandler (Crud master item) master RepHtml+getCrudEditR s = do+ itemId <- maybe notFound return $ itemReadId s+ crud <- getYesodSub+ item <- crudGet crud itemId >>= maybe notFound return+ crudHelper+ "Edit item"+ (Just (itemId, item))+ False++postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item))+ => String -> GHandler (Crud master item) master RepHtml+postCrudEditR s = do+ itemId <- maybe notFound return $ itemReadId s+ crud <- getYesodSub+ item <- crudGet crud itemId >>= maybe notFound return+ crudHelper+ "Edit item"+ (Just (itemId, item))+ False++getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))+ => String -> GHandler (Crud master item) master RepHtml+getCrudDeleteR s = do+ itemId <- maybe notFound return $ itemReadId s+ crud <- getYesodSub+ item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists+ toMaster <- getRouteToMaster+ applyLayout "Confirm delete" mempty [$hamlet|+%form!method=post!action=@toMaster.CrudDeleteR.s@+ %h1 Really delete?+ %p Do you really want to delete $string.itemTitle.item$?+ %p+ %input!type=submit!value=Yes+ \ + %a!href=@toMaster.CrudListR@ No+|]++postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))+ => String -> GHandler (Crud master item) master RepHtml+postCrudDeleteR s = do+ itemId <- maybe notFound return $ itemReadId s+ crud <- getYesodSub+ toMaster <- getRouteToMaster+ crudDelete crud itemId+ redirect RedirectTemporary $ toMaster CrudListR++itemReadId :: SinglePiece x => String -> Maybe x+itemReadId = either (const Nothing) Just . fromSinglePiece++crudHelper+ :: (Item a, Yesod master, SinglePiece (Key a))+ => String -> Maybe (Key a, a) -> Bool+ -> GHandler (Crud master a) master RepHtml+crudHelper title me isPost = do+ crud <- getYesodSub+ (errs, form) <- runForm $ formable $ fmap snd me+ toMaster <- getRouteToMaster+ case (isPost, errs) of+ (True, FormSuccess a) -> do+ eid <- case me of+ Just (eid, _) -> do+ crudReplace crud eid a+ return eid+ Nothing -> crudInsert crud a+ redirect RedirectTemporary $ toMaster $ CrudEditR+ $ toSinglePiece eid+ _ -> return ()+ applyLayout title mempty [$hamlet|+%p+ %a!href=@toMaster.CrudListR@ Return to list+%h1 $string.title$+%form!method=post+ %table+ ^form^+ %tr+ %td!colspan=2+ %input!type=submit+ $maybe me e+ \ + %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete+|]++defaultCrud :: (PersistEntity i, YesodPersist a, PersistMonad i ~ YesodDB a)+ => a -> Crud a i+defaultCrud = const Crud+ { crudSelect = runDB $ select [] []+ , crudReplace = \a -> runDB . replace a+ , crudInsert = runDB . insert+ , crudGet = runDB . get+ , crudDelete = runDB . delete+ }
Yesod/Helpers/Sitemap.hs view
@@ -50,18 +50,18 @@ , priority :: Double } -sitemapNS :: HtmlContent-sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9"+sitemapNS :: Html ()+sitemapNS = string "http://www.sitemaps.org/schemas/sitemap/0.9" -template :: [SitemapUrl url] -> Hamlet url IO ()+template :: [SitemapUrl url] -> Hamlet url template urls = [$hamlet| %urlset!xmlns=$sitemapNS$ $forall urls url %url %loc @sitemapLoc.url@- %lastmod $cs.formatW3.sitemapLastMod.url$- %changefreq $cs.showFreq.sitemapChangeFreq.url$- %priority $cs.show.priority.url$+ %lastmod $string.formatW3.sitemapLastMod.url$+ %changefreq $string.showFreq.sitemapChangeFreq.url$+ %priority $string.show.priority.url$ |] sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml
Yesod/Helpers/Static.hs view
@@ -80,7 +80,7 @@ case content of Nothing -> notFound Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp''- Just (Right bs) -> return [(typeByExt $ ext fp, cs bs)]+ Just (Right bs) -> return [(typeByExt $ ext fp, bs)] where isUnsafe [] = True isUnsafe ('.':_) = True@@ -109,10 +109,11 @@ fs <- qRunIO $ getFileList fp concat `fmap` mapM go fs where- replace '.' = '_'- replace c = c+ replace' '.' = '_'+ replace' '-' = '_'+ replace' c = c go f = do- let name = mkName $ intercalate "_" $ map (map replace) f+ let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f let sr = ConE $ mkName "StaticRoute" return
Yesod/Internal.hs view
@@ -14,7 +14,7 @@ NotFound | InternalError String | InvalidArgs [(String, String)]- | PermissionDenied+ | PermissionDenied String | BadMethod String deriving (Show, Eq)
Yesod/Json.hs view
@@ -9,31 +9,26 @@ -- * Generate Json output , jsonScalar , jsonList- , jsonList' , jsonMap- , jsonMap' #if TEST , testSuite #endif ) where -import Text.Hamlet.Monad-import Control.Applicative-import Data.Text (pack)-import qualified Data.Text as T+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (isControl) import Yesod.Hamlet-import Control.Monad (when) import Yesod.Handler-import Web.Routes.Quasi (Routes) import Numeric (showHex)+import Data.Monoid (Monoid (..)) #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test)-import Data.Text.Lazy (unpack)+import Data.ByteString.Lazy.Char8 (unpack) import Yesod.Content hiding (testSuite) #else import Yesod.Content@@ -46,17 +41,17 @@ -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON -- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'.-newtype Json url a = Json { unJson :: Hamlet url IO a }- deriving (Functor, Applicative, Monad)+newtype Json = Json { unJson :: Html () }+ deriving Monoid -- | Extract the final result from the given 'Json' value. -- -- See also: applyLayoutJson in "Yesod.Yesod".-jsonToContent :: Json (Routes master) () -> GHandler sub master Content-jsonToContent = hamletToContent . unJson+jsonToContent :: Json -> GHandler sub master Content+jsonToContent = return . toContent . renderHtml . unJson -- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'.-jsonToRepJson :: Json (Routes master) () -> GHandler sub master RepJson+jsonToRepJson :: Json -> GHandler sub master RepJson jsonToRepJson = fmap RepJson . jsonToContent -- | Outputs a single scalar. This function essentially:@@ -66,13 +61,14 @@ -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes.-jsonScalar :: HtmlContent -> Json url ()-jsonScalar s = Json $ do- outputString "\""- output $ encodeJson $ htmlContentToText s- outputString "\""+jsonScalar :: Html () -> Json+jsonScalar s = Json $ mconcat+ [ preEscapedString "\""+ , unsafeByteString $ S.concat $ L.toChunks $ encodeJson $ renderHtml s+ , preEscapedString "\""+ ] where- encodeJson = T.concatMap (T.pack . encodeJsonChar)+ encodeJson = L.concatMap (L.pack . encodeJsonChar) encodeJsonChar '\b' = "\\b" encodeJsonChar '\f' = "\\f"@@ -90,38 +86,33 @@ encodeJsonChar c = [c] -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"].-jsonList :: [Json url ()] -> Json url ()-jsonList = jsonList' . fromList---- | Same as 'jsonList', but uses an 'Enumerator' for input.-jsonList' :: Enumerator (Json url ()) (Json url) -> Json url ()-jsonList' (Enumerator enum) = do- Json $ outputString "["- _ <- enum go False- Json $ outputString "]"+jsonList :: [Json] -> Json+jsonList [] = Json $ preEscapedString "[]"+jsonList (x:xs) = mconcat+ [ Json $ preEscapedString "["+ , x+ , mconcat $ map go xs+ , Json $ preEscapedString "]"+ ] where- go putComma j = do- when putComma $ Json $ outputString ","- () <- j- return $ Right True+ go = mappend (Json $ preEscapedString ",") -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}.-jsonMap :: [(String, Json url ())] -> Json url ()-jsonMap = jsonMap' . fromList---- | Same as 'jsonMap', but uses an 'Enumerator' for input.-jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url ()-jsonMap' (Enumerator enum) = do- Json $ outputString "{"- _ <- enum go False- Json $ outputString "}"+jsonMap :: [(String, Json)] -> Json+jsonMap [] = Json $ preEscapedString "{}"+jsonMap (x:xs) = mconcat+ [ Json $ preEscapedString "{"+ , go x+ , mconcat $ map go' xs+ , Json $ preEscapedString "}"+ ] where- go putComma (k, v) = do- when putComma $ Json $ outputString ","- jsonScalar $ Unencoded $ pack k- Json $ outputString ":"- () <- v- return $ Right True+ go' y = mappend (Json $ preEscapedString ",") $ go y+ go (k, v) = mconcat+ [ jsonScalar $ string k+ , Json $ preEscapedString ":"+ , v+ ] #if TEST @@ -135,11 +126,10 @@ let j = do jsonMap [ ("foo" , jsonList- [ jsonScalar $ Encoded $ pack "bar"- , jsonScalar $ Encoded $ pack "baz"+ [ jsonScalar $ preEscapedString "bar"+ , jsonScalar $ preEscapedString "baz" ]) ]- t <- hamletToText id $ unJson j- "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack t+ "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (renderHtml $ unJson j) #endif
Yesod/Request.hs view
@@ -42,11 +42,7 @@ import qualified Network.Wai as W import qualified Data.ByteString.Lazy as BL-#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class-#else-import "transformers" Control.Monad.Trans-#endif import Control.Monad (liftM) import Network.Wai.Parse import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
Yesod/Yesod.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes Yesod (..) , YesodSite (..)+ -- ** Persistence+ , YesodPersist (..)+ , PersistEntity (..) -- * Convenience functions , applyLayout , applyLayoutJson@@ -16,11 +20,14 @@ import Yesod.Request import Yesod.Hamlet import Yesod.Handler-import Data.Convertible.Text import qualified Network.Wai as W import Yesod.Json import Yesod.Internal-import Web.ClientSession (getKey, defaultKeyFile, Key)+import Web.ClientSession (getKey, defaultKeyFile)+import qualified Web.ClientSession as CS+import Data.Monoid (mempty)+import Data.ByteString.UTF8 (toString)+import Database.Persist (PersistEntity (..)) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -45,7 +52,7 @@ approot :: a -> String -- | The encryption key to be used for encrypting client sessions.- encryptKey :: a -> IO Key+ encryptKey :: a -> IO CS.Key encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to@@ -82,15 +89,23 @@ urlRenderOverride :: a -> Routes a -> Maybe String urlRenderOverride _ _ = Nothing + -- | Determine is a request is authorized or not.+ --+ -- Return 'Nothing' is the request is authorized, 'Just' a message if+ -- unauthorized. If authentication is required, you should use a redirect;+ -- the Auth helper provides this functionality automatically.+ isAuthorized :: a -> Routes a -> IO (Maybe String)+ isAuthorized _ _ = return Nothing+ -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title- -> Hamlet (Routes master) IO () -- ^ head- -> Hamlet (Routes master) IO () -- ^ body+ -> Hamlet (Routes master) -- ^ head+ -> Hamlet (Routes master) -- ^ body -> GHandler sub master RepHtml applyLayout t h b = RepHtml `fmap` defaultLayout PageContent- { pageTitle = cs t+ { pageTitle = string t , pageHead = h , pageBody = b }@@ -99,13 +114,13 @@ -- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title- -> Hamlet (Routes master) IO () -- ^ head- -> Hamlet (Routes master) IO () -- ^ body- -> Json (Routes master) ()+ -> Hamlet (Routes master) -- ^ head+ -> Hamlet (Routes master) -- ^ body+ -> Json -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do html' <- defaultLayout PageContent- { pageTitle = cs t+ { pageTitle = string t , pageHead = h , pageBody = html }@@ -114,9 +129,9 @@ applyLayout' :: Yesod master => String -- ^ title- -> Hamlet (Routes master) IO () -- ^ body+ -> Hamlet (Routes master) -- ^ body -> GHandler sub master ChooseRep-applyLayout' s = fmap chooseRep . applyLayout s (return ())+applyLayout' s = fmap chooseRep . applyLayout s mempty -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y@@ -126,28 +141,34 @@ r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found-%p $Unencoded.cs.pathInfo.r$+%p $string.toString.pathInfo.r$ |] where pathInfo = W.pathInfo-defaultErrorHandler PermissionDenied =+defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" $ [$hamlet|-%h1 Permission denied|]+%h1 Permission denied+%p $string.msg$+|] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl $forall ia pair- %dt $cs.fst.pair$- %dd $cs.snd.pair$+ %dt $string.fst.pair$+ %dd $string.snd.pair$ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error-%p $cs.e$+%p $string.e$ |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported-%p Method "$cs.m$" not supported+%p Method "$string.m$" not supported |]++class YesodPersist y where+ type YesodDB y :: (* -> *) -> * -> *+ runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.2.0+version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -9,16 +9,6 @@ Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. . The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.- .- As a quick overview, here is a fully-functional Hello World application:- .- > {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}- > import Yesod- > data HelloWorld = HelloWorld- > mkYesod "HelloWorld" [$parseRoutes|/ Home GET|]- > instance Yesod HelloWorld where approot _ = ""- > getHome = return $ RepPlain $ cs "Hello World!"- > main = toWaiApp HelloWorld >>= basicHandler 3000 category: Web stability: Stable cabal-version: >= 1.6@@ -38,23 +28,24 @@ bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, text >= 0.5 && < 0.8,- convertible-text >= 0.3.0 && < 0.4,+ utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23,- web-routes-quasi >= 0.3 && < 0.4,- hamlet >= 0.2.2 && < 0.3,- transformers >= 0.1 && < 0.3,+ web-routes-quasi >= 0.4 && < 0.5,+ hamlet >= 0.3.1 && < 0.4,+ transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5,- MonadCatchIO-transformers >= 0.1 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3,- old-locale >= 1.0.0.2 && < 1.1+ old-locale >= 1.0.0.2 && < 1.1,+ persistent >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch Yesod.Form+ Yesod.Formable Yesod.Hamlet Yesod.Handler Yesod.Internal@@ -63,6 +54,7 @@ Yesod.Yesod Yesod.Helpers.AtomFeed Yesod.Helpers.Auth+ Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static ghc-options: -Wall