yesod 0.4.1 → 0.5.0
raw patch · 27 files changed
+2425/−1405 lines, 27 filesdep +blaze-builderdep +dataencdep +networkdep −web-routesdep ~hamletdep ~persistentdep ~wai-extrabinary-added
Dependencies added: blaze-builder, dataenc, network, process
Dependencies removed: web-routes
Dependency ranges changed: hamlet, persistent, wai-extra, web-routes-quasi
Files
- CodeGenQ.hs +3/−3
- Yesod.hs +6/−1
- Yesod/Content.hs +2/−2
- Yesod/Dispatch.hs +22/−56
- Yesod/Form.hs +69/−756
- Yesod/Form/Class.hs +61/−0
- Yesod/Form/Core.hs +260/−0
- Yesod/Form/Fields.hs +268/−0
- Yesod/Form/Jquery.hs +155/−0
- Yesod/Form/Nic.hs +38/−0
- Yesod/Form/Profiles.hs +189/−0
- Yesod/Hamlet.hs +22/−3
- Yesod/Handler.hs +28/−40
- Yesod/Helpers/AtomFeed.hs +1/−1
- Yesod/Helpers/Auth.hs +288/−235
- Yesod/Helpers/Crud.hs +25/−15
- Yesod/Helpers/Static.hs +38/−5
- Yesod/Internal.hs +43/−0
- Yesod/Json.hs +40/−43
- Yesod/Mail.hs +120/−0
- Yesod/WebRoutes.hs +88/−0
- Yesod/Widget.hs +21/−104
- Yesod/Yesod.hs +218/−43
- favicon.ico binary
- runtests.hs +2/−0
- scaffold.hs +399/−91
- yesod.cabal +19/−7
CodeGenQ.hs view
@@ -16,10 +16,10 @@ let s = killFirstBlank s' case parse (many parseToken) s s of Left e -> error $ show e- Right tokens -> do- let tokens' = map toExp tokens+ Right tokens' -> do+ let tokens'' = map toExp tokens' concat' <- [|concat|]- return $ concat' `AppE` ListE tokens'+ return $ concat' `AppE` ListE tokens'' where killFirstBlank ('\n':x) = x killFirstBlank ('\r':'\n':x) = x
Yesod.hs view
@@ -11,7 +11,9 @@ , module Yesod.Json , module Yesod.Widget , Application+ , lift , liftIO+ , MonadCatchIO , mempty ) where @@ -19,18 +21,21 @@ import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) import Yesod.Dispatch hiding (testSuite)+import Yesod.Yesod hiding (testSuite) #else import Yesod.Content import Yesod.Json import Yesod.Dispatch+import Yesod.Yesod #endif import Yesod.Request import Yesod.Form-import Yesod.Yesod import Yesod.Widget import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet+import "transformers" Control.Monad.Trans.Class (lift) import "transformers" Control.Monad.IO.Class (liftIO)+import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import Data.Monoid (mempty)
Yesod/Content.hs view
@@ -245,8 +245,8 @@ caseTypeByExt :: Assertion caseTypeByExt = do- typeJavascript @=? typeByExt (ext "foo.js")- typeHtml @=? typeByExt (ext "foo.html")+ Just typeJavascript @=? lookup (ext "foo.js") typeByExt+ Just typeHtml @=? lookup (ext "foo.html") typeByExt #endif -- | Format a 'UTCTime' in W3 format; useful for setting cookies.
Yesod/Dispatch.hs view
@@ -18,26 +18,29 @@ , toWaiApp , basicHandler , basicHandler'- -- * Utilities- , fullRender #if TEST , testSuite #endif ) where -import Yesod.Handler+#if TEST+import Yesod.Yesod hiding (testSuite)+#else import Yesod.Yesod+#endif++import Yesod.Handler import Yesod.Request import Yesod.Internal import Web.Routes.Quasi import Web.Routes.Quasi.Parse import Web.Routes.Quasi.TH-import Web.Routes.Site import Language.Haskell.TH.Syntax+import Yesod.WebRoutes import qualified Network.Wai as W-import Network.Wai.Middleware.CleanPath+import Network.Wai.Middleware.CleanPath (cleanPathFunc) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -46,7 +49,6 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B-import Web.Routes (encodePathInfo) import qualified Data.ByteString.UTF8 as S @@ -93,7 +95,7 @@ -- executable by itself, but instead provides functionality to -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype- -> [(String, [Name])]+ -> Cxt -> [Resource] -> Q [Dec] mkYesodSub name clazzes =@@ -119,18 +121,9 @@ mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -typeHelper :: String -> Type-typeHelper =- foldl1 AppT . map go . words- where- go s@(x:_)- | isLower x = VarT $ mkName s- | otherwise = ConT $ mkName s- go [] = error "typeHelper: empty string to go"- mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument- -> [(String, [Name])] -- ^ classes+ -> Cxt -- ^ classes -> Bool -- ^ is subsite? -> [Resource] -> Q ([Dec], [Dec])@@ -138,10 +131,6 @@ let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args'- let clazzes' = map (\(x, y) -> ClassP x [typeHelper y])- $ concatMap (\(x, y) -> zip y $ repeat x)- $ compact- $ map (\x -> (x, [])) ("master" : args) ++ clazzes th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th let routesName = mkName $ name ++ "Route"@@ -166,7 +155,7 @@ let site' = site `AppE` dispatch `AppE` render `AppE` parse let (ctx, ytyp, yfunc) = if isSub- then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")+ then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") let y = InstanceD ctx ytyp [ FunD (mkName yfunc) [Clause [] (NormalB site') []]@@ -212,13 +201,6 @@ thResourceFromResource _ (Resource n _ _) = error $ "Invalid attributes for resource: " ++ n -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" @@ -228,7 +210,7 @@ toWaiApp a = return $ gzip $ jsonp- $ cleanPathRel (B.pack $ approot a)+ $ cleanPathFunc (splitPath a) (B.pack $ approot a) $ toWaiApp' a toWaiApp' :: (Yesod y, YesodSite y)@@ -251,16 +233,20 @@ types = httpAccept env pathSegments = filter (not . null) segments eurl = parsePathSegments site pathSegments- render u = fromMaybe- (fullRender (approot y) (formatPathSegments site) u)+ render u qs =+ let (ps, qs') = formatPathSegments site u+ in fromMaybe+ (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u)+ let errorHandler' = localNoCurrent . errorHandler rr <- parseWaiRequest env session' let h = do onRequest case eurl of- Left _ -> errorHandler NotFound+ Left _ -> errorHandler' NotFound Right url -> do- ar <- isAuthorized url+ isWrite <- isWriteRequest url+ ar <- isAuthorized url isWrite case ar of Authorized -> return () AuthenticationRequired ->@@ -272,10 +258,10 @@ redirect RedirectTemporary url' Unauthorized s -> permissionDenied s case handleSite site render url method of- Nothing -> errorHandler $ BadMethod method+ Nothing -> errorHandler' $ BadMethod method Just h' -> h' let eurl' = either (const Nothing) Just eurl- let eh er = runHandler (errorHandler er) render eurl' id y id+ let eh er = runHandler (errorHandler' er) render eurl' id y id let ya = runHandler h render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal@@ -286,19 +272,6 @@ hs''' = ("Content-Type", S.fromString ct) : hs'' return $ W.Response s hs''' c --- | 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--- generate links /outside/ of the Handler monad, this may be useful.------ For example, if you want to generate an e-mail which links to your site,--- this is the function you would want to use.-fullRender :: String -- ^ approot, no trailing slash- -> (url -> [String])- -> url- -> String-fullRender ar render route =- ar ++ '/' : encodePathInfo (fixSegs $ render route)- httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack . parseHttpAccept@@ -333,13 +306,6 @@ ["http://", h, ":", show port, "/"] SS.run port app Just _ -> CGI.run app--fixSegs :: [String] -> [String]-fixSegs [] = []-fixSegs [x]- | any (== '.') x = [x]- | otherwise = [x, ""] -- append trailing slash-fixSegs (x:xs) = x : fixSegs xs parseWaiRequest :: W.Request -> [(String, String)] -- ^ session
Yesod/Form.hs view
@@ -1,193 +1,67 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types- GForm (..)+ GForm+ , FormResult (..)+ , Enctype (..)+ , FormFieldSettings (..)+ , Textarea (..)+ -- * Type synonyms , Form , Formlet , FormField , FormletField , FormInput- , FormResult (..)- , Enctype (..)- , FieldInfo (..)- -- * Newtype wrappers- , JqueryDay (..)- , NicHtml (..)- , Html' -- * Unwrapping functions , runFormGet , runFormPost , runFormGet' , runFormPost'- -- * Type classes- , ToForm (..)- , ToFormField (..) -- * Field/form helpers- , requiredFieldHelper- , optionalFieldHelper- , mapFormXml- , newFormIdent , fieldsToTable , fieldsToPlain- , fieldsToInput- -- * Field profiles- , FieldProfile (..)- , stringFieldProfile- , intFieldProfile- , dayFieldProfile- , jqueryDayFieldProfile- , timeFieldProfile- , htmlFieldProfile- , emailFieldProfile- -- * Pre-built fields- , stringField- , maybeStringField- , intField- , maybeIntField- , doubleField- , maybeDoubleField- , dayField- , maybeDayField- , jqueryDayField- , maybeJqueryDayField- , timeField- , maybeTimeField- , htmlField- , maybeHtmlField- , nicHtmlField- , maybeNicHtmlField- , selectField- , maybeSelectField- , boolField- , jqueryAutocompleteField- , maybeJqueryAutocompleteField- , emailField- , maybeEmailField- -- * Pre-built inputs- , stringInput- , maybeStringInput- , boolInput- , dayInput- , maybeDayInput- , emailInput+ , checkForm -- * Template Haskell- , share2 , mkToForm+ -- * Re-exports+ , module Yesod.Form.Fields+ , module Yesod.Form.Class ) where +import Yesod.Form.Core+import Yesod.Form.Fields+import Yesod.Form.Class+import Yesod.Form.Profiles (Textarea (..))+ import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional)-import Data.Time (Day, TimeOfDay (TimeOfDay))-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class-import Control.Monad ((<=<), liftM, join)-import Data.Monoid (Monoid (..))+import Control.Monad ((<=<)) import Control.Monad.Trans.State+import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax-import Database.Persist.Base (EntityDef (..), PersistField)+import Database.Persist.Base (EntityDef (..)) import Data.Char (toUpper, isUpper)-import Data.Int (Int64)-import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget import Control.Arrow ((&&&))-import qualified Text.Email.Validate as Email---- | A form can produce three different results: there was no data available,--- the data was invalid, or there was a successful parse.------ The 'Applicative' instance will concatenate the failure messages in two--- 'FormResult's.-data FormResult a = FormMissing- | FormFailure [String]- | FormSuccess a- deriving Show-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---- | The encoding type required by a form. The 'Show' instance produces values--- that can be inserted directly into HTML.-data Enctype = UrlEncoded | Multipart-instance Show Enctype where- show UrlEncoded = "application/x-www-form-urlencoded"- show Multipart = "multipart/form-data"-instance Monoid Enctype where- mempty = UrlEncoded- mappend UrlEncoded UrlEncoded = UrlEncoded- mappend _ _ = Multipart---- | A generic form, allowing you to specifying the subsite datatype, master--- site datatype, a datatype for the form XML and the return type.-newtype GForm sub y xml a = GForm- { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype)- }-type Form sub y = GForm sub y (GWidget sub y ())-type Formlet sub y a = Maybe a -> Form sub y a-type FormField sub y = GForm sub y [FieldInfo sub y]-type FormletField sub y a = Maybe a -> FormField sub y a-type FormInput sub y = GForm sub y [GWidget sub y ()]---- | Convert the XML in a 'GForm'.-mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a-mapFormXml f (GForm g) = GForm $ \e fe -> do- (res, xml, enc) <- g e fe- return (res, f xml, enc)---- | Using this as the intermediate XML representation for fields allows us to--- write generic field functions and then different functions for producing--- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.-data FieldInfo sub y = FieldInfo- { fiLabel :: Html ()- , fiTooltip :: Html ()- , fiIdent :: String- , fiInput :: GWidget sub y ()- , fiErrors :: Maybe (Html ())- }--type Env = [(String, String)]-type FileEnv = [(String, FileInfo)]--instance Monoid xml => Functor (GForm sub url xml) where- fmap f (GForm g) =- GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe)- where- first3 f' (x, y, z) = (f' x, y, z)--instance Monoid xml => Applicative (GForm sub url xml) where- pure a = GForm $ const $ const $ return (pure a, mempty, mempty)- (GForm f) <*> (GForm g) = GForm $ \env fe -> do- (f1, f2, f3) <- f env fe- (g1, g2, g3) <- g env fe- return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)+import Data.List (group, sort) -- | Display only the actual input widget code, without any decoration.-fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y ()-fieldsToPlain = mapM_ fiInput--fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]-fieldsToInput = map fiInput+fieldsToPlain :: FormField sub y a -> Form sub y a+fieldsToPlain = mapFormXml $ mapM_ fiInput -- | Display the label, tooltip, input code and errors in a single row of a -- table.-fieldsToTable :: [FieldInfo sub y] -> GWidget sub y ()-fieldsToTable = mapM_ go+fieldsToTable :: FormField sub y a -> Form sub y a+fieldsToTable = mapFormXml $ mapM_ go where go fi = do wrapWidget (fiInput fi) $ \w -> [$hamlet|@@ -201,529 +75,12 @@ %td.errors $err$ |] -class ToForm a where- toForm :: Maybe a -> Form sub y a-class ToFormField a where- toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a---- | Create a required field (ie, one that cannot be blank) from a--- 'FieldProfile'.-requiredFieldHelper :: FieldProfile sub y a -> Maybe a -> FormField sub y a-requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig =- GForm $ \env _ -> do- name <- maybe newFormIdent return name'- let (res, val) =- if null env- then (FormMissing, maybe "" render orig)- else case lookup name env of- Nothing -> (FormMissing, "")- Just "" -> (FormFailure ["Value is required"], "")- Just x ->- case parse x of- Left e -> (FormFailure [e], x)- Right y -> (FormSuccess y, x)- let fi = FieldInfo- { fiLabel = label- , fiTooltip = tooltip- , fiIdent = name- , fiInput = w name >> addBody (mkXml (string name) (string val) True)- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- }- return (res, [fi], UrlEncoded)---- | Create an optional field (ie, one that can be blank) from a--- 'FieldProfile'.-optionalFieldHelper :: FieldProfile sub y a -> Maybe (Maybe a)- -> FormField sub y (Maybe a)-optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig' =- GForm $ \env _ -> do- let orig = join orig'- name <- maybe newFormIdent return name'- let (res, val) =- if null env- then (FormSuccess Nothing, maybe "" render orig)- else case lookup name env of- Nothing -> (FormSuccess Nothing, "")- Just "" -> (FormSuccess Nothing, "")- Just x ->- case parse x of- Left e -> (FormFailure [e], x)- Right y -> (FormSuccess $ Just y, x)- let fi = FieldInfo- { fiLabel = label- , fiTooltip = tooltip- , fiIdent = name- , fiInput = w name >> addBody (mkXml (string name) (string val) False)- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- }- return (res, [fi], UrlEncoded)---- | A generic definition of a form field that can be used for generating both--- required and optional fields. See 'requiredFieldHelper and--- 'optionalFieldHelper'.-data FieldProfile sub y a = FieldProfile- { fpParse :: String -> Either String a- , fpRender :: a -> String- , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Route y)- , fpWidget :: String -> GWidget sub y ()- , fpName :: Maybe String- , fpLabel :: Html ()- , fpTooltip :: Html ()- }----------------------- Begin prebuilt forms--stringField :: Html () -> Html () -> FormletField sub y String-stringField label tooltip = requiredFieldHelper stringFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String)-maybeStringField label tooltip = optionalFieldHelper stringFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--stringFieldProfile :: FieldProfile sub y String-stringFieldProfile = FieldProfile- { fpParse = Right- , fpRender = id- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!type=text!:isReq:required!value=$val$-|]- , fpWidget = \_name -> return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }-instance ToFormField String where- toFormField = stringField-instance ToFormField (Maybe String) where- toFormField = maybeStringField--intField :: Integral i => Html () -> Html () -> FormletField sub y i-intField l t = requiredFieldHelper intFieldProfile- { fpLabel = l- , fpTooltip = t- }--maybeIntField :: Integral i =>- Html () -> Html () -> FormletField sub y (Maybe i)-maybeIntField l t = optionalFieldHelper intFieldProfile- { fpLabel = l- , fpTooltip = t- }--intFieldProfile :: Integral i => FieldProfile sub y i-intFieldProfile = FieldProfile- { fpParse = maybe (Left "Invalid integer") Right . readMayI- , fpRender = showI- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!type=number!:isReq:required!value=$val$-|]- , fpWidget = \_name -> return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }- where- showI x = show (fromIntegral x :: Integer)- readMayI s = case reads s of- (x, _):_ -> Just $ fromInteger x- [] -> Nothing-instance ToFormField Int where- toFormField = intField-instance ToFormField (Maybe Int) where- toFormField = maybeIntField-instance ToFormField Int64 where- toFormField = intField-instance ToFormField (Maybe Int64) where- toFormField = maybeIntField--doubleField :: Html () -> Html () -> FormletField sub y Double-doubleField l t = requiredFieldHelper doubleFieldProfile- { fpLabel = l- , fpTooltip = t- }--maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double)-maybeDoubleField l t = optionalFieldHelper doubleFieldProfile- { fpLabel = l- , fpTooltip = t- }--doubleFieldProfile :: FieldProfile sub y Double-doubleFieldProfile = FieldProfile- { fpParse = maybe (Left "Invalid number") Right . readMay- , fpRender = show- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!type=number!:isReq:required!value=$val$-|]- , fpWidget = \_name -> return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }-instance ToFormField Double where- toFormField = doubleField-instance ToFormField (Maybe Double) where- toFormField = maybeDoubleField--dayField :: Html () -> Html () -> FormletField sub y Day-dayField l t = requiredFieldHelper dayFieldProfile- { fpLabel = l- , fpTooltip = t- }--maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day)-maybeDayField l t = optionalFieldHelper dayFieldProfile- { fpLabel = l- , fpTooltip = t- }--dayFieldProfile :: FieldProfile sub y Day-dayFieldProfile = FieldProfile- { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right- . readMay- , fpRender = show- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!type=date!:isReq:required!value=$val$-|]- , fpWidget = const $ return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }-instance ToFormField Day where- toFormField = dayField-instance ToFormField (Maybe Day) where- toFormField = maybeDayField--jqueryDayField :: Html () -> Html () -> FormletField sub y Day-jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile- { fpLabel = l- , fpTooltip = t- }--maybeJqueryDayField :: Html () -> Html () -> FormletField sub y (Maybe Day)-maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile- { fpLabel = l- , fpTooltip = t- }--jqueryDayFieldProfile :: FieldProfile sub y Day-jqueryDayFieldProfile = FieldProfile- { fpParse = maybe- (Left "Invalid day, must be in YYYY-MM-DD format")- Right- . readMay- , fpRender = show- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!type=date!:isReq:required!value=$val$-|]- , fpWidget = \name -> do- addScriptRemote urlJqueryJs- addScriptRemote urlJqueryUiJs- addStylesheetRemote urlJqueryUiCss- addJavaScript [$hamlet|-$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})});-|]- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }---- | A newtype wrapper around 'Day', using jQuery UI date picker for the--- 'ToFormField' instance.-newtype JqueryDay = JqueryDay { unJqueryDay :: Day }- deriving PersistField-instance ToFormField JqueryDay where- toFormField = applyFormTypeWrappers JqueryDay unJqueryDay jqueryDayField-instance ToFormField (Maybe JqueryDay) where- toFormField = applyFormTypeWrappers (fmap JqueryDay) (fmap unJqueryDay)- maybeJqueryDayField--parseTime :: String -> Either String TimeOfDay-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =- parseTimeHelper (h1, h2, m1, m2, s1, s2)-parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"--parseTimeHelper :: (Char, Char, Char, Char, Char, Char)- -> Either [Char] TimeOfDay-parseTimeHelper (h1, h2, m1, m2, s1, s2)- | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h- | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m- | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s- | otherwise = Right $ TimeOfDay h m s- where- h = read [h1, h2]- m = read [m1, m2]- s = fromInteger $ read [s1, s2]--timeField :: Html () -> Html () -> FormletField sub y TimeOfDay-timeField label tooltip = requiredFieldHelper timeFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay)-maybeTimeField label tooltip = optionalFieldHelper timeFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--timeFieldProfile :: FieldProfile sub y TimeOfDay-timeFieldProfile = FieldProfile- { fpParse = parseTime- , fpRender = show- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!:isReq:required!value=$val$-|]- , fpWidget = const $ return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }-instance ToFormField TimeOfDay where- toFormField = timeField-instance ToFormField (Maybe TimeOfDay) where- toFormField = maybeTimeField--boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool-boolField label tooltip orig = GForm $ \env _ -> do- name <- newFormIdent- let (res, val) =- if null env- then (FormMissing, fromMaybe False orig)- else case lookup name env of- Nothing -> (FormSuccess False, False)- Just _ -> (FormSuccess True, True)- let fi = FieldInfo- { fiLabel = label- , fiTooltip = tooltip- , fiIdent = name- , fiInput = addBody [$hamlet|-%input#$name$!type=checkbox!name=$name$!:val:checked-|]- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- }- return (res, [fi], UrlEncoded)-instance ToFormField Bool where- toFormField = boolField--htmlField :: Html () -> Html () -> FormletField sub y (Html ())-htmlField label tooltip = requiredFieldHelper htmlFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ()))-maybeHtmlField label tooltip = optionalFieldHelper htmlFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--htmlFieldProfile :: FieldProfile sub y (Html ())-htmlFieldProfile = FieldProfile- { fpParse = Right . preEscapedString- , fpRender = U.toString . renderHtml- , fpHamlet = \name val _isReq -> [$hamlet|-%textarea.html#$name$!name=$name$ $val$-|]- , fpWidget = const $ return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }-instance ToFormField (Html ()) where- toFormField = htmlField-instance ToFormField (Maybe (Html ())) where- toFormField = maybeHtmlField--newtype NicHtml = NicHtml { unNicHtml :: Html () }- deriving PersistField--type Html' = Html ()--nicHtmlField :: Html () -> Html () -> FormletField sub y (Html ())-nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--maybeNicHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ()))-maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--nicHtmlFieldProfile :: FieldProfile sub y (Html ())-nicHtmlFieldProfile = FieldProfile- { fpParse = Right . preEscapedString- , fpRender = U.toString . renderHtml- , fpHamlet = \name val _isReq -> [$hamlet|-%textarea.html#$name$!name=$name$ $val$-|]- , fpWidget = \name -> do- addScriptRemote "http://js.nicedit.com/nicEdit-latest.js"- addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|]- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }-instance ToFormField NicHtml where- toFormField = applyFormTypeWrappers NicHtml unNicHtml nicHtmlField-instance ToFormField (Maybe NicHtml) where- toFormField = applyFormTypeWrappers (fmap NicHtml) (fmap unNicHtml)- maybeNicHtmlField--applyFormTypeWrappers :: (a -> b) -> (b -> a)- -> (f -> g -> FormletField s y a)- -> (f -> g -> FormletField s y b)-applyFormTypeWrappers wrap unwrap field l t orig =- fmap wrap $ field l t $ fmap unwrap orig--readMay :: Read a => String -> Maybe a-readMay s = case reads s of- (x, _):_ -> Just x- [] -> Nothing--selectField :: Eq x => [(x, String)]- -> Html () -> Html ()- -> Maybe x -> FormField sub master x-selectField pairs label tooltip initial = GForm $ \env _ -> do- i <- newFormIdent- let pairs' = zip [1 :: Int ..] pairs- let res = case lookup i env of- Nothing -> FormMissing- Just "none" -> FormFailure ["Field is required"]- Just x ->- case reads x of- (x', _):_ ->- case lookup x' pairs' of- Nothing -> FormFailure ["Invalid entry"]- Just (y, _) -> FormSuccess y- [] -> FormFailure ["Invalid entry"]- let isSelected x =- case res of- FormSuccess y -> x == y- _ -> Just x == initial- let input = [$hamlet|-%select#$i$!name=$i$- %option!value=none- $forall pairs' pair- %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$-|]- let fi = FieldInfo- { fiLabel = label- , fiTooltip = tooltip- , fiIdent = i- , fiInput = addBody input- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- }- return (res, [fi], UrlEncoded)--maybeSelectField :: Eq x => [(x, String)]- -> Html () -> Html ()- -> Maybe x -> FormField sub master (Maybe x)-maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do- i <- newFormIdent- let pairs' = zip [1 :: Int ..] pairs- let res = case lookup i env of- Nothing -> FormMissing- Just "none" -> FormSuccess Nothing- Just x ->- case reads x of- (x', _):_ ->- case lookup x' pairs' of- Nothing -> FormFailure ["Invalid entry"]- Just (y, _) -> FormSuccess $ Just y- [] -> FormFailure ["Invalid entry"]- let isSelected x =- case res of- FormSuccess y -> Just x == y- _ -> Just x == initial- let input = [$hamlet|-%select#$i$!name=$i$- %option!value=none- $forall pairs' pair- %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$-|]- let fi = FieldInfo- { fiLabel = label- , fiTooltip = tooltip- , fiIdent = i- , fiInput = addBody input- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- }- return (res, [fi], UrlEncoded)----------------------- End prebuilt forms----------------------- Begin prebuilt inputs--stringInput :: String -> FormInput sub master String-stringInput n =- mapFormXml fieldsToInput $- requiredFieldHelper stringFieldProfile- { fpName = Just n- } Nothing--maybeStringInput :: String -> FormInput sub master (Maybe String)-maybeStringInput n =- mapFormXml fieldsToInput $- optionalFieldHelper stringFieldProfile- { fpName = Just n- } Nothing--boolInput :: String -> FormInput sub master Bool-boolInput n = GForm $ \env _ -> return- (FormSuccess $ isJust $ lookup n env, return $ addBody [$hamlet|-%input#$n$!type=checkbox!name=$n$-|], UrlEncoded)--dayInput :: String -> FormInput sub master Day-dayInput n =- mapFormXml fieldsToInput $- requiredFieldHelper dayFieldProfile- { fpName = Just n- } Nothing--maybeDayInput :: String -> FormInput sub master (Maybe Day)-maybeDayInput n =- mapFormXml fieldsToInput $- optionalFieldHelper dayFieldProfile- { fpName = Just n- } Nothing----------------------- End prebuilt inputs---- | Get a unique identifier.-newFormIdent :: Monad m => StateT Int m String-newFormIdent = do- i <- get- let i' = i + 1- put i'- return $ "f" ++ show i'- runFormGeneric :: Env -> FileEnv -> GForm sub y xml a -> GHandler sub y (FormResult a, xml, Enctype)-runFormGeneric env fe f = evalStateT (deform f env fe) 1+runFormGeneric env fe (GForm f) =+ runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe -- | Run a form against POST parameters. runFormPost :: GForm sub y xml a@@ -755,19 +112,23 @@ gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f --- | This function allows two different monadic functions to share the same--- input and have their results concatenated. This is particularly useful for--- allowing 'mkToForm' to share its input with mkPersist.-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'- -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. mkToForm :: [EntityDef] -> Q [Dec] mkToForm = mapM derive where+ afterPeriod s =+ case dropWhile (/= '.') s of+ ('.':t) -> t+ _ -> s+ beforePeriod s =+ case break (== '.') s of+ (t, '.':_) -> Just t+ _ -> Nothing+ getSuperclass (_, _, z) = getTFF' z >>= beforePeriod+ getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z+ getTFF' [] = Nothing+ getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x+ getTFF' (_:x) = getTFF' x getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z getLabel' [] = Nothing getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x@@ -776,9 +137,17 @@ getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x getTooltip' (_:x) = getTooltip' x getTooltip' [] = Nothing+ getId (_, _, z) = fromMaybe "" $ getId' z+ getId' (('i':'d':'=':x):_) = Just x+ getId' (_:x) = getId' x+ getId' [] = Nothing+ getName (_, _, z) = fromMaybe "" $ getName' z+ getName' (('n':'a':'m':'e':'=':x):_) = Just x+ getName' (_:x) = getName' x+ getName' [] = Nothing derive :: EntityDef -> Q Dec derive t = do- let cols = map (getLabel &&& getTooltip) $ entityColumns t+ let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|]@@ -786,7 +155,10 @@ string' <- [|string|] mfx <- [|mapFormXml|] ftt <- [|fieldsToTable|]- let go_ = go ap just' string' mfx ftt+ ffs' <- [|FormFieldSettings|]+ let stm "" = nothing+ stm x = just `AppE` LitE (StringL x)+ let go_ = go ap just' ffs' stm string' mfx ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] (NormalB $ go_ $ zip cols $ map (const nothing) cols)@@ -797,17 +169,27 @@ $ map VarP xs]] (NormalB $ go_ $ zip cols xs') []- return $ InstanceD [] (ConT ''ToForm- `AppT` ConT (mkName $ entityName t))+ let y = mkName "y"+ let ctx = map (\x -> ClassP (mkName x) [VarT y])+ $ map head $ group $ sort+ $ mapMaybe getSuperclass+ $ entityColumns t+ return $ InstanceD ctx ( ConT ''ToForm+ `AppT` ConT (mkName $ entityName t)+ `AppT` VarT y) [FunD (mkName "toForm") [c1, c2]]- go ap just' string' mfx ftt a =- let x = foldl (ap' ap) just' $ map (go' string') a+ go ap just' ffs' stm string' mfx ftt a =+ let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a in mfx `AppE` ftt `AppE` x- go' string' ((label, tooltip), ex) =+ go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = let label' = string' `AppE` LitE (StringL label) tooltip' = string' `AppE` LitE (StringL tooltip)- in VarE (mkName "toFormField") `AppE` label'- `AppE` tooltip' `AppE` ex+ ffs = ffs' `AppE`+ label' `AppE`+ tooltip' `AppE`+ (stm theId) `AppE`+ (stm name)+ in VarE (mkName tff) `AppE` ffs `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String@@ -818,72 +200,3 @@ go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs--jqueryAutocompleteField ::- Route y -> Html () -> Html () -> FormletField sub y String-jqueryAutocompleteField src l t =- requiredFieldHelper $ (jqueryAutocompleteFieldProfile src)- { fpLabel = l- , fpTooltip = t- }--maybeJqueryAutocompleteField ::- Route y -> Html () -> Html () -> FormletField sub y (Maybe String)-maybeJqueryAutocompleteField src l t =- optionalFieldHelper $ (jqueryAutocompleteFieldProfile src)- { fpLabel = l- , fpTooltip = t- }--jqueryAutocompleteFieldProfile :: Route y -> FieldProfile sub y String-jqueryAutocompleteFieldProfile src = FieldProfile- { fpParse = Right- , fpRender = id- , fpHamlet = \name val isReq -> [$hamlet|-%input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$-|]- , fpWidget = \name -> do- addScriptRemote urlJqueryJs- addScriptRemote urlJqueryUiJs- addStylesheetRemote urlJqueryUiCss- addJavaScript [$hamlet|-$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});-|]- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }--emailFieldProfile :: FieldProfile s y String-emailFieldProfile = FieldProfile- { fpParse = \s -> if Email.isValid s- then Right s- else Left "Invalid e-mail address"- , fpRender = id- , fpHamlet = \name val isReq -> [$hamlet|-%input#$name$!name=$name$!type=email!:isReq:required!value=$val$-|]- , fpWidget = const $ return ()- , fpName = Nothing- , fpLabel = mempty- , fpTooltip = mempty- }--emailField :: Html () -> Html () -> FormletField sub y String-emailField label tooltip = requiredFieldHelper emailFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--maybeEmailField :: Html () -> Html () -> FormletField sub y (Maybe String)-maybeEmailField label tooltip = optionalFieldHelper emailFieldProfile- { fpLabel = label- , fpTooltip = tooltip- }--emailInput :: String -> FormInput sub master String-emailInput n =- mapFormXml fieldsToInput $- requiredFieldHelper emailFieldProfile- { fpName = Just n- } Nothing
+ Yesod/Form/Class.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Yesod.Form.Class+ ( ToForm (..)+ , ToFormField (..)+ ) where++import Text.Hamlet+import Yesod.Form.Fields+import Yesod.Form.Core+import Yesod.Form.Profiles (Textarea)+import Data.Int (Int64)+import Data.Time (Day, TimeOfDay)++class ToForm a y where+ toForm :: Formlet sub y a+class ToFormField a y where+ toFormField :: FormFieldSettings -> FormletField sub y a++instance ToFormField String y where+ toFormField = stringField+instance ToFormField (Maybe String) y where+ toFormField = maybeStringField++instance ToFormField Int y where+ toFormField = intField+instance ToFormField (Maybe Int) y where+ toFormField = maybeIntField+instance ToFormField Int64 y where+ toFormField = intField+instance ToFormField (Maybe Int64) y where+ toFormField = maybeIntField++instance ToFormField Double y where+ toFormField = doubleField+instance ToFormField (Maybe Double) y where+ toFormField = maybeDoubleField++instance ToFormField Day y where+ toFormField = dayField+instance ToFormField (Maybe Day) y where+ toFormField = maybeDayField++instance ToFormField TimeOfDay y where+ toFormField = timeField+instance ToFormField (Maybe TimeOfDay) y where+ toFormField = maybeTimeField++instance ToFormField Bool y where+ toFormField = boolField++instance ToFormField Html y where+ toFormField = htmlField+instance ToFormField (Maybe Html) y where+ toFormField = maybeHtmlField++instance ToFormField Textarea y where+ toFormField = textareaField+instance ToFormField (Maybe Textarea) y where+ toFormField = maybeTextareaField
+ Yesod/Form/Core.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Form.Core+ ( FormResult (..)+ , GForm (..)+ , newFormIdent+ , deeperFormIdent+ , shallowerFormIdent+ , Env+ , FileEnv+ , Enctype (..)+ , Ints (..)+ , requiredFieldHelper+ , optionalFieldHelper+ , fieldsToInput+ , mapFormXml+ , checkForm+ , askParams+ , askFiles+ , liftForm+ -- * Data types+ , FieldInfo (..)+ , FormFieldSettings (..)+ , FieldProfile (..)+ -- * Type synonyms+ , Form+ , Formlet+ , FormField+ , FormletField+ , FormInput+ ) where++import Control.Monad.Trans.State+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class (lift)+import Yesod.Handler+import Yesod.Widget+import Data.Monoid (Monoid (..))+import Control.Applicative+import Yesod.Request+import Control.Monad (liftM)+import Text.Hamlet+import Data.String+import Control.Monad (join)++-- | A form can produce three different results: there was no data available,+-- the data was invalid, or there was a successful parse.+--+-- The 'Applicative' instance will concatenate the failure messages in two+-- 'FormResult's.+data FormResult a = FormMissing+ | FormFailure [String]+ | FormSuccess a+ deriving Show+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+instance Monoid m => Monoid (FormResult m) where+ mempty = pure mempty+ mappend x y = mappend <$> x <*> y++-- | The encoding type required by a form. The 'Show' instance produces values+-- that can be inserted directly into HTML.+data Enctype = UrlEncoded | Multipart+ deriving (Eq, Enum, Bounded)+instance ToHtml Enctype where+ toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"+ toHtml Multipart = unsafeByteString "multipart/form-data"+instance Monoid Enctype where+ mempty = UrlEncoded+ mappend UrlEncoded UrlEncoded = UrlEncoded+ mappend _ _ = Multipart++data Ints = IntCons Int Ints | IntSingle Int+instance Show Ints where+ show (IntSingle i) = show i+ show (IntCons i is) = show i ++ '-' : show is++incrInts :: Ints -> Ints+incrInts (IntSingle i) = IntSingle $ i + 1+incrInts (IntCons i is) = (i + 1) `IntCons` is++-- | A generic form, allowing you to specifying the subsite datatype, master+-- site datatype, a datatype for the form XML and the return type.+newtype GForm sub y xml a = GForm+ { deform :: StateT Ints (+ ReaderT Env (+ ReaderT FileEnv (+ (GHandler sub y)+ ))) (FormResult a, xml, Enctype)+ }++type Env = [(String, String)]+type FileEnv = [(String, FileInfo)]++-- | Get a unique identifier.+newFormIdent :: Monad m => StateT Ints m String+newFormIdent = do+ i <- get+ let i' = incrInts i+ put i'+ return $ 'f' : show i'++deeperFormIdent :: Monad m => StateT Ints m ()+deeperFormIdent = do+ i <- get+ let i' = 1 `IntCons` incrInts i+ put i'++shallowerFormIdent :: Monad m => StateT Ints m ()+shallowerFormIdent = do+ IntCons _ i <- get+ put i++instance Monoid xml => Functor (GForm sub url xml) where+ fmap f (GForm g) =+ GForm $ liftM (first3 $ fmap f) g+ where+ first3 f' (x, y, z) = (f' x, y, z)++instance Monoid xml => Applicative (GForm sub url xml) where+ pure a = GForm $ return (pure a, mempty, mempty)+ (GForm f) <*> (GForm g) = GForm $ do+ (f1, f2, f3) <- f+ (g1, g2, g3) <- g+ return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)++-- | Create a required field (ie, one that cannot be blank) from a+-- 'FieldProfile'.ngs+requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings+ -> Maybe a -> FormField sub y a+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do+ env <- lift ask+ let (FormFieldSettings label tooltip theId' name') = ffs+ name <- maybe newFormIdent return name'+ theId <- maybe newFormIdent return theId'+ let (res, val) =+ if null env+ then (FormMissing, maybe "" render orig)+ else case lookup name env of+ Nothing -> (FormMissing, "")+ Just "" -> (FormFailure ["Value is required"], "")+ Just x ->+ case parse x of+ Left e -> (FormFailure [e], x)+ Right y -> (FormSuccess y, x)+ let fi = FieldInfo+ { fiLabel = label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiName = name+ , fiInput = mkWidget theId name val True+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ }+ return (res, [fi], UrlEncoded)++-- | Create an optional field (ie, one that can be blank) from a+-- 'FieldProfile'.+optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings+ -> FormletField sub y (Maybe a)+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do+ env <- lift ask+ let (FormFieldSettings label tooltip theId' name') = ffs+ let orig = join orig'+ name <- maybe newFormIdent return name'+ theId <- maybe newFormIdent return theId'+ let (res, val) =+ if null env+ then (FormSuccess Nothing, maybe "" render orig)+ else case lookup name env of+ Nothing -> (FormSuccess Nothing, "")+ Just "" -> (FormSuccess Nothing, "")+ Just x ->+ case parse x of+ Left e -> (FormFailure [e], x)+ Right y -> (FormSuccess $ Just y, x)+ let fi = FieldInfo+ { fiLabel = label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiName = name+ , fiInput = mkWidget theId name val False+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ }+ return (res, [fi], UrlEncoded)++fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]+fieldsToInput = map fiInput++-- | Convert the XML in a 'GForm'.+mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a+mapFormXml f (GForm g) = GForm $ do+ (res, xml, enc) <- g+ return (res, f xml, enc)++-- | Using this as the intermediate XML representation for fields allows us to+-- write generic field functions and then different functions for producing+-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.+data FieldInfo sub y = FieldInfo+ { fiLabel :: Html+ , fiTooltip :: Html+ , fiIdent :: String+ , fiName :: String+ , fiInput :: GWidget sub y ()+ , fiErrors :: Maybe Html+ }++data FormFieldSettings = FormFieldSettings+ { ffsLabel :: Html+ , ffsTooltip :: Html+ , ffsId :: Maybe String+ , ffsName :: Maybe String+ }+instance IsString FormFieldSettings where+ fromString s = FormFieldSettings (string s) mempty Nothing Nothing++-- | A generic definition of a form field that can be used for generating both+-- required and optional fields. See 'requiredFieldHelper and+-- 'optionalFieldHelper'.+data FieldProfile sub y a = FieldProfile+ { fpParse :: String -> Either String a+ , fpRender :: a -> String+ -- | ID, name, value, required+ , fpWidget :: String -> String -> String -> Bool -> GWidget sub y ()+ }++type Form sub y = GForm sub y (GWidget sub y ())+type Formlet sub y a = Maybe a -> Form sub y a+type FormField sub y = GForm sub y [FieldInfo sub y]+type FormletField sub y a = Maybe a -> FormField sub y a+type FormInput sub y = GForm sub y [GWidget sub y ()]++checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b+checkForm f (GForm form) = GForm $ do+ (res, xml, enc) <- form+ let res' = case res of+ FormSuccess a -> f a+ FormFailure e -> FormFailure e+ FormMissing -> FormMissing+ return (res', xml, enc)++askParams :: Monad m => StateT Ints (ReaderT Env m) Env+askParams = lift ask++askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv+askFiles = lift $ lift ask++liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a+liftForm = lift . lift . lift
+ Yesod/Form/Fields.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE QuasiQuotes #-}+module Yesod.Form.Fields+ ( -- * Fields+ -- ** Required+ stringField+ , textareaField+ , hiddenField+ , intField+ , doubleField+ , dayField+ , timeField+ , htmlField+ , selectField+ , boolField+ , emailField+ , urlField+ -- ** Optional+ , maybeStringField+ , maybeTextareaField+ , maybeHiddenField+ , maybeIntField+ , maybeDoubleField+ , maybeDayField+ , maybeTimeField+ , maybeHtmlField+ , maybeSelectField+ , maybeEmailField+ , maybeUrlField+ -- * Inputs+ -- ** Required+ , stringInput+ , intInput+ , boolInput+ , dayInput+ , emailInput+ , urlInput+ -- ** Optional+ , maybeStringInput+ , maybeDayInput+ ) where++import Yesod.Form.Core+import Yesod.Form.Profiles+import Yesod.Widget+import Data.Time (Day, TimeOfDay)+import Text.Hamlet+import Data.Monoid+import Control.Monad (join)+import Data.Maybe (fromMaybe)++stringField :: FormFieldSettings -> FormletField sub y String+stringField = requiredFieldHelper stringFieldProfile++maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeStringField = optionalFieldHelper stringFieldProfile++intInput :: Integral i => String -> FormInput sub master i+intInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper intFieldProfile (nameSettings n) Nothing++intField :: Integral i => FormFieldSettings -> FormletField sub y i+intField = requiredFieldHelper intFieldProfile++maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i)+maybeIntField = optionalFieldHelper intFieldProfile++doubleField :: FormFieldSettings -> FormletField sub y Double+doubleField = requiredFieldHelper doubleFieldProfile++maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double)+maybeDoubleField = optionalFieldHelper doubleFieldProfile++dayField :: FormFieldSettings -> FormletField sub y Day+dayField = requiredFieldHelper dayFieldProfile++maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day)+maybeDayField = optionalFieldHelper dayFieldProfile++timeField :: FormFieldSettings -> FormletField sub y TimeOfDay+timeField = requiredFieldHelper timeFieldProfile++maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay)+maybeTimeField = optionalFieldHelper timeFieldProfile++boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool+boolField ffs orig = GForm $ do+ env <- askParams+ let label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ name <- maybe newFormIdent return $ ffsName ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ let (res, val) =+ if null env+ then (FormMissing, fromMaybe False orig)+ else case lookup name env of+ Nothing -> (FormSuccess False, False)+ Just _ -> (FormSuccess True, True)+ let fi = FieldInfo+ { fiLabel = label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiName = name+ , fiInput = addBody [$hamlet|+%input#$theId$!type=checkbox!name=$name$!:val:checked+|]+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ }+ return (res, [fi], UrlEncoded)++htmlField :: FormFieldSettings -> FormletField sub y Html+htmlField = requiredFieldHelper htmlFieldProfile++maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html)+maybeHtmlField = optionalFieldHelper htmlFieldProfile++selectField :: Eq x => [(x, String)]+ -> FormFieldSettings+ -> Maybe x -> FormField sub master x+selectField pairs ffs initial = GForm $ do+ env <- askParams+ let label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ name <- maybe newFormIdent return $ ffsName ffs+ let pairs' = zip [1 :: Int ..] pairs+ let res = case lookup name env of+ Nothing -> FormMissing+ Just "none" -> FormFailure ["Field is required"]+ Just x ->+ case reads x of+ (x', _):_ ->+ case lookup x' pairs' of+ Nothing -> FormFailure ["Invalid entry"]+ Just (y, _) -> FormSuccess y+ [] -> FormFailure ["Invalid entry"]+ let isSelected x =+ case res of+ FormSuccess y -> x == y+ _ -> Just x == initial+ let input = [$hamlet|+%select#$theId$!name=$name$+ %option!value=none+ $forall pairs' pair+ %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$+|]+ let fi = FieldInfo+ { fiLabel = label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiName = name+ , fiInput = addBody input+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ }+ return (res, [fi], UrlEncoded)++maybeSelectField :: Eq x => [(x, String)]+ -> FormFieldSettings+ -> FormletField sub master (Maybe x)+maybeSelectField pairs ffs initial' = GForm $ do+ env <- askParams+ let initial = join initial'+ label = ffsLabel ffs+ tooltip = ffsTooltip ffs+ theId <- maybe newFormIdent return $ ffsId ffs+ name <- maybe newFormIdent return $ ffsName ffs+ let pairs' = zip [1 :: Int ..] pairs+ let res = case lookup name env of+ Nothing -> FormMissing+ Just "none" -> FormSuccess Nothing+ Just x ->+ case reads x of+ (x', _):_ ->+ case lookup x' pairs' of+ Nothing -> FormFailure ["Invalid entry"]+ Just (y, _) -> FormSuccess $ Just y+ [] -> FormFailure ["Invalid entry"]+ let isSelected x =+ case res of+ FormSuccess y -> Just x == y+ _ -> Just x == initial+ let input = [$hamlet|+%select#$theId$!name=$name$+ %option!value=none+ $forall pairs' pair+ %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$+|]+ let fi = FieldInfo+ { fiLabel = label+ , fiTooltip = tooltip+ , fiIdent = theId+ , fiName = name+ , fiInput = addBody input+ , fiErrors = case res of+ FormFailure [x] -> Just $ string x+ _ -> Nothing+ }+ return (res, [fi], UrlEncoded)++stringInput :: String -> FormInput sub master String+stringInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper stringFieldProfile (nameSettings n) Nothing++maybeStringInput :: String -> FormInput sub master (Maybe String)+maybeStringInput n =+ mapFormXml fieldsToInput $+ optionalFieldHelper stringFieldProfile (nameSettings n) Nothing++boolInput :: String -> FormInput sub master Bool+boolInput n = GForm $ do+ env <- askParams+ let res = FormSuccess $ fromMaybe "" (lookup n env) /= ""+ let xml = addBody [$hamlet|+%input#$n$!type=checkbox!name=$n$+|]+ return (res, [xml], UrlEncoded)++dayInput :: String -> FormInput sub master Day+dayInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper dayFieldProfile (nameSettings n) Nothing++maybeDayInput :: String -> FormInput sub master (Maybe Day)+maybeDayInput n =+ mapFormXml fieldsToInput $+ optionalFieldHelper dayFieldProfile (nameSettings n) Nothing++nameSettings :: String -> FormFieldSettings+nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)++urlField :: FormFieldSettings -> FormletField sub y String+urlField = requiredFieldHelper urlFieldProfile++maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeUrlField = optionalFieldHelper urlFieldProfile++urlInput :: String -> FormInput sub master String+urlInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper urlFieldProfile (nameSettings n) Nothing++emailField :: FormFieldSettings -> FormletField sub y String+emailField = requiredFieldHelper emailFieldProfile++maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeEmailField = optionalFieldHelper emailFieldProfile++emailInput :: String -> FormInput sub master String+emailInput n =+ mapFormXml fieldsToInput $+ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing++textareaField :: FormFieldSettings -> FormletField sub y Textarea+textareaField = requiredFieldHelper textareaFieldProfile++maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)+maybeTextareaField = optionalFieldHelper textareaFieldProfile++hiddenField :: FormFieldSettings -> FormletField sub y String+hiddenField = requiredFieldHelper hiddenFieldProfile++maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeHiddenField = optionalFieldHelper hiddenFieldProfile
+ Yesod/Form/Jquery.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE QuasiQuotes #-}+module Yesod.Form.Jquery+ ( YesodJquery (..)+ , jqueryDayField+ , maybeJqueryDayField+ , jqueryDayTimeField+ , jqueryDayTimeFieldProfile+ , jqueryAutocompleteField+ , maybeJqueryAutocompleteField+ , jqueryDayFieldProfile+ ) where++import Yesod.Handler+import Yesod.Form.Core+import Yesod.Form.Profiles+import Yesod.Widget+import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,+ timeToTimeOfDay)+import Yesod.Hamlet+import Data.Char (isSpace)++class YesodJquery a where+ -- | The jQuery Javascript file.+ urlJqueryJs :: a -> Either (Route a) String+ urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"++ -- | The jQuery UI 1.8.1 Javascript file.+ urlJqueryUiJs :: a -> Either (Route a) String+ urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"++ -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme.+ urlJqueryUiCss :: a -> Either (Route a) String+ urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"++ -- | jQuery UI time picker add-on.+ urlJqueryUiDateTimePicker :: a -> Either (Route a) String+ urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"++jqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y Day+jqueryDayField = requiredFieldHelper jqueryDayFieldProfile++maybeJqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y (Maybe Day)+maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile++jqueryDayFieldProfile :: YesodJquery y => FieldProfile sub y Day+jqueryDayFieldProfile = FieldProfile+ { fpParse = maybe+ (Left "Invalid day, must be in YYYY-MM-DD format")+ Right+ . readMay+ , fpRender = show+ , fpWidget = \theId name val isReq -> do+ addBody [$hamlet|+%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addStylesheet' urlJqueryUiCss+ addJavascript [$julius|+$(function(){$("#%theId%").datepicker({dateFormat:'yy-mm-dd'})});+|]+ }++ifRight :: Either a b -> (b -> c) -> Either a c+ifRight e f = case e of+ Left l -> Left l+ Right r -> Right $ f r++showLeadingZero :: (Show a) => a -> String+showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t++jqueryDayTimeField :: YesodJquery y => FormFieldSettings -> FormletField sub y UTCTime+jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile++-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)+jqueryDayTimeUTCTime :: UTCTime -> String+jqueryDayTimeUTCTime (UTCTime day utcTime) =+ let timeOfDay = timeToTimeOfDay utcTime+ in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay+ where+ showTimeOfDay (TimeOfDay hour minute _) =+ let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")+ in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm++jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime+jqueryDayTimeFieldProfile = FieldProfile+ { fpParse = parseUTCTime+ , fpRender = jqueryDayTimeUTCTime+ , fpWidget = \theId name val isReq -> do+ addBody [$hamlet|+%input#$theId$!name=$name$!:isReq:required!value=$val$+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addScript' urlJqueryUiDateTimePicker+ addStylesheet' urlJqueryUiCss+ addJavascript [$julius|+$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});+|]+ }++parseUTCTime :: String -> Either String UTCTime+parseUTCTime s =+ let (dateS, timeS) = break isSpace (dropWhile isSpace s)+ dateE = parseDate dateS+ in case dateE of+ Left l -> Left l+ Right date ->+ ifRight (parseTime timeS)+ (UTCTime date . timeOfDayToTime)++jqueryAutocompleteField :: YesodJquery y =>+ Route y -> FormFieldSettings -> FormletField sub y String+jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile++maybeJqueryAutocompleteField :: YesodJquery y =>+ Route y -> FormFieldSettings -> FormletField sub y (Maybe String)+maybeJqueryAutocompleteField src =+ optionalFieldHelper $ jqueryAutocompleteFieldProfile src++jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String+jqueryAutocompleteFieldProfile src = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val isReq -> do+ addBody [$hamlet|+%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addStylesheet' urlJqueryUiCss+ addJavascript [$julius|+$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})});+|]+ }++addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()+addScript' f = do+ y <- liftHandler getYesod+ addScriptEither $ f y++addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()+addStylesheet' f = do+ y <- liftHandler getYesod+ addStylesheetEither $ f y++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++-- | Replaces all instances of a value in a list by another value.+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace+replace :: Eq a => a -> a -> [a] -> [a]+replace x y = map (\z -> if z == x then y else z)
+ Yesod/Form/Nic.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE QuasiQuotes #-}+module Yesod.Form.Nic+ ( YesodNic (..)+ , nicHtmlField+ , maybeNicHtmlField+ ) where++import Yesod.Handler+import Yesod.Form.Core+import Yesod.Hamlet+import Yesod.Widget+import qualified Data.ByteString.Lazy.UTF8 as U++class YesodNic a where+ -- | NIC Editor.+ urlNicEdit :: a -> Either (Route a) String+ urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"++nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y Html+nicHtmlField = requiredFieldHelper nicHtmlFieldProfile++maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe Html)+maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile++nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html+nicHtmlFieldProfile = FieldProfile+ { fpParse = Right . preEscapedString+ , fpRender = U.toString . renderHtml+ , fpWidget = \theId name val _isReq -> do+ addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|]+ addScript' urlNicEdit+ addJavascript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|]+ }++addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()+addScript' f = do+ y <- liftHandler getYesod+ addScriptEither $ f y
+ Yesod/Form/Profiles.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Yesod.Form.Profiles+ ( stringFieldProfile+ , textareaFieldProfile+ , hiddenFieldProfile+ , intFieldProfile+ , dayFieldProfile+ , timeFieldProfile+ , htmlFieldProfile+ , emailFieldProfile+ , urlFieldProfile+ , doubleFieldProfile+ , fileFieldProfile+ , parseDate+ , parseTime+ , Textarea (..)+ ) where++import Yesod.Form.Core+import Yesod.Widget+import Yesod.Request+import Text.Hamlet+import Data.Time (Day, TimeOfDay(..))+import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Text.Email.Validate as Email+import Network.URI (parseURI)+import Database.Persist (PersistField)++import Text.Blaze.Builder.Utf8 (writeChar)+import Text.Blaze.Builder.Core (writeList, writeByteString)++intFieldProfile :: Integral i => FieldProfile sub y i+intFieldProfile = FieldProfile+ { fpParse = maybe (Left "Invalid integer") Right . readMayI+ , fpRender = showI+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$+|]+ }+ where+ showI x = show (fromIntegral x :: Integer)+ readMayI s = case reads s of+ (x, _):_ -> Just $ fromInteger x+ [] -> Nothing++doubleFieldProfile :: FieldProfile sub y Double+doubleFieldProfile = FieldProfile+ { fpParse = maybe (Left "Invalid number") Right . readMay+ , fpRender = show+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$+|]+ }++fileFieldProfile :: FieldProfile s m FileInfo+fileFieldProfile = undefined -- FIXME++dayFieldProfile :: FieldProfile sub y Day+dayFieldProfile = FieldProfile+ { fpParse = parseDate+ , fpRender = show+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$+|]+ }++timeFieldProfile :: FieldProfile sub y TimeOfDay+timeFieldProfile = FieldProfile+ { fpParse = parseTime+ , fpRender = show+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!:isReq:required!value=$val$+|]+ }++htmlFieldProfile :: FieldProfile sub y Html+htmlFieldProfile = FieldProfile+ { fpParse = Right . preEscapedString+ , fpRender = U.toString . renderHtml+ , fpWidget = \theId name val _isReq -> addBody [$hamlet|+%textarea.html#$theId$!name=$name$ $val$+|]+ }++-- | A newtype wrapper around a 'String' that converts newlines to HTML+-- br-tags.+newtype Textarea = Textarea { unTextarea :: String }+ deriving (Show, Read, Eq, PersistField)+instance ToHtml Textarea where+ toHtml =+ Html . writeList writeHtmlEscapedChar . unTextarea+ where+ -- Taken from blaze-builder and modified with newline handling.+ writeHtmlEscapedChar '<' = writeByteString "<"+ writeHtmlEscapedChar '>' = writeByteString ">"+ writeHtmlEscapedChar '&' = writeByteString "&"+ writeHtmlEscapedChar '"' = writeByteString """+ writeHtmlEscapedChar '\'' = writeByteString "'"+ writeHtmlEscapedChar '\n' = writeByteString "<br>"+ writeHtmlEscapedChar c = writeChar c++textareaFieldProfile :: FieldProfile sub y Textarea+textareaFieldProfile = FieldProfile+ { fpParse = Right . Textarea+ , fpRender = unTextarea+ , fpWidget = \theId name val _isReq -> addBody [$hamlet|+%textarea#$theId$!name=$name$ $val$+|]+ }++hiddenFieldProfile :: FieldProfile sub y String+hiddenFieldProfile = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val _isReq -> addBody [$hamlet|+%input!type=hidden#$theId$!name=$name$!value=$val$+|]+ }++stringFieldProfile :: FieldProfile sub y String+stringFieldProfile = FieldProfile+ { fpParse = Right+ , fpRender = id+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$+|]+ }++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++parseDate :: String -> Either String Day+parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right+ . readMay . replace '/' '-'++-- | Replaces all instances of a value in a list by another value.+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace+replace :: Eq a => a -> a -> [a] -> [a]+replace x y = map (\z -> if z == x then y else z)++parseTime :: String -> Either String TimeOfDay+parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =+ parseTimeHelper (h1, h2, m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =+ let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12+ in parseTimeHelper (h1', h2', m1, m2, '0', '0')+parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =+ parseTimeHelper (h1, h2, m1, m2, s1, s2)+parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"++parseTimeHelper :: (Char, Char, Char, Char, Char, Char)+ -> Either [Char] TimeOfDay+parseTimeHelper (h1, h2, m1, m2, s1, s2)+ | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h+ | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m+ | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s+ | otherwise = Right $ TimeOfDay h m s+ where+ h = read [h1, h2]+ m = read [m1, m2]+ s = fromInteger $ read [s1, s2]++emailFieldProfile :: FieldProfile s y String+emailFieldProfile = FieldProfile+ { fpParse = \s -> if Email.isValid s+ then Right s+ else Left "Invalid e-mail address"+ , fpRender = id+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$+|]+ }++urlFieldProfile :: FieldProfile s y String+urlFieldProfile = FieldProfile+ { fpParse = \s -> case parseURI s of+ Nothing -> Left "Invalid URL"+ Just _ -> Right s+ , fpRender = id+ , fpWidget = \theId name val isReq -> addBody [$hamlet|+%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$+|]+ }
Yesod/Hamlet.hs view
@@ -5,7 +5,24 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet ( -- * Hamlet library- module Text.Hamlet+ -- ** Hamlet+ hamlet+ , xhamlet+ , Hamlet+ , Html+ , renderHamlet+ , renderHtml+ , string+ , preEscapedString+ , cdata+ -- ** Julius+ , julius+ , Julius+ , renderJulius+ -- ** Cassius+ , cassius+ , Cassius+ , renderCassius -- * Convert to something displayable , hamletToContent , hamletToRepHtml@@ -15,6 +32,8 @@ where import Text.Hamlet+import Text.Cassius+import Text.Julius import Yesod.Content import Yesod.Handler @@ -23,7 +42,7 @@ -- -- > PageContent url -> Hamlet url data PageContent url = PageContent- { pageTitle :: Html ()+ { pageTitle :: Html , pageHead :: Hamlet url , pageBody :: Hamlet url }@@ -32,7 +51,7 @@ -- Yesod 'Response'. hamletToContent :: Hamlet (Route master) -> GHandler sub master Content hamletToContent h = do- render <- getUrlRender+ render <- getUrlRenderParams return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
Yesod/Handler.hs view
@@ -24,12 +24,12 @@ ( -- * Type families Route -- * Handler monad- , Handler , GHandler -- ** Read information from handler , getYesod , getYesodSub , getUrlRender+ , getUrlRenderParams , getCurrentRoute , getRouteToMaster -- * Special responses@@ -66,13 +66,14 @@ , runHandler , YesodApp (..) , toMasterHandler+ , localNoCurrent ) where import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal-import Data.List (foldl', intercalate)+import Data.List (foldl') import Data.Neither import Control.Exception hiding (Handler, catch)@@ -92,8 +93,6 @@ import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet-import Numeric (showIntAtBase)-import Data.Char (ord, chr) -- | The type-safe URLs associated with a site argument. type family Route a@@ -103,7 +102,7 @@ , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub)- , handlerRender :: (Route master -> String)+ , handlerRender :: (Route master -> [(String, String)] -> String) , handlerToMaster :: Route sub -> Route master } @@ -124,7 +123,7 @@ -> (master -> sub) -> Route sub -> GHandler sub master a- -> Handler master a+ -> GHandler master master a toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h @@ -145,11 +144,6 @@ 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.-type Handler yesod = GHandler yesod yesod- -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as -- the 'GHandler' monad and template haskell code should hide it away.@@ -182,8 +176,14 @@ -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Route master -> String)-getUrlRender = handlerRender <$> GHandler ask+getUrlRender = do+ x <- handlerRender <$> GHandler ask+ return $ flip x [] +-- | The URL rendering function with query-string parameters.+getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String)+getUrlRenderParams = handlerRender <$> GHandler 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'. getCurrentRoute :: GHandler sub master (Maybe (Route sub))@@ -208,7 +208,7 @@ -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c- -> (Route master -> String)+ -> (Route master -> [(String, String)] -> String) -> Maybe (Route sub) -> (Route sub -> Route master) -> master@@ -267,29 +267,8 @@ redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do- r <- getUrlRender- redirectString rt $ r url ++- if null params then "" else '?' : encodeUrlPairs params- where- encodeUrlPairs = intercalate "&" . map encodeUrlPair- encodeUrlPair (x, []) = escape x- encodeUrlPair (x, y) = escape x ++ '=' : escape y- escape = concatMap escape'- escape' c- | 'A' < c && c < 'Z' = [c]- | 'a' < c && c < 'a' = [c]- | '0' < c && c < '9' = [c]- | c `elem` ".-~_" = [c]- | c == ' ' = "+"- | otherwise = '%' : myShowHex (ord c) ""- myShowHex :: Int -> ShowS- myShowHex n r = case showIntAtBase 16 toChrHex n r of- [] -> "00"- [c] -> ['0',c]- s -> s- toChrHex d- | d < 10 = chr (ord '0' + fromIntegral d)- | otherwise = chr (ord 'A' + fromIntegral (d - 10))+ r <- getUrlRenderParams+ redirectString rt $ r url params -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a@@ -318,8 +297,13 @@ setUltDest' :: GHandler sub master () setUltDest' = do route <- getCurrentRoute- tm <- getRouteToMaster- maybe (return ()) setUltDest $ tm <$> route+ case route of+ Nothing -> return ()+ Just r -> do+ tm <- getRouteToMaster+ gets <- reqGetParams <$> getRequest+ render <- getUrlRenderParams+ setUltDestString $ render (tm r) gets -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session.@@ -342,14 +326,14 @@ -- instead, it will only appear in the next request. -- -- See 'getMessage'.-setMessage :: Html () -> GHandler sub master ()+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 (Html ()))+getMessage :: GHandler sub master (Maybe Html) getMessage = do deleteSession msgKey fmap (fmap preEscapedString) $ lookupSession msgKey@@ -438,3 +422,7 @@ | RedirectTemporary | RedirectSeeOther deriving (Show, Eq)++localNoCurrent :: GHandler s m a -> GHandler s m a+localNoCurrent =+ GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
Yesod/Helpers/AtomFeed.hs view
@@ -44,7 +44,7 @@ { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String- , atomEntryContent :: Html ()+ , atomEntryContent :: Html } template :: AtomFeed url -> Hamlet url
Yesod/Helpers/Auth.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes #-}@@ -6,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth@@ -22,17 +24,22 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..)+ , getAuth , AuthRoute (..) -- * Settings , YesodAuth (..) , Creds (..) , EmailCreds (..) , AuthType (..)- , AuthEmailSettings (..)- , inMemoryEmailSettings+ , RpxnowSettings (..)+ , EmailSettings (..)+ , FacebookSettings (..)+ , getFacebookUrl -- * Functions- , maybeCreds- , requireCreds+ , maybeAuth+ , maybeAuthId+ , requireAuth+ , requireAuthId ) where import qualified Web.Authenticate.Rpxnow as Rpxnow@@ -40,33 +47,35 @@ import qualified Web.Authenticate.Facebook as Facebook import Yesod+import Yesod.Mail (randomString) import Data.Maybe+import Data.Int (Int64) import Control.Monad import System.Random import Data.Digest.Pure.MD5 import Control.Applicative-import Control.Concurrent.MVar-import System.IO import Control.Monad.Attempt import Data.ByteString.Lazy.UTF8 (fromString) import Data.Object+import Language.Haskell.TH.Syntax --- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'.-class Yesod master => YesodAuth master where+type AuthId m = Key (AuthEntity m)+type AuthEmailId m = Key (AuthEmailEntity m)++class ( Yesod master+ , PersistEntity (AuthEntity master)+ , PersistEntity (AuthEmailEntity master)+ ) => YesodAuth master where+ type AuthEntity master+ type AuthEmailEntity master+ -- | Default destination on successful login or logout, if no other -- destination exists. defaultDest :: master -> Route master - -- | Default page to redirect user to for logging in.- defaultLoginRoute :: master -> Route master-- -- | Callback for a successful login.- --- -- The second parameter can contain various information, depending on login- -- mechanism.- onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()- onLogin _ _ = return ()+ getAuthId :: Creds master -> [(String, String)]+ -> GHandler s master (Maybe (AuthId master)) -- | Generate a random alphanumeric string. --@@ -74,19 +83,26 @@ randomKey :: master -> IO String randomKey _ = do stdgen <- newStdGen- return $ take 10 $ randomRs ('A', 'Z') stdgen+ return $ fst $ randomString 10 stdgen --- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its--- own settings. If those settings are not present, then relevant handlers will--- simply return a 404.-data Auth = Auth- { authIsOpenIdEnabled :: Bool- , authRpxnowApiKey :: Maybe String- , authEmailSettings :: Maybe AuthEmailSettings+ openIdEnabled :: master -> Bool+ openIdEnabled _ = False++ rpxnowSettings :: master -> Maybe RpxnowSettings+ rpxnowSettings _ = Nothing++ emailSettings :: master -> Maybe (EmailSettings master)+ emailSettings _ = Nothing+ -- | client id, secret and requested permissions- , authFacebook :: Maybe (String, String, [String])- }+ facebookSettings :: master -> Maybe FacebookSettings+ facebookSettings _ = Nothing +data Auth = Auth++getAuth :: a -> Auth+getAuth = const Auth+ -- | Which subsystem authenticated the user. data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook deriving (Show, Read, Eq)@@ -94,109 +110,127 @@ type Email = String type VerKey = String type VerUrl = String-type EmailId = Integer type SaltedPass = String type VerStatus = Bool -- | Data stored in a database for each e-mail address.-data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey+data EmailCreds m = EmailCreds+ { emailCredsId :: AuthEmailId m+ , emailCredsAuthId :: Maybe (AuthId m)+ , emailCredsStatus :: VerStatus+ , emailCredsVerkey :: Maybe VerKey+ } --- | For a sample set of settings for a trivial in-memory database, see--- 'inMemoryEmailSettings'.-data AuthEmailSettings = AuthEmailSettings- { addUnverified :: Email -> VerKey -> IO EmailId- , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO ()- , getVerifyKey :: EmailId -> IO (Maybe VerKey)- , verifyAccount :: EmailId -> IO ()- , setPassword :: EmailId -> String -> IO ()- , getEmailCreds :: Email -> IO (Maybe EmailCreds)- , getEmail :: EmailId -> IO (Maybe Email)+data RpxnowSettings = RpxnowSettings+ { rpxnowApp :: String+ , rpxnowKey :: String } +data EmailSettings m = EmailSettings+ { addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)+ , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()+ , getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)+ , setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()+ , verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))+ , getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)+ , setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()+ , getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))+ , getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)+ }++data FacebookSettings = FacebookSettings+ { fbAppId :: String+ , fbSecret :: String+ , fbPerms :: [String]+ }+ -- | User credentials-data Creds = Creds+data Creds m = Creds { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. , credsAuthType :: AuthType -- ^ How the user was authenticated , credsEmail :: Maybe String -- ^ Verified e-mail address. , credsDisplayName :: Maybe String -- ^ Display name.- , credsId :: Maybe Integer -- ^ Numeric ID, if used.+ , credsId :: Maybe (AuthId m) -- ^ Numeric ID, if used. , credsFacebookToken :: Maybe Facebook.AccessToken }- deriving (Show, Read, Eq) credsKey :: String-credsKey = "_CREDS"+credsKey = "_ID" setCreds :: YesodAuth master- => Creds -> [(String, String)] -> GHandler Auth master ()+ => Creds master -> [(String, String)] -> GHandler Auth master () setCreds creds extra = do- setSession credsKey $ show creds- onLogin creds extra+ maid <- getAuthId creds extra+ case maid of+ Nothing -> return ()+ Just aid -> setSession credsKey $ show $ fromPersistKey aid -- | Retrieves user credentials, if user is authenticated.-maybeCreds :: RequestReader r => r (Maybe Creds)-maybeCreds = do- mstring <- lookupSession credsKey- return $ mstring >>= readMay- where- readMay x = case reads x of- (y, _):_ -> Just y- _ -> Nothing+maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))+maybeAuthId = do+ ms <- lookupSession credsKey+ case ms of+ Nothing -> return Nothing+ Just s -> case reads s of+ [] -> return Nothing+ (i, _):_ -> return $ Just $ toPersistKey i -mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes|-/check Check GET-/logout Logout GET-/openid OpenIdR GET-/openid/forward OpenIdForward GET-/openid/complete OpenIdComplete GET+maybeAuth :: ( PersistBackend (YesodDB m (GHandler s m))+ , YesodPersist m+ , YesodAuth m+ ) => GHandler s m (Maybe (AuthId m, AuthEntity m))+maybeAuth = do+ maid <- maybeAuthId+ case maid of+ Nothing -> return Nothing+ Just aid -> do+ ma <- runDB $ get aid+ case ma of+ Nothing -> return Nothing+ Just a -> return $ Just (aid, a)++mkYesodSub "Auth"+ [ ClassP ''YesodAuth [VarT $ mkName "master"]+ ]+ [$parseRoutes|+/check CheckR GET+/logout LogoutR GET+/openid/forward OpenIdForwardR GET+/openid/complete OpenIdCompleteR GET /login/rpxnow RpxnowR /facebook FacebookR GET-/facebook/start StartFacebookR GET /register EmailRegisterR GET POST-/verify/#Integer/#String EmailVerifyR GET-/login EmailLoginR GET POST+/verify/#Int64/#String EmailVerifyR GET+/email-login EmailLoginR POST /set-password EmailPasswordR GET POST++/login LoginR GET |] -testOpenId :: GHandler Auth master ()+testOpenId :: YesodAuth master => GHandler Auth master () testOpenId = do- a <- getYesodSub- unless (authIsOpenIdEnabled a) notFound--getOpenIdR :: Yesod master => GHandler Auth master RepHtml-getOpenIdR = do- testOpenId- lookupGetParam "dest" >>= maybe (return ()) setUltDestString- rtom <- getRouteToMaster- message <- getMessage- applyLayout "Log in via OpenID" mempty [$hamlet|-$maybe message msg- %p.message $msg$-%form!method=get!action=@rtom.OpenIdForward@- %label!for=openid OpenID: $- %input#openid!type=text!name=openid- %input!type=submit!value=Login-|]+ a <- getYesod+ unless (openIdEnabled a) notFound -getOpenIdForward :: GHandler Auth master ()-getOpenIdForward = do+getOpenIdForwardR :: YesodAuth master => GHandler Auth master ()+getOpenIdForwardR = do testOpenId oid <- runFormGet' $ stringInput "openid" render <- getUrlRender toMaster <- getRouteToMaster- let complete = render $ toMaster OpenIdComplete+ let complete = render $ toMaster OpenIdCompleteR res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt (\err -> do setMessage $ string $ show err- redirect RedirectTemporary $ toMaster OpenIdR)+ redirect RedirectTemporary $ toMaster LoginR) (redirectString RedirectTemporary) res -getOpenIdComplete :: YesodAuth master => GHandler Auth master ()-getOpenIdComplete = do+getOpenIdCompleteR :: YesodAuth master => GHandler Auth master ()+getOpenIdCompleteR = do testOpenId rr <- getRequest let gets' = reqGetParams rr@@ -204,7 +238,7 @@ toMaster <- getRouteToMaster let onFailure err = do setMessage $ string $ show err- redirect RedirectTemporary $ toMaster OpenIdR+ redirect RedirectTemporary $ toMaster LoginR let onSuccess (OpenId.Identifier ident) = do y <- getYesod setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) []@@ -214,8 +248,8 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod- auth <- getYesodSub- apiKey <- case authRpxnowApiKey auth of+ auth <- getYesod+ apiKey <- case rpxnowKey <$> rpxnowSettings auth of Just x -> return x Nothing -> notFound token1 <- lookupGetParam "token"@@ -248,51 +282,60 @@ where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] -getCheck :: Yesod master => GHandler Auth master RepHtmlJson-getCheck = do- creds <- maybeCreds- applyLayoutJson "Authentication Status" mempty (html creds) (json creds)+getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson+getCheckR = do+ creds <- maybeAuthId+ defaultLayoutJson (do+ setTitle "Authentication Status"+ addBody $ 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 $credsIdent.c$+ %p Not logged in.+$maybe creds _+ %p Logged in. |] json creds = jsonMap- [ ("ident", jsonScalar $ maybe (string "") (string . credsIdent) creds)- , ("displayName", jsonScalar $ string $ fromMaybe ""- $ creds >>= credsDisplayName)+ [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds) ] -getLogout :: YesodAuth master => GHandler Auth master ()-getLogout = do+getLogoutR :: YesodAuth master => GHandler Auth master ()+getLogoutR = do y <- getYesod deleteSession credsKey redirectUltDest RedirectTemporary $ defaultDest y -- | Retrieve user credentials. If user is not logged in, redirects to the--- 'defaultLoginRoute'. Sets ultimate destination to current route, so user+-- 'authRoute'. Sets ultimate destination to current route, so user -- should be sent back here after authenticating.-requireCreds :: YesodAuth master => GHandler sub master Creds-requireCreds =- maybeCreds >>= maybe redirectLogin return- where- redirectLogin = do- y <- getYesod- setUltDest'- redirect RedirectTemporary $ defaultLoginRoute y+requireAuthId :: YesodAuth m => GHandler sub m (AuthId m)+requireAuthId = maybeAuthId >>= maybe redirectLogin return -getAuthEmailSettings :: GHandler Auth master AuthEmailSettings-getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings+requireAuth :: ( PersistBackend (YesodDB m (GHandler s m))+ , YesodPersist m+ , YesodAuth m+ ) => GHandler s m (AuthId m, AuthEntity m)+requireAuth = maybeAuth >>= maybe redirectLogin return -getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml+redirectLogin :: Yesod m => GHandler s m a+redirectLogin = do+ y <- getYesod+ setUltDest'+ case authRoute y of+ Just z -> redirect RedirectTemporary z+ Nothing -> permissionDenied "Please configure authRoute"++getEmailSettings :: YesodAuth master+ => GHandler Auth master (EmailSettings master)+getEmailSettings = getYesod >>= maybe notFound return . emailSettings++getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml getEmailRegisterR = do- _ae <- getAuthEmailSettings+ _ae <- getEmailSettings toMaster <- getRouteToMaster- applyLayout "Register a new account" mempty [$hamlet|+ defaultLayout $ setTitle "Register a new account" >> addBody [$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@@ -302,105 +345,96 @@ postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do- ae <- getAuthEmailSettings+ ae <- getEmailSettings email <- runFormPost' $ emailInput "email"- y <- getYesod- mecreds <- liftIO $ getEmailCreds ae email+ mecreds <- getEmailCreds ae email (lid, verKey) <- case mecreds of- Nothing -> liftIO $ do- key <- randomKey y+ Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)+ Just (EmailCreds lid _ _ Nothing) -> do+ y <- getYesod+ key <- liftIO $ randomKey y+ setVerifyKey ae lid key+ return (lid, key)+ Nothing -> do+ y <- getYesod+ key <- liftIO $ randomKey y lid <- addUnverified ae email key return (lid, key)- Just (EmailCreds lid _ _ key) -> return (lid, key) render <- getUrlRender tm <- getRouteToMaster- let verUrl = render $ tm $ EmailVerifyR lid verKey- liftIO $ sendVerifyEmail ae email verKey verUrl- applyLayout "Confirmation e-mail sent" mempty [$hamlet|+ let verUrl = render $ tm $ EmailVerifyR (fromPersistKey lid) verKey+ sendVerifyEmail ae email verKey verUrl+ defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| %p A confirmation e-mail has been sent to $email$. |] getEmailVerifyR :: YesodAuth master- => Integer -> String -> GHandler Auth master RepHtml-getEmailVerifyR lid key = do- ae <- getAuthEmailSettings- realKey <- liftIO $ getVerifyKey ae lid- memail <- liftIO $ getEmail ae lid+ => Int64 -> String -> GHandler Auth master RepHtml+getEmailVerifyR lid' key = do+ let lid = toPersistKey lid'+ ae <- getEmailSettings+ realKey <- getVerifyKey ae lid+ memail <- getEmail ae lid case (realKey == Just key, memail) of (True, Just email) -> do- liftIO $ verifyAccount ae lid- setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)- Nothing) []- toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster EmailPasswordR- _ -> applyLayout "Invalid verification key" mempty [$hamlet|+ muid <- verifyAccount ae lid+ case muid of+ Nothing -> return ()+ Just uid -> do+ setCreds (Creds email AuthEmail (Just email) Nothing (Just uid)+ Nothing) []+ toMaster <- getRouteToMaster+ redirect RedirectTemporary $ toMaster EmailPasswordR+ _ -> return ()+ defaultLayout $ do+ setTitle "Invalid verification key"+ addBody [$hamlet| %p I'm sorry, but that was an invalid verification key. |] -getEmailLoginR :: Yesod master => GHandler Auth master RepHtml-getEmailLoginR = do- _ae <- getAuthEmailSettings- toMaster <- getRouteToMaster- msg <- getMessage- applyLayout "Login" mempty [$hamlet|-$maybe msg ms- %p.message $ms$-%p Please log in to your account.-%p- %a!href=@toMaster.EmailRegisterR@ I don't have an account-%form!method=post!action=@toMaster.EmailLoginR@- %table- %tr- %th E-mail- %td- %input!type=email!name=email- %tr- %th Password- %td- %input!type=password!name=password- %tr- %td!colspan=2- %input!type=submit!value=Login-|]- postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do- ae <- getAuthEmailSettings+ ae <- getEmailSettings (email, pass) <- runFormPost' $ (,) <$> emailInput "email" <*> stringInput "password" y <- getYesod- mecreds <- liftIO $ getEmailCreds ae email- let mlid =- case mecreds of- Just (EmailCreds lid (Just realpass) True _) ->- if isValidPass pass realpass then Just lid else Nothing- _ -> Nothing- case mlid of- Just lid -> do- setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)+ mecreds <- getEmailCreds ae email+ maid <-+ case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of+ (Just aid, Just True) -> do+ mrealpass <- getPassword ae aid+ case mrealpass of+ Nothing -> return Nothing+ Just realpass -> return $+ if isValidPass pass realpass+ then Just aid+ else Nothing+ _ -> return Nothing+ case maid of+ Just aid -> do+ setCreds (Creds email AuthEmail (Just email) Nothing (Just aid) Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y Nothing -> do setMessage $ string "Invalid email/password combination" toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster EmailLoginR+ redirect RedirectTemporary $ toMaster LoginR -getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml+getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml getEmailPasswordR = do- _ae <- getAuthEmailSettings+ _ae <- getEmailSettings toMaster <- getRouteToMaster- mcreds <- maybeCreds- case mcreds of- Just (Creds _ AuthEmail _ _ (Just _) _) -> return ()- _ -> do+ maid <- maybeAuthId+ case maid of+ Just _ -> return ()+ Nothing -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR- msg <- getMessage- applyLayout "Set password" mempty [$hamlet|-$maybe msg ms- %p.message $ms$+ defaultLayout $ do+ setTitle "Set password"+ addBody [$hamlet| %h3 Set a new password %form!method=post!action=@toMaster.EmailPasswordR@ %table@@ -419,7 +453,7 @@ postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR = do- ae <- getAuthEmailSettings+ ae <- getEmailSettings (new, confirm) <- runFormPost' $ (,) <$> stringInput "new" <*> stringInput "confirm"@@ -427,16 +461,17 @@ when (new /= confirm) $ do 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+ maid <- maybeAuthId+ aid <- case maid of+ Nothing -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR+ Just aid -> return aid salted <- liftIO $ saltPass new- liftIO $ setPassword ae lid salted+ setPassword ae aid salted setMessage $ string "Password updated"- redirect RedirectTemporary $ toMaster EmailLoginR+ y <- getYesod+ redirect RedirectTemporary $ defaultDest y saltLength :: Int saltLength = 5@@ -457,45 +492,13 @@ saltPass' :: String -> String -> String saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) --- | A simplistic set of email settings, useful only for testing purposes. In--- particular, it doesn't actually send emails, but instead prints verification--- URLs to stderr.-inMemoryEmailSettings :: IO AuthEmailSettings-inMemoryEmailSettings = do- mm <- newMVar []- return AuthEmailSettings- { addUnverified = \email verkey -> modifyMVar mm $ \m -> do- let helper (_, EmailCreds x _ _ _) = x- let newId = 1 + maximum (0 : map helper m)- let ec = EmailCreds newId Nothing False verkey- return ((email, ec) : m, newId)- , sendVerifyEmail = \_email _verkey verurl ->- hPutStrLn stderr $ "Please go to: " ++ verurl- , getVerifyKey = \eid -> withMVar mm $ \m -> return $- lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m- , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid)- , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass)- , getEmailCreds = \email -> withMVar mm $ return . lookup email- , getEmail = \eid -> withMVar mm $ \m -> return $- case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of- ((email, _):_) -> Just email- _ -> Nothing- }- where- vago eid (email, EmailCreds eid' pass status key)- | eid == eid' = (email, EmailCreds eid pass True key)- | otherwise = (email, EmailCreds eid' pass status key)- spgo eid pass (email, EmailCreds eid' pass' status key)- | eid == eid' = (email, EmailCreds eid (Just pass) status key)- | otherwise = (email, EmailCreds eid' pass' status key)- getFacebookR :: YesodAuth master => GHandler Auth master () getFacebookR = do y <- getYesod- a <- authFacebook <$> getYesodSub+ a <- facebookSettings <$> getYesod case a of Nothing -> notFound- Just (cid, secret, _) -> do+ Just (FacebookSettings cid secret _) -> do render <- getUrlRender tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm FacebookR@@ -512,14 +515,64 @@ setCreds c [] redirectUltDest RedirectTemporary $ defaultDest y -getStartFacebookR :: GHandler Auth master ()-getStartFacebookR = do- y <- getYesodSub- case authFacebook y of- Nothing -> notFound- Just (cid, secret, perms) -> do- render <- getUrlRender- tm <- getRouteToMaster- let fb = Facebook.Facebook cid secret $ render $ tm FacebookR- let fburl = Facebook.getForwardUrl fb perms- redirectString RedirectTemporary fburl+getFacebookUrl :: YesodAuth m+ => (AuthRoute -> Route m) -> GHandler s m (Maybe String)+getFacebookUrl tm = do+ y <- getYesod+ render <- getUrlRender+ case facebookSettings y of+ Nothing -> return Nothing+ Just f -> do+ let fb =+ Facebook.Facebook+ (fbAppId f)+ (fbSecret f)+ (render $ tm FacebookR)+ return $ Just $ Facebook.getForwardUrl fb $ fbPerms f++getLoginR :: YesodAuth master => GHandler Auth master RepHtml+getLoginR = do+ lookupGetParam "dest" >>= maybe (return ()) setUltDestString+ tm <- getRouteToMaster+ y <- getYesod+ fb <- getFacebookUrl tm+ defaultLayout $ do+ setTitle "Login"+ addStyle [$cassius|+#openid+ background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;+ padding-left: 18px;+|]+ addBody [$hamlet|+$maybe emailSettings.y _+ %h3 Email+ %form!method=post!action=@tm.EmailLoginR@+ %table+ %tr+ %th E-mail+ %td+ %input!type=email!name=email+ %tr+ %th Password+ %td+ %input!type=password!name=password+ %tr+ %td!colspan=2+ %input!type=submit!value="Login via email"+ %a!href=@tm.EmailRegisterR@ I don't have an account+$if openIdEnabled.y+ %h3 OpenID+ %form!action=@tm.OpenIdForwardR@+ %label!for=openid OpenID: $+ %input#openid!type=text!name=openid+ %input!type=submit!value="Login via OpenID"+$maybe fb f+ %h3 Facebook+ %p+ %a!href=$f$ Login via Facebook+$maybe rpxnowSettings.y r+ %h3 OpenID+ %p+ %a!onclick="return false;"!href="https://$rpxnowApp.r$.rpxnow.com/openid/v2/signin?token_url=@tm.RpxnowR@"+ Login via Rpxnow+|]
Yesod/Helpers/Crud.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..)@@ -17,10 +18,10 @@ import Yesod.Handler import Text.Hamlet import Yesod.Form-import Data.Monoid (mempty)+import Language.Haskell.TH.Syntax -- | An entity which can be displayed by the Crud subsite.-class ToForm a => Item a where+class Item a where -- | The title of an entity, to be displayed in the list of all entities. itemTitle :: a -> String @@ -36,9 +37,10 @@ } mkYesodSub "Crud master item"- [ ("master", [''Yesod])- , ("item", [''Item])- , ("Key item", [''SinglePiece])+ [ ClassP ''Yesod [VarT $ mkName "master"]+ , ClassP ''Item [VarT $ mkName "item"]+ , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]+ , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] ] [$parseRoutes| / CrudListR GET /add CrudAddR GET POST@@ -51,7 +53,9 @@ getCrudListR = do items <- getYesodSub >>= crudSelect toMaster <- getRouteToMaster- applyLayout "Items" mempty [$hamlet|+ defaultLayout $ do+ setTitle "Items"+ addBody [$hamlet| %h1 Items %ul $forall items item@@ -62,21 +66,24 @@ %a!href=@toMaster.CrudAddR@ Add new item |] -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item))+getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),+ ToForm item master) => GHandler (Crud master item) master RepHtml getCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) False -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item))+postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),+ ToForm item master) => GHandler (Crud master item) master RepHtml postCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) True -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item))+getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),+ ToForm item master) => String -> GHandler (Crud master item) master RepHtml getCrudEditR s = do itemId <- maybe notFound return $ itemReadId s@@ -87,7 +94,8 @@ (Just (itemId, item)) False -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item))+postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),+ ToForm item master) => String -> GHandler (Crud master item) master RepHtml postCrudEditR s = do itemId <- maybe notFound return $ itemReadId s@@ -105,7 +113,9 @@ crud <- getYesodSub item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists toMaster <- getRouteToMaster- applyLayout "Confirm delete" mempty [$hamlet|+ defaultLayout $ do+ setTitle "Confirm delete"+ addBody [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$?@@ -128,7 +138,7 @@ itemReadId = either (const Nothing) Just . fromSinglePiece crudHelper- :: (Item a, Yesod master, SinglePiece (Key a))+ :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) => String -> Maybe (Key a, a) -> Bool -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do@@ -145,7 +155,7 @@ redirect RedirectTemporary $ toMaster $ CrudEditR $ toSinglePiece eid _ -> return ()- applyLayoutW $ do+ defaultLayout $ do wrapWidget form (wrapForm toMaster enctype) setTitle $ string title where@@ -153,7 +163,7 @@ %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$-%form!method=post!enctype=$show.enctype$+%form!method=post!enctype=$enctype$ %table ^form^ %tr@@ -170,7 +180,7 @@ YesodPersist a) => a -> Crud a i defaultCrud = const Crud- { crudSelect = runDB $ select [] []+ { crudSelect = runDB $ selectList [] [] 0 0 , crudReplace = \a -> runDB . replace a , crudInsert = runDB . insert , crudGet = runDB . get
Yesod/Helpers/Static.hs view
@@ -31,6 +31,8 @@ -- * Lookup files in filesystem , fileLookupDir , staticFiles+ -- * Hashing+ , base64md5 #if TEST , testSuite #endif@@ -40,10 +42,17 @@ import Control.Monad import Data.Maybe (fromMaybe) -import Yesod+import Yesod hiding (lift) import Data.List (intercalate) import Language.Haskell.TH.Syntax +import qualified Data.ByteString.Lazy as L+import Data.Digest.Pure.MD5+import qualified Codec.Binary.Base64Url+import qualified Data.ByteString as S+import qualified Data.Serialize+import Yesod.WebRoutes+ #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit@@ -58,10 +67,21 @@ , staticTypes :: [(String, ContentType)] } -mkYesodSub "Static" [] [$parseRoutes|-*Strings StaticRoute GET-|]+data StaticRoute = StaticRoute [String] [(String, String)]+ deriving (Eq, Show, Read) +type instance Route Static = StaticRoute++instance YesodSubSite Static master where+ getSubSite = Site+ { handleSite = \_ (StaticRoute ps _) m ->+ case m of+ "GET" -> Just $ fmap chooseRep $ getStaticRoute ps+ _ -> Nothing+ , formatPathSegments = \(StaticRoute x y) -> (x, y)+ , parsePathSegments = \x -> Right $ StaticRoute x []+ }+ -- | Lookup files in a specific directory. -- -- If you are just using this in combination with the static subsite (you@@ -132,10 +152,12 @@ let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f let sr = ConE $ mkName "StaticRoute"+ hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f+ let qs = ListE [TupE [LitE $ StringL hash, ListE []]] return [ SigD name $ ConT ''Route `AppT` ConT ''Static , FunD name- [ Clause [] (NormalB $ sr `AppE` f') []+ [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] ] ] @@ -152,3 +174,14 @@ x @?= [["foo"], ["bar", "baz"]] #endif++-- | md5-hashes the given lazy bytestring and returns the hash as+-- base64url-encoded string.+--+-- This function returns the first 8 characters of the hash.+base64md5 :: L.ByteString -> String+base64md5 = take 8+ . Codec.Binary.Base64Url.encode+ . S.unpack+ . Data.Serialize.encode+ . md5
Yesod/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses@@ -6,8 +8,23 @@ , Header (..) -- * Cookie names , langKey+ -- * Widgets+ , Location (..)+ , UniqueList (..)+ , Script (..)+ , Stylesheet (..)+ , Title (..)+ , Head (..)+ , Body (..)+ , locationToHamlet+ , runUniqueList+ , toUnique ) where +import Text.Hamlet (Hamlet, hamlet, Html)+import Data.Monoid (Monoid (..))+import Data.List (nub)+ -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse =@@ -28,3 +45,29 @@ langKey :: String langKey = "_LANG"++data Location url = Local url | Remote String+ deriving (Show, Eq)+locationToHamlet :: Location url -> Hamlet url+locationToHamlet (Local url) = [$hamlet|@url@|]+locationToHamlet (Remote s) = [$hamlet|$s$|]++newtype UniqueList x = UniqueList ([x] -> [x])+instance Monoid (UniqueList x) where+ mempty = UniqueList id+ UniqueList x `mappend` UniqueList y = UniqueList $ x . y+runUniqueList :: Eq x => UniqueList x -> [x]+runUniqueList (UniqueList x) = nub $ x []+toUnique :: x -> UniqueList x+toUnique = UniqueList . (:)++newtype Script url = Script { unScript :: Location url }+ deriving (Show, Eq)+newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }+ deriving (Show, Eq)+newtype Title = Title { unTitle :: Html }++newtype Head url = Head (Hamlet url)+ deriving Monoid+newtype Body url = Body (Hamlet url)+ deriving Monoid
Yesod/Json.hs view
@@ -1,6 +1,7 @@--- | Efficient generation of JSON documents, with HTML-entity encoding handled via types.+-- | Efficient generation of JSON documents. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Json ( -- * Monad Json@@ -18,12 +19,12 @@ where import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (isControl)-import Yesod.Hamlet import Yesod.Handler import Numeric (showHex) import Data.Monoid (Monoid (..))+import Text.Blaze.Builder.Core+import Text.Blaze.Builder.Utf8 (writeChar) #if TEST import Test.Framework (testGroup, Test)@@ -35,21 +36,20 @@ import Yesod.Content #endif --- | A monad for generating Json output. In truth, it is just a newtype wrapper--- around 'Html'; we thereby get the benefits of BlazeHtml (type safety and--- speed) without accidently mixing non-JSON content.+-- | A monad for generating Json output. It wraps the Builder monoid from the+-- blaze-builder package. -- -- 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 = Json { unJson :: Html () }+newtype Json = Json { unJson :: Builder } deriving Monoid -- | Extract the final result from the given 'Json' value. -- -- See also: applyLayoutJson in "Yesod.Yesod". jsonToContent :: Json -> GHandler sub master Content-jsonToContent = return . toContent . renderHtml . unJson+jsonToContent = return . toContent . toLazyByteString . unJson -- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. jsonToRepJson :: Json -> GHandler sub master RepJson@@ -57,61 +57,58 @@ -- | Outputs a single scalar. This function essentially: ----- * Performs HTML entity escaping as necesary.--- -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes.-jsonScalar :: Html () -> Json+jsonScalar :: String -> Json jsonScalar s = Json $ mconcat- [ preEscapedString "\""- , unsafeByteString $ S.concat $ L.toChunks $ encodeJson $ renderHtml s- , preEscapedString "\""+ [ fromByteString "\""+ , writeList writeJsonChar s+ , fromByteString "\"" ] where- encodeJson = L.concatMap (L.pack . encodeJsonChar)-- encodeJsonChar '\b' = "\\b"- encodeJsonChar '\f' = "\\f"- encodeJsonChar '\n' = "\\n"- encodeJsonChar '\r' = "\\r"- encodeJsonChar '\t' = "\\t"- encodeJsonChar '"' = "\\\""- encodeJsonChar '\\' = "\\\\"- encodeJsonChar c- | not $ isControl c = [c]- | c < '\x10' = '\\' : 'u' : '0' : '0' : '0' : hexxs- | c < '\x100' = '\\' : 'u' : '0' : '0' : hexxs- | c < '\x1000' = '\\' : 'u' : '0' : hexxs+ writeJsonChar '\b' = writeByteString "\\b"+ writeJsonChar '\f' = writeByteString "\\f"+ writeJsonChar '\n' = writeByteString "\\n"+ writeJsonChar '\r' = writeByteString "\\r"+ writeJsonChar '\t' = writeByteString "\\t"+ writeJsonChar '"' = writeByteString "\\\""+ writeJsonChar '\\' = writeByteString "\\\\"+ writeJsonChar c+ | not $ isControl c = writeChar c+ | c < '\x10' = writeString $ '\\' : 'u' : '0' : '0' : '0' : hexxs+ | c < '\x100' = writeString $ '\\' : 'u' : '0' : '0' : hexxs+ | c < '\x1000' = writeString $ '\\' : 'u' : '0' : hexxs where hexxs = showHex (fromEnum c) ""- encodeJsonChar c = [c]+ writeJsonChar c = writeChar c+ writeString = writeByteString . S.pack -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. jsonList :: [Json] -> Json-jsonList [] = Json $ preEscapedString "[]"+jsonList [] = Json $ fromByteString "[]" jsonList (x:xs) = mconcat- [ Json $ preEscapedString "["+ [ Json $ fromByteString "[" , x , mconcat $ map go xs- , Json $ preEscapedString "]"+ , Json $ fromByteString "]" ] where- go = mappend (Json $ preEscapedString ",")+ go = mappend (Json $ fromByteString ",") -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. jsonMap :: [(String, Json)] -> Json-jsonMap [] = Json $ preEscapedString "{}"+jsonMap [] = Json $ fromByteString "{}" jsonMap (x:xs) = mconcat- [ Json $ preEscapedString "{"+ [ Json $ fromByteString "{" , go x , mconcat $ map go' xs- , Json $ preEscapedString "}"+ , Json $ fromByteString "}" ] where- go' y = mappend (Json $ preEscapedString ",") $ go y+ go' y = mappend (Json $ fromByteString ",") $ go y go (k, v) = mconcat- [ jsonScalar $ string k- , Json $ preEscapedString ":"+ [ jsonScalar k+ , Json $ fromByteString ":" , v ] @@ -119,7 +116,7 @@ -- this is the only function in this module that allows you to create broken -- JSON documents. jsonRaw :: S.ByteString -> Json-jsonRaw bs = Json $ unsafeByteString bs+jsonRaw = Json . fromByteString #if TEST @@ -133,10 +130,10 @@ let j = do jsonMap [ ("foo" , jsonList- [ jsonScalar $ preEscapedString "bar"- , jsonScalar $ preEscapedString "baz"+ [ jsonScalar "bar"+ , jsonScalar "baz" ]) ]- "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (renderHtml $ unJson j)+ "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (toLazyByteString $ unJson j) #endif
+ Yesod/Mail.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Mail+ ( Boundary (..)+ , Mail (..)+ , Part (..)+ , Encoding (..)+ , renderMail+ , renderMail'+ , sendmail+ , Disposition (..)+ , renderSendMail+ , randomString+ ) where++import qualified Data.ByteString.Lazy as L+import Text.Blaze.Builder.Utf8+import Text.Blaze.Builder.Core+import Data.Monoid+import System.Random+import Control.Arrow+import System.Process+import System.IO+import System.Exit+import Codec.Binary.Base64 (encode)+import Control.Monad ((<=<))++randomString :: RandomGen d => Int -> d -> (String, d)+randomString len =+ first (map toChar) . sequence' (replicate len (randomR (0, 61)))+ where+ sequence' [] g = ([], g)+ sequence' (f:fs) g =+ let (f', g') = f g+ (fs', g'') = sequence' fs g'+ in (f' : fs', g'')+ toChar i+ | i < 26 = toEnum $ i + fromEnum 'A'+ | i < 52 = toEnum $ i + fromEnum 'a' - 26+ | otherwise = toEnum $ i + fromEnum '0' - 52++newtype Boundary = Boundary { unBoundary :: String }+instance Random Boundary where+ randomR = const random+ random = first Boundary . randomString 10++data Mail = Mail+ { mailHeaders :: [(String, String)]+ , mailPlain :: String+ , mailParts :: [Part]+ }++data Encoding = None | Base64++data Part = Part+ { partType :: String -- ^ content type+ , partEncoding :: Encoding+ , partDisposition :: Disposition+ , partContent :: L.ByteString+ }++data Disposition = Inline | Attachment String++renderMail :: Boundary -> Mail -> L.ByteString+renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat+ [ mconcat $ map showHeader headers+ , mconcat $ map showHeader+ [ ("MIME-Version", "1.0")+ , ("Content-Type", "multipart/mixed; boundary=\""+ ++ b ++ "\"")+ ]+ , fromByteString "\n"+ , fromString plain+ , mconcat $ map showPart parts+ , fromByteString "\n--"+ , fromString b+ , fromByteString "--"+ ]+ where+ showHeader (k, v) = mconcat+ [ fromString k+ , fromByteString ": "+ , fromString v+ , fromByteString "\n"+ ]+ showPart (Part contentType encoding disposition content) = mconcat+ [ fromByteString "\n--"+ , fromString b+ , fromByteString "\n"+ , showHeader ("Content-Type", contentType)+ , case encoding of+ None -> mempty+ Base64 -> showHeader ("Content-Transfer-Encoding", "base64")+ , case disposition of+ Inline -> mempty+ Attachment filename ->+ showHeader ("Content-Disposition", "attachment; filename=" ++ filename)+ , fromByteString "\n"+ , case encoding of+ None -> writeList writeByteString $ L.toChunks content+ Base64 -> writeList writeByte $ map (toEnum . fromEnum) $ encode $ L.unpack content+ ]++renderMail' :: Mail -> IO L.ByteString+renderMail' m = do+ b <- randomIO+ return $ renderMail b m++sendmail :: L.ByteString -> IO ()+sendmail lbs = do+ (Just hin, _, _, phandle) <- createProcess $ (proc+ "/usr/sbin/sendmail" ["-t"]) { std_in = CreatePipe }+ L.hPut hin lbs+ hClose hin+ exitCode <- waitForProcess phandle+ case exitCode of+ ExitSuccess -> return ()+ _ -> error $ "sendmail exited with error code " ++ show exitCode++renderSendMail :: Mail -> IO ()+renderSendMail = sendmail <=< renderMail'
+ Yesod/WebRoutes.hs view
@@ -0,0 +1,88 @@+-- | This module should be removed when web-routes incorporates necessary support.+module Yesod.WebRoutes+ ( encodePathInfo+ , Site (..)+ ) where++import Codec.Binary.UTF8.String (encodeString)+import Data.List (intercalate)+import Network.URI++encodePathInfo :: [String] -> [(String, String)] -> String+encodePathInfo pieces qs = + let x = map encodeString `o` -- utf-8 encode the data characters in path components (we have not added any delimiters yet)+ map (escapeURIString (\c -> isUnreserved c || c `elem` ":@&=+$,")) `o` -- percent encode the characters+ map (\str -> case str of "." -> "%2E" ; ".." -> "%2E%2E" ; _ -> str) `o` -- encode . and ..+ intercalate "/" -- add in the delimiters+ y = showParams qs+ in x pieces ++ y+ where+ -- reverse composition + o :: (a -> b) -> (b -> c) -> a -> c+ o = flip (.)++{-|++A site groups together the three functions necesary to make an application:++* A function to convert from the URL type to path segments.++* A function to convert from path segments to the URL, if possible.++* A function to return the application for a given URL.++There are two type parameters for Site: the first is the URL datatype, the+second is the application datatype. The application datatype will depend upon+your server backend.+-}+data Site url a+ = Site {+ {-|+ Return the appropriate application for a given URL.++ The first argument is a function which will give an appropriate+ URL (as a String) for a URL datatype. This is usually+ constructed by a combination of 'formatPathSegments' and the+ prepending of an absolute application root.++ Well behaving applications should use this function to+ generating all internal URLs.+ -}+ handleSite :: (url -> [(String, String)] -> String) -> url -> a+ -- | This function must be the inverse of 'parsePathSegments'.+ , formatPathSegments :: url -> ([String], [(String, String)])+ -- | This function must be the inverse of 'formatPathSegments'.+ , parsePathSegments :: [String] -> Either String url+ }++showParams :: [(String, String)] -> String+showParams [] = ""+showParams z =+ '?' : intercalate "&" (map go z)+ where+ go (x, "") = go' x+ go (x, y) = go' x ++ '=' : go' y+ go' = concatMap encodeUrlChar++-- | Taken straight from web-encodings; reimplemented here to avoid extra+-- dependencies.+encodeUrlChar :: Char -> String+encodeUrlChar c+ -- List of unreserved characters per RFC 3986+ -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding+ | 'A' <= c && c <= 'Z' = [c]+ | 'a' <= c && c <= 'z' = [c]+ | '0' <= c && c <= '9' = [c]+encodeUrlChar c@'-' = [c]+encodeUrlChar c@'_' = [c]+encodeUrlChar c@'.' = [c]+encodeUrlChar c@'~' = [c]+encodeUrlChar ' ' = "+"+encodeUrlChar y =+ let (a, c) = fromEnum y `divMod` 16+ b = a `mod` 16+ showHex' x+ | x < 10 = toEnum $ x + (fromEnum '0')+ | x < 16 = toEnum $ x - 10 + (fromEnum 'A')+ | otherwise = error $ "Invalid argument to showHex: " ++ show x+ in ['%', showHex' b, showHex' c]
Yesod/Widget.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,73 +6,39 @@ -- generator, allowing you to create truly modular HTML components. module Yesod.Widget ( -- * Datatype- GWidget+ GWidget (..) , Widget , liftHandler- -- * Unwrapping- , widgetToPageContent- , applyLayoutW -- * Creating , newIdent , setTitle , addStyle , addStylesheet , addStylesheetRemote+ , addStylesheetEither , addScript , addScriptRemote+ , addScriptEither , addHead , addBody- , addJavaScript+ , addJavascript -- * Manipulating , wrapWidget , extractBody- -- * Default library URLs- , urlJqueryJs- , urlJqueryUiJs- , urlJqueryUiCss ) where -import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State-import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html)+import Text.Hamlet+import Text.Cassius+import Text.Julius import Yesod.Handler (Route, GHandler)-import Yesod.Yesod (Yesod, defaultLayout)-import Yesod.Content (RepHtml (..)) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)--data Location url = Local url | Remote String- deriving (Show, Eq)-locationToHamlet :: Location url -> Hamlet url-locationToHamlet (Local url) = [$hamlet|@url@|]-locationToHamlet (Remote s) = [$hamlet|$s$|]--newtype UniqueList x = UniqueList ([x] -> [x])-instance Monoid (UniqueList x) where- mempty = UniqueList id- UniqueList x `mappend` UniqueList y = UniqueList $ x . y-runUniqueList :: Eq x => UniqueList x -> [x]-runUniqueList (UniqueList x) = nub $ x []-toUnique :: x -> UniqueList x-toUnique = UniqueList . (:)--newtype Script url = Script { unScript :: Location url }- deriving (Show, Eq)-newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }- deriving (Show, Eq)-newtype Title = Title { unTitle :: Html () }-newtype Style url = Style (Maybe (Hamlet url))- deriving Monoid-newtype Head url = Head (Hamlet url)- deriving Monoid-newtype Body url = Body (Hamlet url)- deriving Monoid-newtype JavaScript url = JavaScript (Maybe (Hamlet url))- deriving Monoid+import Yesod.Internal -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of@@ -83,8 +48,8 @@ WriterT (Last Title) ( WriterT (UniqueList (Script (Route master))) ( WriterT (UniqueList (Stylesheet (Route master))) (- WriterT (Style (Route master)) (- WriterT (JavaScript (Route master)) (+ WriterT (Maybe (Cassius (Route master))) (+ WriterT (Maybe (Julius (Route master))) ( WriterT (Head (Route master)) ( StateT Int ( GHandler sub master@@ -103,7 +68,7 @@ -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values.-setTitle :: Html () -> GWidget sub master ()+setTitle :: Html -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title -- | Add some raw HTML to the head tag.@@ -123,8 +88,8 @@ return $ "w" ++ show i' -- | Add some raw CSS to the style tag.-addStyle :: Hamlet (Route master) -> GWidget sub master ()-addStyle = GWidget . lift . lift . lift . lift . tell . Style . Just+addStyle :: Cassius (Route master) -> GWidget sub master ()+addStyle = GWidget . lift . lift . lift . lift . tell . Just -- | Link to the specified local stylesheet. addStylesheet :: Route master -> GWidget sub master ()@@ -135,6 +100,12 @@ addStylesheetRemote = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote +addStylesheetEither :: Either (Route master) String -> GWidget sub master ()+addStylesheetEither = either addStylesheet addStylesheetRemote++addScriptEither :: Either (Route master) String -> GWidget sub master ()+addScriptEither = either addScript addScriptRemote+ -- | Link to the specified local script. addScript :: Route master -> GWidget sub master () addScript = GWidget . lift . lift . tell . toUnique . Script . Local@@ -145,47 +116,8 @@ GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag.-addJavaScript :: Hamlet (Route master) -> GWidget sub master ()-addJavaScript = GWidget . lift . lift . lift . lift . lift. tell- . JavaScript . Just---- | Apply the default layout to the given widget.-applyLayoutW :: (Eq (Route m), Yesod m)- => GWidget sub m () -> GHandler sub m RepHtml-applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout---- | Convert a widget to a 'PageContent'.-widgetToPageContent :: Eq (Route master)- => GWidget sub master ()- -> GHandler sub master (PageContent (Route master))-widgetToPageContent (GWidget w) = do- w' <- flip evalStateT 0- $ runWriterT $ runWriterT $ runWriterT $ runWriterT- $ runWriterT $ runWriterT $ runWriterT w- let ((((((((),- Body body),- Last mTitle),- scripts'),- stylesheets'),- Style style),- JavaScript jscript),- Head head') = w'- let title = maybe mempty unTitle mTitle- let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'- let stylesheets = map (locationToHamlet . unStylesheet)- $ runUniqueList stylesheets'- let head'' = [$hamlet|-$forall scripts s- %script!src=^s^-$forall stylesheets s- %link!rel=stylesheet!href=^s^-$maybe style s- %style ^s^-$maybe jscript j- %script ^j^-^head'^-|]- return $ PageContent title head'' body+addJavascript :: Julius (Route master) -> GWidget sub master ()+addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Modify the given 'GWidget' by wrapping the body tag HTML code with the -- given function. You might also consider using 'extractBody'.@@ -204,18 +136,3 @@ GWidget $ mapWriterT (fmap go) w where go ((), Body h) = (h, Body mempty)---- | The Google-hosted jQuery 1.4.2 file.-urlJqueryJs :: String-urlJqueryJs =- "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"---- | The Google-hosted jQuery UI 1.8.1 javascript file.-urlJqueryUiJs :: String-urlJqueryUiJs =- "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"---- | The Google-hosted jQuery UI 1.8.1 CSS file with cupertino theme.-urlJqueryUiCss :: String-urlJqueryUiCss =- "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
Yesod/Yesod.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes@@ -16,36 +18,61 @@ -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs- -- * Convenience functions- , applyLayout- , applyLayoutJson+ -- * Utitlities , maybeAuthorized+ , widgetToPageContent+ , defaultLayoutJson -- * Defaults , defaultErrorHandler -- * Data types , AuthResult (..)+#if TEST+ , testSuite+#endif ) where +#if TEST+import Yesod.Content hiding (testSuite)+import Yesod.Json hiding (testSuite)+#else import Yesod.Content+import Yesod.Json+#endif++import Yesod.Widget import Yesod.Request import Yesod.Hamlet import Yesod.Handler import qualified Network.Wai as W-import Yesod.Json import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS-import Data.Monoid (mempty)-import Data.ByteString.UTF8 (toString)+import qualified Data.ByteString.UTF8 as BSU import Database.Persist-import Web.Routes.Site (Site) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure)+import qualified Data.ByteString as S+import qualified Network.Wai.Middleware.CleanPath+import qualified Data.ByteString.Lazy as L+import Yesod.WebRoutes+import Data.Monoid+import Control.Monad.Trans.Writer+import Control.Monad.Trans.State hiding (get)+import Text.Hamlet+import Text.Cassius+import Text.Julius +#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit hiding (Test)+#endif+ -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where- getSite :: Site (Route y) (Method -> Maybe (Handler y ChooseRep))+ getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) type Method = String -- | Same as 'YesodSite', but for subsites. Once again, users should not need@@ -82,8 +109,10 @@ errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page.- defaultLayout :: PageContent (Route a) -> GHandler sub a Content- defaultLayout p = hamletToContent [$hamlet|+ defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml+ defaultLayout w = do+ p <- widgetToPageContent w+ hamletToRepHtml [$hamlet| !!! %html %head@@ -108,9 +137,24 @@ -- 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 :: Route a -> GHandler s a AuthResult- isAuthorized _ = return Authorized+ isAuthorized :: Route a+ -> Bool -- ^ is this a write request?+ -> GHandler s a AuthResult+ isAuthorized _ _ = return Authorized + -- | Determines whether the current request is a write request. By default,+ -- this assumes you are following RESTful principles, and determines this+ -- from request method. In particular, all except the following request+ -- methods are considered write: GET HEAD OPTIONS TRACE.+ --+ -- This function is used to determine if a request is authorized; see+ -- 'isAuthorized'.+ isWriteRequest :: Route a -> GHandler s a Bool+ isWriteRequest _ = do+ wai <- waiRequest+ return $ not $ W.requestMethod wai `elem`+ ["GET", "HEAD", "OPTIONS", "TRACE"]+ -- | The default route for authentication. -- -- Used in particular by 'isAuthorized', but library users can do whatever@@ -118,6 +162,48 @@ authRoute :: a -> Maybe (Route a) authRoute _ = Nothing + -- | A function used to split a raw PATH_INFO value into path pieces. It+ -- returns a 'Left' value when you should redirect to the given path, and a+ -- 'Right' value on successful parse.+ --+ -- By default, it splits paths on slashes, and ensures the following are true:+ --+ -- * No double slashes+ --+ -- * If the last path segment has a period, there is no trailing slash.+ --+ -- * Otherwise, ensures there /is/ a trailing slash.+ splitPath :: a -> S.ByteString -> Either S.ByteString [String]+ splitPath _ = Network.Wai.Middleware.CleanPath.splitPath++ -- | Join the pieces of a path together into an absolute URL. This should+ -- be the inverse of 'splitPath'.+ joinPath :: a -> String -> [String] -> [(String, String)] -> String+ joinPath _ ar pieces qs =+ ar ++ '/' : encodePathInfo (fixSegs pieces) qs+ where+ fixSegs [] = []+ fixSegs [x]+ | any (== '.') x = [x]+ | otherwise = [x, ""] -- append trailing slash+ fixSegs (x:xs) = x : fixSegs xs++ -- | This function is used to store some static content to be served as an+ -- external file. The most common case of this is stashing CSS and+ -- JavaScript content in an external file; the "Yesod.Widget" module uses+ -- this feature.+ --+ -- The return value is 'Nothing' if no storing was performed; this is the+ -- default implementation. A 'Just' 'Left' gives the absolute URL of the+ -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is+ -- necessary when you are serving the content outside the context of a+ -- Yesod application, such as via memcached.+ addStaticContent :: String -- ^ filename extension+ -> String -- ^ mime-type+ -> L.ByteString -- ^ content+ -> GHandler sub a (Maybe (Either String (Route a, [(String, String)])))+ addStaticContent _ _ _ = return Nothing+ data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) @@ -148,49 +234,33 @@ (title, next) <- breadcrumb this go ((this, title) : back) next --- | Apply the default layout ('defaultLayout') to the given title and body.-applyLayout :: Yesod master- => String -- ^ title- -> Hamlet (Route master) -- ^ head- -> Hamlet (Route master) -- ^ body- -> GHandler sub master RepHtml-applyLayout t h b =- RepHtml `fmap` defaultLayout PageContent- { pageTitle = string t- , pageHead = h- , pageBody = b- }- -- | Provide both an HTML and JSON representation for a piece of data, using -- the default layout for the HTML output ('defaultLayout').-applyLayoutJson :: Yesod master- => String -- ^ title- -> Hamlet (Route master) -- ^ head- -> Hamlet (Route master) -- ^ body- -> Json- -> GHandler sub master RepHtmlJson-applyLayoutJson t h html json = do- html' <- defaultLayout PageContent- { pageTitle = string t- , pageHead = h- , pageBody = html- }+defaultLayoutJson :: Yesod master+ => GWidget sub master ()+ -> Json+ -> GHandler sub master RepHtmlJson+defaultLayoutJson w json = do+ RepHtml html' <- defaultLayout w json' <- jsonToContent json return $ RepHtmlJson html' json' applyLayout' :: Yesod master- => String -- ^ title+ => Html -- ^ title -> Hamlet (Route master) -- ^ body -> GHandler sub master ChooseRep-applyLayout' s = fmap chooseRep . applyLayout s mempty+applyLayout' title body = fmap chooseRep $ defaultLayout $ do+ setTitle title+ addBody body -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest+ let path = BSU.toString $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found-%p $toString.pathInfo.r$+%p $path$ |] where pathInfo = W.pathInfo@@ -236,7 +306,112 @@ -- -- Built on top of 'isAuthorized'. This is useful for building page that only -- contain links to pages the user is allowed to see.-maybeAuthorized :: Yesod a => Route a -> GHandler s a (Maybe (Route a))-maybeAuthorized r = do- x <- isAuthorized r+maybeAuthorized :: Yesod a+ => Route a+ -> Bool -- ^ is this a write request?+ -> GHandler s a (Maybe (Route a))+maybeAuthorized r isWrite = do+ x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing++-- | Convert a widget to a 'PageContent'.+widgetToPageContent :: (Eq (Route master), Yesod master)+ => GWidget sub master ()+ -> GHandler sub master (PageContent (Route master))+widgetToPageContent (GWidget w) = do+ w' <- flip evalStateT 0+ $ runWriterT $ runWriterT $ runWriterT $ runWriterT+ $ runWriterT $ runWriterT $ runWriterT w+ let ((((((((),+ Body body),+ Last mTitle),+ scripts'),+ stylesheets'),+ style),+ jscript),+ Head head') = w'+ let title = maybe mempty unTitle mTitle+ let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'+ let stylesheets = map (locationToHamlet . unStylesheet)+ $ runUniqueList stylesheets'+ let cssToHtml (Css b) = Html b+ celper :: Cassius url -> Hamlet url+ celper = fmap cssToHtml+ jsToHtml (Javascript b) = Html b+ jelper :: Julius url -> Hamlet url+ jelper = fmap jsToHtml++ render <- getUrlRenderParams+ let renderLoc x =+ case x of+ Nothing -> Nothing+ Just (Left s) -> Just s+ Just (Right (u, p)) -> Just $ render u p+ cssLoc <-+ case style of+ Nothing -> return Nothing+ Just s -> do+ x <- addStaticContent "css" "text/css; charset=utf-8"+ $ renderCassius render s+ return $ renderLoc x+ jsLoc <-+ case jscript of+ Nothing -> return Nothing+ Just s -> do+ x <- addStaticContent "js" "text/javascript; charset=utf-8"+ $ renderJulius render s+ return $ renderLoc x++ let head'' = [$hamlet|+$forall scripts s+ %script!src=^s^+$forall stylesheets s+ %link!rel=stylesheet!href=^s^+$maybe style s+ $maybe cssLoc s+ %link!rel=stylesheet!href=$s$+ $nothing+ %style ^celper.s^+$maybe jscript j+ $maybe jsLoc s+ %script!src=$s$+ $nothing+ %script ^jelper.j^+^head'^+|]+ return $ PageContent title head'' body++#if TEST+testSuite :: Test+testSuite = testGroup "Yesod.Yesod"+ [ testProperty "join/split path" propJoinSplitPath+ , testCase "utf8 split path" caseUtf8SplitPath+ , testCase "utf8 join path" caseUtf8JoinPath+ ]++data TmpYesod = TmpYesod+data TmpRoute = TmpRoute deriving Eq+type instance Route TmpYesod = TmpRoute+instance Yesod TmpYesod where approot _ = ""++propJoinSplitPath ss =+ splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' [])+ == Right ss'+ where+ ss' = filter (not . null) ss++caseUtf8SplitPath :: Assertion+caseUtf8SplitPath = do+ Right ["שלום"] @=?+ splitPath TmpYesod (BSU.fromString "/שלום/")+ Right ["page", "Fooé"] @=?+ splitPath TmpYesod (BSU.fromString "/page/Fooé/")+ Right ["\156"] @=?+ splitPath TmpYesod (BSU.fromString "/\156/")+ Right ["ð"] @=?+ splitPath TmpYesod (BSU.fromString "/%C3%B0/")++caseUtf8JoinPath :: Assertion+caseUtf8JoinPath = do+ "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []+#endif
+ favicon.ico view
binary file changed (absent → 1150 bytes)
runtests.hs view
@@ -4,6 +4,7 @@ import qualified Yesod.Json import qualified Yesod.Dispatch import qualified Yesod.Helpers.Static+import qualified Yesod.Yesod main :: IO () main = defaultMain@@ -11,4 +12,5 @@ , Yesod.Json.testSuite , Yesod.Dispatch.testSuite , Yesod.Helpers.Static.testSuite+ , Yesod.Yesod.testSuite ]
scaffold.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} import CodeGenQ import System.IO import System.Directory+import qualified Data.ByteString.Char8 as S+import Language.Haskell.TH.Syntax main :: IO () main = do putStr [$codegen|Welcome to the Yesod scaffolder. I'm going to be creating a skeleton Yesod project for you.-Please make sure you are in the directory where you'd like the files created. What is your name? We're going to put this in the cabal and LICENSE files. @@ -17,26 +18,80 @@ putStr [$codegen| Welcome ~name~.-What do you want to call your project? We'll use this for the cabal name and-executable filenames.+What do you want to call your project? We'll use this for the cabal name. Project name: |] hFlush stdout project <- getLine+ putStr [$codegen|-Great, we'll be creating ~project~ today. What's going to be the name of-your site argument datatype? This name must start with a capital letter;-I recommend picking something short, as this name gets typed a lot.+Now where would you like me to place your generated files? I'm smart enough+to create the directories, don't worry about that. If you leave this answer+blank, we'll place the files in ~project~. +Directory name: |]+ hFlush stdout+ dirRaw <- getLine+ let dir = if null dirRaw then project else dirRaw++ putStr [$codegen|+Great, we'll be creating ~project~ today, and placing it in ~dir~.+What's going to be the name of your site argument datatype? This name must+start with a capital letter.+ Site argument: |] hFlush stdout sitearg <- getLine+ putStr [$codegen| That's it! I'm creating your files now... |] - putStrLn $ "Generating " ++ project ++ ".cabal"- writeFile (project ++ ".cabal") [$codegen|+ putStr [$codegen|+Yesod uses Persistent for its (you guessed it) persistence layer.+This tool will build in either SQLite or PostgreSQL support for you. If you+want to use a different backend, you'll have to make changes manually.+If you're not sure, stick with SQLite: it has no dependencies.++So, what'll it be? s for sqlite, p for postgresql: |]+ hFlush stdout+ backendS <- getLine+ let pconn1 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug|]+ let pconn2 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production|]+ let (lower, upper, connstr1, connstr2) =+ case backendS of+ "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3")+ "p" -> ("postgresql", "Postgresql", pconn1, pconn2)+ _ -> error $ "Invalid backend: " ++ backendS+++ let writeFile' fp s = do+ putStrLn $ "Generating " ++ fp+ writeFile (dir ++ '/' : fp) s+ mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp++ mkDir "Handler"+ mkDir "hamlet"+ mkDir "cassius"+ mkDir "julius"++ writeFile' "simple-server.hs" [$codegen|+import Controller+import Network.Wai.Handler.SimpleServer (run)++main :: IO ()+main = putStrLn "Loaded" >> with~sitearg~ (run 3000)+|]++ writeFile' "fastcgi.hs" [$codegen|+import Controller+import Network.Wai.Handler.FastCGI (run)++main :: IO ()+main = with~sitearg~ run+|]++ writeFile' (project ++ ".cabal") [$codegen| name: ~project~ version: 0.0.0 license: BSD3@@ -51,16 +106,39 @@ build-type: Simple homepage: http://www.yesodweb.com/~project~ -executable ~project~+Flag production+ Description: Build the production executable.+ Default: False++executable simple-server+ if flag(production)+ Buildable: False+ main-is: simple-server.hs build-depends: base >= 4 && < 5,- yesod >= 0.4.0 && < 0.5.0,- persistent-sqlite >= 0.1.0 && < 0.2+ yesod >= 0.5 && < 0.6,+ wai-extra,+ directory,+ bytestring,+ persistent,+ persistent-sqlite,+ template-haskell,+ hamlet ghc-options: -Wall- main-is: ~project~.hs+ extensions: TemplateHaskell, QuasiQuotes, TypeFamilies++executable fastcgi+ if flag(production)+ Buildable: True+ else+ Buildable: False+ cpp-options: -DPRODUCTION+ main-is: fastcgi.hs+ build-depends: wai-handler-fastcgi+ ghc-options: -Wall+ extensions: TemplateHaskell, QuasiQuotes, TypeFamilies |] - putStrLn "Generating LICENSE"- writeFile "LICENSE" [$codegen|+ writeFile' "LICENSE" [$codegen| The following license covers this documentation, and the source code, except where otherwise indicated. @@ -88,113 +166,343 @@ ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |] - putStrLn ("Generating " ++ project ++ ".hs")- writeFile (project ++ ".hs") [$codegen|-import Yesod-import App--main :: IO ()-main = with~sitearg~ $ basicHandler 3000-|]-- putStrLn "Generating App.hs"- writeFile "App.hs" [$codegen|-{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}-module App+ writeFile' (sitearg ++ ".hs") [$codegen|+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+module ~sitearg~ ( ~sitearg~ (..)- , with~sitearg~+ , ~sitearg~Route (..)+ , resources~sitearg~+ , Handler+ , maybeAuth+ , requireAuth+ , module Yesod+ , module Settings+ , module Model+ , StaticRoute (..)+ , AuthRoute (..) ) where+ import Yesod-import Yesod.Helpers.Crud+import Yesod.Mail import Yesod.Helpers.Static-import Database.Persist.Sqlite+import Yesod.Helpers.Auth+import qualified Settings+import System.Directory+import qualified Data.ByteString.Lazy as L+import Yesod.WebRoutes+import Database.Persist.GenericSql+import Settings (hamletFile, cassiusFile, juliusFile) import Model+import Control.Monad (join)+import Data.Maybe (isJust) data ~sitearg~ = ~sitearg~- { connPool :: Pool Connection- , static :: Static+ { getStatic :: Static+ , connPool :: Settings.ConnectionPool } -with~sitearg~ :: (~sitearg~ -> IO a) -> IO a-with~sitearg~ f = withSqlite "~project~.db3" 8 $ \pool -> do- flip runSqlite pool $ do- -- This is where you can initialize your database.- initialize (undefined :: Person)- f $ ~sitearg~ pool $ fileLookupDir "static" typeByExt+type Handler = GHandler ~sitearg~ ~sitearg~ -type PersonCrud = Crud ~sitearg~ Person+mkYesodData "~sitearg~" [$parseRoutes|+/static StaticR Static getStatic+/auth AuthR Auth getAuth -mkYesod "~sitearg~" [$parseRoutes|-/ RootR GET-/people PeopleR PersonCrud defaultCrud-/static StaticR Static static+/favicon.ico FaviconR GET+/robots.txt RobotsR GET++/ RootR GET |~~] instance Yesod ~sitearg~ where- approot _ = "http://localhost:3000"- defaultLayout (PageContent title head' body) = hamletToContent [$hamlet|-!!!-%html- %head- %title $title$- %link!rel=stylesheet!href=@stylesheet@- ^head'^- %body- #wrapper- ^body^-|~~]+ approot _ = Settings.approot+ defaultLayout widget = do+ mmsg <- getMessage+ pc <- widgetToPageContent $ do+ widget+ addStyle $(Settings.cassiusFile "default-layout")+ hamletToRepHtml $(Settings.hamletFile "default-layout")+ urlRenderOverride a (StaticR s) =+ Just $ uncurry (joinPath a Settings.staticroot) $ format s where- stylesheet = StaticR $ StaticRoute ["style.css"]+ format = formatPathSegments ss+ ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))+ ss = getSubSite+ urlRenderOverride _ _ = Nothing+ authRoute _ = Just $ AuthR LoginR+ addStaticContent ext' _ content = do+ let fn = base64md5 content ++ '.' : ext'+ let statictmp = Settings.staticdir ++ "/tmp/"+ liftIO $ createDirectoryIfMissing True statictmp+ liftIO $ L.writeFile (statictmp ++ fn) content+ return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) instance YesodPersist ~sitearg~ where- type YesodDB ~sitearg~ = SqliteReader- runDB db = fmap connPool getYesod >>= runSqlite db+ type YesodDB ~sitearg~ = SqlPersist+ runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db -getRootR :: Handler ~sitearg~ RepHtml-getRootR = applyLayoutW $ do- setTitle "Welcome to the ~project~ project"- addBody [$hamlet|-%h1 Welcome to ~project~-%h2 The greatest Yesod web application ever!+instance YesodAuth ~sitearg~ where+ type AuthEntity ~sitearg~ = User+ type AuthEmailEntity ~sitearg~ = Email++ defaultDest _ = RootR++ getAuthId creds _extra = runDB $ do+ x <- getBy $ UniqueUser $ credsIdent creds+ case x of+ Just (uid, _) -> return $ Just uid+ Nothing -> do+ fmap Just $ insert $ User (credsIdent creds) Nothing++ openIdEnabled _ = True++ emailSettings _ = Just EmailSettings+ { addUnverified = \email verkey ->+ runDB $ insert $ Email email Nothing (Just verkey)+ , sendVerifyEmail = sendVerifyEmail'+ , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get+ , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]+ , verifyAccount = \eid -> runDB $ do+ me <- get eid+ case me of+ Nothing -> return Nothing+ Just e -> do+ let email = emailEmail e+ case emailUser e of+ Just uid -> return $ Just uid+ Nothing -> do+ uid <- insert $ User email Nothing+ update eid [EmailUser $ Just uid]+ return $ Just uid+ , getPassword = runDB . fmap (join . fmap userPassword) . get+ , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]+ , getEmailCreds = \email -> runDB $ do+ me <- getBy $ UniqueEmail email+ case me of+ Nothing -> return Nothing+ Just (eid, e) -> return $ Just EmailCreds+ { emailCredsId = eid+ , emailCredsAuthId = emailUser e+ , emailCredsStatus = isJust $ emailUser e+ , emailCredsVerkey = emailVerkey e+ }+ , getEmail = runDB . fmap (fmap emailEmail) . get+ }++sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()+sendVerifyEmail' email _ verurl =+ liftIO $ renderSendMail Mail+ { mailHeaders =+ [ ("From", "noreply")+ , ("To", email)+ , ("Subject", "Verify your email address")+ ]+ , mailPlain = verurl+ , mailParts = return Part+ { partType = "text/html; charset=utf-8"+ , partEncoding = None+ , partDisposition = Inline+ , partContent = renderHamlet id [$hamlet|+%p Please confirm your email address by clicking on the link below. %p- %a!href=@PeopleR.CrudListR@ Manage people+ %a!href=$verurl$ $verurl$+%p Thank you |~~]+ }+ } |] - putStrLn "Generating Model.hs"- writeFile "Model.hs" [$codegen|-{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TypeFamilies #-}+ writeFile' "Controller.hs" [$codegen|+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Controller+ ( with~sitearg~+ ) where --- We don't explicitly state our export list, since there are funny things--- that happen with type family constructors.+import ~sitearg~+import Settings+import Yesod.Helpers.Static+import Yesod.Helpers.Auth+import Database.Persist.GenericSql++import Handler.Root++mkYesodDispatch "~sitearg~" resources~sitearg~++getFaviconR :: Handler ()+getFaviconR = sendFile "image/x-icon" "favicon.ico"++getRobotsR :: Handler RepPlain+getRobotsR = return $ RepPlain $ toContent "User-agent: *"++with~sitearg~ :: (Application -> IO a) -> IO a+with~sitearg~ f = Settings.withConnectionPool $ \p -> do+ flip runConnectionPool p $ runMigration $ do+ migrate (undefined :: User)+ migrate (undefined :: Email)+ let h = ~sitearg~ s p+ toWaiApp h >>= f+ where+ s = fileLookupDir Settings.staticdir typeByExt+|]++ writeFile' "Handler/Root.hs" [$codegen|+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}+module Handler.Root where++import ~sitearg~++getRootR :: Handler RepHtml+getRootR = do+ mu <- maybeAuth+ defaultLayout $ do+ h2id <- newIdent+ setTitle "~project~ homepage"+ addBody $(hamletFile "homepage")+ addStyle $(cassiusFile "homepage")+ addJavascript $(juliusFile "homepage")+|]++ writeFile' "Model.hs" [$codegen|+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} module Model where import Yesod-import Yesod.Helpers.Crud -share2 mkPersist mkToForm [$persist|-Person- name String- age Int+mkPersist [$persist|+User+ ident String+ password String null update+ UniqueUser ident+Email+ email String+ user UserId null update+ verkey String null update+ UniqueEmail email |~~]+|] -instance Item Person where- itemTitle = personName+ writeFile' "Settings.hs" [$codegen|+{-# LANGUAGE CPP #-}+module Settings+ ( hamletFile+ , cassiusFile+ , juliusFile+ , connStr+ , ConnectionPool+ , withConnectionPool+ , runConnectionPool+ , approot+ , staticroot+ , staticdir+ ) where++import qualified Text.Hamlet as H+import qualified Text.Cassius as H+import qualified Text.Julius as H+import Language.Haskell.TH.Syntax+import Database.Persist.Sqlite+import Yesod (MonadCatchIO)++hamletFile :: FilePath -> Q Exp+#ifdef PRODUCTION+hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet"+#else+hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet"+#endif++cassiusFile :: FilePath -> Q Exp+#ifdef PRODUCTION+cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius"+#else+cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius"+#endif++juliusFile :: FilePath -> Q Exp+#ifdef PRODUCTION+juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius"+#else+juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius"+#endif++connStr :: String+#ifdef PRODUCTION+connStr = "production.db3"+#else+connStr = "debug.db3"+#endif++connectionCount :: Int+connectionCount = 10++withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a+withConnectionPool = withSqlitePool connStr connectionCount++runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a+runConnectionPool = runSqlPool++approot :: String+#ifdef PRODUCTION+approot = "http://localhost:3000"+#else+approot = "http://localhost:3000"+#endif++staticroot :: String+staticroot = approot ++ "/static"++staticdir :: FilePath+staticdir = "static" |] - putStrLn "Generating static/style.css"- createDirectoryIfMissing True "static"- writeFile "static/style.css" [$codegen|-body {- font-family: sans-serif;- background: #eee;-}+ writeFile' "cassius/default-layout.cassius" [$codegen|+body+ font-family: sans-serif+|] -#wrapper {- width: 760px;- margin: 1em auto;- border: 2px solid #000;- padding: 0.5em;- background: #fff;+ writeFile' "hamlet/default-layout.hamlet" [$codegen|+!!!+%html+ %head+ %title $pageTitle.pc$+ ^pageHead.pc^+ %body+ $maybe mmsg msg+ #message $msg$+ ^pageBody.pc^+|]++ writeFile' "hamlet/homepage.hamlet" [$codegen|+%h1 Hello+%h2#$h2id$ You do not have Javascript enabled.+$maybe mu u+ %p+ You are logged in as $userIdent.snd.u$. $+ %a!href=@AuthR.LogoutR@ Logout+ \.+$nothing+ %p+ You are not logged in. $+ %a!href=@AuthR.LoginR@ Login now+ \.+|]++ writeFile' "cassius/homepage.cassius" [$codegen|+body+ font-family: sans-serif+h1+ text-align: center+h2#$h2id$+ color: #990+|]++ writeFile' "julius/homepage.julius" [$codegen|+window.onload = function(){+ document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>"; } |]++ S.writeFile (dir ++ "/favicon.ico")+ $(runIO (S.readFile "favicon.ico") >>= \bs -> do+ pack <- [|S.pack|]+ return $ pack `AppE` LitE (StringL $ S.unpack bs))
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.4.1+version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -14,6 +14,7 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/yesod/+extra-source-files: favicon.ico flag buildtests description: Build the executable to run unit tests@@ -23,36 +24,46 @@ build-depends: base >= 4 && < 5, time >= 1.1.4 && < 1.3, wai >= 0.2.0 && < 0.3,- wai-extra >= 0.2.0 && < 0.3,+ wai-extra >= 0.2.2 && < 0.3, authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, text >= 0.5 && < 0.8, utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5,- web-routes >= 0.22 && < 0.23,- web-routes-quasi >= 0.5 && < 0.6,- hamlet >= 0.4.0 && < 0.5,+ web-routes-quasi >= 0.6 && < 0.7,+ hamlet >= 0.5.0 && < 0.6,+ blaze-builder >= 0.1 && < 0.2, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, 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,+ dataenc >= 0.13.0.2 && < 0.14, old-locale >= 1.0.0.2 && < 1.1,- persistent >= 0.1.0 && < 0.2,+ persistent >= 0.2.0 && < 0.3, neither >= 0.0.0 && < 0.1, MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, data-object >= 0.3.1 && < 0.4,- email-validate >= 0.2.5 && < 0.3+ network >= 2.2.1.5 && < 2.3,+ email-validate >= 0.2.5 && < 0.3,+ process >= 1.0.1 && < 1.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch Yesod.Form+ Yesod.Form.Class+ Yesod.Form.Core+ Yesod.Form.Fields+ Yesod.Form.Profiles+ Yesod.Form.Jquery+ Yesod.Form.Nic Yesod.Hamlet Yesod.Handler Yesod.Internal Yesod.Json+ Yesod.Mail Yesod.Request Yesod.Widget Yesod.Yesod@@ -61,6 +72,7 @@ Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static+ Yesod.WebRoutes ghc-options: -Wall executable yesod