yesod 0.5.4.2 → 0.6.0
raw patch · 29 files changed
+731/−1086 lines, 29 filesdep +base64-bytestringdep +containersdep +data-defaultdep −MonadCatchIO-transformersdep −authenticatedep −control-monad-attemptdep ~neitherdep ~persistentdep ~text
Dependencies added: base64-bytestring, containers, data-default, failure
Dependencies removed: MonadCatchIO-transformers, authenticate, control-monad-attempt, data-object, dataenc, process, utf8-string
Dependency ranges changed: neither, persistent, text
Files
- CodeGen.hs +5/−3
- Yesod.hs +16/−5
- Yesod/Content.hs +1/−2
- Yesod/Dispatch.hs +43/−17
- Yesod/Form.hs +92/−26
- Yesod/Form/Core.hs +100/−19
- Yesod/Form/Fields.hs +66/−40
- Yesod/Form/Jquery.hs +78/−18
- Yesod/Form/Nic.hs +14/−7
- Yesod/Form/Profiles.hs +13/−12
- Yesod/Handler.hs +61/−60
- Yesod/Helpers/Auth.hs +0/−578
- Yesod/Helpers/Crud.hs +5/−6
- Yesod/Helpers/Static.hs +12/−6
- Yesod/Internal.hs +23/−0
- Yesod/Mail.hs +0/−120
- Yesod/Request.hs +2/−14
- Yesod/WebRoutes.hs +0/−8
- Yesod/Widget.hs +56/−37
- Yesod/Yesod.hs +10/−5
- scaffold.hs +4/−1
- scaffold/Controller_hs.cg +1/−3
- scaffold/Model_hs.cg +3/−1
- scaffold/Root_hs.cg +3/−3
- scaffold/Settings_hs.cg +7/−7
- scaffold/cabal.cg +14/−10
- scaffold/site-arg.cg +2/−2
- scaffold/sitearg_hs.cg +86/−56
- yesod.cabal +14/−20
CodeGen.hs view
@@ -5,14 +5,16 @@ import Language.Haskell.TH.Syntax import Text.ParserCombinators.Parsec-import qualified System.IO.UTF8 as U+import qualified Data.ByteString.Lazy as L+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT data Token = VarToken String | LitToken String | EmptyToken codegen :: FilePath -> Q Exp codegen fp = do- s' <- qRunIO $ U.readFile $ "scaffold/" ++ fp ++ ".cg"- let s = init s'+ s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg"+ let s = init $ LT.unpack $ LT.decodeUtf8 s' case parse (many parseToken) s s of Left e -> error $ show e Right tokens' -> do
Yesod.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-}+-- | This module simply re-exports from other modules for your convenience. module Yesod ( module Yesod.Request , module Yesod.Content@@ -13,8 +13,10 @@ , Application , lift , liftIO- , MonadCatchIO+ , MonadInvertIO , mempty+ , showIntegral+ , readIntegral ) where #if TEST@@ -36,7 +38,16 @@ import Yesod.Widget 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 Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (liftIO) import Data.Monoid (mempty)+import Control.Monad.Invert (MonadInvertIO)++showIntegral :: Integral a => a -> String+showIntegral x = show (fromIntegral x :: Integer)++readIntegral :: Num a => String -> Maybe a+readIntegral s =+ case reads s of+ (i, _):_ -> Just $ fromInteger i+ [] -> Nothing
Yesod/Content.hs view
@@ -63,7 +63,6 @@ import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding-import qualified Data.ByteString.Lazy.UTF8 #if TEST import Test.Framework (testGroup, Test)@@ -94,7 +93,7 @@ instance ToContent Text where toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where- toContent = W.ResponseLBS . Data.ByteString.Lazy.UTF8.fromString+ toContent = toContent . T.pack -- | A function which gives targetted representations of content based on the -- content-types the user accepts.
Yesod/Dispatch.hs view
@@ -39,7 +39,6 @@ import Web.Routes.Quasi.Parse import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax-import Yesod.WebRoutes import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath (cleanPathFunc)@@ -52,8 +51,6 @@ import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.UTF8 as S- import Control.Concurrent.MVar import Control.Arrow ((***)) @@ -70,7 +67,12 @@ import Network.Wai.Parse hiding (FileInfo) import qualified Network.Wai.Parse as NWP import Data.String (fromString)+import Web.Routes+import Control.Arrow (first)+import System.Random (randomR, newStdGen) +import qualified Data.Map as Map+ #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty)@@ -225,7 +227,7 @@ now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y- let host = W.remoteHost env+ let host = if sessionIpAddress y then W.remoteHost env else "" let session' = fromMaybe [] $ do raw <- lookup "Cookie" $ W.requestHeaders env val <- lookup (B.pack sessionName) $ parseCookies raw@@ -265,13 +267,17 @@ let eurl' = either (const Nothing) Just eurl 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+ let sessionMap = Map.fromList+ $ filter (\(x, _) -> x /= nonceKey) session'+ (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap+ let sessionVal = encodeSession key' exp' host+ $ Map.toList+ $ Map.insert nonceKey (reqNonce rr) sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName- (S.toString sessionVal)+ (bsToChars sessionVal) : hs hs'' = map (headerToPair getExpires) hs'- hs''' = ("Content-Type", S.fromString ct) : hs''+ hs''' = ("Content-Type", charsToBs ct) : hs'' return $ W.Response s hs''' c httpAccept :: W.Request -> [ContentType]@@ -313,13 +319,13 @@ -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do- let gets' = map (S.toString *** S.toString)+ let gets' = map (bsToChars *** bsToChars) $ parseQueryString $ W.queryString env let reqCookie = fromMaybe B.empty $ lookup "Cookie" $ W.requestHeaders env- cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie+ cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env- langs = map S.toString $ maybe [] parseHttpAccept acceptLang+ langs = map bsToChars $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey session' of Nothing -> langs Just x -> x : langs@@ -330,13 +336,33 @@ Nothing -> langs'' Just x -> x : langs'' rbthunk <- iothunk $ rbHelper env- return $ Request gets' cookies' session' rbthunk env langs'''+ nonce <- case lookup nonceKey session' of+ Just x -> return x+ Nothing -> do+ g <- newStdGen+ return $ fst $ randomString 10 g+ return $ Request gets' cookies' rbthunk env langs''' nonce+ where+ randomString len =+ first (map toChar) . sequence' (replicate len (randomR (0, 61)))+ 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 +nonceKey :: String+nonceKey = "_NONCE"+ rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where- fix1 = map (S.toString *** S.toString)+ fix1 = map (bsToChars *** bsToChars) fix2 (x, NWP.FileInfo a b c) =- (S.toString x, FileInfo (S.toString a) (S.toString b) c)+ (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) -- | Produces a \"compute on demand\" value. The computation will be run once -- it is requested, and then the result will be stored. This will happen only@@ -357,14 +383,14 @@ -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes- in ("Set-Cookie", S.fromString+ in ("Set-Cookie", charsToBs $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) =- ("Set-Cookie", S.fromString $+ ("Set-Cookie", charsToBs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) =- (fromString key, S.fromString value)+ (fromString key, charsToBs value) encodeSession :: CS.Key -> UTCTime -- ^ expire time
Yesod/Form.hs view
@@ -11,6 +11,9 @@ , Enctype (..) , FormFieldSettings (..) , Textarea (..)+ , FieldInfo (..)+ -- ** Utilities+ , formFailures -- * Type synonyms , Form , Formlet@@ -18,19 +21,24 @@ , FormletField , FormInput -- * Unwrapping functions+ , generateForm , runFormGet+ , runFormMonadGet , runFormPost+ , runFormPostNoNonce+ , runFormMonadPost , runFormGet' , runFormPost' -- * Field/form helpers , fieldsToTable+ , fieldsToDivs , fieldsToPlain , checkForm+ -- * Type classes+ , module Yesod.Form.Class -- * Template Haskell , mkToForm- -- * Re-exports , module Yesod.Form.Fields- , module Yesod.Form.Class ) where import Yesod.Form.Core@@ -45,12 +53,9 @@ import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<))-import Control.Monad.Trans.State-import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax-import Database.Persist.Base (EntityDef (..))+import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) import Data.Char (toUpper, isUpper)-import Yesod.Widget import Control.Arrow ((&&&)) import Data.List (group, sort) @@ -63,37 +68,81 @@ fieldsToTable :: FormField sub y a -> Form sub y a fieldsToTable = mapFormXml $ mapM_ go where- go fi = do- wrapWidget (fiInput fi) $ \w -> [$hamlet|-%tr+ go fi = [$hamlet|+%tr.$clazz.fi$ %td %label!for=$fiIdent.fi$ $fiLabel.fi$ .tooltip $fiTooltip.fi$ %td- ^w^+ ^fiInput.fi^ $maybe fiErrors.fi err %td.errors $err$ |]+ clazz fi = if fiRequired fi then "required" else "optional" -runFormGeneric :: Env- -> FileEnv- -> GForm sub y xml a- -> GHandler sub y (FormResult a, xml, Enctype)-runFormGeneric env fe (GForm f) =- runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe+-- | Display the label, tooltip, input code and errors in a single div.+fieldsToDivs :: FormField sub y a -> Form sub y a+fieldsToDivs = mapFormXml $ mapM_ go+ where+ go fi = [$hamlet|+.$clazz.fi$+ %label!for=$fiIdent.fi$ $fiLabel.fi$+ .tooltip $fiTooltip.fi$+ ^fiInput.fi^+ $maybe fiErrors.fi err+ %div.errors $err$+|]+ clazz fi = if fiRequired fi then "required" else "optional" +-- | Run a form against POST parameters, without CSRF protection.+runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)+runFormPostNoNonce f = do+ rr <- getRequest+ (pp, files) <- liftIO $ reqRequestBody rr+ runFormGeneric pp files f+ -- | Run a form against POST parameters.-runFormPost :: GForm sub y xml a- -> GHandler sub y (FormResult a, xml, Enctype)+--+-- This function includes CSRF protection by checking a nonce value. You must+-- therefore embed this nonce in the form as a hidden field; that is the+-- meaning of the fourth element in the tuple.+runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) runFormPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr+ nonce <- fmap reqNonce getRequest+ (res, xml, enctype) <- runFormGeneric pp files f+ let res' =+ case res of+ FormSuccess x ->+ if lookup nonceName pp == Just nonce+ then FormSuccess x+ else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]+ _ -> res+ return (res', xml, enctype, hidden nonce)+ where+ hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|]++nonceName :: String+nonceName = "_nonce"++-- | Run a form against POST parameters. Please note that this does not provide+-- CSRF protection.+runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)+runFormMonadPost f = do+ rr <- getRequest+ (pp, files) <- liftIO $ reqRequestBody rr runFormGeneric pp files f -- | Run a form against POST parameters, disregarding the resulting HTML and--- returning an error response on invalid input.+-- returning an error response on invalid input. Note: this does /not/ perform+-- CSRF protection. runFormPost' :: GForm sub y xml a -> GHandler sub y a-runFormPost' = helper <=< runFormPost+runFormPost' f = do+ rr <- getRequest+ (pp, files) <- liftIO $ reqRequestBody rr+ x <- runFormGeneric pp files f+ helper x -- | Run a form against GET parameters, disregarding the resulting HTML and -- returning an error response on invalid input.@@ -105,16 +154,29 @@ helper (FormFailure e, _, _) = invalidArgs e helper (FormMissing, _, _) = invalidArgs ["No input found"] +-- | Generate a form, feeding it no data. The third element in the result tuple+-- is a nonce hidden field.+generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)+generateForm f = do+ (_, b, c) <- runFormGeneric [] [] f+ nonce <- fmap reqNonce getRequest+ return (b, c, [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|])+ -- | Run a form against GET parameters.-runFormGet :: GForm sub y xml a- -> GHandler sub y (FormResult a, xml, Enctype)+runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f --- | 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+runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)+runFormMonadGet f = do+ gs <- reqGetParams `fmap` getRequest+ runFormGeneric gs [] f++-- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.+mkToForm :: PersistEntity v => v -> Q [Dec]+mkToForm =+ fmap return . derive . entityDef where afterPeriod s = case dropWhile (/= '.') s of@@ -181,7 +243,7 @@ let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a in ftt `AppE` x go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) =- let label' = string' `AppE` LitE (StringL label)+ let label' = LitE $ StringL label tooltip' = string' `AppE` LitE (StringL tooltip) ffs = ffs' `AppE` label' `AppE`@@ -199,3 +261,7 @@ go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs++formFailures :: FormResult a -> Maybe [String]+formFailures (FormFailure x) = Just x+formFailures _ = Nothing
Yesod/Form/Core.hs view
@@ -1,4 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- | Users of the forms library should not need to use this module in general.+-- It is intended only for writing custom forms and form fields. module Yesod.Form.Core ( FormResult (..) , GForm (..)@@ -18,6 +23,9 @@ , askParams , askFiles , liftForm+ , IsForm (..)+ , RunForm (..)+ , GFormMonad -- * Data types , FieldInfo (..) , FormFieldSettings (..)@@ -32,6 +40,7 @@ import Control.Monad.Trans.State import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer import Control.Monad.Trans.Class (lift) import Yesod.Handler import Yesod.Widget@@ -90,14 +99,19 @@ -- | 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)+newtype GForm s m xml a = GForm+ { deform :: FormInner s m (FormResult a, xml, Enctype) } +type GFormMonad s m a = WriterT Enctype (FormInner s m) a++type FormInner s m =+ StateT Ints (+ ReaderT Env (+ ReaderT FileEnv (+ GHandler s m+ )))+ type Env = [(String, String)] type FileEnv = [(String, FileInfo)] @@ -134,10 +148,14 @@ 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+-- 'FieldProfile'.+requiredFieldHelper+ :: IsForm f+ => FieldProfile (FormSub f) (FormMaster f) (FormType f)+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name'@@ -153,21 +171,79 @@ Left e -> (FormFailure [e], x) Right y -> (FormSuccess y, x) let fi = FieldInfo- { fiLabel = label+ { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = mkWidget theId name val True , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing+ , fiRequired = True }- return (res, [fi], UrlEncoded)+ let res' = case res of+ FormFailure [e] -> FormFailure [label ++ ": " ++ e]+ _ -> res+ return (res', fi, UrlEncoded) +class IsForm f where+ type FormSub f+ type FormMaster f+ type FormType f+ toForm :: FormInner+ (FormSub f)+ (FormMaster f)+ (FormResult (FormType f),+ FieldInfo (FormSub f) (FormMaster f),+ Enctype) -> f+instance IsForm (FormField s m a) where+ type FormSub (FormField s m a) = s+ type FormMaster (FormField s m a) = m+ type FormType (FormField s m a) = a+ toForm x = GForm $ do+ (a, b, c) <- x+ return (a, [b], c)+instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where+ type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s+ type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m+ type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a+ toForm x = do+ (res, fi, enctype) <- lift x+ tell enctype+ return (res, fi)++class RunForm f where+ type RunFormSub f+ type RunFormMaster f+ type RunFormType f+ runFormGeneric :: Env -> FileEnv -> f+ -> GHandler (RunFormSub f)+ (RunFormMaster f)+ (RunFormType f)++instance RunForm (GForm s m xml a) where+ type RunFormSub (GForm s m xml a) = s+ type RunFormMaster (GForm s m xml a) = m+ type RunFormType (GForm s m xml a) =+ (FormResult a, xml, Enctype)+ runFormGeneric env fe (GForm f) =+ runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe++instance RunForm (GFormMonad s m a) where+ type RunFormSub (GFormMonad s m a) = s+ type RunFormMaster (GFormMonad s m a) = m+ type RunFormType (GFormMonad s m a) = (a, Enctype)+ runFormGeneric e fe f =+ runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe+ -- | 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+optionalFieldHelper+ :: (IsForm f, Maybe b ~ FormType f)+ => FieldProfile (FormSub f) (FormMaster f) b+ -> FormFieldSettings+ -> Maybe (Maybe b)+ -> f+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig'@@ -184,15 +260,19 @@ Left e -> (FormFailure [e], x) Right y -> (FormSuccess $ Just y, x) let fi = FieldInfo- { fiLabel = label+ { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = mkWidget theId name val False , fiErrors = case res of FormFailure x -> Just $ string $ unlines x _ -> Nothing+ , fiRequired = False }- return (res, [fi], UrlEncoded)+ let res' = case res of+ FormFailure [e] -> FormFailure [label ++ ": " ++ e]+ _ -> res+ return (res', fi, UrlEncoded) fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] fieldsToInput = map fiInput@@ -212,16 +292,17 @@ , fiIdent :: String , fiInput :: GWidget sub y () , fiErrors :: Maybe Html+ , fiRequired :: Bool } data FormFieldSettings = FormFieldSettings- { ffsLabel :: Html+ { ffsLabel :: String , ffsTooltip :: Html , ffsId :: Maybe String , ffsName :: Maybe String } instance IsString FormFieldSettings where- fromString s = FormFieldSettings (string s) mempty Nothing Nothing+ fromString s = FormFieldSettings 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
Yesod/Form/Fields.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module Yesod.Form.Fields ( -- * Fields -- ** Required@@ -42,17 +44,18 @@ 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 :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f stringField = requiredFieldHelper stringFieldProfile -maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeStringField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f maybeStringField = optionalFieldHelper stringFieldProfile intInput :: Integral i => String -> FormInput sub master i@@ -65,32 +68,41 @@ mapFormXml fieldsToInput $ optionalFieldHelper intFieldProfile (nameSettings n) Nothing -intField :: Integral i => FormFieldSettings -> FormletField sub y i+intField :: (Integral (FormType f), IsForm f)+ => FormFieldSettings -> Maybe (FormType f) -> f intField = requiredFieldHelper intFieldProfile -maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i)+maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)+ => FormFieldSettings -> Maybe (FormType f) -> f maybeIntField = optionalFieldHelper intFieldProfile -doubleField :: FormFieldSettings -> FormletField sub y Double+doubleField :: (IsForm f, FormType f ~ Double)+ => FormFieldSettings -> Maybe Double -> f doubleField = requiredFieldHelper doubleFieldProfile -maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double)+maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)+ => FormFieldSettings -> Maybe (Maybe Double) -> f maybeDoubleField = optionalFieldHelper doubleFieldProfile -dayField :: FormFieldSettings -> FormletField sub y Day+dayField :: (IsForm f, FormType f ~ Day)+ => FormFieldSettings -> Maybe Day -> f dayField = requiredFieldHelper dayFieldProfile -maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day)+maybeDayField :: (IsForm f, FormType f ~ Maybe Day)+ => FormFieldSettings -> Maybe (Maybe Day) -> f maybeDayField = optionalFieldHelper dayFieldProfile -timeField :: FormFieldSettings -> FormletField sub y TimeOfDay+timeField :: (IsForm f, FormType f ~ TimeOfDay)+ => FormFieldSettings -> Maybe TimeOfDay -> f timeField = requiredFieldHelper timeFieldProfile -maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay)+maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)+ => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f maybeTimeField = optionalFieldHelper timeFieldProfile -boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool-boolField ffs orig = GForm $ do+boolField :: (IsForm f, FormType f ~ Bool)+ => FormFieldSettings -> Maybe Bool -> f+boolField ffs orig = toForm $ do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs@@ -105,28 +117,33 @@ Just "false" -> (FormSuccess False, False) Just _ -> (FormSuccess True, True) let fi = FieldInfo- { fiLabel = label+ { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId- , fiInput = addBody [$hamlet|+ , fiInput = [$hamlet| %input#$theId$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing+ , fiRequired = True }- return (res, [fi], UrlEncoded)+ return (res, fi, UrlEncoded) -htmlField :: FormFieldSettings -> FormletField sub y Html+htmlField :: (IsForm f, FormType f ~ Html)+ => FormFieldSettings -> Maybe Html -> f htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html)+maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)+ => FormFieldSettings -> Maybe (Maybe Html) -> f maybeHtmlField = optionalFieldHelper htmlFieldProfile -selectField :: Eq x => [(x, String)]+selectField :: (Eq x, IsForm f, FormType f ~ x)+ => [(x, String)] -> FormFieldSettings- -> Maybe x -> FormField sub master x-selectField pairs ffs initial = GForm $ do+ -> Maybe x+ -> f+selectField pairs ffs initial = toForm $ do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs@@ -154,20 +171,23 @@ %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo- { fiLabel = label+ { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId- , fiInput = addBody input+ , fiInput = input , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing+ , fiRequired = True }- return (res, [fi], UrlEncoded)+ return (res, fi, UrlEncoded) -maybeSelectField :: Eq x => [(x, String)]+maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)+ => [(x, String)] -> FormFieldSettings- -> FormletField sub master (Maybe x)-maybeSelectField pairs ffs initial' = GForm $ do+ -> Maybe (FormType f)+ -> f+maybeSelectField pairs ffs initial' = toForm $ do env <- askParams let initial = join initial' label = ffsLabel ffs@@ -196,15 +216,16 @@ %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo- { fiLabel = label+ { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId- , fiInput = addBody input+ , fiInput = input , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing+ , fiRequired = False }- return (res, [fi], UrlEncoded)+ return (res, fi, UrlEncoded) stringInput :: String -> FormInput sub master String stringInput n =@@ -224,9 +245,7 @@ Just "" -> FormSuccess False Just "false" -> FormSuccess False Just _ -> FormSuccess True- let xml = addBody [$hamlet|-%input#$n$!type=checkbox!name=$n$-|]+ let xml = [$hamlet|%input#$n$!type=checkbox!name=$n$|] return (res, [xml], UrlEncoded) dayInput :: String -> FormInput sub master Day@@ -242,10 +261,12 @@ nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) -urlField :: FormFieldSettings -> FormletField sub y String+urlField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f urlField = requiredFieldHelper urlFieldProfile -maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeUrlField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f maybeUrlField = optionalFieldHelper urlFieldProfile urlInput :: String -> FormInput sub master String@@ -253,10 +274,12 @@ mapFormXml fieldsToInput $ requiredFieldHelper urlFieldProfile (nameSettings n) Nothing -emailField :: FormFieldSettings -> FormletField sub y String+emailField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f emailField = requiredFieldHelper emailFieldProfile -maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeEmailField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f maybeEmailField = optionalFieldHelper emailFieldProfile emailInput :: String -> FormInput sub master String@@ -264,14 +287,17 @@ mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing -textareaField :: FormFieldSettings -> FormletField sub y Textarea+textareaField :: (IsForm f, FormType f ~ Textarea)+ => FormFieldSettings -> Maybe Textarea -> f textareaField = requiredFieldHelper textareaFieldProfile maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile -hiddenField :: FormFieldSettings -> FormletField sub y String+hiddenField :: (IsForm f, FormType f ~ String)+ => FormFieldSettings -> Maybe String -> f hiddenField = requiredFieldHelper hiddenFieldProfile -maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String)+maybeHiddenField :: (IsForm f, FormType f ~ Maybe String)+ => FormFieldSettings -> Maybe (Maybe String) -> f maybeHiddenField = optionalFieldHelper hiddenFieldProfile
Yesod/Form/Jquery.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Some fields spiced up with jQuery UI. module Yesod.Form.Jquery ( YesodJquery (..) , jqueryDayField@@ -9,6 +12,8 @@ , maybeJqueryAutocompleteField , jqueryDayFieldProfile , googleHostedJqueryUiCss+ , JqueryDaySettings (..)+ , Default (..) ) where import Yesod.Handler@@ -19,6 +24,7 @@ timeToTimeOfDay) import Yesod.Hamlet import Data.Char (isSpace)+import Data.Default -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: String -> String@@ -45,30 +51,57 @@ 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+jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))+ => JqueryDaySettings+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile -maybeJqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y (Maybe Day)-maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile+maybeJqueryDayField+ :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f))+ => JqueryDaySettings+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f+maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile -jqueryDayFieldProfile :: YesodJquery y => FieldProfile sub y Day-jqueryDayFieldProfile = FieldProfile+jqueryDayFieldProfile :: YesodJquery y+ => JqueryDaySettings -> FieldProfile sub y Day+jqueryDayFieldProfile jds = 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|+ addHtml [$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'})});+ addJulius [$julius|+$(function(){$("#%theId%").datepicker({+ dateFormat:'yy-mm-dd',+ changeMonth:%jsBool.jdsChangeMonth.jds%,+ changeYear:%jsBool.jdsChangeYear.jds%,+ numberOfMonths:%mos.jdsNumberOfMonths.jds%,+ yearRange:"%jdsYearRange.jds%"+})}); |] }+ where+ jsBool True = "true"+ jsBool False = "false"+ mos (Left i) = show i+ mos (Right (x, y)) = concat+ [ "["+ , show x+ , ","+ , show y+ , "]"+ ] ifRight :: Either a b -> (b -> c) -> Either a c ifRight e f = case e of@@ -78,7 +111,11 @@ 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+ :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f))+ => FormFieldSettings+ -> Maybe (FormType f)+ -> f jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile -- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)@@ -96,14 +133,14 @@ { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime , fpWidget = \theId name val isReq -> do- addBody [$hamlet|+ addHtml [$hamlet| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss- addJavascript [$julius|+ addJulius [$julius| $(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] }@@ -118,12 +155,20 @@ ifRight (parseTime timeS) (UTCTime date . timeOfDayToTime) -jqueryAutocompleteField :: YesodJquery y =>- Route y -> FormFieldSettings -> FormletField sub y String+jqueryAutocompleteField+ :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f))+ => Route (FormMaster f)+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile -maybeJqueryAutocompleteField :: YesodJquery y =>- Route y -> FormFieldSettings -> FormletField sub y (Maybe String)+maybeJqueryAutocompleteField+ :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f))+ => Route (FormMaster f)+ -> FormFieldSettings+ -> Maybe (FormType f)+ -> f maybeJqueryAutocompleteField src = optionalFieldHelper $ jqueryAutocompleteFieldProfile src @@ -132,13 +177,13 @@ { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> do- addBody [$hamlet|+ addHtml [$hamlet| %input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJavascript [$julius|+ addJulius [$julius| $(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); |] }@@ -162,3 +207,18 @@ -- 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)++data JqueryDaySettings = JqueryDaySettings+ { jdsChangeMonth :: Bool+ , jdsChangeYear :: Bool+ , jdsYearRange :: String+ , jdsNumberOfMonths :: Either Int (Int, Int)+ }++instance Default JqueryDaySettings where+ def = JqueryDaySettings+ { jdsChangeMonth = False+ , jdsChangeYear = False+ , jdsYearRange = "c-10:c+10"+ , jdsNumberOfMonths = Left 1+ }
Yesod/Form/Nic.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Provide the user with a rich text editor. module Yesod.Form.Nic ( YesodNic (..) , nicHtmlField@@ -9,28 +12,32 @@ import Yesod.Form.Core import Yesod.Hamlet import Yesod.Widget-import qualified Data.ByteString.Lazy.UTF8 as U import Text.HTML.SanitizeXSS (sanitizeXSS) +import Yesod.Internal (lbsToChars)+ class YesodNic a where- -- | NIC Editor.+ -- | NIC Editor Javascript file. urlNicEdit :: a -> Either (Route a) String urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y Html+nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))+ => FormFieldSettings -> Maybe Html -> f nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe Html)+maybeNicHtmlField+ :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f))+ => FormFieldSettings -> Maybe (FormType f) -> f maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS- , fpRender = U.toString . renderHtml+ , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do- addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|]+ addHtml [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit- addJavascript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|]+ addJulius [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
Yesod/Form/Profiles.hs view
@@ -21,7 +21,6 @@ import Yesod.Widget 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)@@ -30,11 +29,13 @@ import Text.Blaze.Builder.Utf8 (writeChar) import Text.Blaze.Builder.Core (writeList, writeByteString) +import Yesod.Internal (lbsToChars)+ 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|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] }@@ -48,7 +49,7 @@ doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show- , fpWidget = \theId name val isReq -> addBody [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] }@@ -57,7 +58,7 @@ dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show- , fpWidget = \theId name val isReq -> addBody [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] }@@ -66,7 +67,7 @@ timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show- , fpWidget = \theId name val isReq -> addBody [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] }@@ -74,8 +75,8 @@ htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS- , fpRender = U.toString . renderHtml- , fpWidget = \theId name val _isReq -> addBody [$hamlet|+ , fpRender = lbsToChars . renderHtml+ , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %textarea.html#$theId$!name=$name$ $val$ |] }@@ -101,7 +102,7 @@ textareaFieldProfile = FieldProfile { fpParse = Right . Textarea , fpRender = unTextarea- , fpWidget = \theId name val _isReq -> addBody [$hamlet|+ , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %textarea#$theId$!name=$name$ $val$ |] }@@ -110,7 +111,7 @@ hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id- , fpWidget = \theId name val _isReq -> addBody [$hamlet|+ , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %input!type=hidden#$theId$!name=$name$!value=$val$ |] }@@ -119,7 +120,7 @@ stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id- , fpWidget = \theId name val isReq -> addBody [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] }@@ -168,7 +169,7 @@ then Right s else Left "Invalid e-mail address" , fpRender = id- , fpWidget = \theId name val isReq -> addBody [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] }@@ -179,7 +180,7 @@ Nothing -> Left "Invalid URL" Just _ -> Right s , fpRender = id- , fpWidget = \theId name val isReq -> addBody [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ |] }
Yesod/Handler.hs view
@@ -58,6 +58,9 @@ , alreadyExpired , expiresAt -- * Session+ , SessionMap+ , lookupSession+ , getSession , setSession , deleteSession -- ** Ultimate destination@@ -73,7 +76,7 @@ , YesodApp (..) , toMasterHandler , localNoCurrent- , finallyHandler+ , HandlerData #if TEST , testSuite #endif@@ -82,7 +85,6 @@ import Prelude hiding (catch) import Yesod.Request import Yesod.Internal-import Data.List (foldl') import Data.Neither import Data.Time (UTCTime) @@ -94,17 +96,18 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)-import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C+import Control.Monad.Trans.State import System.IO import qualified Network.Wai as W-import Control.Monad.Attempt-import Data.ByteString.UTF8 (toString)-import qualified Data.ByteString.Lazy.UTF8 as L+import Control.Failure (Failure (failure)) import Text.Hamlet +import Control.Monad.Invert (MonadInvertIO (..))+import Control.Monad (liftM)+import qualified Data.Map as Map+ #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit (testCase)@@ -153,16 +156,31 @@ -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling -- special responses. It is declared as a newtype to make compiler errors more -- readable.-newtype GHandler sub master a = GHandler { unGHandler ::- ReaderT (HandlerData sub master) (+newtype GHandler sub master a =+ GHandler+ { unGHandler :: GHInner sub master a+ }+ deriving (Functor, Applicative, Monad, MonadIO)++type GHInner s m =+ ReaderT (HandlerData s m) ( MEitherT HandlerContents ( WriterT (Endo [Header]) (- WriterT (Endo [(String, Maybe String)]) (+ StateT SessionMap ( -- session IO- )))) a-}- deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)+ )))) +type SessionMap = Map.Map String String++instance MonadInvertIO (GHandler s m) where+ newtype InvertedIO (GHandler s m) a =+ InvGHandlerIO+ { runInvGHandlerIO :: InvertedIO (GHInner s m) a+ }+ type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ()))+ invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler+ revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f+ type Endo a = a -> a -- | An extension of the basic WAI 'W.Application' datatype to provide extra@@ -173,7 +191,8 @@ :: (ErrorResponse -> YesodApp) -> Request -> [ContentType]- -> IO (W.Status, [Header], ContentType, Content, [(String, String)])+ -> SessionMap+ -> IO (W.Status, [Header], ContentType, Content, SessionMap) } data HandlerContents =@@ -215,16 +234,6 @@ getRouteToMaster :: GHandler sub master (Route sub -> Route master) getRouteToMaster = handlerToMaster <$> GHandler ask -modifySession :: [(String, String)] -> (String, Maybe String)- -> [(String, String)]-modifySession orig (k, v) =- case v of- Nothing -> dropKeys k orig- Just v' -> (k, v') : dropKeys k orig--dropKeys :: String -> [(String, x)] -> [(String, x)]-dropKeys k = filter $ \(x, _) -> x /= k- -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c@@ -235,7 +244,8 @@ -> master -> (master -> sub) -> YesodApp-runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do+runHandler handler mrender sroute tomr ma tosa =+ YesodApp $ \eh rr cts initSession -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String)@@ -247,17 +257,16 @@ , handlerRender = mrender , handlerToMaster = tomr }- ((contents', headers), session') <- E.catch (- runWriterT+ ((contents', headers), finalSession) <- E.catch (+ flip runStateT initSession $ runWriterT $ runMEitherT $ flip runReaderT hd $ unGHandler handler- ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id))+ ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) let contents = meither id (HCContent . chooseRep) contents'- let finalSession = foldl' modifySession (reqSession rr) $ session' [] let handleError e = do- (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts+ (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp =@@ -276,9 +285,10 @@ (handleError . toErrorHandler) safeEh :: ErrorResponse -> YesodApp-safeEh er = YesodApp $ \_ _ _ -> do+safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er- return (W.status500, [], typePlain, toContent "Internal Server Error", [])+ return (W.status500, [], typePlain, toContent "Internal Server Error",+ session) -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a@@ -322,9 +332,9 @@ Nothing -> return () Just r -> do tm <- getRouteToMaster- gets <- reqGetParams <$> getRequest+ gets' <- reqGetParams <$> getRequest render <- getUrlRenderParams- setUltDestString $ render (tm r) gets+ setUltDestString $ render (tm r) gets' -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session.@@ -343,12 +353,9 @@ -- | Sets a message in the user's session. ----- The message set here will not be visible within the current request;--- instead, it will only appear in the next request.--- -- See 'getMessage'. setMessage :: Html -> GHandler sub master ()-setMessage = setSession msgKey . L.toString . renderHtml+setMessage = setSession msgKey . lbsToChars . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable.@@ -378,7 +385,7 @@ badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest- failure $ BadMethod $ toString $ W.requestMethod w+ failure $ BadMethod $ bsToChars $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => String -> m a@@ -400,7 +407,8 @@ deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie --- | Set the language in the user session. Will show up in 'languages'.+-- | Set the language in the user session. Will show up in 'languages' on the+-- next request. setLanguage :: String -> GHandler sub master () setLanguage = setSession langKey @@ -439,11 +447,11 @@ setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master ()-setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v)+setSession k = GHandler . lift . lift . lift . modify . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: String -> GHandler sub master ()-deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing)+deleteSession = GHandler . lift . lift . lift . modify . Map.delete -- | Internal use only, not to be confused with 'setHeader'. addHeader :: Header -> GHandler sub master ()@@ -471,28 +479,21 @@ localNoCurrent = GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler +-- | Lookup for session data.+lookupSession :: ParamName -> GHandler s m (Maybe ParamValue)+lookupSession n = GHandler $ do+ m <- lift $ lift $ lift get+ return $ Map.lookup n m++-- | Get all session variables.+getSession :: GHandler s m SessionMap+getSession = GHandler $ lift $ lift $ lift get+ #if TEST testSuite :: Test testSuite = testGroup "Yesod.Handler"- [ testCase "finally" caseFinally+ [ ] -caseFinally :: Assertion-caseFinally = do- i <- newIORef (1 :: Int)- let h = finallyHandler (do- liftIO $ writeIORef i 2- () <- redirectString RedirectTemporary ""- return ()) $ liftIO $ writeIORef i 3- let y = runHandler h undefined undefined undefined undefined undefined- _ <- unYesodApp y undefined undefined undefined- j <- readIORef i- j @?= 3- #endif---- | A version of 'finally' which works correctly with short-circuiting.-finallyHandler :: GHandler s m a -> GHandler s m b -> GHandler s m a-finallyHandler (GHandler (ReaderT thing)) (GHandler (ReaderT after)) =- GHandler $ ReaderT $ \hd -> mapMEitherT (`C.finally` runMEitherT (after hd)) (thing hd)
− Yesod/Helpers/Auth.hs
@@ -1,578 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------- Module : Yesod.Helpers.Auth--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ Authentication through the authentication package.--------------------------------------------------------------module Yesod.Helpers.Auth- ( -- * Subsite- Auth (..)- , getAuth- , AuthRoute (..)- -- * Settings- , YesodAuth (..)- , Creds (..)- , EmailCreds (..)- , AuthType (..)- , RpxnowSettings (..)- , EmailSettings (..)- , FacebookSettings (..)- , getFacebookUrl- -- * Functions- , maybeAuth- , maybeAuthId- , requireAuth- , requireAuthId- ) where--import qualified Web.Authenticate.Rpxnow as Rpxnow-import qualified Web.Authenticate.OpenId as OpenId-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.Monad.Attempt-import Data.ByteString.Lazy.UTF8 (fromString)-import Data.Object-import Language.Haskell.TH.Syntax--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-- getAuthId :: Creds master -> [(String, String)]- -> GHandler s master (Maybe (AuthId master))-- -- | Generate a random alphanumeric string.- --- -- This is used for verify string in email authentication.- randomKey :: master -> IO String- randomKey _ = do- stdgen <- newStdGen- return $ fst $ randomString 10 stdgen-- openIdEnabled :: master -> Bool- openIdEnabled _ = False-- rpxnowSettings :: master -> Maybe RpxnowSettings- rpxnowSettings _ = Nothing-- emailSettings :: master -> Maybe (EmailSettings master)- emailSettings _ = Nothing-- -- | client id, secret and requested permissions- 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)--type Email = String-type VerKey = String-type VerUrl = String-type SaltedPass = String-type VerStatus = Bool---- | Data stored in a database for each e-mail address.-data EmailCreds m = EmailCreds- { emailCredsId :: AuthEmailId m- , emailCredsAuthId :: Maybe (AuthId m)- , emailCredsStatus :: VerStatus- , emailCredsVerkey :: Maybe VerKey- }--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 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 (AuthId m) -- ^ Numeric ID, if used.- , credsFacebookToken :: Maybe Facebook.AccessToken- }--credsKey :: String-credsKey = "_ID"--setCreds :: YesodAuth master- => Creds master -> [(String, String)] -> GHandler Auth master ()-setCreds creds extra = do- maid <- getAuthId creds extra- case maid of- Nothing -> return ()- Just aid -> setSession credsKey $ show $ fromPersistKey aid---- | Retrieves user credentials, if user is authenticated.-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--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--/register EmailRegisterR GET POST-/verify/#Int64/#String EmailVerifyR GET-/email-login EmailLoginR POST-/set-password EmailPasswordR GET POST--/login LoginR GET-|]--testOpenId :: YesodAuth master => GHandler Auth master ()-testOpenId = do- a <- getYesod- unless (openIdEnabled a) notFound--getOpenIdForwardR :: YesodAuth master => GHandler Auth master ()-getOpenIdForwardR = do- testOpenId- oid <- runFormGet' $ stringInput "openid"- render <- getUrlRender- toMaster <- getRouteToMaster- let complete = render $ toMaster OpenIdCompleteR- res <- runAttemptT $ OpenId.getForwardUrl oid complete- attempt- (\err -> do- setMessage $ string $ show err- redirect RedirectTemporary $ toMaster LoginR)- (redirectString RedirectTemporary)- res--getOpenIdCompleteR :: YesodAuth master => GHandler Auth master ()-getOpenIdCompleteR = do- testOpenId- rr <- getRequest- let gets' = reqGetParams rr- res <- runAttemptT $ OpenId.authenticate gets'- toMaster <- getRouteToMaster- let onFailure err = do- setMessage $ string $ show err- redirect RedirectTemporary $ toMaster LoginR- let onSuccess (OpenId.Identifier ident) = do- y <- getYesod- setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) []- redirectUltDest RedirectTemporary $ defaultDest y- attempt onFailure onSuccess res--handleRpxnowR :: YesodAuth master => GHandler Auth master ()-handleRpxnowR = do- ay <- getYesod- auth <- getYesod- apiKey <- case rpxnowKey <$> rpxnowSettings auth of- Just x -> return x- Nothing -> notFound- token1 <- lookupGetParam "token"- token2 <- lookupPostParam "token"- let token = case token1 `mplus` token2 of- Nothing -> invalidArgs ["token: Value not supplied"]- Just x -> x- Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token- let creds = Creds- ident- AuthRpxnow- (lookup "verifiedEmail" extra)- (getDisplayName extra)- Nothing- Nothing- setCreds creds extra- dest1 <- lookupPostParam "dest"- dest2 <- lookupGetParam "dest"- either (redirect RedirectTemporary) (redirectString RedirectTemporary) $- case dest1 `mplus` dest2 of- Just "" -> Left $ defaultDest ay- Nothing -> Left $ defaultDest ay- Just ('#':d) -> Right d- Just d -> Right d---- | Get some form of a display name.-getDisplayName :: [(String, String)] -> Maybe String-getDisplayName extra =- foldr (\x -> mplus (lookup x extra)) Nothing choices- where- choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]--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 _- %p Logged in.-|]- json creds =- jsonMap- [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds)- ]--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--- 'authRoute'. Sets ultimate destination to current route, so user--- should be sent back here after authenticating.-requireAuthId :: YesodAuth m => GHandler sub m (AuthId m)-requireAuthId = maybeAuthId >>= maybe redirectLogin return--requireAuth :: ( PersistBackend (YesodDB m (GHandler s m))- , YesodPersist m- , YesodAuth m- ) => GHandler s m (AuthId m, AuthEntity m)-requireAuth = maybeAuth >>= maybe redirectLogin return--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 <- getEmailSettings- toMaster <- getRouteToMaster- 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- %input#email!type=email!name=email!width=150- %input!type=submit!value=Register-|]--postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml-postEmailRegisterR = do- ae <- getEmailSettings- email <- runFormPost' $ emailInput "email"- mecreds <- getEmailCreds ae email- (lid, verKey) <-- case mecreds of- 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)- render <- getUrlRender- tm <- getRouteToMaster- 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- => 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- 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.-|]--postEmailLoginR :: YesodAuth master => GHandler Auth master ()-postEmailLoginR = do- ae <- getEmailSettings- (email, pass) <- runFormPost' $ (,)- <$> emailInput "email"- <*> stringInput "password"- y <- getYesod- 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 LoginR--getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml-getEmailPasswordR = do- _ae <- getEmailSettings- toMaster <- getRouteToMaster- maid <- maybeAuthId- case maid of- Just _ -> return ()- Nothing -> do- setMessage $ string "You must be logged in to set a password"- redirect RedirectTemporary $ toMaster EmailLoginR- defaultLayout $ do- setTitle "Set password"- addBody [$hamlet|-%h3 Set a new password-%form!method=post!action=@toMaster.EmailPasswordR@- %table- %tr- %th New password- %td- %input!type=password!name=new- %tr- %th Confirm- %td- %input!type=password!name=confirm- %tr- %td!colspan=2- %input!type=submit!value=Submit-|]--postEmailPasswordR :: YesodAuth master => GHandler Auth master ()-postEmailPasswordR = do- ae <- getEmailSettings- (new, confirm) <- runFormPost' $ (,)- <$> stringInput "new"- <*> stringInput "confirm"- toMaster <- getRouteToMaster- when (new /= confirm) $ do- setMessage $ string "Passwords did not match, please try again"- redirect RedirectTemporary $ toMaster EmailPasswordR- 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- setPassword ae aid salted- setMessage $ string "Password updated"- y <- getYesod- redirect RedirectTemporary $ defaultDest y--saltLength :: Int-saltLength = 5--isValidPass :: String -- ^ cleartext password- -> String -- ^ salted password- -> Bool-isValidPass clear salted =- let salt = take saltLength salted- in salted == saltPass' salt clear--saltPass :: String -> IO String-saltPass pass = do- stdgen <- newStdGen- let salt = take saltLength $ randomRs ('A', 'Z') stdgen- return $ saltPass' salt pass--saltPass' :: String -> String -> String-saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass)--getFacebookR :: YesodAuth master => GHandler Auth master ()-getFacebookR = do- y <- getYesod- a <- facebookSettings <$> getYesod- case a of- Nothing -> notFound- Just (FacebookSettings cid secret _) -> do- render <- getUrlRender- tm <- getRouteToMaster- let fb = Facebook.Facebook cid secret $ render $ tm FacebookR- code <- runFormGet' $ stringInput "code"- at <- liftIO $ Facebook.getAccessToken fb code- so <- liftIO $ Facebook.getGraphData at "me"- let c = fromMaybe (error "Invalid response from Facebook") $ do- m <- fromMapping so- id' <- lookupScalar "id" m- let name = lookupScalar "name" m- let email = lookupScalar "email" m- let id'' = "http://graph.facebook.com/" ++ id'- return $ Creds id'' AuthFacebook email name Nothing $ Just at- setCreds c []- redirectUltDest RedirectTemporary $ defaultDest y--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 Rpxnow- %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
@@ -55,7 +55,7 @@ toMaster <- getRouteToMaster defaultLayout $ do setTitle "Items"- addBody [$hamlet|+ addWidget [$hamlet| %h1 Items %ul $forall items item@@ -115,7 +115,7 @@ toMaster <- getRouteToMaster defaultLayout $ do setTitle "Confirm delete"- addBody [$hamlet|+ addWidget [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$?@@ -143,7 +143,7 @@ -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do crud <- getYesodSub- (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me+ (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of (True, FormSuccess a) -> do@@ -156,10 +156,8 @@ $ toSinglePiece eid _ -> return () defaultLayout $ do- wrapWidget form (wrapForm toMaster enctype) setTitle $ string title- where- wrapForm toMaster enctype form = [$hamlet|+ addWidget [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$@@ -168,6 +166,7 @@ ^form^ %tr %td!colspan=2+ $hidden$ %input!type=submit $maybe me e \ $
Yesod/Helpers/Static.hs view
@@ -45,13 +45,13 @@ import Yesod hiding (lift) import Data.List (intercalate) import Language.Haskell.TH.Syntax+import Web.Routes 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.ByteString.Base64+import qualified Data.ByteString.Char8 as S8 import qualified Data.Serialize-import Yesod.WebRoutes #if TEST import Test.Framework (testGroup, Test)@@ -127,6 +127,7 @@ notHidden :: FilePath -> Bool notHidden ('.':_) = False+notHidden "tmp" = False notHidden _ = True getFileList :: FilePath -> IO [[String]]@@ -187,8 +188,13 @@ -- -- This function returns the first 8 characters of the hash. base64md5 :: L.ByteString -> String-base64md5 = take 8- . Codec.Binary.Base64Url.encode- . S.unpack+base64md5 = map go+ . take 8+ . S8.unpack+ . Data.ByteString.Base64.encode . Data.Serialize.encode . md5+ where+ go '+' = '-'+ go '/' = '_'+ go c = c
Yesod/Internal.hs view
@@ -19,12 +19,26 @@ , locationToHamlet , runUniqueList , toUnique+ -- * UTF8 helpers+ , bsToChars+ , lbsToChars+ , charsToBs ) where import Text.Hamlet (Hamlet, hamlet, Html) import Data.Monoid (Monoid (..)) import Data.List (nub) +import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T++import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+ -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse =@@ -71,3 +85,12 @@ deriving Monoid newtype Body url = Body (Hamlet url) deriving Monoid++lbsToChars :: L.ByteString -> String+lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode++bsToChars :: S.ByteString -> String+bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode++charsToBs :: String -> S.ByteString+charsToBs = T.encodeUtf8 . T.pack
− Yesod/Mail.hs
@@ -1,120 +0,0 @@-{-# 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/Request.hs view
@@ -28,13 +28,11 @@ , lookupGetParam , lookupPostParam , lookupCookie- , lookupSession , lookupFile -- ** Multi-lookup , lookupGetParams , lookupPostParams , lookupCookies- , lookupSessions , lookupFiles -- * Parameter type synonyms , ParamName@@ -98,8 +96,6 @@ data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)]- -- | Session data stored in a cookie via the clientsession package.- , reqSession :: [(ParamName, ParamValue)] -- | The POST parameters and submitted files. This is stored in an IO -- thunk, which essentially means it will be computed once at most, but -- only if requested. This allows avoidance of the potentially costly@@ -108,6 +104,8 @@ , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [String]+ -- | A random, session-specific nonce used to prevent CSRF attacks.+ , reqNonce :: String } lookup' :: Eq a => a -> [(a, b)] -> [b]@@ -161,13 +159,3 @@ lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr---- | Lookup for session data.-lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue)-lookupSession = liftM listToMaybe . lookupSessions---- | Lookup for session data.-lookupSessions :: RequestReader m => ParamName -> m [ParamValue]-lookupSessions pn = do- rr <- getRequest- return $ lookup' pn $ reqSession rr
− Yesod/WebRoutes.hs
@@ -1,8 +0,0 @@--- | This module should be removed when web-routes incorporates necessary support.-module Yesod.WebRoutes- ( encodePathInfo- , Site (..)- ) where--import Web.Routes.Base (encodePathInfo)-import Web.Routes.Site (Site (..))
Yesod/Widget.hs view
@@ -8,24 +8,29 @@ module Yesod.Widget ( -- * Datatype GWidget (..)- , Widget , liftHandler -- * Creating- , newIdent+ -- ** Head of page , setTitle- , addStyle+ , addHamletHead+ , addHtmlHead+ -- ** Body+ , addHamlet+ , addHtml+ , addWidget+ -- ** CSS+ , addCassius , addStylesheet , addStylesheetRemote , addStylesheetEither+ -- ** Javascript+ , addJulius , addScript , addScriptRemote , addScriptEither- , addHead- , addBody- , addJavascript- -- * Manipulating- , wrapWidget+ -- * Utilities , extractBody+ , newIdent ) where import Data.Monoid@@ -34,17 +39,22 @@ import Text.Hamlet import Text.Cassius import Text.Julius-import Yesod.Handler (Route, GHandler)+import Yesod.Handler (Route, GHandler, HandlerData) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift)-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import Yesod.Internal +import Control.Monad.Invert (MonadInvertIO (..))+import Control.Monad (liftM)+import qualified Data.Map as Map+ -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers.-newtype GWidget sub master a = GWidget (+newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a }+ deriving (Functor, Applicative, Monad, MonadIO)+type GWInner sub master = WriterT (Body (Route master)) ( WriterT (Last Title) ( WriterT (UniqueList (Script (Route master))) (@@ -54,22 +64,28 @@ WriterT (Head (Route master)) ( StateT Int ( GHandler sub master- )))))))) a)- deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)+ )))))))) instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y--- | A 'GWidget' specialized to when the subsite and master site are the same.-type Widget y = GWidget y y+instance MonadInvertIO (GWidget s m) where+ newtype InvertedIO (GWidget s m) a =+ InvGWidgetIO+ { runInvGWidgetIO :: InvertedIO (GWInner s m) a+ }+ type InvertedArg (GWidget s m) =+ (Int, (HandlerData s m, (Map.Map String String, ())))+ invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget+ revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f instance HamletValue (GWidget s m ()) where newtype HamletMonad (GWidget s m ()) a = GWidget' { runGWidget' :: GWidget s m a } type HamletUrl (GWidget s m ()) = Route m toHamletValue = runGWidget'- htmlToHamletMonad = GWidget' . addBody . const+ htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $- addBody $ \r -> preEscapedString (r url params)+ addHamlet $ \r -> preEscapedString (r url params) fromHamletValue = GWidget' instance Monad (HamletMonad (GWidget s m ())) where return = GWidget' . return@@ -85,14 +101,27 @@ setTitle :: Html -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title --- | Add some raw HTML to the head tag.-addHead :: Hamlet (Route master) -> GWidget sub master ()-addHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head+-- | Add a 'Hamlet' to the head tag.+addHamletHead :: Hamlet (Route master) -> GWidget sub master ()+addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head --- | Add some raw HTML to the body tag.-addBody :: Hamlet (Route master) -> GWidget sub master ()-addBody = GWidget . tell . Body+-- | Add a 'Html' to the head tag.+addHtmlHead :: Html -> GWidget sub master ()+addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const +-- | Add a 'Hamlet' to the body tag.+addHamlet :: Hamlet (Route master) -> GWidget sub master ()+addHamlet = GWidget . tell . Body++-- | Add a 'Html' to the body tag.+addHtml :: Html -> GWidget sub master ()+addHtml = GWidget . tell . Body . const++-- | Add another widget. This is defined as 'id', by can help with types, and+-- makes widget blocks look more consistent.+addWidget :: GWidget s m () -> GWidget s m ()+addWidget = id+ -- | Get a unique identifier. newIdent :: GWidget sub master String newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do@@ -102,8 +131,8 @@ return $ "w" ++ show i' -- | Add some raw CSS to the style tag.-addStyle :: Cassius (Route master) -> GWidget sub master ()-addStyle = GWidget . lift . lift . lift . lift . tell . Just+addCassius :: Cassius (Route master) -> GWidget sub master ()+addCassius = GWidget . lift . lift . lift . lift . tell . Just -- | Link to the specified local stylesheet. addStylesheet :: Route master -> GWidget sub master ()@@ -130,18 +159,8 @@ GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag.-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'.-wrapWidget :: GWidget s m a- -> (Hamlet (Route m) -> Hamlet (Route m))- -> GWidget s m a-wrapWidget (GWidget w) wrap =- GWidget $ mapWriterT (fmap go) w- where- go (a, Body h) = (a, Body $ wrap h)+addJulius :: Julius (Route master) -> GWidget sub master ()+addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
Yesod/Yesod.hs view
@@ -36,6 +36,7 @@ import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) import Yesod.Handler hiding (testSuite)+import qualified Data.ByteString.UTF8 as BSU #else import Yesod.Content import Yesod.Json@@ -49,20 +50,19 @@ import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS-import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.Attempt (Failure)+import Control.Failure (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+import Web.Routes #if TEST import Test.Framework (testGroup, Test)@@ -209,6 +209,11 @@ -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) addStaticContent _ _ _ = return Nothing + -- | Whether or not to tie a session to a specific IP address. Defaults to+ -- 'True'.+ sessionIpAddress :: a -> Bool+ sessionIpAddress _ = True+ data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) @@ -256,13 +261,13 @@ -> GHandler sub master ChooseRep applyLayout' title body = fmap chooseRep $ defaultLayout $ do setTitle title- addBody body+ addHamlet 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+ let path' = bsToChars $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $path'$
scaffold.hs view
@@ -6,6 +6,9 @@ import Language.Haskell.TH.Syntax import Data.Time (getCurrentTime, utctDay, toGregorian) import Control.Applicative ((<$>))+import qualified Data.ByteString.Lazy as L+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT main :: IO () main = do@@ -44,7 +47,7 @@ let writeFile' fp s = do putStrLn $ "Generating " ++ fp- writeFile (dir ++ '/' : fp) s+ L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp mkDir "Handler"
scaffold/Controller_hs.cg view
@@ -32,9 +32,7 @@ -- migrations handled by Yesod. 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)+ runConnectionPool (runMigration migrateAll) p let h = ~sitearg~ s p toWaiApp h >>= f where
scaffold/Model_hs.cg view
@@ -2,11 +2,13 @@ module Model where import Yesod+import Database.Persist.TH (share2)+import Database.Persist.GenericSql (mkMigrate) -- You can define all of your database entities here. You can find more -- information on persistent and how to declare entities at: -- http://docs.yesodweb.com/book/persistent/-mkPersist [$persist|+share2 mkPersist (mkMigrate "migrateAll") [$persist| User ident String password String null update
scaffold/Root_hs.cg view
@@ -16,7 +16,7 @@ defaultLayout $ do h2id <- newIdent setTitle "~project~ homepage"- addBody $(hamletFile "homepage")- addStyle $(cassiusFile "homepage")- addJavascript $(juliusFile "homepage")+ addCassius $(cassiusFile "homepage")+ addJulius $(juliusFile "homepage")+ addWidget $(hamletFile "homepage")
scaffold/Settings_hs.cg view
@@ -22,7 +22,7 @@ import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~-import Yesod (MonadCatchIO)+import Yesod (MonadInvertIO) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you,@@ -93,13 +93,13 @@ -- is used for increased performance. -- -- You can see an example of how to call these functions in Handler/Root.hs+--+-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer+-- used; to get the same auto-loading effect, it is recommended that you+-- use the devel server. 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@@ -119,9 +119,9 @@ -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself.-withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a+withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount -runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a+runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool
scaffold/cabal.cg view
@@ -20,15 +20,19 @@ if flag(production) Buildable: False main-is: simple-server.hs- build-depends: base >= 4 && < 5,- yesod >= 0.5 && < 0.6,- wai-extra,- directory,- bytestring,- persistent,- persistent-~lower~,- template-haskell,- hamlet+ build-depends: base >= 4 && < 5+ , yesod >= 0.6 && < 0.7+ , yesod-auth >= 0.2 && < 0.3+ , mime-mail >= 0.0 && < 0.1+ , wai-extra+ , directory+ , bytestring+ , text+ , persistent+ , persistent-~lower~+ , template-haskell+ , hamlet+ , web-routes ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies @@ -47,7 +51,7 @@ Buildable: False cpp-options: -DPRODUCTION main-is: fastcgi.hs- build-depends: wai-handler-fastcgi+ build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
scaffold/site-arg.cg view
@@ -1,5 +1,5 @@ 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+What's going to be the name of your foundation datatype? This name must start with a capital letter. -Site argument: +Foundation:
scaffold/sitearg_hs.cg view
@@ -4,6 +4,7 @@ , ~sitearg~Route (..) , resources~sitearg~ , Handler+ , Widget , maybeAuth , requireAuth , module Yesod@@ -14,18 +15,22 @@ ) where import Yesod-import Yesod.Mail import Yesod.Helpers.Static import Yesod.Helpers.Auth+import Yesod.Helpers.Auth.OpenId+import Yesod.Helpers.Auth.Email import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L-import Yesod.WebRoutes+import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile) import Model-import Control.Monad (join) import Data.Maybe (isJust)+import Control.Monad (join)+import Network.Mail.Mime+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Encoding -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application@@ -40,6 +45,10 @@ -- will need to be of this type. type Handler = GHandler ~sitearg~ ~sitearg~ +-- | A useful synonym; most of the widgets functions in your application+-- will need to be of this type.+type Widget = GWidget ~sitearg~ ~sitearg~+ -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://docs.yesodweb.com/book/web-routes-quasi/@@ -78,7 +87,7 @@ mmsg <- getMessage pc <- widgetToPageContent $ do widget- addStyle $(Settings.cassiusFile "default-layout")+ addCassius $(Settings.cassiusFile "default-layout") hamletToRepHtml $(Settings.hamletFile "default-layout") -- This is done to provide an optimization for serving static files from@@ -111,72 +120,93 @@ runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db instance YesodAuth ~sitearg~ where- type AuthEntity ~sitearg~ = User- type AuthEmailEntity ~sitearg~ = Email+ type AuthId ~sitearg~ = UserId - defaultDest _ = RootR+ -- Where to send a user after successful login+ loginDest _ = RootR+ -- Where to send a user after logout+ logoutDest _ = RootR - getAuthId creds _extra = runDB $ do+ getAuthId creds = 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+ showAuthId _ = showIntegral+ readAuthId _ = readIntegral - 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- }+ authPlugins = [ authOpenId+ , authEmail+ ] -sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()-sendVerifyEmail' email _ verurl =- liftIO $ renderSendMail Mail- { mailHeaders =- [ ("From", "noreply")- , ("To", email)- , ("Subject", "Verify your email address")+instance YesodAuthEmail ~sitearg~ where+ type AuthEmailId ~sitearg~ = EmailId++ showAuthEmailId _ = showIntegral+ readAuthEmailId _ = readIntegral++ addUnverified email verkey =+ runDB $ insert $ Email email Nothing $ Just verkey+ sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail+ { mailHeaders =+ [ ("From", "noreply")+ , ("To", email)+ , ("Subject", "Verify your email address")+ ]+ , mailParts = [[textPart, htmlPart]]+ }+ where+ textPart = Part+ { partType = "text/plain; charset=utf-8"+ , partEncoding = None+ , partFilename = Nothing+ , partContent = Data.Text.Lazy.Encoding.encodeUtf8+ $ Data.Text.Lazy.pack $ unlines+ [ "Please confirm your email address by clicking on the link below."+ , ""+ , verurl+ , ""+ , "Thank you" ]- , mailPlain = verurl- , mailParts = return Part- { partType = "text/html; charset=utf-8"- , partEncoding = None- , partDisposition = Inline- , partContent = renderHamlet id [$hamlet|+ }+ htmlPart = Part+ { partType = "text/html; charset=utf-8"+ , partEncoding = None+ , partFilename = Nothing+ , partContent = renderHtml [$hamlet| %p Please confirm your email address by clicking on the link below. %p %a!href=$verurl$ $verurl$ %p Thank you-|~~]- }+|] }+ 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, EmailVerkey Nothing]+ 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
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.5.4.2+version: 0.6.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,7 +16,7 @@ homepage: http://docs.yesodweb.com/ extra-source-files: scaffold/*.cg -flag buildtests+flag test description: Build the executable to run unit tests default: False @@ -25,11 +25,9 @@ , time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 , wai-extra >= 0.2.4 && < 0.3- , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2- , text >= 0.5 && < 0.10- , utf8-string >= 0.3.4 && < 0.4+ , text >= 0.5 && < 0.11 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 , hamlet >= 0.5.1 && < 0.6@@ -38,43 +36,39 @@ , clientsession >= 0.4.0 && < 0.5 , pureMD5 >= 1.1.0.0 && < 2.2 , random >= 1.0.0.2 && < 1.1- , control-monad-attempt >= 0.3 && < 0.4 , cereal >= 0.2 && < 0.4- , dataenc >= 0.13.0.2 && < 0.14+ , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1- , persistent >= 0.2.2 && < 0.3- , neither >= 0.0.0 && < 0.1- , MonadCatchIO-transformers >= 0.2.2.0 && < 0.3- , data-object >= 0.3.1 && < 0.4+ , persistent >= 0.3.0 && < 0.4+ , neither >= 0.1.0 && < 0.2 , network >= 2.2.1.5 && < 2.3 , email-validate >= 0.2.5 && < 0.3- , process >= 1.0.1 && < 1.1 , web-routes >= 0.23 && < 0.24 , xss-sanitize >= 0.2 && < 0.3+ , data-default >= 0.2 && < 0.3+ , failure >= 0.1 && < 0.2+ , containers >= 0.2 && < 0.5 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 Yesod.Helpers.AtomFeed- Yesod.Helpers.Auth Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static- Yesod.WebRoutes+ other-modules: Yesod.Form.Class+ Yesod.Internal+ Yesod.Form.Fields+ Yesod.Form.Profiles ghc-options: -Wall executable yesod@@ -85,7 +79,7 @@ extensions: TemplateHaskell executable runtests- if flag(buildtests)+ if flag(test) Buildable: True cpp-options: -DTEST build-depends: test-framework,