yesod 0.3.1.1 → 0.4.0
raw patch · 20 files changed
+1902/−818 lines, 20 filesdep +MonadCatchIO-transformersdep +data-objectdep +email-validatedep ~authenticatedep ~hamletdep ~persistentnew-component:exe:yesod
Dependencies added: MonadCatchIO-transformers, data-object, email-validate, neither, parsec
Dependency ranges changed: authenticate, hamlet, persistent, time, wai, wai-extra, web-routes-quasi
Files
- LICENSE +1/−1
- Yesod.hs +6/−7
- Yesod/Content.hs +29/−35
- Yesod/Dispatch.hs +159/−97
- Yesod/Form.hs +857/−102
- Yesod/Formable.hs +0/−319
- Yesod/Hamlet.hs +2/−3
- Yesod/Handler.hs +114/−73
- Yesod/Helpers/AtomFeed.hs +6/−9
- Yesod/Helpers/Auth.hs +88/−46
- Yesod/Helpers/Crud.hs +28/−14
- Yesod/Helpers/Sitemap.hs +6/−9
- Yesod/Helpers/Static.hs +27/−11
- Yesod/Internal.hs +1/−1
- Yesod/Json.hs +9/−2
- Yesod/Request.hs +58/−42
- Yesod/Widget.hs +215/−0
- Yesod/Yesod.hs +78/−38
- scaffold.hs +200/−0
- yesod.cabal +18/−9
LICENSE view
@@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2009, Michael Snoyman. All rights reserved.+Copyright 2010, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
Yesod.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} module Yesod- (- module Yesod.Request+ ( module Yesod.Request , module Yesod.Content , module Yesod.Yesod , module Yesod.Handler@@ -10,10 +9,10 @@ , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json- , module Yesod.Formable+ , module Yesod.Widget , Application , liftIO- , Routes+ , mempty ) where #if TEST@@ -27,11 +26,11 @@ #endif import Yesod.Request-import Yesod.Form hiding (Form)-import Yesod.Formable+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.IO.Class (liftIO)-import Web.Routes.Quasi (Routes)+import Data.Monoid (mempty)
Yesod/Content.hs view
@@ -8,7 +8,7 @@ module Yesod.Content ( -- * Content- Content (..)+ Content , emptyContent , ToContent (..) -- * Mime types@@ -56,7 +56,6 @@ import qualified Data.Text as T import qualified Network.Wai as W-import qualified Network.Wai.Enumerator as WE import Data.Time import System.Locale@@ -72,35 +71,29 @@ import Test.HUnit hiding (Test) #endif --- | There are two different methods available for providing content in the--- response: via files and enumerators. The former allows server to use--- optimizations (usually the sendfile system call) for serving static files.--- The latter is a space-efficient approach to content.------ It can be tedious to write enumerators; often times, you will be well served--- to use 'toContent'.-data Content = ContentFile FilePath- | ContentEnum (forall a.- (a -> B.ByteString -> IO (Either a a))- -> a- -> IO (Either a a))+type Content = W.ResponseBody +-- | Zero-length enumerator. emptyContent :: Content-emptyContent = ContentEnum $ \_ -> return . Right+emptyContent = W.ResponseLBS L.empty +-- | Anything which can be converted into 'Content'. Most of the time, you will+-- want to use the 'ContentEnum' constructor. An easier approach will be to use+-- a pre-defined 'toContent' function, such as converting your data into a lazy+-- bytestring and then calling 'toContent' on that. class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where- toContent bs = ContentEnum $ \f a -> f a bs+ toContent = W.ResponseLBS . L.fromChunks . return instance ToContent L.ByteString where- toContent = swapEnum . WE.fromLBS+ toContent = W.ResponseLBS instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where- toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8+ toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where- toContent = toContent . Data.ByteString.Lazy.UTF8.fromString+ toContent = W.ResponseLBS . Data.ByteString.Lazy.UTF8.fromString -- | A function which gives targetted representations of content based on the -- content-types the user accepts.@@ -108,9 +101,6 @@ [ContentType] -- ^ list of content-types user accepts, ordered by preference -> IO (ContentType, Content) -swapEnum :: W.Enumerator -> Content-swapEnum (W.Enumerator e) = ContentEnum e- -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep@@ -140,6 +130,9 @@ instance HasReps () where chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] +instance HasReps (ContentType, Content) where+ chooseRep = const . return+ instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ case filter (\(ct, _) -> go ct `elem` map go cts) a of@@ -218,19 +211,20 @@ simpleContentType :: String -> String simpleContentType = fst . span (/= ';') --- | Determine a mime-type based on the file extension.-typeByExt :: String -> ContentType-typeByExt "jpg" = typeJpeg-typeByExt "jpeg" = typeJpeg-typeByExt "js" = typeJavascript-typeByExt "css" = typeCss-typeByExt "html" = typeHtml-typeByExt "png" = typePng-typeByExt "gif" = typeGif-typeByExt "txt" = typePlain-typeByExt "flv" = typeFlv-typeByExt "ogv" = typeOgv-typeByExt _ = typeOctet+-- | A default extension to mime-type dictionary.+typeByExt :: [(String, ContentType)]+typeByExt =+ [ ("jpg", typeJpeg)+ , ("jpeg", typeJpeg)+ , ("js", typeJavascript)+ , ("css", typeCss)+ , ("html", typeHtml)+ , ("png", typePng)+ , ("gif", typeGif)+ , ("txt", typePlain)+ , ("flv", typeFlv)+ , ("ogv", typeOgv)+ ] -- | Get a file extension (everything after last period). ext :: String -> String
Yesod/Dispatch.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes@@ -16,9 +17,9 @@ -- * Convert to WAI , toWaiApp , basicHandler+ , basicHandler' -- * Utilities , fullRender- , quasiRender #if TEST , testSuite #endif@@ -30,6 +31,9 @@ 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 qualified Network.Wai as W@@ -55,10 +59,13 @@ import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS+import Data.Char (isLower, isUpper) import Data.Serialize import qualified Data.Serialize as Ser-import Network.Wai.Parse+import Network.Wai.Parse hiding (FileInfo)+import qualified Network.Wai.Parse as NWP+import Data.String (fromString) #if TEST import Test.Framework (testGroup, Test)@@ -73,7 +80,7 @@ #endif -- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter.+-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype -> [Resource]@@ -81,7 +88,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating subsites, *not* sites. See 'mkYesod' for the latter.+-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter. -- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not -- executable by itself, but instead provides functionality to -- be embedded in other sites.@@ -96,13 +103,13 @@ -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a--- monolithic file into smaller parts. This function, paired with--- 'mkYesodDispatch', do just that.+-- monolithic file into smaller parts. Use this function, paired with+-- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData name res = do (x, _) <- mkYesodGeneral name [] [] False res let rname = mkName $ "resources" ++ name- eres <- liftResources res+ eres <- lift res let y = [ SigD rname $ ListT `AppT` ConT ''Resource , FunD rname [Clause [] (NormalB eres) []] ]@@ -112,17 +119,14 @@ mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -explodeHandler :: HasReps c- => GHandler sub master c- -> (Routes master -> String)- -> Routes sub- -> (Routes sub -> Routes master)- -> master- -> (master -> sub)- -> YesodApp- -> String- -> YesodApp-explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f+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@@ -134,27 +138,80 @@ let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args'- let site = mkName $ "site" ++ name- let gsbod = NormalB $ VarE site- let yes' = FunD (mkName "getSite") [Clause [] gsbod []]- let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']- let clazzes' = compact- $ map (\x -> (x, [])) ("master" : args) ++- clazzes- explode <- [|explodeHandler|]- QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings- { crRoutes = mkName $ name ++ "Routes"- , crApplication = ConT ''YesodApp- , crArgument = arg- , crExplode = explode- , crResources = res- , crSite = site- , crMaster = if isSub- then Right clazzes'- else Left (ConT name')- }- return ([w, x], (if isSub then id else (:) yes) [y, z])+ 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"+ let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]+ let x = TySynInstD ''Route [arg] $ ConT routesName + parse' <- createParse th+ parse'' <- newName "parse"+ let parse = LetE [FunD parse'' parse'] $ VarE parse''++ render' <- createRender th+ render'' <- newName "render"+ let render = LetE [FunD render'' render'] $ VarE render''++ tmh <- [|toMasterHandler|]+ modMaster <- [|fmap chooseRep|]+ dispatch' <- createDispatch modMaster tmh th+ dispatch'' <- newName "dispatch"+ let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch''++ site <- [|Site|]+ 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")+ else ([], ConT ''YesodSite `AppT` arg, "getSite")+ let y = InstanceD ctx ytyp+ [ FunD (mkName yfunc) [Clause [] (NormalB site') []]+ ]+ return ([w, x], [y])++isStatic :: Piece -> Bool+isStatic StaticPiece{} = True+isStatic _ = False++fromStatic :: Piece -> String+fromStatic (StaticPiece s) = s+fromStatic _ = error "fromStatic"++thResourceFromResource :: Type -> Resource -> Q THResource+thResourceFromResource _ (Resource n ps attribs)+ | all (all isUpper) attribs = return (n, Simple ps attribs)+thResourceFromResource master (Resource n ps atts@[stype, toSubArg])+ | all isStatic ps && any (any isLower) atts = do+ let stype' = ConT $ mkName stype+ gss <- [|getSubSite|]+ let inside = ConT ''Maybe `AppT`+ (ConT ''GHandler `AppT` stype' `AppT` master `AppT`+ ConT ''ChooseRep)+ let typ = ConT ''Site `AppT`+ (ConT ''Route `AppT` stype') `AppT`+ (ArrowT `AppT` ConT ''String `AppT` inside)+ let gss' = gss `SigE` typ+ parse' <- [|parsePathSegments|]+ let parse = parse' `AppE` gss'+ render' <- [|formatPathSegments|]+ let render = render' `AppE` gss'+ dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]+ let dispatch = dispatch' `AppE` gss'+ return (n, SubSite+ { ssType = ConT ''Route `AppT` stype'+ , ssParse = parse+ , ssRender = render+ , ssDispatch = dispatch+ , ssToMasterArg = VarE $ mkName toSubArg+ , ssPieces = map fromStatic ps+ })+thResourceFromResource _ (Resource n _ _) =+ error $ "Invalid attributes for resource: " ++ n+ compact :: [(String, [a])] -> [(String, [a])] compact [] = [] compact ((x, x'):rest) =@@ -186,62 +243,52 @@ let exp' = getExpires $ clientSessionDuration y let host = W.remoteHost env let session' = fromMaybe [] $ do- raw <- lookup W.Cookie $ W.requestHeaders env+ raw <- lookup "Cookie" $ W.requestHeaders env val <- lookup (B.pack sessionName) $ parseCookies raw decodeSession key' now host val let site = getSite- method = B.unpack $ W.methodToBS $ W.requestMethod env+ method = B.unpack $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments- eurl = quasiParse site pathSegments+ eurl = parsePathSegments site pathSegments render u = fromMaybe- (fullRender (approot y) (quasiRender site) u)+ (fullRender (approot y) (formatPathSegments site) u) (urlRenderOverride y u) rr <- parseWaiRequest env session'- onRequest y rr- ya <-- case eurl of- Left _ -> return $ runHandler (errorHandler y NotFound)- render- Nothing- id- y- id- Right url -> do- auth <- isAuthorized y url- case auth of- Nothing -> return $ quasiDispatch site- render- url- id- y- id- (badMethodApp method)- method- Just msg ->- return $ runHandler- (errorHandler y $ PermissionDenied msg)- render- (Just url)- id- y- id+ let h = do+ onRequest+ case eurl of+ Left _ -> errorHandler NotFound+ Right url -> do+ ar <- isAuthorized url+ case ar of+ Authorized -> return ()+ AuthenticationRequired ->+ case authRoute y of+ Nothing ->+ permissionDenied "Authentication required"+ Just url' -> do+ setUltDest'+ redirect RedirectTemporary url'+ Unauthorized s -> permissionDenied s+ case handleSite site render url method of+ Nothing -> errorHandler $ BadMethod method+ Just h' -> h' let eurl' = either (const Nothing) Just eurl- let eh er = runHandler (errorHandler y 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 let hs' = AddCookie (clientSessionDuration y) sessionName (S.toString sessionVal) : hs hs'' = map (headerToPair getExpires) hs'- hs''' = (W.ContentType, S.fromString ct) : hs''- return $ W.Response s hs''' $ case c of- ContentFile fp -> Left fp- ContentEnum e -> Right $ W.Enumerator e+ 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.+-- 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.@@ -256,25 +303,37 @@ httpAccept = map B.unpack . parseHttpAccept . fromMaybe B.empty- . lookup W.Accept+ . lookup "Accept" . W.requestHeaders -- | Runs an application with CGI if CGI variables are present (namely -- PATH_INFO); otherwise uses SimpleServer.-basicHandler :: Int -- ^ port number- -> W.Application -> IO ()-basicHandler port app = do+basicHandler :: (Yesod y, YesodSite y)+ => Int -- ^ port number+ -> y+ -> IO ()+basicHandler port y = basicHandler' port (Just "localhost") y+++-- | Same as 'basicHandler', but allows you to specify the hostname to display+-- to the user. If 'Nothing' is provided, then no output is produced.+basicHandler' :: (Yesod y, YesodSite y)+ => Int -- ^ port number+ -> Maybe String -- ^ host name, 'Nothing' to show nothing+ -> y+ -> IO ()+basicHandler' port mhost y = do+ app <- toWaiApp y vars <- getEnvironment case lookup "PATH_INFO" vars of Nothing -> do- putStrLn $ "http://localhost:" ++ show port ++ "/"+ case mhost of+ Nothing -> return ()+ Just h -> putStrLn $ concat+ ["http://", h, ":", show port, "/"] SS.run port app Just _ -> CGI.run app -badMethodApp :: String -> YesodApp-badMethodApp m = YesodApp $ \eh req cts- -> unYesodApp (eh $ BadMethod m) eh req cts- fixSegs :: [String] -> [String] fixSegs [] = [] fixSegs [x]@@ -288,25 +347,28 @@ parseWaiRequest env session' = do let gets' = map (S.toString *** S.toString) $ parseQueryString $ W.queryString env- let reqCookie = fromMaybe B.empty $ lookup W.Cookie+ let reqCookie = fromMaybe B.empty $ lookup "Cookie" $ W.requestHeaders env cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie- acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env+ acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map S.toString $ maybe [] parseHttpAccept acceptLang- langs' = case lookup langKey cookies' of+ langs' = case lookup langKey session' of Nothing -> langs Just x -> x : langs- langs'' = case lookup langKey gets' of- Nothing -> langs'- Just x -> x : langs'+ langs'' = case lookup langKey cookies' of+ Nothing -> langs'+ Just x -> x : langs'+ langs''' = case lookup langKey gets' of+ Nothing -> langs''+ Just x -> x : langs'' rbthunk <- iothunk $ rbHelper env- return $ Request gets' cookies' session' rbthunk env langs''+ return $ Request gets' cookies' session' rbthunk env langs''' rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where fix1 = map (S.toString *** S.toString)- fix2 (x, FileInfo a b c) =- (S.toString x, FileInfo a b c)+ fix2 (x, NWP.FileInfo a b c) =+ (S.toString x, FileInfo (S.toString a) (S.toString 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@@ -327,14 +389,14 @@ -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes- in (W.SetCookie, S.fromString+ in ("Set-Cookie", S.fromString $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) =- (W.SetCookie, S.fromString $+ ("Set-Cookie", S.fromString $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) =- (W.responseHeaderFromBS $ S.fromString key, S.fromString value)+ (fromString key, S.fromString value) encodeSession :: CS.Key -> UTCTime -- ^ expire time
Yesod/Form.hs view
@@ -1,134 +1,889 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Parse forms (and query strings). module Yesod.Form- ( Form (..)- , runFormGeneric- , runFormPost+ ( -- * Data types+ GForm (..)+ , Form+ , Formlet+ , FormField+ , FormletField+ , FormInput+ , FormResult (..)+ , Enctype (..)+ , FieldInfo (..)+ -- * Newtype wrappers+ , JqueryDay (..)+ , NicHtml (..)+ , Html'+ -- * Unwrapping functions , runFormGet- , input- , applyForm- -- * Specific checks- , required- , optional- , notEmpty- , checkDay- , checkBool- , checkInteger- -- * Utility- , catchFormError+ , 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+ -- * Template Haskell+ , share2+ , mkToForm ) where +import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional)-import Data.Time (Day)-import Data.Maybe (fromMaybe)+import Data.Time (Day, TimeOfDay (TimeOfDay))+import Data.Maybe (fromMaybe, isJust) import "transformers" Control.Monad.IO.Class-import Yesod.Internal-import Control.Monad.Attempt+import Control.Monad ((<=<), liftM, join)+import Data.Monoid (Monoid (..))+import Control.Monad.Trans.State+import Language.Haskell.TH.Syntax+import Database.Persist.Base (EntityDef (..), PersistField)+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 -noParamNameError :: String-noParamNameError = "No param name (miscalling of Yesod.Form library)"+-- | 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 -data Form x = Form (- (ParamName -> [ParamValue])- -> Either [(ParamName, FormError)] (Maybe ParamName, x)- )+-- | 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 -instance Functor Form where- fmap f (Form x) = Form $ \l -> case x l of- Left errors -> Left errors- Right (pn, x') -> Right (pn, f x')-instance Applicative Form where- pure x = Form $ \_ -> Right (Nothing, x)- (Form f') <*> (Form x') = Form $ \l -> case (f' l, x' l) of- (Right (_, f), Right (_, x)) -> Right (Nothing, f x)- (Left e1, Left e2) -> Left $ e1 ++ e2- (Left e, _) -> Left e- (_, Left e) -> Left e+-- | 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 ()] -type FormError = String+-- | 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) -runFormGeneric :: Failure ErrorResponse m- => (ParamName -> [ParamValue]) -> Form x -> m x-runFormGeneric params (Form f) =- case f params of- Left es -> invalidArgs es- Right (_, x) -> return x+-- | 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)++-- | 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++-- | 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+ where+ go fi = do+ wrapWidget (fiInput fi) $ \w -> [$hamlet|+%tr+ %td+ %label!for=$fiIdent.fi$ $fiLabel.fi$+ .tooltip $fiTooltip.fi$+ %td+ ^w^+ $maybe fiErrors.fi err+ %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+ -- | Run a form against POST parameters.-runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m)- => Form x -> m x+runFormPost :: GForm sub y xml a+ -> GHandler sub y (FormResult a, xml, Enctype) runFormPost f = do rr <- getRequest- pp <- postParams rr- runFormGeneric pp f+ (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.+runFormPost' :: GForm sub y xml a -> GHandler sub y a+runFormPost' = helper <=< runFormPost++-- | Run a form against GET parameters, disregarding the resulting HTML and+-- returning an error response on invalid input.+runFormGet' :: GForm sub y xml a -> GHandler sub y a+runFormGet' = helper <=< runFormGet++helper :: (FormResult a, b, c) -> GHandler sub y a+helper (FormSuccess a, _, _) = return a+helper (FormFailure e, _, _) = invalidArgs e+helper (FormMissing, _, _) = invalidArgs ["No input found"]+ -- | Run a form against GET parameters.-runFormGet :: (RequestReader m, Failure ErrorResponse m)- => Form x -> m x+runFormGet :: GForm sub y xml a+ -> GHandler sub y (FormResult a, xml, Enctype) runFormGet f = do- rr <- getRequest- runFormGeneric (getParams rr) f+ gs <- reqGetParams `fmap` getRequest+ runFormGeneric gs [] f -input :: ParamName -> Form [ParamValue]-input pn = Form $ \l -> Right (Just pn, l pn)+-- | 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' -applyForm :: (x -> Either FormError y) -> Form x -> Form y-applyForm f (Form x') =- Form $ \l ->- case x' l of- Left e -> Left e- Right (pn, x) ->- case f x of- Left e -> Left [(fromMaybe noParamNameError pn, e)]- Right y -> Right (pn, y)+-- | 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+ getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z+ getLabel' [] = Nothing+ getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x+ getLabel' (_:x) = getLabel' x+ getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z+ getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x+ getTooltip' (_:x) = getTooltip' x+ getTooltip' [] = Nothing+ derive :: EntityDef -> Q Dec+ derive t = do+ let cols = map (getLabel &&& getTooltip) $ entityColumns t+ ap <- [|(<*>)|]+ just <- [|pure|]+ nothing <- [|Nothing|]+ let just' = just `AppE` ConE (mkName $ entityName t)+ string' <- [|string|]+ mfx <- [|mapFormXml|]+ ftt <- [|fieldsToTable|]+ let go_ = go ap just' string' mfx ftt+ let c1 = Clause [ ConP (mkName "Nothing") []+ ]+ (NormalB $ go_ $ zip cols $ map (const nothing) cols)+ []+ xs <- mapM (const $ newName "x") cols+ let xs' = map (AppE just . VarE) xs+ let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)+ $ map VarP xs]]+ (NormalB $ go_ $ zip cols xs')+ []+ return $ InstanceD [] (ConT ''ToForm+ `AppT` ConT (mkName $ entityName t))+ [FunD (mkName "toForm") [c1, c2]]+ go ap just' string' mfx ftt a =+ let x = foldl (ap' ap) just' $ map (go' string') a+ in mfx `AppE` ftt `AppE` x+ go' string' ((label, tooltip), ex) =+ let label' = string' `AppE` LitE (StringL label)+ tooltip' = string' `AppE` LitE (StringL tooltip)+ in VarE (mkName "toFormField") `AppE` label'+ `AppE` tooltip' `AppE` ex+ ap' ap x y = InfixE (Just x) ap (Just y) -required :: Form [ParamValue] -> Form ParamValue-required = applyForm $ \pvs -> case pvs of- [x] -> Right x- [] -> Left "No value for required field"- _ -> Left "Multiple values for required field"+toLabel :: String -> String+toLabel "" = ""+toLabel (x:rest) = toUpper x : go rest+ where+ go "" = ""+ go (c:cs)+ | isUpper c = ' ' : c : go cs+ | otherwise = c : go cs -optional :: Form [ParamValue] -> Form (Maybe ParamValue)-optional = applyForm $ \pvs -> case pvs of- [""] -> Right Nothing- [x] -> Right $ Just x- [] -> Right Nothing- _ -> Left "Multiple values for optional field"+jqueryAutocompleteField ::+ Route y -> Html () -> Html () -> FormletField sub y String+jqueryAutocompleteField src l t =+ requiredFieldHelper $ (jqueryAutocompleteFieldProfile src)+ { fpLabel = l+ , fpTooltip = t+ } -notEmpty :: Form ParamValue -> Form ParamValue-notEmpty = applyForm $ \pv ->- if null pv- then Left "Value required"- else Right pv+maybeJqueryAutocompleteField ::+ Route y -> Html () -> Html () -> FormletField sub y (Maybe String)+maybeJqueryAutocompleteField src l t =+ optionalFieldHelper $ (jqueryAutocompleteFieldProfile src)+ { fpLabel = l+ , fpTooltip = t+ } -checkDay :: Form ParamValue -> Form Day-checkDay = applyForm $ maybe (Left "Invalid day") Right . readMay- where- readMay s = case reads s of- (x, _):_ -> Just x- [] -> Nothing+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+ } -checkBool :: Form [ParamValue] -> Form Bool-checkBool = applyForm $ \pv -> Right $ case pv of- [] -> False- [""] -> False- ["false"] -> False- _ -> True+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+ } -checkInteger :: Form ParamValue -> Form Integer-checkInteger = applyForm $ \pv ->- case reads pv of- [] -> Left "Invalid integer"- ((i, _):_) -> Right i+emailField :: Html () -> Html () -> FormletField sub y String+emailField label tooltip = requiredFieldHelper emailFieldProfile+ { fpLabel = label+ , fpTooltip = tooltip+ } --- | Instead of calling 'failure' with an 'InvalidArgs', return the error--- messages.-catchFormError :: Form x -> Form (Either [(ParamName, FormError)] x)-catchFormError (Form x) = Form $ \l ->- case x l of- Left e -> Right (Nothing, Left e)- Right (_, v) -> Right (Nothing, Right v)+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/Formable.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Yesod.Formable- ( Form (..)- , Formlet- , FormResult (..)- , runForm- , incr- , Formable (..)- , deriveFormable- , share2- , wrapperRow- , sealFormlet- , sealForm- , Slug (..)- , sealRow- , check- ) where--import Text.Hamlet-import Data.Time (Day)-import Control.Applicative-import Database.Persist (PersistField)-import Database.Persist.Helper (EntityDef (..))-import Data.Char (isAlphaNum, toUpper, isUpper)-import Language.Haskell.TH.Syntax-import Control.Monad (liftM, join)-import Control.Arrow (first)-import Data.Maybe (fromMaybe, isJust)-import Data.Monoid (mempty, mappend)-import qualified Data.ByteString.Lazy.UTF8-import Yesod.Request-import Yesod.Handler-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.State-import Web.Routes.Quasi (Routes, SinglePiece)-import Data.Int (Int64)--sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b-sealRow label getVal val =- sealForm (wrapperRow label) $ formable $ fmap getVal val--runForm :: Form sub y a- -> GHandler sub y (FormResult a, Hamlet (Routes y))-runForm f = do- req <- getRequest- (pp, _) <- liftIO $ reqRequestBody req- evalStateT (deform f pp) 1--type Env = [(String, String)]--type Incr = StateT Int--incr :: Monad m => Incr m Int-incr = do- i <- get- let i' = i + 1- put i'- return i'--data FormResult a = FormMissing- | FormFailure [String]- | FormSuccess a-instance Functor FormResult where- fmap _ FormMissing = FormMissing- fmap _ (FormFailure errs) = FormFailure errs- fmap f (FormSuccess a) = FormSuccess $ f a-instance Applicative FormResult where- pure = FormSuccess- (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g- (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y- (FormFailure x) <*> _ = FormFailure x- _ <*> (FormFailure y) = FormFailure y- _ <*> _ = FormMissing--newtype Form sub y a = Form- { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))- }-type Formlet sub y a = Maybe a -> Form sub y a--instance Functor (Form sub url) where- fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)--instance Applicative (Form sub url) where- pure a = Form $ const $ return (pure a, mempty)- (Form f) <*> (Form g) = Form $ \env -> do- (f1, f2) <- f env- (g1, g2) <- g env- return (f1 <*> g1, f2 `mappend` g2)--sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))- -> Form sub y a -> Form sub y a-sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)- where- go (res, xml) = (res, wrapper (toList res) xml)- toList (FormFailure errs) = errs- toList _ = []--sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))- -> Formlet sub y a -> Formlet sub y a-sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal--input' :: (String -> String -> Hamlet (Routes y))- -> Maybe String- -> Form sub y String-input' mkXml val = Form $ \env -> do- i <- incr- let i' = show i- let param = lookup i' env- let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param- return (maybe FormMissing FormSuccess param, xml)--check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b-check (Form form) f = Form $ \env -> liftM (first go) (form env)- where- go FormMissing = FormMissing- go (FormFailure x) = FormFailure x- go (FormSuccess a) =- case f a of- Left errs -> FormFailure errs- Right b -> FormSuccess b--class Formable a where- formable :: Formlet sub master a--wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url-wrapperRow label errs control = [$hamlet|-%tr- %th $string.label$- %td ^control^- $if not.null.errs- %td.errors- %ul- $forall errs err- %li $string.err$-|]--instance Formable String where- formable x = input' go x `check` notEmpty- where- go name val = [$hamlet|-%input!type=text!name=$string.name$!value=$string.val$-|]- notEmpty s- | null s = Left ["Value required"]- | otherwise = Right s--instance Formable (Maybe String) where- formable x = input' go (join x) `check` isEmpty- where- go name val = [$hamlet|-%input!type=text!name=$string.name$!value=$string.val$-|]- isEmpty s- | null s = Right Nothing- | otherwise = Right $ Just s--instance Formable (Html ()) where- formable = fmap preEscapedString- . input' go- . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)- where- go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]--instance Formable Day where- formable x = input' go (fmap show x) `check` asDay- where- go name val = [$hamlet|-%input!type=date!name=$string.name$!value=$string.val$-|]- asDay s = case reads s of- (y, _):_ -> Right y- [] -> Left ["Invalid day"]--instance Formable Int64 where- formable x = input' go (fmap show x) `check` asInt- where- go name val = [$hamlet|-%input!type=number!name=$string.name$!value=$string.val$-|]- asInt s = case reads s of- (y, _):_ -> Right y- [] -> Left ["Invalid integer"]--instance Formable Double where- formable x = input' go (fmap numstring x) `check` asDouble- where- go name val = [$hamlet|-%input!type=number!name=$string.name$!value=$string.val$-|]- asDouble s = case reads s of- (y, _):_ -> Right y- [] -> Left ["Invalid double"]- numstring d =- let s = show d- in case reverse s of- '0':'.':y -> reverse y- _ -> s--instance Formable (Maybe Day) where- formable x = input' go (fmap show $ join x) `check` asDay- where- go name val = [$hamlet|-%input!type=date!name=$string.name$!value=$string.val$-|]- asDay "" = Right Nothing- asDay s = case reads s of- (y, _):_ -> Right $ Just y- [] -> Left ["Invalid day"]--instance Formable (Maybe Int) where- formable x = input' go (fmap show $ join x) `check` asInt- where- go name val = [$hamlet|-%input!type=number!name=$string.name$!value=$string.val$-|]- asInt "" = Right Nothing- asInt s = case reads s of- (y, _):_ -> Right $ Just y- [] -> Left ["Invalid integer"]--instance Formable (Maybe Int64) where- formable x = input' go (fmap show $ join x) `check` asInt- where- go name val = [$hamlet|-%input!type=number!name=$string.name$!value=$string.val$-|]- asInt "" = Right Nothing- asInt s = case reads s of- (y, _):_ -> Right $ Just y- [] -> Left ["Invalid integer"]--instance Formable Bool where- formable x = Form $ \env -> do- i <- incr- let i' = show i- let param = lookup i' env- let def = if null env then fromMaybe False x else isJust param- return (FormSuccess $ isJust param, go i' def)- where- go name val = [$hamlet|-%input!type=checkbox!name=$string.name$!:val:checked-|]--instance Formable Int where- formable x = input' go (fmap show x) `check` asInt- where- go name val = [$hamlet|-%input!type=number!name=$string.name$!value=$string.val$-|]- asInt s = case reads s of- (y, _):_ -> Right y- [] -> Left ["Invalid integer"]--newtype Slug = Slug { unSlug :: String }- deriving (Read, Eq, Show, SinglePiece, PersistField)--instance Formable Slug where- formable x = input' go (fmap unSlug x) `check` asSlug- where- go name val = [$hamlet|-%input!type=text!name=$string.name$!value=$string.val$-|]- asSlug [] = Left ["Slug must be non-empty"]- asSlug x'- | all (\c -> c `elem` "-_" || isAlphaNum c) x' =- Right $ Slug x'- | otherwise = Left ["Slug must be alphanumeric, - and _"]--share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]-share2 f g a = do- f' <- f a- g' <- g a- return $ f' ++ g'--deriveFormable :: [EntityDef] -> Q [Dec]-deriveFormable = mapM derive- where- derive :: EntityDef -> Q Dec- derive t = do- let fst3 (x, _, _) = x- let cols = map (toLabel . fst3) $ entityColumns t- ap <- [|(<*>)|]- just <- [|pure|]- nothing <- [|Nothing|]- let just' = just `AppE` ConE (mkName $ entityName t)- let c1 = Clause [ ConP (mkName "Nothing") []- ]- (NormalB $ go ap just' $ zip cols $ map (const nothing) cols)- []- xs <- mapM (const $ newName "x") cols- let xs' = map (AppE just . VarE) xs- let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)- $ map VarP xs]]- (NormalB $ go ap just' $ zip cols xs')- []- return $ InstanceD [] (ConT ''Formable- `AppT` ConT (mkName $ entityName t))- [FunD (mkName "formable") [c1, c2]]- go ap just' = foldl (ap' ap) just' . map go'- go' (label, ex) =- VarE (mkName "sealForm") `AppE`- (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`- (VarE (mkName "formable") `AppE` ex)- ap' ap x y = InfixE (Just x) ap (Just y)--toLabel :: String -> String-toLabel "" = ""-toLabel (x:rest) = toUpper x : go rest- where- go "" = ""- go (c:cs)- | isUpper c = ' ' : c : go cs- | otherwise = c : go cs
Yesod/Hamlet.hs view
@@ -17,7 +17,6 @@ import Text.Hamlet import Yesod.Content import Yesod.Handler-import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature:@@ -31,11 +30,11 @@ -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'.-hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content+hamletToContent :: Hamlet (Route master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRender return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml+hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent
Yesod/Handler.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------- -- -- Module : Yesod.Handler@@ -21,14 +21,16 @@ -- --------------------------------------------------------- module Yesod.Handler- ( -- * Handler monad- Handler+ ( -- * Type families+ Route+ -- * Handler monad+ , Handler , GHandler -- ** Read information from handler , getYesod , getYesodSub , getUrlRender- , getRoute+ , getCurrentRoute , getRouteToMaster -- * Special responses -- ** Redirecting@@ -41,16 +43,17 @@ , badMethod , permissionDenied , invalidArgs- -- ** Sending static files+ -- ** Short-circuit responses. , sendFile+ , sendResponse -- * Setting headers- , addCookie+ , setCookie , deleteCookie- , header+ , setHeader , setLanguage -- * Session , setSession- , clearSession+ , deleteSession -- ** Ultimate destination , setUltDest , setUltDestString@@ -62,14 +65,15 @@ -- * Internal Yesod , runHandler , YesodApp (..)+ , toMasterHandler ) where import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal-import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate)+import Data.Neither import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E@@ -79,7 +83,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader-import Control.Monad.Trans.Cont+import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import System.IO import qualified Network.Wai as W@@ -91,25 +95,53 @@ import Numeric (showIntAtBase) import Data.Char (ord, chr) +-- | The type-safe URLs associated with a site argument.+type family Route a+ data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub , handlerMaster :: master- , handlerRoute :: Maybe (Routes sub)- , handlerRender :: (Routes master -> String)- , handlerToMaster :: Routes sub -> Routes master+ , handlerRoute :: Maybe (Route sub)+ , handlerRender :: (Route master -> String)+ , handlerToMaster :: Route sub -> Route master } +handlerSubData :: (Route sub -> Route master)+ -> (master -> sub)+ -> Route sub+ -> HandlerData oldSub master+ -> HandlerData sub master+handlerSubData tm ts route hd = hd+ { handlerSub = ts $ handlerMaster hd+ , handlerToMaster = tm+ , handlerRoute = Just route+ }++-- | Used internally for promoting subsite handler functions to master site+-- handler functions. Should not be needed by users.+toMasterHandler :: (Route sub -> Route master)+ -> (master -> sub)+ -> Route sub+ -> GHandler sub master a+ -> Handler master a+toMasterHandler tm ts route (GHandler h) =+ GHandler $ withReaderT (handlerSubData tm ts route) h+ -- | A generic handler monad, which can have a different subsite and master--- site. This monad is a combination of reader for basic arguments, a writer--- for headers, and an error-type monad for handling special responses.-type GHandler sub master =+-- site. This monad is a combination of 'ReaderT' for basic arguments, a+-- '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) (- ContT HandlerContents (+ MEitherT HandlerContents ( WriterT (Endo [Header]) ( WriterT (Endo [(String, Maybe String)]) ( IO- ))))+ )))) a+}+ deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) type Endo a = a -> a @@ -136,31 +168,31 @@ | HCRedirect RedirectType String instance Failure ErrorResponse (GHandler sub master) where- failure = lift . ContT . const . return . HCError+ failure = GHandler . lift . throwMEither . HCError instance RequestReader (GHandler sub master) where- getRequest = handlerRequest <$> ask+ getRequest = handlerRequest <$> GHandler ask -- | Get the sub application argument. getYesodSub :: GHandler sub master sub-getYesodSub = handlerSub <$> ask+getYesodSub = handlerSub <$> GHandler ask -- | Get the master site appliation argument. getYesod :: GHandler sub master master-getYesod = handlerMaster <$> ask+getYesod = handlerMaster <$> GHandler ask -- | Get the URL rendering function.-getUrlRender :: GHandler sub master (Routes master -> String)-getUrlRender = handlerRender <$> ask+getUrlRender :: GHandler sub master (Route master -> String)+getUrlRender = 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'.-getRoute :: GHandler sub master (Maybe (Routes sub))-getRoute = handlerRoute <$> ask+getCurrentRoute :: GHandler sub master (Maybe (Route sub))+getCurrentRoute = handlerRoute <$> GHandler ask -- | Get the function to promote a route for a subsite to a route for the -- master site.-getRouteToMaster :: GHandler sub master (Routes sub -> Routes master)-getRouteToMaster = handlerToMaster <$> ask+getRouteToMaster :: GHandler sub master (Route sub -> Route master)+getRouteToMaster = handlerToMaster <$> GHandler ask modifySession :: [(String, String)] -> (String, Maybe String) -> [(String, String)]@@ -176,9 +208,9 @@ -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c- -> (Routes master -> String)- -> Maybe (Routes sub)- -> (Routes sub -> Routes master)+ -> (Route master -> String)+ -> Maybe (Route sub)+ -> (Route sub -> Route master) -> master -> (master -> sub) -> YesodApp@@ -194,23 +226,25 @@ , handlerRender = mrender , handlerToMaster = tomr }- ((contents, headers), session') <- E.catch (+ ((contents', headers), session') <- E.catch ( runWriterT $ runWriterT- $ flip runContT (return . HCContent . chooseRep)- $ flip runReaderT hd handler- ) (\e -> return ((HCError $ toErrorHandler e, id), id))+ $ runMEitherT+ $ flip runReaderT hd+ $ unGHandler handler+ ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id))+ 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 let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp =- return (W.Status200, headers [], ct, ContentFile fp, finalSession)+ return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts- return (W.Status200, headers [], ct, c, finalSession)+ return (W.status200, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers []@@ -223,20 +257,19 @@ safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> 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", []) -- | Redirect to the given route.-redirect :: RedirectType -> Routes master -> GHandler sub master a-redirect rt url = do- r <- getUrlRender- redirectString rt $ r url+redirect :: RedirectType -> Route master -> GHandler sub master a+redirect rt url = redirectParams rt url [] -- | Redirects to the given route with the associated query-string parameters.-redirectParams :: RedirectType -> Routes master -> [(String, String)]+redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do r <- getUrlRender- redirectString rt $ r url ++ '?' : encodeUrlPairs params+ redirectString rt $ r url +++ if null params then "" else '?' : encodeUrlPairs params where encodeUrlPairs = intercalate "&" . map encodeUrlPair encodeUrlPair (x, []) = escape x@@ -260,7 +293,7 @@ -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a-redirectString rt url = lift $ ContT $ const $ return $ HCRedirect rt url+redirectString rt = GHandler . lift . throwMEither . HCRedirect rt ultDestKey :: String ultDestKey = "_ULT"@@ -269,7 +302,7 @@ -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'.-setUltDest :: Routes master -> GHandler sub master ()+setUltDest :: Route master -> GHandler sub master () setUltDest dest = do render <- getUrlRender setUltDestString $ render dest@@ -284,7 +317,7 @@ -- nothing. setUltDest' :: GHandler sub master () setUltDest' = do- route <- getRoute+ route <- getCurrentRoute tm <- getRouteToMaster maybe (return ()) setUltDest $ tm <$> route @@ -293,11 +326,11 @@ -- -- The ultimate destination is set with 'setUltDest'. redirectUltDest :: RedirectType- -> Routes master -- ^ default destination if nothing in session+ -> Route master -- ^ default destination if nothing in session -> GHandler sub master () redirectUltDest rt def = do mdest <- lookupSession ultDestKey- clearSession ultDestKey+ deleteSession ultDestKey maybe (redirect rt def) (redirectString rt) mdest msgKey :: String@@ -305,6 +338,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@@ -315,7 +351,7 @@ -- See 'setMessage'. getMessage :: GHandler sub master (Maybe (Html ())) getMessage = do- clearSession msgKey+ deleteSession msgKey fmap (fmap preEscapedString) $ lookupSession msgKey -- | Bypass remaining handler code and output the given file.@@ -323,8 +359,12 @@ -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a-sendFile ct fp = lift $ ContT $ const $ return $ HCSendFile ct fp+sendFile ct = GHandler . lift . throwMEither . HCSendFile ct +-- | Bypass remaining handler code and output the given content.+sendResponse :: HasReps c => c -> GHandler sub master a+sendResponse = GHandler . lift . throwMEither . HCContent . chooseRep+ -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound@@ -333,35 +373,35 @@ badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest- failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w+ failure $ BadMethod $ toString $ W.requestMethod w -- | Return a 403 permission denied page.-permissionDenied :: Failure ErrorResponse m => m a-permissionDenied = failure $ PermissionDenied "Permission denied"+permissionDenied :: Failure ErrorResponse m => String -> m a+permissionDenied = failure . PermissionDenied -- | Return a 400 invalid arguments page.-invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a+invalidArgs :: Failure ErrorResponse m => [String] -> m a invalidArgs = failure . InvalidArgs ------- Headers -- | Set the cookie on the client.-addCookie :: Int -- ^ minutes to timeout+setCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value -> GHandler sub master ()-addCookie a b = addHeader . AddCookie a b+setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie --- | Set the language header. Will show up in 'languages'.+-- | Set the language in the user session. Will show up in 'languages'. setLanguage :: String -> GHandler sub master ()-setLanguage = addCookie 60 langKey+setLanguage = setSession langKey -- | Set an arbitrary header on the client.-header :: String -> String -> GHandler sub master ()-header a = addHeader . Header a+setHeader :: String -> String -> GHandler sub master ()+setHeader a = addHeader . Header a -- | Set a variable in the user's session. --@@ -371,26 +411,27 @@ setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master ()-setSession k v = lift . lift . lift . tell $ (:) (k, Just v)+setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v) -- | Unsets a session variable. See 'setSession'.-clearSession :: String -> GHandler sub master ()-clearSession k = lift . lift . lift . tell $ (:) (k, Nothing)+deleteSession :: String -> GHandler sub master ()+deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing) +-- | Internal use only, not to be confused with 'setHeader'. addHeader :: Header -> GHandler sub master ()-addHeader = lift . lift . tell . (:)+addHeader = GHandler . lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status-getStatus NotFound = W.Status404-getStatus (InternalError _) = W.Status500-getStatus (InvalidArgs _) = W.Status400-getStatus (PermissionDenied _) = W.Status403-getStatus (BadMethod _) = W.Status405+getStatus NotFound = W.status404+getStatus (InternalError _) = W.status500+getStatus (InvalidArgs _) = W.status400+getStatus (PermissionDenied _) = W.status403+getStatus (BadMethod _) = W.status405 getRedirectStatus :: RedirectType -> W.Status-getRedirectStatus RedirectPermanent = W.Status301-getRedirectStatus RedirectTemporary = W.Status302-getRedirectStatus RedirectSeeOther = W.Status303+getRedirectStatus RedirectPermanent = W.status301+getRedirectStatus RedirectTemporary = W.status302+getRedirectStatus RedirectSeeOther = W.status303 -- | Different types of redirects. data RedirectType = RedirectPermanent
Yesod/Helpers/AtomFeed.hs view
@@ -29,7 +29,7 @@ instance HasReps RepAtom where chooseRep (RepAtom c) _ = return (typeAtom, c) -atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom+atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom atomFeed = fmap RepAtom . hamletToContent . template data AtomFeed url = AtomFeed@@ -47,17 +47,14 @@ , atomEntryContent :: Html () } -xmlns :: AtomFeed url -> Html ()-xmlns _ = preEscapedString "http://www.w3.org/2005/Atom"- template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| <?xml version="1.0" encoding="utf-8"?>-%feed!xmlns=$xmlns.arg$- %title $string.atomTitle.arg$+%feed!xmlns="http://www.w3.org/2005/Atom"+ %title $atomTitle.arg$ %link!rel=self!href=@atomLinkSelf.arg@ %link!href=@atomLinkHome.arg@- %updated $string.formatW3.atomUpdated.arg$+ %updated $formatW3.atomUpdated.arg$ %id @atomLinkHome.arg@ $forall atomEntries.arg entry ^entryTemplate.entry^@@ -68,7 +65,7 @@ %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@- %updated $string.formatW3.atomEntryUpdated.arg$- %title $string.atomEntryTitle.arg$+ %updated $formatW3.atomEntryUpdated.arg$+ %title $atomEntryTitle.arg$ %content!type=html $cdata.atomEntryContent.arg$ |]
Yesod/Helpers/Auth.hs view
@@ -22,8 +22,7 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..)- , AuthRoutes (..)- , siteAuth+ , AuthRoute (..) -- * Settings , YesodAuth (..) , Creds (..)@@ -38,6 +37,7 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId+import qualified Web.Authenticate.Facebook as Facebook import Yesod @@ -49,16 +49,17 @@ import Control.Concurrent.MVar import System.IO import Control.Monad.Attempt-import Data.Monoid (mempty) import Data.ByteString.Lazy.UTF8 (fromString)+import Data.Object +-- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'. class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other -- destination exists.- defaultDest :: master -> Routes master+ defaultDest :: master -> Route master -- | Default page to redirect user to for logging in.- defaultLoginRoute :: master -> Routes master+ defaultLoginRoute :: master -> Route master -- | Callback for a successful login. --@@ -75,17 +76,19 @@ stdgen <- newStdGen return $ take 10 $ randomRs ('A', 'Z') stdgen --- | Each authentication subsystem (OpenId, Rpxnow, Email) has its own--- settings. If those settings are not present, then relevant handlers will+-- | 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+ -- | client id, secret and requested permissions+ , authFacebook :: Maybe (String, String, [String]) } -- | Which subsystem authenticated the user.-data AuthType = AuthOpenId | AuthRpxnow | AuthEmail+data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook deriving (Show, Read, Eq) type Email = String@@ -117,6 +120,7 @@ , credsEmail :: Maybe String -- ^ Verified e-mail address. , credsDisplayName :: Maybe String -- ^ Display name. , credsId :: Maybe Integer -- ^ Numeric ID, if used.+ , credsFacebookToken :: Maybe Facebook.AccessToken } deriving (Show, Read, Eq) @@ -147,8 +151,11 @@ /openid/complete OpenIdComplete GET /login/rpxnow RpxnowR +/facebook FacebookR GET+/facebook/start StartFacebookR GET+ /register EmailRegisterR GET POST-/verify/#EmailId/#String EmailVerifyR GET+/verify/#Integer/#String EmailVerifyR GET /login EmailLoginR GET POST /set-password EmailPasswordR GET POST |]@@ -161,17 +168,14 @@ getOpenIdR :: Yesod master => GHandler Auth master RepHtml getOpenIdR = do testOpenId- rr <- getRequest- case getParams rr "dest" of- [] -> return ()- (x:_) -> setUltDestString x+ 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: + %label!for=openid OpenID: $ %input#openid!type=text!name=openid %input!type=submit!value=Login |]@@ -179,10 +183,7 @@ getOpenIdForward :: GHandler Auth master () getOpenIdForward = do testOpenId- rr <- getRequest- oid <- case getParams rr "openid" of- [x] -> return x- _ -> invalidArgs [("openid", "Expected single parameter")]+ oid <- runFormGet' $ stringInput "openid" render <- getUrlRender toMaster <- getRouteToMaster let complete = render $ toMaster OpenIdComplete@@ -206,7 +207,7 @@ redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do y <- getYesod- setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) []+ setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res @@ -217,11 +218,11 @@ apiKey <- case authRpxnowApiKey auth of Just x -> return x Nothing -> notFound- rr <- getRequest- pp <- postParams rr- let token = case getParams rr "token" ++ pp "token" of- [] -> invalidArgs [("token", "Value not supplied")]- (x:_) -> x+ 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@@ -229,15 +230,16 @@ (lookup "verifiedEmail" extra) (getDisplayName extra) Nothing+ Nothing setCreds creds extra+ dest1 <- lookupPostParam "dest"+ dest2 <- lookupGetParam "dest" either (redirect RedirectTemporary) (redirectString RedirectTemporary) $- case pp "dest" of- (d:_) -> Right d- [] -> case getParams rr "dest" of- [] -> Left $ defaultDest ay- ("":_) -> Left $ defaultDest ay- (('#':rest):_) -> Right rest- (s:_) -> Right s+ 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@@ -256,7 +258,7 @@ $if isNothing.creds %p Not logged in $maybe creds c- %p Logged in as $string.credsIdent.c$+ %p Logged in as $credsIdent.c$ |] json creds = jsonMap@@ -268,7 +270,7 @@ getLogout :: YesodAuth master => GHandler Auth master () getLogout = do y <- getYesod- clearSession credsKey+ deleteSession credsKey redirectUltDest RedirectTemporary $ defaultDest y -- | Retrieve user credentials. If user is not logged in, redirects to the@@ -301,7 +303,7 @@ postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings- email <- runFormPost $ notEmpty $ required $ input "email" -- FIXME checkEmail+ email <- runFormPost' $ emailInput "email" y <- getYesod mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <-@@ -316,7 +318,7 @@ let verUrl = render $ tm $ EmailVerifyR lid verKey liftIO $ sendVerifyEmail ae email verKey verUrl applyLayout "Confirmation e-mail sent" mempty [$hamlet|-%p A confirmation e-mail has been sent to $string.email$.+%p A confirmation e-mail has been sent to $email$. |] getEmailVerifyR :: YesodAuth master@@ -328,12 +330,13 @@ case (realKey == Just key, memail) of (True, Just email) -> do liftIO $ verifyAccount ae lid- setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []+ setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)+ Nothing) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR _ -> applyLayout "Invalid verification key" mempty [$hamlet| %p I'm sorry, but that was an invalid verification key.- |]+|] getEmailLoginR :: Yesod master => GHandler Auth master RepHtml getEmailLoginR = do@@ -364,9 +367,9 @@ postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do ae <- getAuthEmailSettings- (email, pass) <- runFormPost $ (,)- <$> notEmpty (required $ input "email") -- FIXME valid e-mail?- <*> required (input "password")+ (email, pass) <- runFormPost' $ (,)+ <$> emailInput "email"+ <*> stringInput "password" y <- getYesod mecreds <- liftIO $ getEmailCreds ae email let mlid =@@ -376,7 +379,8 @@ _ -> Nothing case mlid of Just lid -> do- setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []+ setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)+ Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y Nothing -> do setMessage $ string "Invalid email/password combination"@@ -389,7 +393,7 @@ toMaster <- getRouteToMaster mcreds <- maybeCreds case mcreds of- Just (Creds _ AuthEmail _ _ (Just _)) -> return ()+ Just (Creds _ AuthEmail _ _ (Just _) _) -> return () _ -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR@@ -416,16 +420,16 @@ postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR = do ae <- getAuthEmailSettings- (new, confirm) <- runFormPost $ (,)- <$> notEmpty (required $ input "new")- <*> notEmpty (required $ input "confirm")+ (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 mcreds <- maybeCreds lid <- case mcreds of- Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid+ Just (Creds _ AuthEmail _ _ (Just lid) _) -> return lid _ -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR@@ -453,6 +457,9 @@ 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 []@@ -481,3 +488,38 @@ 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+ case a of+ Nothing -> notFound+ Just (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++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
Yesod/Helpers/Crud.hs view
@@ -1,25 +1,32 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..)- , CrudRoutes (..)+ , CrudRoute (..) , defaultCrud- , siteCrud ) where import Yesod.Yesod+import Yesod.Widget import Yesod.Dispatch import Yesod.Content import Yesod.Handler import Text.Hamlet-import Yesod.Formable+import Yesod.Form import Data.Monoid (mempty) -class Formable a => Item a where+-- | An entity which can be displayed by the Crud subsite.+class ToForm a => Item a where+ -- | The title of an entity, to be displayed in the list of all entities. itemTitle :: a -> String +-- | Defines all of the CRUD operations (Create, Read, Update, Delete)+-- necessary to implement this subsite. When using the "Yesod.Form" module and+-- 'ToForm' typeclass, you can probably just use 'defaultCrud'. data Crud master item = Crud { crudSelect :: GHandler (Crud master item) master [(Key item, item)] , crudReplace :: Key item -> item -> GHandler (Crud master item) master ()@@ -50,7 +57,7 @@ $forall items item %li %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@- $string.itemTitle.snd.item$+ $itemTitle.snd.item$ %p %a!href=@toMaster.CrudAddR@ Add new item |]@@ -101,10 +108,10 @@ applyLayout "Confirm delete" mempty [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete?- %p Do you really want to delete $string.itemTitle.item$?+ %p Do you really want to delete $itemTitle.item$? %p %input!type=submit!value=Yes- \ + \ $ %a!href=@toMaster.CrudListR@ No |] @@ -126,7 +133,7 @@ -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do crud <- getYesodSub- (errs, form) <- runForm $ formable $ fmap snd me+ (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of (True, FormSuccess a) -> do@@ -138,23 +145,30 @@ redirect RedirectTemporary $ toMaster $ CrudEditR $ toSinglePiece eid _ -> return ()- applyLayout title mempty [$hamlet|+ applyLayoutW $ do+ wrapWidget form (wrapForm toMaster enctype)+ setTitle $ string title+ where+ wrapForm toMaster enctype form = [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list-%h1 $string.title$-%form!method=post+%h1 $title$+%form!method=post!enctype=$show.enctype$ %table ^form^ %tr %td!colspan=2 %input!type=submit $maybe me e- \ + \ $ %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete |] -defaultCrud :: (PersistEntity i, YesodPersist a, PersistMonad i ~ YesodDB a)- => a -> Crud a i+-- | A default 'Crud' value which relies about persistent and "Yesod.Form".+defaultCrud+ :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)),+ YesodPersist a)+ => a -> Crud a i defaultCrud = const Crud { crudSelect = runDB $ select [] [] , crudReplace = \a -> runDB . replace a
Yesod/Helpers/Sitemap.hs view
@@ -50,25 +50,22 @@ , priority :: Double } -sitemapNS :: Html ()-sitemapNS = string "http://www.sitemaps.org/schemas/sitemap/0.9"- template :: [SitemapUrl url] -> Hamlet url template urls = [$hamlet|-%urlset!xmlns=$sitemapNS$+%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" $forall urls url %url %loc @sitemapLoc.url@- %lastmod $string.formatW3.sitemapLastMod.url$- %changefreq $string.showFreq.sitemapChangeFreq.url$- %priority $string.show.priority.url$+ %lastmod $formatW3.sitemapLastMod.url$+ %changefreq $showFreq.sitemapChangeFreq.url$+ %priority $show.priority.url$ |] -sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml+sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml sitemap = fmap RepXml . hamletToContent . template -- | A basic robots file which just lists the "Sitemap: " line.-robots :: Routes sub -- ^ sitemap url+robots :: Route sub -- ^ sitemap url -> GHandler sub master RepPlain robots smurl = do tm <- getRouteToMaster
Yesod/Helpers/Static.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static@@ -25,8 +27,7 @@ module Yesod.Helpers.Static ( -- * Subsite Static (..)- , StaticRoutes (..)- , siteStatic+ , StaticRoute (..) -- * Lookup files in filesystem , fileLookupDir , staticFiles@@ -37,6 +38,7 @@ import System.Directory import Control.Monad+import Data.Maybe (fromMaybe) import Yesod import Data.List (intercalate)@@ -50,11 +52,15 @@ -- | A function for looking up file contents. For serving from the file system, -- see 'fileLookupDir'.-data Static = Static (FilePath -> IO (Maybe (Either FilePath Content)))+data Static = Static+ { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content))+ -- | Mapping from file extension to content type. See 'typeByExt'.+ , staticTypes :: [(String, ContentType)]+ } -$(mkYesodSub "Static" [] [$parseRoutes|+mkYesodSub "Static" [] [$parseRoutes| *Strings StaticRoute GET-|])+|] -- | Lookup files in a specific directory. --@@ -62,7 +68,9 @@ -- probably are), the handler itself checks that no unsafe paths are being -- requested. In particular, no path segments may begin with a single period, -- so hidden files and parent directories are safe.-fileLookupDir :: FilePath -> Static+--+-- For the second argument to this function, you can just use 'typeByExt'.+fileLookupDir :: FilePath -> [(String, ContentType)] -> Static fileLookupDir dir = Static $ \fp -> do let fp' = dir ++ '/' : fp exists <- doesFileExist fp'@@ -71,16 +79,20 @@ else return Nothing getStaticRoute :: [String]- -> GHandler Static master [(ContentType, Content)]+ -> GHandler Static master (ContentType, Content) getStaticRoute fp' = do- Static fl <- getYesodSub+ Static fl ctypes <- getYesodSub when (any isUnsafe fp') notFound let fp = intercalate "/" fp' content <- liftIO $ fl fp case content of Nothing -> notFound- Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp''- Just (Right bs) -> return [(typeByExt $ ext fp, bs)]+ Just (Left fp'') -> do+ let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes+ sendFile ctype fp''+ Just (Right bs) -> do+ let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes+ return (ctype, bs) where isUnsafe [] = True isUnsafe ('.':_) = True@@ -104,6 +116,10 @@ dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs return $ concat $ files' : dirs' +-- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create:+--+-- > style_css = StaticRoute ["style.css"]+-- > js_script_js = StaticRoute ["js/script.js"] staticFiles :: FilePath -> Q [Dec] staticFiles fp = do fs <- qRunIO $ getFileList fp@@ -117,7 +133,7 @@ f' <- lift f let sr = ConE $ mkName "StaticRoute" return- [ SigD name $ ConT ''StaticRoutes+ [ SigD name $ ConT ''Route `AppT` ConT ''Static , FunD name [ Clause [] (NormalB $ sr `AppE` f') [] ]
Yesod/Internal.hs view
@@ -13,7 +13,7 @@ data ErrorResponse = NotFound | InternalError String- | InvalidArgs [(String, String)]+ | InvalidArgs [String] | PermissionDenied String | BadMethod String deriving (Show, Eq)
Yesod/Json.hs view
@@ -10,6 +10,7 @@ , jsonScalar , jsonList , jsonMap+ , jsonRaw #if TEST , testSuite #endif@@ -35,8 +36,8 @@ #endif -- | A monad for generating Json output. In truth, it is just a newtype wrapper--- around 'Hamlet'; we thereby get the benefits of Hamlet (interleaving IO and--- enumerator output) without accidently mixing non-JSON content.+-- around 'Html'; we thereby get the benefits of BlazeHtml (type safety and+-- speed) without accidently mixing non-JSON content. -- -- 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@@ -113,6 +114,12 @@ , Json $ preEscapedString ":" , v ]++-- | Outputs raw JSON data without performing any escaping. Use with caution:+-- 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 #if TEST
Yesod/Request.hs view
@@ -29,11 +29,13 @@ , lookupPostParam , lookupCookie , lookupSession- -- ** Alternate- , getParams- , postParams- , cookies- , session+ , lookupFile+ -- ** Multi-lookup+ , lookupGetParams+ , lookupPostParams+ , lookupCookies+ , lookupSessions+ , lookupFiles -- * Parameter type synonyms , ParamName , ParamValue@@ -44,8 +46,8 @@ import qualified Data.ByteString.Lazy as BL import "transformers" Control.Monad.IO.Class import Control.Monad (liftM)-import Network.Wai.Parse import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r+import Data.Maybe (listToMaybe) type ParamName = String type ParamValue = String@@ -60,12 +62,14 @@ -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order--- of preference:+-- of preference): -- -- * The _LANG get parameter. -- -- * The _LANG cookie. --+-- * The _LANG user session variable.+-- -- * Accept-Language HTTP header. -- -- This is handled by the parseWaiRequest function in Yesod.Dispatch (not@@ -80,9 +84,16 @@ -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(ParamName, ParamValue)]- , [(ParamName, FileInfo BL.ByteString)]+ , [(ParamName, FileInfo)] ) +data FileInfo = FileInfo+ { fileName :: String+ , fileContentType :: String+ , fileContent :: BL.ByteString+ }+ deriving (Eq, Show)+ -- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)]@@ -99,59 +110,64 @@ , reqLangs :: [String] } -multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue]-multiLookup [] _ = []-multiLookup ((k, v):rest) pn- | k == pn = v : multiLookup rest pn- | otherwise = multiLookup rest pn+lookup' :: Eq a => a -> [(a, b)] -> [b]+lookup' a = map snd . filter (\x -> a == fst x) --- | All GET paramater values with the given name.-getParams :: RequestReader m => m (ParamName -> [ParamValue])-getParams = do+-- | Lookup for GET parameters.+lookupGetParams :: RequestReader m => ParamName -> m [ParamValue]+lookupGetParams pn = do rr <- getRequest- return $ multiLookup $ reqGetParams rr+ return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)-lookupGetParam pn = do- rr <- getRequest- return $ lookup pn $ reqGetParams rr+lookupGetParam = liftM listToMaybe . lookupGetParams --- | All POST paramater values with the given name.-postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue])-postParams rr = do+-- | Lookup for POST parameters.+lookupPostParams :: (MonadIO m, RequestReader m)+ => ParamName+ -> m [ParamValue]+lookupPostParams pn = do+ rr <- getRequest (pp, _) <- liftIO $ reqRequestBody rr- return $ multiLookup pp+ return $ lookup' pn pp --- | Lookup for POST parameters. lookupPostParam :: (MonadIO m, RequestReader m) => ParamName -> m (Maybe ParamValue)-lookupPostParam pn = do- rr <- getRequest- (pp, _) <- liftIO $ reqRequestBody rr- return $ lookup pn pp+lookupPostParam = liftM listToMaybe . lookupPostParams --- | All cookies with the given name.-cookies :: RequestReader m => m (ParamName -> [ParamValue])-cookies = do+-- | Lookup for POSTed files.+lookupFile :: (MonadIO m, RequestReader m)+ => ParamName+ -> m (Maybe FileInfo)+lookupFile = liftM listToMaybe . lookupFiles++-- | Lookup for POSTed files.+lookupFiles :: (MonadIO m, RequestReader m)+ => ParamName+ -> m [FileInfo]+lookupFiles pn = do rr <- getRequest- return $ multiLookup $ reqCookies rr+ (_, files) <- liftIO $ reqRequestBody rr+ return $ lookup' pn files -- | Lookup for cookie data. lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)-lookupCookie pn = do- rr <- getRequest- return $ lookup pn $ reqCookies rr+lookupCookie = liftM listToMaybe . lookupCookies --- | All session data with the given name.-session :: RequestReader m => m (ParamName -> [ParamValue])-session = do+-- | Lookup for cookie data.+lookupCookies :: RequestReader m => ParamName -> m [ParamValue]+lookupCookies pn = do rr <- getRequest- return $ multiLookup $ reqSession rr+ return $ lookup' pn $ reqCookies rr -- | Lookup for session data. lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue)-lookupSession pn = do+lookupSession = liftM listToMaybe . lookupSessions++-- | Lookup for session data.+lookupSessions :: RequestReader m => ParamName -> m [ParamValue]+lookupSessions pn = do rr <- getRequest- return $ lookup pn $ reqSession rr+ return $ lookup' pn $ reqSession rr
+ Yesod/Widget.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE FlexibleInstances #-}+-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier+-- generator, allowing you to create truly modular HTML components.+module Yesod.Widget+ ( -- * Datatype+ GWidget+ , Widget+ -- * Unwrapping+ , widgetToPageContent+ , applyLayoutW+ -- * Creating+ , newIdent+ , setTitle+ , addStyle+ , addStylesheet+ , addStylesheetRemote+ , addScript+ , addScriptRemote+ , addHead+ , addBody+ , 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 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++-- | 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 (+ WriterT (Body (Route master)) (+ WriterT (Last Title) (+ WriterT (UniqueList (Script (Route master))) (+ WriterT (UniqueList (Stylesheet (Route master))) (+ WriterT (Style (Route master)) (+ WriterT (JavaScript (Route master)) (+ 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++-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+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 some raw HTML to the body tag.+addBody :: Hamlet (Route master) -> GWidget sub master ()+addBody = GWidget . tell . Body++-- | Get a unique identifier.+newIdent :: GWidget sub master String+newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do+ i <- get+ let i' = i + 1+ put i'+ 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++-- | Link to the specified local stylesheet.+addStylesheet :: Route master -> GWidget sub master ()+addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local++-- | Link to the specified remote stylesheet.+addStylesheetRemote :: String -> GWidget sub master ()+addStylesheetRemote =+ GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote++-- | Link to the specified local script.+addScript :: Route master -> GWidget sub master ()+addScript = GWidget . lift . lift . tell . toUnique . Script . Local++-- | Link to the specified remote script.+addScriptRemote :: String -> GWidget sub master ()+addScriptRemote =+ 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++-- | 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)++-- | Pull out the HTML tag contents and return it. Useful for performing some+-- manipulations. It can be easier to use this sometimes than 'wrapWidget'.+extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m))+extractBody (GWidget w) =+ 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
@@ -1,22 +1,29 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes Yesod (..) , YesodSite (..)+ , YesodSubSite (..) -- ** Persistence , YesodPersist (..)- , PersistEntity (..)+ , module Database.Persist+ , get404 -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs -- * Convenience functions , applyLayout , applyLayoutJson+ , maybeAuthorized -- * Defaults , defaultErrorHandler+ -- * Data types+ , AuthResult (..) ) where import Yesod.Content@@ -30,18 +37,25 @@ import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString)-import Database.Persist (PersistEntity (..))--import Web.Routes.Quasi (QuasiSite (..), Routes)+import Database.Persist+import Web.Routes.Site (Site)+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.Attempt (Failure) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly.-class YesodSite y where- getSite :: QuasiSite YesodApp y y+class Eq (Route y) => YesodSite y where+ getSite :: Site (Route y) (Method -> Maybe (Handler y ChooseRep))+type Method = String +-- | Same as 'YesodSite', but for subsites. Once again, users should not need+-- to deal with it directly, as the mkYesodSub creates instances appropriately.+class Eq (Route s) => YesodSubSite s y where+ getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep))+ -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults.-class Yesod a where+class Eq (Route a) => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. --@@ -64,14 +78,11 @@ clientSessionDuration = const 120 -- | Output error response pages.- errorHandler :: Yesod y- => a- -> ErrorResponse- -> Handler y ChooseRep- errorHandler _ = defaultErrorHandler+ errorHandler :: ErrorResponse -> GHandler sub a ChooseRep+ errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page.- defaultLayout :: PageContent (Routes a) -> GHandler sub a Content+ defaultLayout :: PageContent (Route a) -> GHandler sub a Content defaultLayout p = hamletToContent [$hamlet| !!! %html@@ -83,36 +94,48 @@ |] -- | Gets called at the beginning of each request. Useful for logging.- onRequest :: a -> Request -> IO ()- onRequest _ _ = return ()+ onRequest :: GHandler sub a ()+ onRequest = return () -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies.- urlRenderOverride :: a -> Routes a -> Maybe String+ urlRenderOverride :: a -> Route a -> Maybe String urlRenderOverride _ _ = Nothing - -- | Determine is a request is authorized or not.+ -- | Determine if a request is authorized or not. -- -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically.- isAuthorized :: a -> Routes a -> IO (Maybe String)- isAuthorized _ _ = return Nothing+ isAuthorized :: Route a -> GHandler s a AuthResult+ isAuthorized _ = return Authorized + -- | The default route for authentication.+ --+ -- Used in particular by 'isAuthorized', but library users can do whatever+ -- they want with it.+ authRoute :: a -> Maybe (Route a)+ authRoute _ = Nothing++data AuthResult = Authorized | AuthenticationRequired | Unauthorized String+ deriving (Eq, Show, Read)+ -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). class YesodBreadcrumbs y where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page.- breadcrumb :: Routes y -> Handler y (String, Maybe (Routes y))+ breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles.-breadcrumbs :: YesodBreadcrumbs y => Handler y (String, [(Routes y, String)])+breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) breadcrumbs = do- x <- getRoute+ x' <- getCurrentRoute+ tm <- getRouteToMaster+ let x = fmap tm x' case x of Nothing -> return ("Not found", []) Just y -> do@@ -128,8 +151,8 @@ -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title- -> Hamlet (Routes master) -- ^ head- -> Hamlet (Routes master) -- ^ body+ -> Hamlet (Route master) -- ^ head+ -> Hamlet (Route master) -- ^ body -> GHandler sub master RepHtml applyLayout t h b = RepHtml `fmap` defaultLayout PageContent@@ -142,8 +165,8 @@ -- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title- -> Hamlet (Routes master) -- ^ head- -> Hamlet (Routes master) -- ^ body+ -> Hamlet (Route master) -- ^ head+ -> Hamlet (Route master) -- ^ body -> Json -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do@@ -157,46 +180,63 @@ applyLayout' :: Yesod master => String -- ^ title- -> Hamlet (Routes master) -- ^ body+ -> Hamlet (Route master) -- ^ body -> GHandler sub master ChooseRep applyLayout' s = fmap chooseRep . applyLayout s mempty -- | The default error handler for 'errorHandler'.-defaultErrorHandler :: Yesod y- => ErrorResponse- -> Handler y ChooseRep+defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found-%p $string.toString.pathInfo.r$+%p $toString.pathInfo.r$ |] where pathInfo = W.pathInfo defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied-%p $string.msg$+%p $msg$ |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments-%dl- $forall ia pair- %dt $string.fst.pair$- %dd $string.snd.pair$+%ul+ $forall ia msg+ %li $msg$ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error-%p $string.e$+%p $e$ |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported-%p Method "$string.m$" not supported+%p Method "$m$" not supported |] class YesodPersist y where type YesodDB y :: (* -> *) -> * -> * runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a+++-- Get the given entity by ID, or return a 404 not found if it doesn't exist.+get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m),+ Failure ErrorResponse m, MonadTrans t)+ => Key val -> t m val+get404 key = do+ mres <- get key+ case mres of+ Nothing -> lift notFound+ Just res -> return res++-- | Return the same URL if the user is authorized to see it.+--+-- 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+ return $ if x == Authorized then Just r else Nothing
+ scaffold.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE QuasiQuotes #-}+import CodeGen+import System.IO+import System.Directory++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.++Your name: |]+ hFlush stdout+ name <- getLine++ putStr [$codegen|+Welcome ~name~.+What do you want to call your project? We'll use this for the cabal name and+executable filenames.++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.++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|+name: ~project~+version: 0.0.0+license: BSD3+license-file: LICENSE+author: ~name~+maintainer: ~name~+synopsis: The greatest Yesod web application ever.+description: I'm sure you can say something clever here if you try.+category: Web+stability: Experimental+cabal-version: >= 1.6+build-type: Simple+homepage: http://www.yesodweb.com/~project~++executable ~project~+ build-depends: base >= 4 && < 5,+ yesod >= 0.4.0 && < 0.5.0,+ persistent-sqlite >= 0.1.0 && < 0.2+ ghc-options: -Wall+ main-is: ~project~.hs+|]++ putStrLn "Generating LICENSE"+ writeFile "LICENSE" [$codegen|+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, ~name~. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+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+ ( ~sitearg~ (..)+ , with~sitearg~+ ) where+import Yesod+import Yesod.Helpers.Crud+import Yesod.Helpers.Static+import Database.Persist.Sqlite+import Model++data ~sitearg~ = ~sitearg~+ { connPool :: Pool Connection+ , static :: Static+ }++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 PersonCrud = Crud ~sitearg~ Person++mkYesod "~sitearg~" [$parseRoutes|+/ RootR GET+/people PeopleR PersonCrud defaultCrud+/static StaticR Static static+|~~]++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^+|~~]+ where+ stylesheet = StaticR $ StaticRoute ["style.css"]++instance YesodPersist ~sitearg~ where+ type YesodDB ~sitearg~ = SqliteReader+ runDB db = fmap connPool getYesod >>= runSqlite 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!+%p+ %a!href=@PeopleR.CrudListR@ Manage people+|~~]+|]++ putStrLn "Generating Model.hs"+ writeFile "Model.hs" [$codegen|+{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TypeFamilies #-}++-- We don't explicitly state our export list, since there are funny things+-- that happen with type family constructors.+module Model where++import Yesod+import Yesod.Helpers.Crud++share2 mkPersist mkToForm [$persist|+Person+ name String+ age Int+|~~]++instance Item Person where+ itemTitle = personName+|]++ putStrLn "Generating static/style.css"+ createDirectoryIfMissing True "static"+ writeFile "static/style.css" [$codegen|+body {+ font-family: sans-serif;+ background: #eee;+}++#wrapper {+ width: 760px;+ margin: 1em auto;+ border: 2px solid #000;+ padding: 0.5em;+ background: #fff;+}+|]
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.3.1.1+version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -21,18 +21,18 @@ library build-depends: base >= 4 && < 5,- time >= 1.1.3 && < 1.2,- wai >= 0.1.0 && < 0.2,- wai-extra >= 0.1.3 && < 0.2,- authenticate >= 0.6.2 && < 0.7,+ time >= 1.1.4 && < 1.3,+ wai >= 0.2.0 && < 0.3,+ wai-extra >= 0.2.0 && < 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.4 && < 0.5,- hamlet >= 0.3.1 && < 0.4,+ web-routes-quasi >= 0.5 && < 0.6,+ hamlet >= 0.4.0 && < 0.5, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2,@@ -40,17 +40,21 @@ control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, old-locale >= 1.0.0.2 && < 1.1,- persistent >= 0.0.0 && < 0.1+ persistent >= 0.1.0 && < 0.2,+ 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 exposed-modules: Yesod Yesod.Content Yesod.Dispatch Yesod.Form- Yesod.Formable Yesod.Hamlet Yesod.Handler Yesod.Internal Yesod.Json Yesod.Request+ Yesod.Widget Yesod.Yesod Yesod.Helpers.AtomFeed Yesod.Helpers.Auth@@ -58,6 +62,11 @@ Yesod.Helpers.Sitemap Yesod.Helpers.Static ghc-options: -Wall++executable yesod+ build-depends: parsec >= 2.1 && < 4+ ghc-options: -Wall+ main-is: scaffold.hs executable runtests if flag(buildtests)