diff --git a/Yesod/Form.hs b/Yesod/Form.hs --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -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) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -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 |] diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -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})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -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 () diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -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$ |] } diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -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 diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -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 %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$ |] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -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$ diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -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) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -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 diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -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. diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -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 diff --git a/scaffold.hs b/scaffold.hs --- a/scaffold.hs +++ b/scaffold.hs @@ -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 diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -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 |] diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -16,7 +16,5 @@ defaultLayout $ do h2id <- newIdent setTitle "~project~ homepage" - addCassius $(cassiusFile "homepage") - addJulius $(juliusFile "homepage") - addWidget $(hamletFile "homepage") + addWidget $(widgetFile "homepage") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -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 diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -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 diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -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$ diff --git a/yesod.cabal b/yesod.cabal --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.2 +version: 0.6.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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