Logout
+$nothing
+
+ Login
+|]
+
+instance Yesod BID where
+ approot _ = "http://localhost:3000"
+
+instance YesodAuth BID where
+ type AuthId BID = Text
+ loginDest _ = AfterLoginR
+ logoutDest _ = AuthR LoginR
+ getAuthId = return . Just . credsIdent
+ authPlugins = [authOpenId]
+
+instance RenderMessage BID FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
+main :: IO ()
+main = toWaiApp BID >>= run 3000
+
diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal
index 331da47b..8f3d1e67 100644
--- a/yesod-auth/yesod-auth.cabal
+++ b/yesod-auth/yesod-auth.cabal
@@ -1,5 +1,5 @@
name: yesod-auth
-version: 0.7.3
+version: 0.7.8
license: BSD3
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@@ -17,33 +17,34 @@ flag ghc7
library
if flag(ghc7)
- build-depends: base >= 4.3 && < 5
+ build-depends: base >= 4.3 && < 5
cpp-options: -DGHC7
else
- build-depends: base >= 4 && < 4.3
- build-depends: authenticate >= 0.10 && < 0.11
+ build-depends: base >= 4 && < 4.3
+ build-depends: authenticate >= 0.10.4 && < 0.11
, bytestring >= 0.9.1.4 && < 0.10
- , yesod-core >= 0.9 && < 0.10
+ , yesod-core >= 0.9.3.4 && < 0.10
, wai >= 0.4 && < 0.5
, template-haskell
- , pureMD5 >= 1.1 && < 2.2
- , random >= 1.0 && < 1.1
+ , pureMD5 >= 2.0 && < 2.2
+ , random >= 1.0.0.2 && < 1.1
, control-monad-attempt >= 0.3.0 && < 0.4
, text >= 0.7 && < 0.12
- , mime-mail >= 0.3 && < 0.4
- , blaze-html >= 0.4 && < 0.5
+ , mime-mail >= 0.3 && < 0.5
+ , blaze-html >= 0.4.1.3 && < 0.5
, yesod-persistent >= 0.2 && < 0.3
, hamlet >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11
, yesod-json >= 0.2 && < 0.3
- , containers >= 0.2 && < 0.5
+ , containers
+ , unordered-containers
, yesod-form >= 0.3 && < 0.4
- , transformers >= 0.2 && < 0.3
+ , transformers >= 0.2.2 && < 0.3
, persistent >= 0.6 && < 0.7
, persistent-template >= 0.6 && < 0.7
, SHA >= 1.4.1.3 && < 1.6
, http-enumerator >= 0.6 && < 0.8
- , aeson-native >= 0.3.2.11 && < 0.4
+ , aeson >= 0.3
, pwstore-fast >= 2.2 && < 3
exposed-modules: Yesod.Auth
@@ -57,9 +58,10 @@ library
Yesod.Auth.HashDB
Yesod.Auth.Message
Yesod.Auth.Kerberos
+ Yesod.Auth.GoogleEmail
ghc-options: -Wall
include-dirs: include
source-repository head
type: git
- location: git://github.com/snoyberg/yesod-auth.git
+ location: git://github.com/yesodweb/yesod.git
diff --git a/yesod-core/Yesod/Config.hs b/yesod-core/Yesod/Config.hs
new file mode 100644
index 00000000..e7bd4a11
--- /dev/null
+++ b/yesod-core/Yesod/Config.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Config
+ {-# DEPRECATED "This code has been moved to yesod-default. This module will be removed in the next major version bump." #-}
+ ( AppConfig(..)
+ , loadConfig
+ , withYamlEnvironment
+ ) where
+
+import Control.Monad (join)
+import Data.Maybe (fromMaybe)
+import Data.Object
+import Data.Object.Yaml
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- | Dynamic per-environment configuration which can be loaded at
+-- run-time negating the need to recompile between environments.
+data AppConfig e = AppConfig
+ { appEnv :: e
+ , appPort :: Int
+ , appRoot :: Text
+ } deriving (Show)
+
+-- | Load an @'AppConfig'@ from @config\/settings.yml@.
+--
+-- Some examples:
+--
+-- > -- typical local development
+-- > Development:
+-- > host: localhost
+-- > port: 3000
+-- >
+-- > -- ssl: will default false
+-- > -- approot: will default to "http://localhost:3000"
+--
+-- > -- typical outward-facing production box
+-- > Production:
+-- > host: www.example.com
+-- >
+-- > -- ssl: will default false
+-- > -- port: will default 80
+-- > -- approot: will default "http://www.example.com"
+--
+-- > -- maybe you're reverse proxying connections to the running app
+-- > -- on some other port
+-- > Production:
+-- > port: 8080
+-- > approot: "http://example.com"
+-- >
+-- > -- approot is specified so that the non-80 port is not appended
+-- > -- automatically.
+--
+loadConfig :: Show e => e -> IO (AppConfig e)
+loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e' -> do
+ e <- maybe (fail "Expected map") return $ fromMapping e'
+ let mssl = lookupScalar "ssl" e
+ let mhost = lookupScalar "host" e
+ let mport = lookupScalar "port" e
+ let mapproot = lookupScalar "approot" e
+
+ -- set some default arguments
+ let ssl = maybe False toBool mssl
+ port <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport
+
+ approot <- case (mhost, mapproot) of
+ (_ , Just ar) -> return ar
+ (Just host, _ ) -> return $ T.concat
+ [ if ssl then "https://" else "http://"
+ , host
+ , addPort ssl port
+ ]
+ _ -> fail "You must supply either a host or approot"
+
+ return $ AppConfig
+ { appEnv = env
+ , appPort = port
+ , appRoot = approot
+ }
+
+ where
+ toBool :: Text -> Bool
+ toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
+
+ addPort :: Bool -> Int -> Text
+ addPort True 443 = ""
+ addPort False 80 = ""
+ addPort _ p = T.pack $ ':' : show p
+
+-- | Loads the configuration block in the passed file named by the
+-- passed environment, yeilds to the passed function as a mapping.
+--
+-- Errors in the case of a bad load or if your function returns
+-- @Nothing@.
+withYamlEnvironment :: Show e
+ => FilePath -- ^ the yaml file
+ -> e -- ^ the environment you want to load
+ -> (TextObject -> IO a) -- ^ what to do with the mapping
+ -> IO a
+withYamlEnvironment fp env f = do
+ obj <- join $ decodeFile fp
+ envs <- fromMapping obj
+ conf <- maybe (fail $ "Could not find environment: " ++ show env) return
+ $ lookup (T.pack $ show env) envs
+ f conf
+
+-- | Returns 'fail' if read fails
+safeRead :: Monad m => String -> Text -> m Int
+safeRead name t = case reads s of
+ (i, _):_ -> return i
+ [] -> fail $ concat ["Invalid value for ", name, ": ", s]
+ where
+ s = T.unpack t
diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs
index 9f137991..4a78bec7 100644
--- a/yesod-core/Yesod/Core.hs
+++ b/yesod-core/Yesod/Core.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module Yesod.Core
( -- * Type classes
Yesod (..)
@@ -33,6 +34,7 @@ module Yesod.Core
, module Yesod.Request
, module Yesod.Widget
, module Yesod.Message
+ , module Yesod.Config
) where
import Yesod.Internal.Core
@@ -42,6 +44,7 @@ import Yesod.Handler
import Yesod.Request
import Yesod.Widget
import Yesod.Message
+import Yesod.Config
import Language.Haskell.TH.Syntax
import Data.Text (Text)
diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs
index 91147cb8..abe49064 100644
--- a/yesod-core/Yesod/Dispatch.hs
+++ b/yesod-core/Yesod/Dispatch.hs
@@ -4,7 +4,9 @@
module Yesod.Dispatch
( -- * Quasi-quoted routing
parseRoutes
+ , parseRoutesNoCheck
, parseRoutesFile
+ , parseRoutesFileNoCheck
, mkYesod
, mkYesodSub
-- ** More fine-grained
@@ -30,11 +32,10 @@ import Yesod.Internal.Dispatch
import Yesod.Widget (GWidget)
import Web.PathPieces (SinglePiece (..), MultiPiece (..))
-import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesFile)
+import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
-import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Autohead
@@ -172,11 +173,11 @@ thResourceFromResource (Resource n _ _) =
error $ "Invalid attributes for resource: " ++ n
-- | Convert the given argument into a WAI application, executable with any WAI
--- handler. This is the same as 'toWaiAppPlain', except it includes three
--- middlewares: GZIP compression, JSON-P and autohead. This is the
+-- handler. This is the same as 'toWaiAppPlain', except it includes two
+-- middlewares: GZIP compression and autohead. This is the
-- recommended approach for most users.
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
-toWaiApp y = gzip (gzipCompressFiles y) . jsonp . autohead <$> toWaiAppPlain y
+toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares.
diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs
index 8fe9ac22..ad410a97 100644
--- a/yesod-core/Yesod/Handler.hs
+++ b/yesod-core/Yesod/Handler.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
--
-- Module : Yesod.Handler
@@ -97,6 +98,12 @@ module Yesod.Handler
, liftIOHandler
-- * i18n
, getMessageRender
+ -- * Per-request caching
+ , CacheKey
+ , mkCacheKey
+ , cacheLookup
+ , cacheInsert
+ , cacheDelete
-- * Internal Yesod
, runHandler
, YesodApp (..)
@@ -119,17 +126,13 @@ import Yesod.Internal
import Data.Time (UTCTime)
import Control.Exception hiding (Handler, catch, finally)
-import qualified Control.Exception as E
import Control.Applicative
-import Control.Monad (liftM, join, MonadPlus)
+import Control.Monad (liftM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
-import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader
-import Control.Monad.Trans.State
-import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
import System.IO
import qualified Network.Wai as W
@@ -143,8 +146,6 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL
-import Control.Monad.IO.Control (MonadControlIO)
-import Control.Monad.Trans.Control (MonadTransControl, liftControl)
import qualified Data.Map as Map
import qualified Data.ByteString as S
import Data.ByteString (ByteString)
@@ -154,7 +155,7 @@ import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content
import Data.Maybe (fromMaybe)
import Web.Cookie (SetCookie (..), renderSetCookie)
-import Control.Arrow (second, (***))
+import Control.Arrow ((***))
import qualified Network.Wai.Parse as NWP
import Data.Monoid (mappend, mempty, Endo (..))
import qualified Data.ByteString.Char8 as S8
@@ -164,6 +165,12 @@ import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
import Text.Blaze (toHtml, preEscapedText)
+import Yesod.Internal.TestApi (catchIter)
+
+import qualified Yesod.Internal.Cache as Cache
+import Yesod.Internal.Cache (mkCacheKey, CacheKey)
+import Data.Typeable (Typeable)
+import qualified Data.IORef as I
-- | The type-safe URLs associated with a site argument.
type family Route a
@@ -178,6 +185,7 @@ data HandlerData sub master = HandlerData
, handlerRoute :: Maybe (Route sub)
, handlerRender :: Route master -> [(Text, Text)] -> Text
, handlerToMaster :: Route sub -> Route master
+ , handlerState :: I.IORef GHState
}
handlerSubData :: (Route sub -> Route master)
@@ -198,6 +206,24 @@ handlerSubDataMaybe tm ts route hd = hd
, handlerRoute = route
}
+get :: MonadIO monad => GGHandler sub master monad GHState
+get = do
+ hd <- ask
+ liftIO $ I.readIORef $ handlerState hd
+
+put :: MonadIO monad => GHState -> GGHandler sub master monad ()
+put g = do
+ hd <- ask
+ liftIO $ I.writeIORef (handlerState hd) g
+
+modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad ()
+modify f = do
+ hd <- ask
+ liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
+
+tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad ()
+tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
+
-- | Used internally for promoting subsite handler functions to master site
-- handler functions. Should not be needed by users.
toMasterHandler :: (Route sub -> Route master)
@@ -205,8 +231,7 @@ toMasterHandler :: (Route sub -> Route master)
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
-toMasterHandler tm ts route (GHandler h) =
- GHandler $ withReaderT (handlerSubData tm ts route) h
+toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
toMasterHandlerDyn :: Monad mo
=> (Route sub -> Route master)
@@ -214,9 +239,9 @@ toMasterHandlerDyn :: Monad mo
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
-toMasterHandlerDyn tm getSub route (GHandler h) = do
+toMasterHandlerDyn tm getSub route h = do
sub <- getSub
- GHandler $ withReaderT (handlerSubData tm (const sub) route) h
+ withReaderT (handlerSubData tm (const sub) route) h
class SubsiteGetter g m s | g -> s where
runSubsiteGetter :: g -> m s
@@ -235,22 +260,14 @@ toMasterHandlerMaybe :: (Route sub -> Route master)
-> Maybe (Route sub)
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
-toMasterHandlerMaybe tm ts route (GHandler h) =
- GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h
+toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
-- | A generic handler monad, which can have a different subsite and 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 GGHandler sub master m a =
- GHandler
- { unGHandler :: GHInner sub master m a
- }
- deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadPlus)
-
-instance MonadTrans (GGHandler s m) where
- lift = GHandler . lift . lift . lift . lift
+type GGHandler sub master = ReaderT (HandlerData sub master)
type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
@@ -258,16 +275,10 @@ data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents
, ghsIdent :: Int
+ , ghsCache :: Cache.Cache
+ , ghsHeaders :: Endo [Header]
}
-type GHInner s m monad = -- FIXME collapse the stack
- ReaderT (HandlerData s m) (
- ErrorT HandlerContents (
- WriterT (Endo [Header]) (
- StateT GHState (
- monad
- ))))
-
type SessionMap = Map.Map Text Text
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
@@ -293,25 +304,27 @@ data HandlerContents =
| HCRedirect RedirectType Text
| HCCreated Text
| HCWai W.Response
+ deriving Typeable
-instance Error HandlerContents where
- strMsg = HCError . InternalError . T.pack
+instance Show HandlerContents where
+ show _ = "Cannot show a HandlerContents"
+instance Exception HandlerContents
getRequest :: Monad mo => GGHandler s m mo Request
-getRequest = handlerRequest `liftM` GHandler ask
+getRequest = handlerRequest `liftM` ask
-instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
- failure = GHandler . lift . throwError . HCError
+instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where
+ failure = liftIO . throwIO . HCError
runRequestBody :: GHandler s m RequestBodyContents
runRequestBody = do
- x <- GHandler $ lift $ lift $ lift get
+ x <- get
case ghsRBC x of
Just rbc -> return rbc
Nothing -> do
rr <- waiRequest
rbc <- lift $ rbHelper rr
- GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc }
+ put x { ghsRBC = Just rbc }
return rbc
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
@@ -326,33 +339,33 @@ rbHelper req =
-- | Get the sub application argument.
getYesodSub :: Monad m => GGHandler sub master m sub
-getYesodSub = handlerSub `liftM` GHandler ask
+getYesodSub = handlerSub `liftM` ask
-- | Get the master site appliation argument.
getYesod :: Monad m => GGHandler sub master m master
-getYesod = handlerMaster `liftM` GHandler ask
+getYesod = handlerMaster `liftM` ask
-- | Get the URL rendering function.
getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
getUrlRender = do
- x <- handlerRender `liftM` GHandler ask
+ x <- handlerRender `liftM` ask
return $ flip x []
-- | The URL rendering function with query-string parameters.
getUrlRenderParams
:: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
-getUrlRenderParams = handlerRender `liftM` GHandler ask
+getUrlRenderParams = handlerRender `liftM` ask
-- | Get the route requested by the user. If this is a 404 response- where the
-- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
-getCurrentRoute = handlerRoute `liftM` GHandler ask
+getCurrentRoute = handlerRoute `liftM` ask
-- | Get the function to promote a route for a subsite to a route for the
-- master site.
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
-getRouteToMaster = handlerToMaster `liftM` GHandler ask
+getRouteToMaster = handlerToMaster `liftM` ask
-- | Function used internally by Yesod in the process of converting a
-- 'GHandler' into an 'W.Application'. Should not be needed by users.
@@ -370,6 +383,13 @@ runHandler handler mrender sroute tomr ma sa =
case fromException e of
Just x -> x
Nothing -> InternalError $ T.pack $ show e
+ istate <- liftIO $ I.newIORef GHState
+ { ghsSession = initSession
+ , ghsRBC = Nothing
+ , ghsIdent = 1
+ , ghsCache = mempty
+ , ghsHeaders = mempty
+ }
let hd = HandlerData
{ handlerRequest = rr
, handlerSub = sa
@@ -377,16 +397,14 @@ runHandler handler mrender sroute tomr ma sa =
, handlerRoute = sroute
, handlerRender = mrender
, handlerToMaster = tomr
+ , handlerState = istate
}
- let initSession' = GHState initSession Nothing 1
- ((contents', headers), finalSession) <- catchIter (
- fmap (second ghsSession)
- $ flip runStateT initSession'
- $ runWriterT
- $ runErrorT
- $ flip runReaderT hd
- $ unGHandler handler
- ) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession))
+ contents' <- catchIter (fmap Right $ runReaderT handler hd)
+ (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
+ $ fromException e)
+ state <- liftIO $ I.readIORef istate
+ let finalSession = ghsSession state
+ let headers = ghsHeaders state
let contents = either id (HCContent H.status200 . chooseRep) contents'
let handleError e = do
yar <- unYesodApp (eh e) safeEh rr cts finalSession
@@ -420,12 +438,6 @@ runHandler handler mrender sroute tomr ma sa =
finalSession
HCWai r -> return $ YARWai r
-catchIter :: Exception e
- => Iteratee ByteString IO a
- -> (e -> Iteratee ByteString IO a)
- -> Iteratee ByteString IO a
-catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f)
-
safeEh :: ErrorResponse -> YesodApp
safeEh er = YesodApp $ \_ _ _ session -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
@@ -437,11 +449,11 @@ safeEh er = YesodApp $ \_ _ _ session -> do
session
-- | Redirect to the given route.
-redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a
+redirect :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a
redirect rt url = redirectParams rt url []
-- | Redirects to the given route with the associated query-string parameters.
-redirectParams :: Monad mo
+redirectParams :: MonadIO mo
=> RedirectType -> Route master -> [(Text, Text)]
-> GGHandler sub master mo a
redirectParams rt url params = do
@@ -449,8 +461,8 @@ redirectParams rt url params = do
redirectString rt $ r url params
-- | Redirect to the given URL.
-redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
-redirectText rt = GHandler . lift . throwError . HCRedirect rt
+redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a
+redirectText rt = liftIO . throwIO . HCRedirect rt
redirectString = redirectText
{-# DEPRECATED redirectString "Use redirectText instead" #-}
@@ -461,16 +473,16 @@ ultDestKey = "_ULT"
--
-- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'.
-setUltDest :: Monad mo => Route master -> GGHandler sub master mo ()
+setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo ()
setUltDest dest = do
render <- getUrlRender
setUltDestString $ render dest
-- | Same as 'setUltDest', but use the given string.
-setUltDestText :: Monad mo => Text -> GGHandler sub master mo ()
+setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo ()
setUltDestText = setSession ultDestKey
-setUltDestString :: Monad mo => Text -> GGHandler sub master mo ()
+setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo ()
setUltDestString = setSession ultDestKey
{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
@@ -478,21 +490,21 @@ setUltDestString = setSession ultDestKey
--
-- If this is a 404 handler, there is no current page, and then this call does
-- nothing.
-setUltDest' :: Monad mo => GGHandler sub master mo ()
+setUltDest' :: MonadIO mo => GGHandler sub master mo ()
setUltDest' = do
route <- getCurrentRoute
case route of
Nothing -> return ()
Just r -> do
tm <- getRouteToMaster
- gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
+ gets' <- reqGetParams `liftM` handlerRequest `liftM` ask
render <- getUrlRenderParams
setUltDestString $ render (tm r) gets'
-- | Sets the ultimate destination to the referer request header, if present.
--
-- This function will not overwrite an existing ultdest.
-setUltDestReferer :: Monad mo => GGHandler sub master mo ()
+setUltDestReferer :: MonadIO mo => GGHandler sub master mo ()
setUltDestReferer = do
mdest <- lookupSession ultDestKey
maybe
@@ -506,7 +518,7 @@ setUltDestReferer = do
-- value from the session.
--
-- The ultimate destination is set with 'setUltDest'.
-redirectUltDest :: Monad mo
+redirectUltDest :: MonadIO mo
=> RedirectType
-> Route master -- ^ default destination if nothing in session
-> GGHandler sub master mo a
@@ -516,7 +528,7 @@ redirectUltDest rt def = do
maybe (redirect rt def) (redirectText rt) mdest
-- | Remove a previously set ultimate destination. See 'setUltDest'.
-clearUltDest :: Monad mo => GGHandler sub master mo ()
+clearUltDest :: MonadIO mo => GGHandler sub master mo ()
clearUltDest = deleteSession ultDestKey
msgKey :: Text
@@ -525,13 +537,13 @@ msgKey = "_MSG"
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
-setMessage :: Monad mo => Html -> GGHandler sub master mo ()
+setMessage :: MonadIO mo => Html -> GGHandler sub master mo ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
-setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo ()
+setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo ()
setMessageI msg = do
mr <- getMessageRender
setMessage $ toHtml $ mr msg
@@ -540,7 +552,7 @@ setMessageI msg = do
-- variable.
--
-- See 'setMessage'.
-getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
+getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey
@@ -550,52 +562,52 @@ getMessage = do
--
-- 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 :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a
-sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing
+sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a
+sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
-- | Same as 'sendFile', but only sends part of a file.
-sendFilePart :: Monad mo
+sendFilePart :: MonadIO mo
=> ContentType
-> FilePath
-> Integer -- ^ offset
-> Integer -- ^ count
-> GGHandler sub master mo a
sendFilePart ct fp off count =
- GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count
+ liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
-- | Bypass remaining handler code and output the given content with a 200
-- status code.
-sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
-sendResponse = GHandler . lift . throwError . HCContent H.status200
+sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a
+sendResponse = liftIO . throwIO . HCContent H.status200
. chooseRep
-- | Bypass remaining handler code and output the given content with the given
-- status code.
-sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
-sendResponseStatus s = GHandler . lift . throwError . HCContent s
+sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
+sendResponseStatus s = liftIO . throwIO . HCContent s
. chooseRep
-- | Send a 201 "Created" response with the given route as the Location
-- response header.
-sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
+sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do
r <- getUrlRender
- GHandler $ lift $ throwError $ HCCreated $ r url
+ liftIO . throwIO $ HCCreated $ r url
-- | Send a 'W.Response'. Please note: this function is rarely
-- necessary, and will /disregard/ any changes to response headers and session
-- that you have already specified. This function short-circuits. It should be
-- considered only for very specific needs. If you are not sure if you need it,
-- you don't.
-sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b
-sendWaiResponse = GHandler . lift . throwError . HCWai
+sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b
+sendWaiResponse = liftIO . throwIO . HCWai
-- | Return a 404 not found page. Also denotes no handler available.
notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound
-- | Return a 405 method not supported page.
-badMethod :: Monad mo => GGHandler s m mo a
+badMethod :: MonadIO mo => GGHandler s m mo a
badMethod = do
w <- waiRequest
failure $ BadMethod $ W.requestMethod w
@@ -605,7 +617,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied
-- | Return a 403 permission denied page.
-permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a
+permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a
permissionDeniedI msg = do
mr <- getMessageRender
permissionDenied $ mr msg
@@ -615,14 +627,14 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs
-- | Return a 400 invalid arguments page.
-invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a
+invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
------- Headers
-- | Set the cookie on the client.
-setCookie :: Monad mo
+setCookie :: MonadIO mo
=> Int -- ^ minutes to timeout
-> H.Ascii -- ^ key
-> H.Ascii -- ^ value
@@ -630,22 +642,22 @@ setCookie :: Monad mo
setCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client.
-deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
+deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie
-- | Set the language in the user session. Will show up in 'languages' on the
-- next request.
-setLanguage :: Monad mo => Text -> GGHandler sub master mo ()
+setLanguage :: MonadIO mo => Text -> GGHandler sub master mo ()
setLanguage = setSession langKey
-- | Set an arbitrary response header.
-setHeader :: Monad mo
+setHeader :: MonadIO mo
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
setHeader a = addHeader . Header a
-- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds.
-cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
+cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
[ "max-age="
, show i
@@ -654,16 +666,16 @@ cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
-- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired.
-neverExpires :: Monad mo => GGHandler s m mo ()
+neverExpires :: MonadIO mo => GGHandler s m mo ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
-- | Set an Expires header in the past, meaning this content should not be
-- cached.
-alreadyExpired :: Monad mo => GGHandler s m mo ()
+alreadyExpired :: MonadIO mo => GGHandler s m mo ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date.
-expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
+expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo ()
expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
-- | Set a variable in the user's session.
@@ -671,22 +683,22 @@ expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
-- The session is handled by the clientsession package: it sets an encrypted
-- and hashed cookie on the client. This ensures that all data is secure and
-- not tampered with.
-setSession :: Monad mo
+setSession :: MonadIO mo
=> Text -- ^ key
-> Text -- ^ value
-> GGHandler sub master mo ()
-setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
+setSession k = modify . modSession . Map.insert k
-- | Unsets a session variable. See 'setSession'.
-deleteSession :: Monad mo => Text -> GGHandler sub master mo ()
-deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
+deleteSession :: MonadIO mo => Text -> GGHandler sub master mo ()
+deleteSession = modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x }
-- | Internal use only, not to be confused with 'setHeader'.
-addHeader :: Monad mo => Header -> GGHandler sub master mo ()
-addHeader = GHandler . lift . lift . tell . Endo . (:)
+addHeader :: MonadIO mo => Header -> GGHandler sub master mo ()
+addHeader = tell . Endo . (:)
getStatus :: ErrorResponse -> H.Status
getStatus NotFound = H.status404
@@ -708,17 +720,17 @@ data RedirectType = RedirectPermanent
localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a
localNoCurrent =
- GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
+ local (\hd -> hd { handlerRoute = Nothing })
-- | Lookup for session data.
-lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
-lookupSession n = GHandler $ do
- m <- liftM ghsSession $ lift $ lift $ lift get
+lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text)
+lookupSession n = do
+ m <- liftM ghsSession get
return $ Map.lookup n m
-- | Get all session variables.
-getSession :: Monad mo => GGHandler s m mo SessionMap
-getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get
+getSession :: MonadIO mo => GGHandler s m mo SessionMap
+getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b)
=> m -- ^ master site foundation
@@ -808,8 +820,8 @@ headerToPair cp _ (DeleteCookie key) =
headerToPair _ _ (Header key value) = (key, value)
-- | Get a unique identifier.
-newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text
-newIdent = GHandler $ lift $ lift $ lift $ do
+newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text
+newIdent = do
x <- get
let i' = ghsIdent x + 1
put x { ghsIdent = i' }
@@ -818,42 +830,7 @@ newIdent = GHandler $ lift $ lift $ lift $ do
liftIOHandler :: MonadIO mo
=> GGHandler sub master IO a
-> GGHandler sub master mo a
-liftIOHandler m = GHandler $
- ReaderT $ \r ->
- ErrorT $
- WriterT $
- StateT $ \s ->
- liftIO $ runGGHandler m r s
-
-runGGHandler :: GGHandler sub master m a
- -> HandlerData sub master
- -> GHState
- -> m ( ( Either HandlerContents a
- , Endo [Header]
- )
- , GHState
- )
-runGGHandler m r s = runStateT
- (runWriterT
- (runErrorT
- (runReaderT
- (unGHandler m) r))) s
-
-instance MonadTransControl (GGHandler s m) where
- liftControl f =
- GHandler $
- liftControl $ \runRdr ->
- liftControl $ \runErr ->
- liftControl $ \runWrt ->
- liftControl $ \runSt ->
- f ( liftM ( GHandler
- . join . lift
- . join . lift
- . join . lift
- )
- . runSt . runWrt . runErr . runRdr
- . unGHandler
- )
+liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- | Redirect to a POST resource.
--
@@ -861,7 +838,7 @@ instance MonadTransControl (GGHandler s m) where
-- POST form, and some Javascript to automatically submit the form. This can be
-- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server.
-redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a
+redirectToPost :: MonadIO mo => Route master -> GGHandler sub master mo a
redirectToPost dest = hamletToRepHtml
#if GHC7
[hamlet|
@@ -902,3 +879,16 @@ getMessageRender = do
m <- getYesod
l <- reqLangs `liftM` getRequest
return $ renderMessage m l
+
+cacheLookup :: MonadIO mo => CacheKey a -> GGHandler sub master mo (Maybe a)
+cacheLookup k = do
+ gs <- get
+ return $ Cache.lookup k $ ghsCache gs
+
+cacheInsert :: MonadIO mo => CacheKey a -> a -> GGHandler sub master mo ()
+cacheInsert k v = modify $ \gs ->
+ gs { ghsCache = Cache.insert k v $ ghsCache gs }
+
+cacheDelete :: MonadIO mo => CacheKey a -> GGHandler sub master mo ()
+cacheDelete k = modify $ \gs ->
+ gs { ghsCache = Cache.delete k $ ghsCache gs }
diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs
index bd1adc91..9b97cd6b 100644
--- a/yesod-core/Yesod/Internal.hs
+++ b/yesod-core/Yesod/Internal.hs
@@ -29,7 +29,6 @@ module Yesod.Internal
) where
import Text.Hamlet (HtmlUrl, hamlet, Html)
-import Text.Cassius (CssUrl)
import Text.Julius (JavascriptUrl)
import Data.Monoid (Monoid (..), Last)
import Data.List (nub)
@@ -44,6 +43,7 @@ import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI)
import Data.String (IsString)
import qualified Data.Map as Map
+import Data.Text.Lazy.Builder (Builder)
#if GHC7
#define HAMLET hamlet
@@ -107,12 +107,14 @@ nonceKey = "_NONCE"
sessionName :: IsString a => a
sessionName = "_SESSION"
+type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
+
data GWData a = GWData
!(Body a)
!(Last Title)
!(UniqueList (Script a))
!(UniqueList (Stylesheet a))
- !(Map.Map (Maybe Text) (CssUrl a)) -- media type
+ !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
!(Maybe (JavascriptUrl a))
!(Head a)
instance Monoid (GWData a) where
diff --git a/yesod-core/Yesod/Internal/Cache.hs b/yesod-core/Yesod/Internal/Cache.hs
new file mode 100644
index 00000000..4aec0d29
--- /dev/null
+++ b/yesod-core/Yesod/Internal/Cache.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Internal.Cache
+ ( Cache
+ , CacheKey
+ , mkCacheKey
+ , lookup
+ , insert
+ , delete
+ ) where
+
+import Prelude hiding (lookup)
+import qualified Data.IntMap as Map
+import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))
+import Language.Haskell.TH (appE)
+import Data.Unique (hashUnique, newUnique)
+import GHC.Exts (Any)
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Monoid (Monoid)
+import Control.Applicative ((<$>))
+
+newtype Cache = Cache (Map.IntMap Any)
+ deriving Monoid
+
+newtype CacheKey a = CacheKey Int
+
+-- | Generate a new 'CacheKey'. Be sure to give a full type signature.
+mkCacheKey :: Q Exp
+mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)
+
+lookup :: CacheKey a -> Cache -> Maybe a
+lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m
+
+insert :: CacheKey a -> a -> Cache -> Cache
+insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m)
+
+delete :: CacheKey a -> Cache -> Cache
+delete (CacheKey k) (Cache m) = Cache (Map.delete k m)
diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs
index 4ba14405..29e1355a 100644
--- a/yesod-core/Yesod/Internal/Core.hs
+++ b/yesod-core/Yesod/Internal/Core.hs
@@ -35,8 +35,6 @@ import Yesod.Handler
import Control.Arrow ((***))
import Control.Monad (forM)
-import qualified Paths_yesod_core
-import Data.Version (showVersion)
import Yesod.Widget
import Yesod.Request
import qualified Network.Wai as W
@@ -48,11 +46,10 @@ import qualified Web.ClientSession as CS
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Monoid
-import Control.Monad.Trans.RWS
+import Control.Monad.Trans.Writer (runWriterT)
import Text.Hamlet
-import Text.Cassius
import Text.Julius
-import Text.Blaze ((!), customAttribute, textTag, toValue)
+import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
import qualified Text.Blaze.Html5 as TBH
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
@@ -75,6 +72,20 @@ import qualified Data.Text.Lazy.IO
import qualified Data.Text.Lazy.Builder as TB
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
import Text.Blaze (preEscapedLazyText)
+import Data.Aeson (Value (Array, String))
+import Data.Aeson.Encode (encode)
+import qualified Data.Vector as Vector
+
+-- mega repo can't access this
+#ifndef MEGA
+import qualified Paths_yesod_core
+import Data.Version (showVersion)
+yesodVersion :: String
+yesodVersion = showVersion Paths_yesod_core.version
+#else
+yesodVersion :: String
+yesodVersion = "0.9.3.2"
+#endif
#if GHC7
#define HAMLET hamlet
@@ -159,9 +170,9 @@ class RenderRoute (Route a) => Yesod a where
-- | 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.
+ -- Return 'Authorized' if the request is authorized,
+ -- 'Unauthorized' a message if unauthorized.
+ -- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route a
-> Bool -- ^ is this a write request?
-> GHandler s a AuthResult
@@ -264,6 +275,11 @@ class RenderRoute (Route a) => Yesod a where
gzipCompressFiles :: a -> Bool
gzipCompressFiles _ = False
+ -- | Location of yepnope.js, if any. If one is provided, then all
+ -- Javascript files will be loaded asynchronously.
+ yepnopeJs :: a -> Maybe (Either Text (Route a))
+ yepnopeJs _ = Nothing
+
messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo ()
messageLoggerHandler loc level msg = do
@@ -327,12 +343,12 @@ defaultYesodRunner _ m toMaster _ murl _ req
[] -> Nothing
(x, _):_ -> Just x
defaultYesodRunner s master toMasterRoute mkey murl handler req = do
- now <- liftIO getCurrentTime
- let getExpires m = fromIntegral (m * 60) `addUTCTime` now
- let exp' = getExpires $ clientSessionDuration master
- let rh = takeWhile (/= ':') $ show $ W.remoteHost req
+ now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
+ let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
+ let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
+ let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req
let host = if sessionIpAddress master then S8.pack rh else ""
- let session' =
+ let session' = {-# SCC "session'" #-}
case mkey of
Nothing -> []
Just key -> fromMaybe [] $ do
@@ -340,7 +356,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
val <- lookup sessionName $ parseCookies raw
decodeSession key now host val
rr <- liftIO $ parseWaiRequest req session' mkey
- let h = do
+ let h = {-# SCC "h" #-} do
case murl of
Nothing -> handler
Just url -> do
@@ -361,7 +377,8 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
$ filter (\(x, _) -> x /= nonceKey) session'
yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
let mnonce = reqNonce rr
- iv <- liftIO CS.randomIV
+ -- FIXME should we be caching this IV value and reusing it for efficiency?
+ iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
return $ yarToResponse (hr iv mnonce getExpires host exp') yar
where
hr iv mnonce getExpires host exp' hs ct sm =
@@ -472,18 +489,22 @@ maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
+jsToHtml :: Javascript -> Html
+jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
+
+jelper :: JavascriptUrl url -> HtmlUrl url
+jelper = fmap jsToHtml
+
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route master), Yesod master)
=> GWidget sub master ()
-> GHandler sub master (PageContent (Route master))
widgetToPageContent (GWidget w) = do
- ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0
+ master <- getYesod
+ ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runWriterT w
let title = maybe mempty unTitle mTitle
let scripts = runUniqueList scripts'
let stylesheets = runUniqueList stylesheets'
- let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
- jelper :: JavascriptUrl url -> HtmlUrl url
- jelper = fmap jsToHtml
render <- getUrlRenderParams
let renderLoc x =
@@ -492,7 +513,7 @@ widgetToPageContent (GWidget w) = do
Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p
css <- forM (Map.toList style) $ \(mmedia, content) -> do
- let rendered = renderCssUrl render content
+ let rendered = toLazyText $ content render
x <- addStaticContent "css" "text/css; charset=utf-8"
$ encodeUtf8 rendered
return (mmedia,
@@ -536,19 +557,54 @@ $forall s <- css
"].join(""),k.id=i,k.innerHTML+=f,g.appendChild(k),h=c(k,a),k.parentNode.removeChild(k);return!!h},w=function(){function d(d,e){e=e||b.createElement(a[d]||"div"),d="on"+d;var f=d in e;f||(e.setAttribute||(e=b.createElement("div")),e.setAttribute&&e.removeAttribute&&(e.setAttribute(d,""),f=C(e[d],"function"),C(e[d],c)||(e[d]=c),e.removeAttribute(d))),e=null;return f}var a={select:"input",change:"input",submit:"form",reset:"form",error:"img",load:"img",abort:"img"};return d}(),x,y={}.hasOwnProperty,z;!C(y,c)&&!C(y.call,c)?z=function(a,b){return y.call(a,b)}:z=function(a,b){return b in a&&C(a.constructor.prototype[b],c)};var G=function(c,d){var f=c.join(""),g=d.length;v(f,function(c,d){var f=b.styleSheets[b.styleSheets.length-1],h=f.cssRules&&f.cssRules[0]?f.cssRules[0].cssText:f.cssText||"",i=c.childNodes,j={};while(g--)j[i[g].id]=i[g];e.touch="ontouchstart"in a||j.touch.offsetTop===9,e.csstransforms3d=j.csstransforms3d.offsetLeft===9,e.generatedcontent=j.generatedcontent.offsetHeight>=1,e.fontface=/src/i.test(h)&&h.indexOf(d.split(" ")[0])===0},g,d)}(['@font-face {font-family:"font";src:url("https://")}',["@media (",o.join("touch-enabled),("),i,")","{#touch{top:9px;position:absolute}}"].join(""),["@media (",o.join("transform-3d),("),i,")","{#csstransforms3d{left:9px;position:absolute}}"].join(""),['#generatedcontent:after{content:"',m,'";visibility:hidden}'].join("")],["fontface","touch","csstransforms3d","generatedcontent"]);r.flexbox=function(){function c(a,b,c,d){a.style.cssText=o.join(b+":"+c+";")+(d||"")}function a(a,b,c,d){b+=":",a.style.cssText=(b+o.join(c+";"+b)).slice(0,-b.length)+(d||"")}var d=b.createElement("div"),e=b.createElement("div");a(d,"display","box","width:42px;padding:0;"),c(e,"box-flex","1","width:10px;"),d.appendChild(e),g.appendChild(d);var f=e.offsetWidth===42;d.removeChild(e),g.removeChild(d);return f},r.canvas=function(){var a=b.createElement("canvas");return!!a.getContext&&!!a.getContext("2d")},r.canvastext=function(){return!!e.canvas&&!!C(b.createElement("canvas").getContext("2d").fillText,"function")},r.webgl=function(){return!!a.WebGLRenderingContext},r.touch=function(){return e.touch},r.geolocation=function(){return!!navigator.geolocation},r.postmessage=function(){return!!a.postMessage},r.websqldatabase=function(){var b=!!a.openDatabase;return b},r.indexedDB=function(){for(var b=-1,c=p.length;++b7)},r.history=function(){return!!a.history&&!!history.pushState},r.draganddrop=function(){return w("dragstart")&&w("drop")},r.websockets=function(){for(var b=-1,c=p.length;++b";return(a.firstChild&&a.firstChild.namespaceURI)==q.svg},r.smil=function(){return!!b.createElementNS&&/SVG/.test(n.call(b.createElementNS(q.svg,"animate")))},r.svgclippaths=function(){return!!b.createElementNS&&/SVG/.test(n.call(b.createElementNS(q.svg,"clipPath")))};for(var I in r)z(r,I)&&(x=I.toLowerCase(),e[x]=r[I](),u.push((e[x]?"":"no-")+x));e.input||H(),A(""),j=l=null,a.attachEvent&&function(){var a=b.createElement("div");a.innerHTML="";return a.childNodes.length!==1}()&&function(a,b){function s(a){var b=-1;while(++b
+\
+\
+\
+\
+
+
+
+
+ #{pageTitle pc}
+ <meta name="description" content="">
+ <meta name="author" content="">
+
+ <meta name="viewport" content="width=device-width,initial-scale=1">
+
+ ^{pageHead pc}
+
+ \<!--[if lt IE 9]>
+ \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script>
+ \<![endif]-->
+
+ <script>
+ document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js');
+ <body>
+ <div id="container">
+ <header>
+ <div id="main" role="main">
+ ^{pageBody pc}
+ <footer>
+
+ \<!-- Change UA-XXXXX-X to be your site's ID -->
+ <script>
+ window._gaq = [['_setAccount','UAXXXXXXXX1'],['_trackPageview'],['_trackPageLoadTime']];
+ YepNope.load({
+ \ load: ('https:' == location.protocol ? '//ssl' : '//www') + '.google-analytics.com/ga.js'
+ });
+ \<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6. chromium.org/developers/how-tos/chrome-frame-getting-started -->
+ \<!--[if lt IE 7 ]>
+ <script src="//ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js">
+ <script>
+ window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})})
+ \<![endif]-->
diff --git a/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg b/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg
new file mode 100644
index 00000000..c411272c
--- /dev/null
+++ b/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg
@@ -0,0 +1,8 @@
+!!!
+<html>
+ <head
+ <title>#{pageTitle pc}
+ ^{pageHead pc}
+ <body
+ ^{pageBody pc}
+
diff --git a/yesod/scaffold/templates/default-layout.hamlet.cg b/yesod/scaffold/templates/default-layout.hamlet.cg
new file mode 100644
index 00000000..94d68dd5
--- /dev/null
+++ b/yesod/scaffold/templates/default-layout.hamlet.cg
@@ -0,0 +1,4 @@
+$maybe msg <- mmsg
+ <div #message>#{msg}
+^{widget}
+
diff --git a/yesod/scaffold/templates/default-layout.lucius.cg b/yesod/scaffold/templates/default-layout.lucius.cg
new file mode 100644
index 00000000..799dec4f
--- /dev/null
+++ b/yesod/scaffold/templates/default-layout.lucius.cg
@@ -0,0 +1,4 @@
+body {
+ font-family: sans-serif;
+}
+
diff --git a/yesod/scaffold/tiny/hamlet/homepage.hamlet.cg b/yesod/scaffold/templates/homepage.hamlet.cg
similarity index 75%
rename from yesod/scaffold/tiny/hamlet/homepage.hamlet.cg
rename to yesod/scaffold/templates/homepage.hamlet.cg
index 34432b74..e8907860 100644
--- a/yesod/scaffold/tiny/hamlet/homepage.hamlet.cg
+++ b/yesod/scaffold/templates/homepage.hamlet.cg
@@ -1,2 +1,2 @@
-<h1>Hello
+<h1>_{MsgHello}
<h2 ##{h2id}>You do not have Javascript enabled.
diff --git a/yesod/scaffold/templates/homepage.julius.cg b/yesod/scaffold/templates/homepage.julius.cg
new file mode 100644
index 00000000..5903b6ff
--- /dev/null
+++ b/yesod/scaffold/templates/homepage.julius.cg
@@ -0,0 +1,2 @@
+document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>";
+
diff --git a/yesod/scaffold/cassius/homepage.cassius.cg b/yesod/scaffold/templates/homepage.lucius.cg
similarity index 64%
rename from yesod/scaffold/cassius/homepage.cassius.cg
rename to yesod/scaffold/templates/homepage.lucius.cg
index 2ac20924..e8cf5292 100644
--- a/yesod/scaffold/cassius/homepage.cassius.cg
+++ b/yesod/scaffold/templates/homepage.lucius.cg
@@ -1,5 +1,7 @@
-h1
+h1 {
text-align: center
-h2##{h2id}
+}
+h2##{h2id} {
color: #990
+}
diff --git a/yesod/scaffold/static/css/normalize.css.cg b/yesod/scaffold/templates/normalize.lucius.cg
similarity index 100%
rename from yesod/scaffold/static/css/normalize.css.cg
rename to yesod/scaffold/templates/normalize.lucius.cg
diff --git a/yesod/scaffold/tiny/Application.hs.cg b/yesod/scaffold/tiny/Application.hs.cg
index 99e4d7f9..55da0704 100644
--- a/yesod/scaffold/tiny/Application.hs.cg
+++ b/yesod/scaffold/tiny/Application.hs.cg
@@ -1,21 +1,18 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( with~sitearg~
, withDevelAppPort
) where
-import Foundation
+import Import
import Settings
import Yesod.Static
-import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString)
-import Data.ByteString (ByteString)
+import Yesod.Default.Config
+import Yesod.Default.Main (defaultDevelApp, defaultRunner)
+import Yesod.Default.Handlers (getFaviconR, getRobotsR)
+import Yesod.Logger (Logger)
import Network.Wai (Application)
import Data.Dynamic (Dynamic, toDyn)
-import Network.Wai.Middleware.Debug (debugHandle)
-- Import all relevant handler modules here.
import Handler.Root
@@ -25,40 +22,20 @@ import Handler.Root
-- the comments there for more details.
mkYesodDispatch "~sitearg~" resources~sitearg~
--- Some default handlers that ship with the Yesod site template. You will
--- very rarely need to modify this.
-getFaviconR :: Handler ()
-getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
-
-getRobotsR :: Handler RepPlain
-getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
-
-- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
-with~sitearg~ :: AppConfig -> Logger -> (Application -> IO a) -> IO a
+with~sitearg~ :: AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO ()
with~sitearg~ conf logger f = do
-#ifdef PRODUCTION
- s <- static Settings.staticDir
-#else
+#ifdef DEVELOPMENT
s <- staticDevel Settings.staticDir
+#else
+ s <- static Settings.staticDir
#endif
let h = ~sitearg~ conf logger s
- toWaiApp h >>= f
+ defaultRunner f h
-- for yesod devel
withDevelAppPort :: Dynamic
-withDevelAppPort =
- toDyn go
- where
- go :: ((Int, Application) -> IO ()) -> IO ()
- go f = do
- conf <- Settings.loadConfig Settings.Development
- let port = appPort conf
- logger <- makeLogger
- logString logger $ "Devel application launched, listening on port " ++ show port
- with~sitearg~ conf logger $ \app -> f (port, debugHandle (logHandle logger) app)
- flushLogger logger
- where
- logHandle logger msg = logLazyText logger msg >> flushLogger logger
+withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~
diff --git a/yesod/scaffold/tiny/Foundation.hs.cg b/yesod/scaffold/tiny/Foundation.hs.cg
index 72993157..17326b0b 100644
--- a/yesod/scaffold/tiny/Foundation.hs.cg
+++ b/yesod/scaffold/tiny/Foundation.hs.cg
@@ -1,8 +1,7 @@
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings #-}
module Foundation
( ~sitearg~ (..)
, ~sitearg~Route (..)
+ , ~sitearg~Message (..)
, resources~sitearg~
, Handler
, Widget
@@ -13,30 +12,33 @@ module Foundation
, liftIO
) where
-import Yesod.Core
+import Prelude
+import Yesod.Core hiding (AppConfig (..))
+import Yesod.Default.Config
+import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Static (Static, base64md5, StaticRoute(..))
import Settings.StaticFiles
import Yesod.Logger (Logger, logLazyText)
import qualified Settings
-import System.Directory
-import qualified Data.ByteString.Lazy as L
-import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
-import Control.Monad (unless)
+import Settings (widgetFile)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text as T
import Web.ClientSession (getKey)
+import Text.Hamlet (hamletFile)
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data ~sitearg~ = ~sitearg~
- { settings :: Settings.AppConfig
+ { settings :: AppConfig DefaultEnv ()
, getLogger :: Logger
, getStatic :: Static -- ^ Settings for static file serving.
}
+-- Set up i18n messages. See the message folder.
+mkMessage "~sitearg~" "messages" "en"
+
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://docs.yesodweb.com/book/web-routes-quasi/
@@ -61,17 +63,24 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod ~sitearg~ where
- approot = Settings.appRoot . settings
+ approot = appRoot . settings
-- Place the session key file in the config folder
encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
defaultLayout widget = do
mmsg <- getMessage
+
+ -- We break up the default layout into two components:
+ -- default-layout is the contents of the body tag, and
+ -- default-layout-wrapper is the entire page. Since the final
+ -- value passed to hamletToRepHtml cannot be a widget, this allows
+ -- you to use normal widget features in default-layout.
+
pc <- widgetToPageContent $ do
- widget
- addCassius $(cassiusFile "default-layout")
- hamletToRepHtml $(hamletFile "default-layout")
+ $(widgetFile "normalize")
+ $(widgetFile "default-layout")
+ hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
-- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticroot setting in Settings.hs
@@ -86,11 +95,7 @@ instance Yesod ~sitearg~ where
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
- addStaticContent ext' _ content = do
- let fn = base64md5 content ++ '.' : T.unpack ext'
- let statictmp = Settings.staticDir ++ "/tmp/"
- liftIO $ createDirectoryIfMissing True statictmp
- let fn' = statictmp ++ fn
- exists <- liftIO $ doesFileExist fn'
- unless exists $ liftIO $ L.writeFile fn' content
- return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
+ addStaticContent = addStaticContentExternal (const $ Left ()) base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
+
+ -- Enable Javascript async loading
+ yepnopeJs _ = Just $ Right $ StaticR js_modernizr_js
diff --git a/yesod/scaffold/tiny/Handler/Root.hs.cg b/yesod/scaffold/tiny/Handler/Root.hs.cg
deleted file mode 100644
index e485b7cd..00000000
--- a/yesod/scaffold/tiny/Handler/Root.hs.cg
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
-module Handler.Root where
-
-import Foundation
-
--- This is a handler function for the GET request method on the RootR
--- resource pattern. All of your resource patterns are defined in
--- config/routes
---
--- The majority of the code you will write in Yesod lives in these handler
--- functions. You can spread them across multiple files if you are so
--- inclined, or create a single monolithic file.
-getRootR :: Handler RepHtml
-getRootR = do
- defaultLayout $ do
- h2id <- lift newIdent
- setTitle "~project~ homepage"
- addWidget $(widgetFile "homepage")
diff --git a/yesod/scaffold/tiny/Settings.hs.cg b/yesod/scaffold/tiny/Settings.hs.cg
index bec5d248..9c4fc748 100644
--- a/yesod/scaffold/tiny/Settings.hs.cg
+++ b/yesod/scaffold/tiny/Settings.hs.cg
@@ -1,86 +1,20 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
-- | 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
-- by overriding methods in the Yesod typeclass. That instance is
-- declared in the ~project~.hs file.
module Settings
- ( hamletFile
- , cassiusFile
- , juliusFile
- , luciusFile
- , widgetFile
+ ( widgetFile
, staticRoot
, staticDir
- , loadConfig
- , AppEnvironment(..)
- , AppConfig(..)
) where
-import qualified Text.Hamlet as S
-import qualified Text.Cassius as S
-import qualified Text.Julius as S
-import qualified Text.Lucius as S
-import qualified Text.Shakespeare.Text as S
+import Prelude (FilePath, String)
import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
-import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)
-import Data.Monoid (mempty)
-import System.Directory (doesFileExist)
-~settingsTextImport~
-import Data.Object
-import qualified Data.Object.Yaml as YAML
-import Control.Monad (join)
-
-data AppEnvironment = Test
- | Development
- | Staging
- | Production
- deriving (Eq, Show, Read, Enum, Bounded)
-
--- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
--- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
---
--- By convention these settings should be overwritten by any command line arguments.
--- See config/~sitearg~.hs for command line arguments
--- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).
---
-data AppConfig = AppConfig {
- appEnv :: AppEnvironment
-
- , appPort :: Int
-
- -- | The base URL for your application. This will usually be different for
- -- development and production. Yesod automatically constructs URLs for you,
- -- so this value must be accurate to create valid links.
- -- Please note that there is no trailing slash.
- --
- -- You probably want to change this! If your domain name was "yesod.com",
- -- you would probably want it to be:
- -- > "http://yesod.com"
- , appRoot :: Text
-} deriving (Show)
-
-loadConfig :: AppEnvironment -> IO AppConfig
-loadConfig env = do
- allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping
- settings <- lookupMapping (show env) allSettings
- hostS <- lookupScalar "host" settings
- port <- fmap read $ lookupScalar "port" settings
- return $ AppConfig {
- appEnv = env
- , appPort = port
- , appRoot = pack $ hostS ++ addPort port
- }
- where
- addPort :: Int -> String
-#ifdef PRODUCTION
- addPort _ = ""
-#else
- addPort p = ":" ++ (show p)
-#endif
+import Yesod.Default.Config
+import qualified Yesod.Default.Util
+import Data.Text (Text)
-- | The location of static files on your system. This is a file system
-- path. The default value works properly with your scaffolded site.
@@ -100,72 +34,12 @@ staticDir = "static"
-- have to make a corresponding change here.
--
-- To see how this value is used, see urlRenderOverride in ~project~.hs
-staticRoot :: AppConfig -> Text
-staticRoot conf = [st|#{appRoot conf}/static|]
+staticRoot :: AppConfig DefaultEnv a -> Text
+staticRoot conf = [~qq~st|#{appRoot conf}/static|]
--- The rest of this file contains settings which rarely need changing by a
--- user.
-
--- The following functions are used for calling HTML, CSS,
--- Javascript, and plain text templates from your Haskell code. During development,
--- the "Debug" versions of these functions are used so that changes to
--- the templates are immediately reflected in an already running
--- application. When making a production compile, the non-debug version
--- is used for increased performance.
---
--- You can see an example of how to call these functions in Handler/Root.hs
---
--- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer
--- used; to get the same auto-loading effect, it is recommended that you
--- use the devel server.
-
--- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/
-globFile :: String -> String -> FilePath
-globFile kind x = kind ++ "/" ++ x ++ "." ++ kind
-
-hamletFile :: FilePath -> Q Exp
-hamletFile = S.hamletFile . globFile "hamlet"
-
-cassiusFile :: FilePath -> Q Exp
-cassiusFile =
-#ifdef PRODUCTION
- S.cassiusFile . globFile "cassius"
+widgetFile :: String -> Q Exp
+#if DEVELOPMENT
+widgetFile = Yesod.Default.Util.widgetFileReload
#else
- S.cassiusFileDebug . globFile "cassius"
+widgetFile = Yesod.Default.Util.widgetFileNoReload
#endif
-
-luciusFile :: FilePath -> Q Exp
-luciusFile =
-#ifdef PRODUCTION
- S.luciusFile . globFile "lucius"
-#else
- S.luciusFileDebug . globFile "lucius"
-#endif
-
-juliusFile :: FilePath -> Q Exp
-juliusFile =
-#ifdef PRODUCTION
- S.juliusFile . globFile "julius"
-#else
- S.juliusFileDebug . globFile "julius"
-#endif
-
-textFile :: FilePath -> Q Exp
-textFile =
-#ifdef PRODUCTION
- S.textFile . globFile "text"
-#else
- S.textFileDebug . globFile "text"
-#endif
-
-widgetFile :: FilePath -> Q Exp
-widgetFile x = do
- let h = whenExists (globFile "hamlet") (whamletFile . globFile "hamlet")
- let c = whenExists (globFile "cassius") cassiusFile
- let j = whenExists (globFile "julius") juliusFile
- let l = whenExists (globFile "lucius") luciusFile
- [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|]
- where
- whenExists tofn f = do
- e <- qRunIO $ doesFileExist $ tofn x
- if e then f x else [|mempty|]
diff --git a/yesod/scaffold/tiny/project.cabal.cg b/yesod/scaffold/tiny/project.cabal.cg
index 527f265b..4e4ec5fc 100644
--- a/yesod/scaffold/tiny/project.cabal.cg
+++ b/yesod/scaffold/tiny/project.cabal.cg
@@ -12,58 +12,70 @@ cabal-version: >= 1.6
build-type: Simple
homepage: http://~project~.yesodweb.com/
-Flag production
- Description: Build the production executable.
+Flag dev
+ Description: Turn on development settings, like auto-reload templates.
Default: False
-Flag devel
+Flag library-only
Description: Build for use with "yesod devel"
Default: False
library
- if flag(devel)
+ if flag(library-only)
Buildable: True
else
Buildable: False
exposed-modules: Application
- hs-source-dirs: .
other-modules: Foundation
+ Import
Settings
Settings.StaticFiles
Handler.Root
+ ghc-options: -Wall -threaded -O0
+ cpp-options: -DDEVELOPMENT
+
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ CPP
+ OverloadedStrings
+ MultiParamTypeClasses
+ TypeFamilies
+
executable ~project~
- if flag(devel)
+ if flag(library-only)
Buildable: False
- if flag(production)
- cpp-options: -DPRODUCTION
- ghc-options: -Wall -threaded -O2
+ if flag(dev)
+ cpp-options: -DDEVELOPMENT
+ ghc-options: -Wall -threaded -O0
else
ghc-options: -Wall -threaded
main-is: main.hs
- hs-source-dirs: .
- build-depends: base >= 4 && < 5
- , yesod-core >= 0.9 && < 0.10
- , yesod-static
- , clientsession
- , wai-extra
- , directory
- , bytestring
- , text
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ CPP
+ OverloadedStrings
+ MultiParamTypeClasses
+ TypeFamilies
+
+ build-depends: base >= 4 && < 5
+ , yesod-core >= 0.9.3 && < 0.10
+ , yesod-static >= 0.3.1 && < 0.4
+ , yesod-default >= 0.5 && < 0.6
+ , clientsession >= 0.7.3 && < 0.8
+ , bytestring >= 0.9 && < 0.10
+ , text >= 0.11 && < 0.12
, template-haskell
- , hamlet >= 0.10 && < 0.11
- , shakespeare-css >= 0.10 && < 0.11
- , shakespeare-js >= 0.10 && < 0.11
- , shakespeare-text >= 0.10 && < 0.11
- , transformers
- , data-object
- , data-object-yaml
- , wai
- , warp
- , blaze-builder
- , cmdargs
- , data-object
- , data-object-yaml
+ , hamlet >= 0.10 && < 0.11
+ , shakespeare-text >= 0.10 && < 0.11
+ , wai >= 0.4.2 && < 0.5
+ , transformers >= 0.2 && < 0.3
+ , monad-control >= 0.3 && < 0.4
+
diff --git a/yesod/test/run.sh b/yesod/test/run.sh
index 3b81e612..7095acda 100755
--- a/yesod/test/run.sh
+++ b/yesod/test/run.sh
@@ -1,97 +1,12 @@
-#!/bin/bash -e
-#
-# Runs test/scaffold.sh with a variety of inputs. Hides all output
-# besides failure details.
-#
-###
+#!/bin/bash
-[[ "$1" =~ -v|--verbose ]] && stdout=/dev/stdout || stdout=/dev/null
+cat << EOF
-tmp='/tmp'
-pwd="$PWD"
+You're using the deprecated ./test/run.sh. This file will be removed
+soon in favor of ../scripts/runtests.
-pkg=
-dir=
+Running ../scripts/runtests...
-failures=()
-n_tested=0
-n_failed=0
+EOF
-# runs the function named by $1, silencing stdout and redirecting stderr
-# to /tmp/function.errors. failures are tracked to be reported on during
-# cleanup
-run_test() { # {{{
- local test_function="$*"
-
- n_tested=$((n_tested+1))
-
- if $test_function >"$stdout" 2>"$tmp/$test_function.errors"; then
- echo -n '.'
- [[ -f "$tmp/$test_function.errors" ]] && rm "$tmp/$test_function.errors"
- else
- echo -n 'F'
- failures+=( "$test_function" )
- n_failed=$((n_failed+1))
- fi
-}
-# }}}
-
-# changes back to the original directory, removes the dist file and
-# outputs a report of tests and failures
-cleanup() { # {{{
- cd "$pwd"
- [[ -d "$dir" ]] && rm -r "$dir"
-
- echo
- echo
- echo "Tests: $n_tested, Failures: $n_failed."
- echo
-
- [[ $n_failed -eq 0 ]] && return 0
-
- for test in ${failures[@]}; do
- echo "Failure: $test"
- echo 'details:'
- echo
-
- if [[ -f "$tmp/$test.errors" ]]; then
- cat "$tmp/$test.errors"
- rm "$tmp/$test.errors"
- else
- echo '<no stderr captured>'
- fi
-
- echo
- done
-
- return $n_failed
-}
-# }}}
-
-# compilation is test #1, sets global variable dir. other tests are run
-# from within this directory and it is removed as part of cleanup
-test_compile() {
- cabal clean
- cabal install
- cabal sdist
-
- read -r pkg < <(find dist/ -type f -name '*.tar.gz' | sort -rV)
- dir="$(basename "$pkg" .tar.gz)"
-
- tar -xzf "$pkg" && cd "$dir"
-}
-
-test_sqlite() { ../test/scaffold.sh < ../test/sqlite-input.txt ; }
-test_postgresql() { ../test/scaffold.sh < ../test/postgresql-input.txt; }
-test_mongodb() { ../test/scaffold.sh < ../test/mongodb-input.txt ; }
-test_tiny() { ../test/scaffold.sh < ../test/tiny-input.txt ; }
-
-echo 'Started'
-run_test 'test_compile'
-run_test 'test_sqlite'
-run_test 'test_postgresql'
-run_test 'test_mongodb'
-run_test 'test_tiny'
-cleanup
-
-exit $?
+../scripts/runtests "$@"
diff --git a/yesod/test/scaffold.sh b/yesod/test/scaffold.sh
index 303a9656..8ea71803 100755
--- a/yesod/test/scaffold.sh
+++ b/yesod/test/scaffold.sh
@@ -1,12 +1,15 @@
#!/bin/bash -ex
-rm -rf foobar
runghc main.hs init
(
cd foobar
- cabal install
- cabal install -fdevel
+ cabal configure || cabal install
+ cabal build
+ cabal clean
+ cabal configure -fdevel
+ cabal build
+ cabal clean
+ cabal configure -fproduction
+ cabal build
)
-
-ghc-pkg unregister foobar
diff --git a/yesod/test/scaffold_test.sh b/yesod/test/scaffold_test.sh
new file mode 100644
index 00000000..d12ea1ea
--- /dev/null
+++ b/yesod/test/scaffold_test.sh
@@ -0,0 +1,7 @@
+setup() { rm -rf foobar; }
+teardown() { rm -rf foobar; ghc-pkg unregister foobar &>/dev/null; }
+
+test_sqlite() { ../test/scaffold.sh < ../test/sqlite-input.txt ; }
+test_postgresql() { ../test/scaffold.sh < ../test/postgresql-input.txt; }
+test_mongodb() { ../test/scaffold.sh < ../test/mongodb-input.txt ; }
+test_tiny() { ../test/scaffold.sh < ../test/tiny-input.txt ; }
diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal
index 9b13dcdf..1eda612a 100644
--- a/yesod/yesod.cabal
+++ b/yesod/yesod.cabal
@@ -1,14 +1,16 @@
name: yesod
-version: 0.9.2.2
+version: 0.9.4
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
maintainer: Michael Snoyman <michael@snoyman.com>
synopsis: Creation of type-safe, RESTful web applications.
description:
- Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.
+ A RESTful web framework with strong compile-time guarantees of correctness. It also affords space efficient code, highly concurrent loads, and portability to many deployment backends (via the wai package), from CGI to stand-alone serving.
.
- The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.
+ Yesod also focuses on developer productivity. Yesod integrates well with tools for all your basic web development (wai, persistent, and shakespeare/hamlet)
+ .
+ The Yesod documentation site <http://www.yesodweb.com/> has much more information, including on the supporting packages mentioned above.
category: Web, Yesod
stability: Stable
cabal-version: >= 1.6
@@ -17,29 +19,29 @@ homepage: http://www.yesodweb.com/
extra-source-files:
input/*.cg
- scaffold/cassius/default-layout.cassius.cg
- scaffold/cassius/homepage.cassius.cg
+ scaffold/templates/default-layout.lucius.cg
+ scaffold/templates/homepage.lucius.cg
scaffold/Model.hs.cg
+ scaffold/Import.hs.cg
scaffold/Foundation.hs.cg
scaffold/LICENSE.cg
scaffold/mongoDBConnPool.cg
scaffold/tiny/Foundation.hs.cg
scaffold/tiny/project.cabal.cg
scaffold/tiny/Application.hs.cg
- scaffold/tiny/hamlet/homepage.hamlet.cg
- scaffold/tiny/Handler/Root.hs.cg
scaffold/tiny/config/routes.cg
scaffold/tiny/Settings.hs.cg
- scaffold/static/css/normalize.css.cg
+ scaffold/templates/normalize.lucius.cg
scaffold/postgresqlConnPool.cg
scaffold/sqliteConnPool.cg
scaffold/.ghci.cg
scaffold/project.cabal.cg
scaffold/Application.hs.cg
- scaffold/julius/homepage.julius.cg
- scaffold/hamlet/homepage.hamlet.cg
- scaffold/hamlet/default-layout.hamlet.cg
- scaffold/hamlet/boilerplate-layout.hamlet.cg
+ scaffold/templates/homepage.julius.cg
+ scaffold/templates/homepage.hamlet.cg
+ scaffold/templates/default-layout.hamlet.cg
+ scaffold/templates/default-layout-wrapper.hamlet.cg
+ scaffold/templates/boilerplate-wrapper.hamlet.cg
scaffold/deploy/Procfile.cg
scaffold/main.hs.cg
scaffold/Handler/Root.hs.cg
@@ -50,32 +52,39 @@ extra-source-files:
scaffold/config/postgresql.yml.cg
scaffold/config/mongoDB.yml.cg
scaffold/config/routes.cg
+ scaffold/config/robots.txt.cg
scaffold/Settings.hs.cg
scaffold/Settings/StaticFiles.hs.cg
+ scaffold/messages/en.msg.cg
+ scaffold/static/js/modernizr.js.cg
flag ghc7
+flag threaded
+ default: True
+ description: Build with support for multithreaded execution
+
library
if flag(ghc7)
build-depends: base >= 4.3 && < 5
cpp-options: -DGHC7
else
build-depends: base >= 4 && < 4.3
- build-depends: yesod-core >= 0.9.1.1 && < 0.10
+ build-depends: yesod-core >= 0.9.3.4 && < 0.10
, yesod-auth >= 0.7 && < 0.8
- , yesod-json >= 0.2 && < 0.3
+ , yesod-json >= 0.2.2 && < 0.3
, yesod-persistent >= 0.2 && < 0.3
, yesod-form >= 0.3 && < 0.4
- , monad-control >= 0.2 && < 0.3
- , transformers >= 0.2 && < 0.3
+ , monad-control >= 0.2 && < 0.4
+ , transformers >= 0.2.2 && < 0.3
, wai >= 0.4 && < 0.5
, wai-extra >= 0.4.1 && < 0.5
, hamlet >= 0.10 && < 0.11
, shakespeare-js >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11
, warp >= 0.4 && < 0.5
- , blaze-html >= 0.4 && < 0.5
+ , blaze-html >= 0.4.1.3 && < 0.5
exposed-modules: Yesod
ghc-options: -Wall
@@ -90,19 +99,21 @@ executable yesod
build-depends: parsec >= 2.1 && < 4
, text >= 0.11 && < 0.12
, shakespeare-text >= 0.10 && < 0.11
- , bytestring >= 0.9 && < 0.10
- , time >= 1.1.4 && < 1.3
+ , bytestring >= 0.9.1.4 && < 0.10
+ , time >= 1.1.4
, template-haskell
, directory >= 1.0 && < 1.2
, Cabal >= 1.8 && < 1.13
, unix-compat >= 0.2 && < 0.4
, containers >= 0.2 && < 0.5
- , attoparsec-text >= 0.8.5 && < 0.9
+ , attoparsec >= 0.10
, http-types >= 0.6.1 && < 0.7
- , blaze-builder >= 0.2 && < 0.4
+ , blaze-builder >= 0.2.1.4 && < 0.4
, filepath >= 1.1 && < 1.3
, process
- ghc-options: -Wall -threaded
+ ghc-options: -Wall
+ if flag(threaded)
+ ghc-options: -threaded
main-is: main.hs
other-modules: Scaffolding.CodeGen
Scaffolding.Scaffolder