diff --git a/Yesod.hs b/Yesod.hs --- a/Yesod.hs +++ b/Yesod.hs @@ -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) diff --git a/Yesod/Content.hs b/Yesod/Content.hs --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -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. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -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) diff --git a/Yesod/Form.hs b/Yesod/Form.hs --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -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 diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs new file mode 100644 --- /dev/null +++ b/Yesod/Formable.hs @@ -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 diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -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 diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -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 diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -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| %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$ |] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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 diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Crud.hs @@ -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 + } diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -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 diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -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 diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -14,7 +14,7 @@ NotFound | InternalError String | InvalidArgs [(String, String)] - | PermissionDenied + | PermissionDenied String | BadMethod String deriving (Show, Eq) diff --git a/Yesod/Json.hs b/Yesod/Json.hs --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -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 diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -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 diff --git a/yesod.cabal b/yesod.cabal --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.2.0 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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 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