yesod 0.6.2 → 0.6.3
raw patch · 19 files changed
+485/−80 lines, 19 filesdep ~base
Dependency ranges changed: base
Files
- Yesod/Form.hs +41/−6
- Yesod/Form/Fields.hs +33/−5
- Yesod/Form/Jquery.hs +37/−6
- Yesod/Form/Nic.hs +17/−2
- Yesod/Form/Profiles.hs +61/−10
- Yesod/Handler.hs +23/−3
- Yesod/Helpers/AtomFeed.hs +19/−3
- Yesod/Helpers/Crud.hs +25/−4
- Yesod/Helpers/Sitemap.hs +9/−2
- Yesod/Internal.hs +9/−2
- Yesod/Widget.hs +30/−1
- Yesod/Yesod.hs +107/−14
- scaffold.hs +8/−0
- scaffold/Model_hs.cg +4/−4
- scaffold/Root_hs.cg +1/−3
- scaffold/Settings_hs.cg +26/−6
- scaffold/cabal.cg +2/−1
- scaffold/sitearg_hs.cg +14/−5
- yesod.cabal +19/−3
Yesod/Form.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types@@ -72,7 +73,12 @@ fieldsToTable :: FormField sub y a -> Form sub y a fieldsToTable = mapFormXml $ mapM_ go where- go fi = [$hamlet|+ go fi =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %tr.$clazz.fi$ %td %label!for=$fiIdent.fi$ $fiLabel.fi$@@ -88,7 +94,12 @@ fieldsToDivs :: FormField sub y a -> Form sub y a fieldsToDivs = mapFormXml $ mapM_ go where- go fi = [$hamlet|+ go fi =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif .$clazz.fi$ %label!for=$fiIdent.fi$ $fiLabel.fi$ .tooltip $fiTooltip.fi$@@ -125,7 +136,14 @@ _ -> res return (res', xml, enctype, hidden nonce) where- hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|]+ hidden nonce =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ %input!type=hidden!name=$nonceName$!value=$nonce$+|] nonceName :: String nonceName = "_nonce"@@ -158,7 +176,12 @@ -> GHandler s m (FormResult a, GWidget s m ()) runFormTable dest inputLabel form = do (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form- let widget' = [$hamlet|+ let widget' =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %form!method=post!action=@dest@!enctype=$enctype$ %table ^widget^@@ -174,7 +197,12 @@ -> GHandler s m (FormResult a, GWidget s m ()) runFormDivs dest inputLabel form = do (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form- let widget' = [$hamlet|+ let widget' =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %form!method=post!action=@dest@!enctype=$enctype$ ^widget^ %div@@ -199,7 +227,14 @@ generateForm f = do (_, b, c) <- runFormGeneric [] [] f nonce <- fmap reqNonce getRequest- return (b, c, [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|])+ return (b, c,+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ %input!type=hidden!name=$nonceName$!value=$nonce$+|]) -- | Run a form against GET parameters. runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
Yesod/Form/Fields.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} module Yesod.Form.Fields ( -- * Fields -- ** Required@@ -126,7 +127,12 @@ { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId- , fiInput = [$hamlet|+ , fiInput =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of@@ -170,7 +176,12 @@ case res of FormSuccess y -> x == y _ -> Just x == initial- let input = [$hamlet|+ let input =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %select#$theId$!name=$name$ %option!value=none $forall pairs' pair@@ -215,7 +226,12 @@ case res of FormSuccess y -> Just x == y _ -> Just x == initial- let input = [$hamlet|+ let input =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %select#$theId$!name=$name$ %option!value=none $forall pairs' pair@@ -251,7 +267,14 @@ Just "" -> FormSuccess False Just "false" -> FormSuccess False Just _ -> FormSuccess True- let xml = [$hamlet|%input#$n$!type=checkbox!name=$n$|]+ let xml =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ %input#$n$!type=checkbox!name=$n$+|] return (res, [xml], UrlEncoded) dayInput :: String -> FormInput sub master Day@@ -356,6 +379,11 @@ return (res, fi, Multipart) fileWidget :: String -> String -> Bool -> GWidget s m ()-fileWidget theId name isReq = [$hamlet|+fileWidget theId name isReq =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!type=file!name=$name$!:isReq:required |]
Yesod/Form/Jquery.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} -- | Some fields spiced up with jQuery UI. module Yesod.Form.Jquery ( YesodJquery (..)@@ -75,13 +76,23 @@ . readMay , fpRender = show , fpWidget = \theId name val isReq -> do- addHtml [$hamlet|+ addHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJulius [$julius|+ addJulius+#if GHC7+ [julius|+#else+ [$julius|+#endif $(function(){$("#%theId%").datepicker({ dateFormat:'yy-mm-dd', changeMonth:%jsBool.jdsChangeMonth.jds%,@@ -133,14 +144,24 @@ { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime , fpWidget = \theId name val isReq -> do- addHtml [$hamlet|+ addHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss- addJulius [$julius|+ addJulius+#if GHC7+ [julius|+#else+ [$julius|+#endif $(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] }@@ -177,13 +198,23 @@ { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> do- addHtml [$hamlet|+ addHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJulius [$julius|+ addJulius+#if GHC7+ [julius|+#else+ [$julius|+#endif $(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); |] }
Yesod/Form/Nic.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} -- | Provide the user with a rich text editor. module Yesod.Form.Nic ( YesodNic (..)@@ -35,9 +36,23 @@ { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do- addHtml [$hamlet|%textarea.html#$theId$!name=$name$ $val$|]+ addHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ %textarea.html#$theId$!name=$name$ $val$+|] addScript' urlNicEdit- addJulius [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|]+ addJulius+#if GHC7+ [julius|+#else+ [$julius|+#endif+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});+|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
Yesod/Form/Profiles.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} module Yesod.Form.Profiles ( stringFieldProfile , textareaFieldProfile@@ -35,7 +36,12 @@ intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] }@@ -49,7 +55,12 @@ doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] }@@ -58,7 +69,12 @@ dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] }@@ -67,7 +83,12 @@ timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!:isReq:required!value=$val$ |] }@@ -76,7 +97,12 @@ htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml- , fpWidget = \theId name val _isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val _isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %textarea.html#$theId$!name=$name$ $val$ |] }@@ -102,7 +128,12 @@ textareaFieldProfile = FieldProfile { fpParse = Right . Textarea , fpRender = unTextarea- , fpWidget = \theId name val _isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val _isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %textarea#$theId$!name=$name$ $val$ |] }@@ -111,7 +142,12 @@ hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id- , fpWidget = \theId name val _isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val _isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input!type=hidden#$theId$!name=$name$!value=$val$ |] }@@ -120,7 +156,12 @@ stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] }@@ -169,7 +210,12 @@ then Right s else Left "Invalid e-mail address" , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] }@@ -180,7 +226,12 @@ Nothing -> Left "Invalid URL" Just _ -> Right s , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet [$hamlet|+ , fpWidget = \theId name val isReq -> addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ |] }
Yesod/Handler.hs view
@@ -24,6 +24,7 @@ module Yesod.Handler ( -- * Type families Route+ , YesodSubRoute (..) -- * Handler monad , GHandler -- ** Read information from handler@@ -75,6 +76,7 @@ , runHandler , YesodApp (..) , toMasterHandler+ , toMasterHandlerMaybe , localNoCurrent , HandlerData , ErrorResponse (..)@@ -122,6 +124,9 @@ -- | The type-safe URLs associated with a site argument. type family Route a +class YesodSubRoute s y where+ fromSubRoute :: s -> y -> Route s -> Route y+ data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub@@ -136,10 +141,17 @@ -> Route sub -> HandlerData oldSub master -> HandlerData sub master-handlerSubData tm ts route hd = hd+handlerSubData tm ts = handlerSubDataMaybe tm ts . Just++handlerSubDataMaybe :: (Route sub -> Route master)+ -> (master -> sub)+ -> Maybe (Route sub)+ -> HandlerData oldSub master+ -> HandlerData sub master+handlerSubDataMaybe tm ts route hd = hd { handlerSub = ts $ handlerMaster hd , handlerToMaster = tm- , handlerRoute = Just route+ , handlerRoute = route } -- | Used internally for promoting subsite handler functions to master site@@ -148,9 +160,17 @@ -> (master -> sub) -> Route sub -> GHandler sub master a- -> GHandler master master a+ -> GHandler sub' master a toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h++toMasterHandlerMaybe :: (Route sub -> Route master)+ -> (master -> sub)+ -> Maybe (Route sub)+ -> GHandler sub master a+ -> GHandler sub' master a+toMasterHandlerMaybe tm ts route (GHandler h) =+ GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of 'ReaderT' for basic arguments, a
Yesod/Helpers/AtomFeed.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.AtomFeed@@ -49,7 +50,12 @@ } template :: AtomFeed url -> Hamlet url-template arg = [$xhamlet|+template arg =+#if GHC7+ [xhamlet|+#else+ [$xhamlet|+#endif <?xml version="1.0" encoding="utf-8"?> %feed!xmlns="http://www.w3.org/2005/Atom" %title $atomTitle.arg$@@ -62,7 +68,12 @@ |] entryTemplate :: AtomFeedEntry url -> Hamlet url-entryTemplate arg = [$xhamlet|+entryTemplate arg =+#if GHC7+ [xhamlet|+#else+ [$xhamlet|+#endif %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@@@ -75,6 +86,11 @@ atomLink :: Route m -> String -- ^ title -> GWidget s m ()-atomLink u title = addHamletHead [$hamlet|+atomLink u title = addHamletHead+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ |]
Yesod/Helpers/Crud.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..)@@ -41,7 +42,12 @@ , ClassP ''Item [VarT $ mkName "item"] , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]- ] [$parseRoutes|+ ]+#if GHC7+ [parseRoutes|+#else+ [$parseRoutes|+#endif / CrudListR GET /add CrudAddR GET POST /edit/#String CrudEditR GET POST@@ -55,7 +61,12 @@ toMaster <- getRouteToMaster defaultLayout $ do setTitle "Items"- addWidget [$hamlet|+ addWidget+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %h1 Items %ul $forall items item@@ -115,7 +126,12 @@ toMaster <- getRouteToMaster defaultLayout $ do setTitle "Confirm delete"- addWidget [$hamlet|+ addWidget+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$?@@ -157,7 +173,12 @@ _ -> return () defaultLayout $ do setTitle $ string title- addWidget [$hamlet|+ addWidget+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$
Yesod/Helpers/Sitemap.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Sitemap@@ -51,7 +52,12 @@ } template :: [SitemapUrl url] -> Hamlet url-template urls = [$hamlet|+template urls =+#if GHC7+ [xhamlet|+#else+ [$xhamlet|+#endif %urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" $forall urls url %url@@ -69,4 +75,5 @@ -> GHandler sub master RepPlain robots smurl = do tm <- getRouteToMaster- RepPlain `fmap` hamletToContent [$hamlet|Sitemap: @tm.smurl@|]+ render <- getUrlRender+ return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl)
Yesod/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses@@ -39,6 +40,12 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +#if GHC7+#define HAMLET hamlet+#else+#define HAMLET $hamlet+#endif+ -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse =@@ -63,8 +70,8 @@ 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$|]+locationToHamlet (Local url) = [HAMLET|@url@|]+locationToHamlet (Remote s) = [HAMLET|$s$|] newtype UniqueList x = UniqueList ([x] -> [x]) instance Monoid (UniqueList x) where
Yesod/Widget.hs view
@@ -18,6 +18,7 @@ , addHamlet , addHtml , addWidget+ , addSubWidget -- ** CSS , addCassius , addStylesheet@@ -39,7 +40,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius-import Yesod.Handler (Route, GHandler, HandlerData)+import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift)@@ -95,6 +96,34 @@ -- monad. liftHandler :: GHandler sub master a -> GWidget sub master a liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift++addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a+addSubWidget sub w = do master <- liftHandler getYesod+ let sr = fromSubRoute sub master+ i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get+ w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i+ $ runWriterT $ runWriterT $ runWriterT $ runWriterT+ $ runWriterT $ runWriterT $ runWriterT + $ unGWidget w+ let ((((((((a,+ body),+ title),+ scripts),+ stylesheets),+ style),+ jscript),+ h),+ i') = w'+ GWidget $ do+ tell body+ lift $ tell title+ lift $ lift $ tell scripts+ lift $ lift $ lift $ tell stylesheets+ lift $ lift $ lift $ lift $ tell style+ lift $ lift $ lift $ lift $ lift $ tell jscript+ lift $ lift $ lift $ lift $ lift $ lift $ tell h+ lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i'+ return a -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values.
Yesod/Yesod.hs view
@@ -54,7 +54,7 @@ import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Failure (Failure) import qualified Data.ByteString as S-import qualified Network.Wai.Middleware.CleanPath+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid import Control.Monad.Trans.Writer@@ -71,6 +71,12 @@ import Test.HUnit hiding (Test) #endif +#if GHC7+#define HAMLET hamlet+#else+#define HAMLET $hamlet+#endif+ -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where@@ -115,7 +121,7 @@ defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage- hamletToRepHtml [$hamlet|+ hamletToRepHtml [HAMLET| !!! %html %head@@ -179,8 +185,47 @@ -- -- * Otherwise, ensures there /is/ a trailing slash. splitPath :: a -> S.ByteString -> Either S.ByteString [String]- splitPath _ = Network.Wai.Middleware.CleanPath.splitPath+ splitPath _ s =+ if corrected == s+ then Right $ filter (not . null)+ $ decodePathInfo+ $ S8.unpack s+ else Left corrected+ where+ corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s + -- | Remove double slashes+ rds :: String -> String+ rds [] = []+ rds [x] = [x]+ rds (a:b:c)+ | a == '/' && b == '/' = rds (b:c)+ | otherwise = a : rds (b:c)++ -- | Add a trailing slash if it is missing. Empty string is left alone.+ ats :: String -> String+ ats [] = []+ ats t =+ if last t == '/' || dbs (reverse t)+ then t+ else t ++ "/"++ -- | Remove a trailing slash if the last piece has a period.+ rts :: String -> String+ rts [] = []+ rts t =+ if last t == '/' && dbs (tail $ reverse t)+ then init t+ else t++ -- | Is there a period before a slash here?+ dbs :: String -> Bool+ dbs ('/':_) = False+ dbs (_:'.':_) = True+ dbs (_:x) = dbs x+ dbs [] = False++ -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. joinPath :: a -> String -> [String] -> [(String, String)] -> String@@ -189,9 +234,12 @@ where fixSegs [] = [] fixSegs [x]- | any (== '.') x = [x]+ | anyButLast (== '.') x = [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs+ anyButLast _ [] = False+ anyButLast _ [_] = False+ anyButLast p (x:xs) = p x || anyButLast p xs -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and@@ -267,32 +315,55 @@ defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest- let path' = bsToChars $ pathInfo r- applyLayout' "Not Found" $ [$hamlet|+ let path' = bsToChars $ W.pathInfo r+ applyLayout' "Not Found"+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %h1 Not Found %p $path'$ |]- where- pathInfo = W.pathInfo defaultErrorHandler (PermissionDenied msg) =- applyLayout' "Permission Denied" $ [$hamlet|+ applyLayout' "Permission Denied"+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %h1 Permission denied %p $msg$ |] defaultErrorHandler (InvalidArgs ia) =- applyLayout' "Invalid Arguments" $ [$hamlet|+ applyLayout' "Invalid Arguments"+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %h1 Invalid Arguments %ul $forall ia msg %li $msg$ |] defaultErrorHandler (InternalError e) =- applyLayout' "Internal Server Error" $ [$hamlet|+ applyLayout' "Internal Server Error"+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %h1 Internal Server Error %p $e$ |] defaultErrorHandler (BadMethod m) =- applyLayout' "Bad Method" $ [$hamlet|+ applyLayout' "Bad Method"+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif %h1 Method Not Supported %p Method "$m$" not supported |]@@ -372,7 +443,12 @@ $ renderJulius render s return $ renderLoc x - let head'' = [$hamlet|+ let head'' =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif $forall scripts s %script!src=^s^ $forall stylesheets s@@ -395,6 +471,7 @@ testSuite :: Test testSuite = testGroup "Yesod.Yesod" [ testProperty "join/split path" propJoinSplitPath+ , testCase "join/split path [\".\"]" caseJoinSplitPathDquote , testCase "utf8 split path" caseUtf8SplitPath , testCase "utf8 join path" caseUtf8JoinPath ]@@ -411,6 +488,17 @@ where ss' = filter (not . null) ss +caseJoinSplitPathDquote :: Assertion+caseJoinSplitPathDquote = do+ splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."]+ splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."]+ joinPath TmpYesod "" ["z."] [] @?= "/z./"+ x @?= Right ss+ where+ x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' [])+ ss' = filter (not . null) ss+ ss = ["a."]+ caseUtf8SplitPath :: Assertion caseUtf8SplitPath = do Right ["שלום"] @=?@@ -434,7 +522,12 @@ -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. redirectToPost :: Route master -> GHandler sub master a-redirectToPost dest = hamletToRepHtml [$hamlet|+redirectToPost dest = hamletToRepHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif !!! %html %head
scaffold.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-} import CodeGen import System.IO import System.Directory@@ -9,6 +10,13 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT++qq :: String+#if GHC7+qq = ""+#else+qq = "$"+#endif main :: IO () main = do
scaffold/Model_hs.cg view
@@ -8,15 +8,15 @@ -- You can define all of your database entities here. You can find more -- information on persistent and how to declare entities at: -- http://docs.yesodweb.com/book/persistent/-share2 mkPersist (mkMigrate "migrateAll") [$persist|+share2 mkPersist (mkMigrate "migrateAll") [~qq~persist| User ident String- password String null update+ password String Maybe Update UniqueUser ident Email email String- user UserId null update- verkey String null update+ user UserId Maybe Update+ verkey String Maybe Update UniqueEmail email |]
scaffold/Root_hs.cg view
@@ -16,7 +16,5 @@ defaultLayout $ do h2id <- newIdent setTitle "~project~ homepage"- addCassius $(cassiusFile "homepage")- addJulius $(juliusFile "homepage")- addWidget $(hamletFile "homepage")+ addWidget $(widgetFile "homepage")
scaffold/Settings_hs.cg view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod@@ -8,6 +9,7 @@ ( hamletFile , cassiusFile , juliusFile+ , widgetFile , connStr , ConnectionPool , withConnectionPool@@ -22,7 +24,9 @@ import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~-import Yesod (MonadInvertIO)+import Yesod (MonadInvertIO, addWidget, addCassius, addJulius)+import Data.Monoid (mempty)+import System.Directory (doesFileExist) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you,@@ -98,22 +102,38 @@ -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. +toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath+toHamletFile x = "hamlet/" ++ x ++ ".hamlet"+toCassiusFile x = "cassius/" ++ x ++ ".cassius"+toJuliusFile x = "julius/" ++ x ++ ".julius"+ hamletFile :: FilePath -> Q Exp-hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet"+hamletFile = H.hamletFile . toHamletFile cassiusFile :: FilePath -> Q Exp #ifdef PRODUCTION-cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius"+cassiusFile = H.cassiusFile . toCassiusFile #else-cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius"+cassiusFile = H.cassiusFileDebug . toCassiusFile #endif juliusFile :: FilePath -> Q Exp #ifdef PRODUCTION-juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius"+juliusFile = H.juliusFile . toJuliusFile #else-juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius"+juliusFile = H.juliusFileDebug . toJuliusFile #endif++widgetFile :: FilePath -> Q Exp+widgetFile x = do+ let h = unlessExists toHamletFile hamletFile+ let c = unlessExists toCassiusFile cassiusFile+ let j = unlessExists toJuliusFile juliusFile+ [|addWidget $h >> addCassius $c >> addJulius $j|]+ where+ unlessExists tofn f = do+ e <- qRunIO $ doesFileExist $ tofn x+ if e then f x else [|mempty|] -- The next two functions are for allocating a connection pool and running -- database actions using a pool, respectively. It is used internally
scaffold/cabal.cg view
@@ -28,11 +28,12 @@ , directory , bytestring , text- , persistent+ , persistent >= 0.3.1.1 , persistent-~lower~ , template-haskell , hamlet , web-routes+ , hjsmin >= 0.0.4 && < 0.1 ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
scaffold/sitearg_hs.cg view
@@ -24,13 +24,14 @@ import qualified Data.ByteString.Lazy as L import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql-import Settings (hamletFile, cassiusFile, juliusFile)+import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model import Data.Maybe (isJust)-import Control.Monad (join)+import Control.Monad (join, unless) import Network.Mail.Mime import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding+import Text.Jasmine (minifym) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application@@ -68,7 +69,7 @@ -- for our application to be in scope. However, the handler functions -- usually require access to the ~sitearg~Route datatype. Therefore, we -- split these actions into two functions and place them in separate files.-mkYesodData "~sitearg~" [$parseRoutes|+mkYesodData "~sitearg~" [~qq~parseRoutes| /static StaticR Static getStatic /auth AuthR Auth getAuth @@ -109,9 +110,17 @@ -- users receiving stale content. addStaticContent ext' _ content = do let fn = base64md5 content ++ '.' : ext'+ let content' =+ if ext' == "js"+ then case minifym content of+ Left _ -> content+ Right y -> y+ else content let statictmp = Settings.staticdir ++ "/tmp/" liftIO $ createDirectoryIfMissing True statictmp- liftIO $ L.writeFile (statictmp ++ fn) content+ let fn' = statictmp ++ fn+ exists <- liftIO $ doesFileExist fn'+ unless exists $ liftIO $ L.writeFile fn' content' return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) -- How to run database actions.@@ -175,7 +184,7 @@ { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing- , partContent = renderHtml [$hamlet|+ , partContent = renderHtml [~qq~hamlet| %p Please confirm your email address by clicking on the link below. %p %a!href=$verurl$ $verurl$
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.6.2+version: 0.6.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -20,9 +20,15 @@ description: Build the executable to run unit tests default: False +flag ghc7+ library- build-depends: base >= 4 && < 5- , time >= 1.1.4 && < 1.3+ if flag(ghc7)+ build-depends: base >= 4.3 && < 5+ cpp-options: -DGHC7+ else+ build-depends: base >= 4 && < 4.3+ build-depends: time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 , wai-extra >= 0.2.4 && < 0.3 , bytestring >= 0.9.1.4 && < 0.10@@ -72,6 +78,11 @@ ghc-options: -Wall executable yesod+ if flag(ghc7)+ build-depends: base >= 4.3 && < 5+ cpp-options: -DGHC7+ else+ build-depends: base >= 4 && < 4.3 build-depends: parsec >= 2.1 && < 4 ghc-options: -Wall main-is: scaffold.hs@@ -79,6 +90,11 @@ extensions: TemplateHaskell executable runtests+ if flag(ghc7)+ build-depends: base >= 4.3 && < 5+ cpp-options: -DGHC7+ else+ build-depends: base >= 4 && < 4.3 if flag(test) Buildable: True cpp-options: -DTEST