haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'beta'

Browse Source
This commit is contained in:
Michael Snoyman 2011-12-29 12:01:21 +02:00
commit 8e623d04a6
56 changed files with 460 additions and 641 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
yesod-auth/Yesod/Auth.hs
View File

@ -73,7 +73,7 @@ data Creds m = Creds
, credsExtra :: [(Text, Text)] , credsExtra :: [(Text, Text)]
} }
class (Yesod m, SinglePiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where
type AuthId m type AuthId m
-- | Default destination on successful login, if no other -- | Default destination on successful login, if no other
@ -133,7 +133,7 @@ setCreds doRedirects creds = do
Just ar -> do setMessageI Msg.InvalidLogin Just ar -> do setMessageI Msg.InvalidLogin
redirect RedirectTemporary ar redirect RedirectTemporary ar
Just aid -> do Just aid -> do
setSession credsKey $ toSinglePiece aid setSession credsKey $ toPathPiece aid
when doRedirects $ do when doRedirects $ do
setMessageI Msg.NowLoggedIn setMessageI Msg.NowLoggedIn
redirectUltDest RedirectTemporary $ loginDest y redirectUltDest RedirectTemporary $ loginDest y
@ -189,12 +189,12 @@ maybeAuthId = do
ms <- lookupSession credsKey ms <- lookupSession credsKey
case ms of case ms of
Nothing -> return Nothing Nothing -> return Nothing
Just s -> return $ fromSinglePiece s Just s -> return $ fromPathPiece s
maybeAuth :: ( YesodAuth m maybeAuth :: ( YesodAuth m
, b ~ YesodPersistBackend m , b ~ YesodPersistBackend m
, Key b val ~ AuthId m , Key b val ~ AuthId m
, PersistBackend b (GGHandler s m IO) , PersistStore b (GHandler s m)
, PersistEntity val , PersistEntity val
, YesodPersist m , YesodPersist m
) => GHandler s m (Maybe (Key b val, val)) ) => GHandler s m (Maybe (Key b val, val))
@ -209,7 +209,7 @@ requireAuthId = maybeAuthId >>= maybe redirectLogin return
requireAuth :: ( YesodAuth m requireAuth :: ( YesodAuth m
, b ~ YesodPersistBackend m , b ~ YesodPersistBackend m
, Key b val ~ AuthId m , Key b val ~ AuthId m
, PersistBackend b (GGHandler s m IO) , PersistStore b (GHandler s m)
, PersistEntity val , PersistEntity val
, YesodPersist m , YesodPersist m
) => GHandler s m (Key b val, val) ) => GHandler s m (Key b val, val)

6
yesod-auth/Yesod/Auth/Email.hs
View File

@ -60,7 +60,7 @@ data EmailCreds m = EmailCreds
, emailCredsVerkey :: Maybe VerKey , emailCredsVerkey :: Maybe VerKey
} }
class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where
type AuthEmailId m type AuthEmailId m
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
@ -102,7 +102,7 @@ authEmail =
dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "GET" ["register"] = getRegisterR >>= sendResponse
dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse
dispatch "GET" ["verify", eid, verkey] = dispatch "GET" ["verify", eid, verkey] =
case fromSinglePiece eid of case fromPathPiece eid of
Nothing -> notFound Nothing -> notFound
Just eid' -> getVerifyR eid' verkey >>= sendResponse Just eid' -> getVerifyR eid' verkey >>= sendResponse
dispatch "POST" ["login"] = postLoginR >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse
@ -142,7 +142,7 @@ postRegisterR = do
return (lid, key) return (lid, key)
render <- getUrlRender render <- getUrlRender
tm <- getRouteToMaster tm <- getRouteToMaster
let verUrl = render $ tm $ verify (toSinglePiece lid) verKey let verUrl = render $ tm $ verify (toPathPiece lid) verKey
sendVerifyEmail email verKey verUrl sendVerifyEmail email verKey verUrl
defaultLayout $ do defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle setTitleI Msg.ConfirmationEmailSentTitle

2
yesod-auth/Yesod/Auth/Facebook.hs
View File

@ -49,7 +49,7 @@ facebookLogout = PluginR "facebook" ["logout"]
-- @Nothing@ if it's not found (probably because the user is not -- @Nothing@ if it's not found (probably because the user is not
-- logged in via Facebook). Note that the returned access token -- logged in via Facebook). Note that the returned access token
-- may have expired. -- may have expired.
getFacebookAccessToken :: MonadIO mo => GGHandler sub master mo (Maybe Facebook.AccessToken) getFacebookAccessToken :: GHandler sub master (Maybe Facebook.AccessToken)
getFacebookAccessToken = getFacebookAccessToken =
liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey) liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey)

16
yesod-auth/Yesod/Auth/HashDB.hs
View File

@ -137,7 +137,8 @@ setPassword pwd u = do salt <- randomSalt
-- the database values. -- the database values.
validateUser :: ( YesodPersist yesod validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod , b ~ YesodPersistBackend yesod
, PersistBackend b (GGHandler sub yesod IO) , PersistStore b (GHandler sub yesod)
, PersistUnique b (GHandler sub yesod)
, PersistEntity user , PersistEntity user
, HashDBUser user , HashDBUser user
) => ) =>
@ -163,7 +164,8 @@ login = PluginR "hashdb" ["login"]
postLoginR :: ( YesodAuth y, YesodPersist y postLoginR :: ( YesodAuth y, YesodPersist y
, b ~ YesodPersistBackend y , b ~ YesodPersistBackend y
, HashDBUser user, PersistEntity user , HashDBUser user, PersistEntity user
, PersistBackend b (GGHandler Auth y IO)) , PersistStore b (GHandler Auth y)
, PersistUnique b (GHandler Auth y))
=> (Text -> Maybe (Unique user b)) => (Text -> Maybe (Unique user b))
-> GHandler Auth y () -> GHandler Auth y ()
postLoginR uniq = do postLoginR uniq = do
@ -186,7 +188,8 @@ getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user , HashDBUser user, PersistEntity user
, Key b user ~ AuthId master , Key b user ~ AuthId master
, b ~ YesodPersistBackend master , b ~ YesodPersistBackend master
, PersistBackend b (GGHandler sub master IO)) , PersistUnique b (GHandler sub master)
, PersistStore b (GHandler sub master))
=> (AuthRoute -> Route master) -- ^ your site's Auth Route => (AuthRoute -> Route master) -- ^ your site's Auth Route
-> (Text -> Maybe (Unique user b)) -- ^ gets user ID -> (Text -> Maybe (Unique user b)) -- ^ gets user ID
-> Creds master -- ^ the creds argument -> Creds master -- ^ the creds argument
@ -213,7 +216,8 @@ authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user , HashDBUser user
, PersistEntity user , PersistEntity user
, b ~ YesodPersistBackend m , b ~ YesodPersistBackend m
, PersistBackend b (GGHandler Auth m IO)) , PersistStore b (GHandler Auth m)
, PersistUnique b (GHandler Auth m))
=> (Text -> Maybe (Unique user b)) -> AuthPlugin m => (Text -> Maybe (Unique user b)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
[QQ(hamlet)| [QQ(hamlet)|
@ -252,8 +256,8 @@ authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Generate data base instances for a valid user -- | Generate data base instances for a valid user
share2 (mkPersist sqlSettings) (mkMigrate "migrateUsers") share2 (mkPersist sqlMkSettings) (mkMigrate "migrateUsers")
[QQ(persist)| [QQ(persistUpperCase)|
User User
username Text Eq username Text Eq
password Text password Text

22
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth name: yesod-auth
version: 0.7.9 version: 0.8.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin
@ -21,10 +21,10 @@ library
cpp-options: -DGHC7 cpp-options: -DGHC7
else else
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
build-depends: authenticate >= 0.10.4 && < 0.11 build-depends: authenticate >= 0.11 && < 0.12
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 0.9.3.4 && < 0.10 , yesod-core >= 0.10 && < 0.11
, wai >= 0.4 && < 0.5 , wai >= 1.0 && < 1.1
, template-haskell , template-haskell
, pureMD5 >= 2.0 && < 2.2 , pureMD5 >= 2.0 && < 2.2
, random >= 1.0.0.2 && < 1.1 , random >= 1.0.0.2 && < 1.1
@ -32,19 +32,19 @@ library
, text >= 0.7 && < 0.12 , text >= 0.7 && < 0.12
, mime-mail >= 0.3 && < 0.5 , mime-mail >= 0.3 && < 0.5
, blaze-html >= 0.4.1.3 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5
, yesod-persistent >= 0.2 && < 0.3 , yesod-persistent >= 0.3 && < 0.4
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11
, yesod-json >= 0.2 && < 0.3 , yesod-json >= 0.3 && < 0.4
, containers , containers
, unordered-containers , unordered-containers
, yesod-form >= 0.3 && < 0.4 , yesod-form >= 0.4 && < 0.5
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, persistent >= 0.6 && < 0.7 , persistent >= 0.7 && < 0.8
, persistent-template >= 0.6 && < 0.7 , persistent-template >= 0.7 && < 0.8
, SHA >= 1.4.1.3 && < 1.6 , SHA >= 1.4.1.3 && < 1.6
, http-enumerator >= 0.6 && < 0.8 , http-conduit >= 1.0 && < 1.1
, aeson >= 0.3 , aeson >= 0.5
, pwstore-fast >= 2.2 && < 3 , pwstore-fast >= 2.2 && < 3
exposed-modules: Yesod.Auth exposed-modules: Yesod.Auth

113
yesod-core/Yesod/Config.hs
View File

@ -1,113 +0,0 @@
{-# 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

4
yesod-core/Yesod/Content.hs
View File

@ -54,7 +54,6 @@ import System.Locale
import qualified Data.Text.Encoding import qualified Data.Text.Encoding
import qualified Data.Text.Lazy.Encoding import qualified Data.Text.Lazy.Encoding
import Data.Enumerator (Enumerator)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Monoid (mempty) import Data.Monoid (mempty)
@ -62,9 +61,10 @@ import Text.Hamlet (Html)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Data.String (IsString (fromString)) import Data.String (IsString (fromString))
import Network.Wai (FilePart) import Network.Wai (FilePart)
import Data.Conduit (Source)
data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
| ContentEnum (forall a. Enumerator Builder IO a) | ContentSource (Source IO Builder)
| ContentFile FilePath (Maybe FilePart) | ContentFile FilePath (Maybe FilePart)
-- | Zero-length enumerator. -- | Zero-length enumerator.

2
yesod-core/Yesod/Core.hs
View File

@ -34,7 +34,6 @@ module Yesod.Core
, module Yesod.Request , module Yesod.Request
, module Yesod.Widget , module Yesod.Widget
, module Yesod.Message , module Yesod.Message
, module Yesod.Config
) where ) where
import Yesod.Internal.Core import Yesod.Internal.Core
@ -44,7 +43,6 @@ import Yesod.Handler
import Yesod.Request import Yesod.Request
import Yesod.Widget import Yesod.Widget
import Yesod.Message import Yesod.Message
import Yesod.Config
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.Text (Text) import Data.Text (Text)

6
yesod-core/Yesod/Dispatch.hs
View File

@ -15,8 +15,8 @@ module Yesod.Dispatch
, mkYesodDispatch , mkYesodDispatch
, mkYesodSubDispatch , mkYesodSubDispatch
-- ** Path pieces -- ** Path pieces
, SinglePiece (..) , PathPiece (..)
, MultiPiece (..) , PathMultiPiece (..)
, Texts , Texts
-- * Convert to WAI -- * Convert to WAI
, toWaiApp , toWaiApp
@ -31,7 +31,7 @@ import Yesod.Handler
import Yesod.Internal.Dispatch import Yesod.Internal.Dispatch
import Yesod.Widget (GWidget) import Yesod.Widget (GWidget)
import Web.PathPieces (SinglePiece (..), MultiPiece (..)) import Web.PathPieces
import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck) import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax

192
yesod-core/Yesod/Handler.hs
View File

@ -28,7 +28,7 @@ module Yesod.Handler
, YesodSubRoute (..) , YesodSubRoute (..)
-- * Handler monad -- * Handler monad
, GHandler , GHandler
, GGHandler , GHandlerT
-- ** Read information from handler -- ** Read information from handler
, getYesod , getYesod
, getYesodSub , getYesodSub
@ -148,8 +148,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString as S import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..), run_, ($$))
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content import Yesod.Content
@ -160,17 +158,21 @@ import qualified Network.Wai.Parse as NWP
import Data.Monoid (mappend, mempty, Endo (..)) import Data.Monoid (mappend, mempty, Endo (..))
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text) import Data.Text (Text)
import Yesod.Message (RenderMessage (..)) import Yesod.Message (RenderMessage (..))
import Text.Blaze (toHtml, preEscapedText) import Text.Blaze (toHtml, preEscapedText)
import Yesod.Internal.TestApi (catchIter)
import qualified Yesod.Internal.Cache as Cache import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey, CacheKey) import Yesod.Internal.Cache (mkCacheKey, CacheKey)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import qualified Data.IORef as I import qualified Data.IORef as I
import Control.Monad.Trans.Resource (ResourceT)
import Control.Exception.Lifted (catch)
import Network.Wai (requestBody)
import Data.Conduit (($$))
-- | The type-safe URLs associated with a site argument. -- | The type-safe URLs associated with a site argument.
type family Route a type family Route a
@ -206,22 +208,22 @@ handlerSubDataMaybe tm ts route hd = hd
, handlerRoute = route , handlerRoute = route
} }
get :: MonadIO monad => GGHandler sub master monad GHState get :: MonadIO monad => GHandlerT sub master monad GHState
get = do get = do
hd <- ask hd <- ask
liftIO $ I.readIORef $ handlerState hd liftIO $ I.readIORef $ handlerState hd
put :: MonadIO monad => GHState -> GGHandler sub master monad () put :: MonadIO monad => GHState -> GHandlerT sub master monad ()
put g = do put g = do
hd <- ask hd <- ask
liftIO $ I.writeIORef (handlerState hd) g liftIO $ I.writeIORef (handlerState hd) g
modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad () modify :: MonadIO monad => (GHState -> GHState) -> GHandlerT sub master monad ()
modify f = do modify f = do
hd <- ask hd <- ask
liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ()) liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad () tell :: MonadIO monad => Endo [Header] -> GHandlerT sub master monad ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
-- | Used internally for promoting subsite handler functions to master site -- | Used internally for promoting subsite handler functions to master site
@ -229,16 +231,16 @@ tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
toMasterHandler :: (Route sub -> Route master) toMasterHandler :: (Route sub -> Route master)
-> (master -> sub) -> (master -> sub)
-> Route sub -> Route sub
-> GGHandler sub master mo a -> GHandlerT sub master mo a
-> GGHandler sub' master mo a -> GHandlerT sub' master mo a
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route) toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
toMasterHandlerDyn :: Monad mo toMasterHandlerDyn :: Monad mo
=> (Route sub -> Route master) => (Route sub -> Route master)
-> GGHandler sub' master mo sub -> GHandlerT sub' master mo sub
-> Route sub -> Route sub
-> GGHandler sub master mo a -> GHandlerT sub master mo a
-> GGHandler sub' master mo a -> GHandlerT sub' master mo a
toMasterHandlerDyn tm getSub route h = do toMasterHandlerDyn tm getSub route h = do
sub <- getSub sub <- getSub
withReaderT (handlerSubData tm (const sub) route) h withReaderT (handlerSubData tm (const sub) route) h
@ -258,8 +260,8 @@ instance (anySub ~ anySub'
toMasterHandlerMaybe :: (Route sub -> Route master) toMasterHandlerMaybe :: (Route sub -> Route master)
-> (master -> sub) -> (master -> sub)
-> Maybe (Route sub) -> Maybe (Route sub)
-> GGHandler sub master mo a -> GHandlerT sub master mo a
-> GGHandler sub' master mo a -> GHandlerT sub' master mo a
toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route) toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
-- | A generic handler monad, which can have a different subsite and master -- | A generic handler monad, which can have a different subsite and master
@ -267,9 +269,9 @@ toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
-- special responses. It is declared as a newtype to make compiler errors more -- special responses. It is declared as a newtype to make compiler errors more
-- readable. -- readable.
type GGHandler sub master = ReaderT (HandlerData sub master) type GHandlerT sub master = ReaderT (HandlerData sub master)
type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) type GHandler sub master = GHandlerT sub master (ResourceT IO)
data GHState = GHState data GHState = GHState
{ ghsSession :: SessionMap { ghsSession :: SessionMap
@ -290,7 +292,7 @@ newtype YesodApp = YesodApp
-> Request -> Request
-> [ContentType] -> [ContentType]
-> SessionMap -> SessionMap
-> Iteratee ByteString IO YesodAppResult -> ResourceT IO YesodAppResult
} }
data YesodAppResult data YesodAppResult
@ -310,10 +312,10 @@ instance Show HandlerContents where
show _ = "Cannot show a HandlerContents" show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents instance Exception HandlerContents
getRequest :: Monad mo => GGHandler s m mo Request getRequest :: Monad mo => GHandlerT s m mo Request
getRequest = handlerRequest `liftM` ask getRequest = handlerRequest `liftM` ask
instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where instance MonadIO monad => Failure ErrorResponse (GHandlerT sub master monad) where
failure = liftIO . throwIO . HCError failure = liftIO . throwIO . HCError
runRequestBody :: GHandler s m RequestBodyContents runRequestBody :: GHandler s m RequestBodyContents
@ -327,9 +329,9 @@ runRequestBody = do
put x { ghsRBC = Just rbc } put x { ghsRBC = Just rbc }
return rbc return rbc
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents rbHelper :: W.Request -> ResourceT IO RequestBodyContents
rbHelper req = rbHelper req =
(map fix1 *** map fix2) <$> iter (map fix1 *** map fix2) <$> (requestBody req $$ iter)
where where
iter = NWP.parseRequestBody NWP.lbsSink req iter = NWP.parseRequestBody NWP.lbsSink req
fix1 = go *** go fix1 = go *** go
@ -338,15 +340,15 @@ rbHelper req =
go = decodeUtf8With lenientDecode go = decodeUtf8With lenientDecode
-- | Get the sub application argument. -- | Get the sub application argument.
getYesodSub :: Monad m => GGHandler sub master m sub getYesodSub :: Monad m => GHandlerT sub master m sub
getYesodSub = handlerSub `liftM` ask getYesodSub = handlerSub `liftM` ask
-- | Get the master site appliation argument. -- | Get the master site appliation argument.
getYesod :: Monad m => GGHandler sub master m master getYesod :: Monad m => GHandlerT sub master m master
getYesod = handlerMaster `liftM` ask getYesod = handlerMaster `liftM` ask
-- | Get the URL rendering function. -- | Get the URL rendering function.
getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text) getUrlRender :: Monad m => GHandlerT sub master m (Route master -> Text)
getUrlRender = do getUrlRender = do
x <- handlerRender `liftM` ask x <- handlerRender `liftM` ask
return $ flip x [] return $ flip x []
@ -354,17 +356,17 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters. -- | The URL rendering function with query-string parameters.
getUrlRenderParams getUrlRenderParams
:: Monad m :: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text) => GHandlerT sub master m (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` ask getUrlRenderParams = handlerRender `liftM` ask
-- | Get the route requested by the user. If this is a 404 response- where the -- | 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'. -- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub)) getCurrentRoute :: Monad m => GHandlerT sub master m (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` ask getCurrentRoute = handlerRoute `liftM` ask
-- | Get the function to promote a route for a subsite to a route for the -- | Get the function to promote a route for a subsite to a route for the
-- master site. -- master site.
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master) getRouteToMaster :: Monad m => GHandlerT sub master m (Route sub -> Route master)
getRouteToMaster = handlerToMaster `liftM` ask getRouteToMaster = handlerToMaster `liftM` ask
-- | Function used internally by Yesod in the process of converting a -- | Function used internally by Yesod in the process of converting a
@ -399,7 +401,7 @@ runHandler handler mrender sroute tomr master sub =
, handlerToMaster = tomr , handlerToMaster = tomr
, handlerState = istate , handlerState = istate
} }
contents' <- catchIter (fmap Right $ runReaderT handler hd) contents' <- catch (fmap Right $ runReaderT handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e) $ fromException e)
state <- liftIO $ I.readIORef istate state <- liftIO $ I.readIORef istate
@ -425,7 +427,7 @@ runHandler handler mrender sroute tomr master sub =
return $ YARPlain return $ YARPlain
(getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent (getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent
finalSession finalSession
HCSendFile ct fp p -> catchIter HCSendFile ct fp p -> catch
(sendFile' ct fp p) (sendFile' ct fp p)
(handleError . toErrorHandler) (handleError . toErrorHandler)
HCCreated loc -> do HCCreated loc -> do
@ -449,19 +451,19 @@ safeEh er = YesodApp $ \_ _ _ session -> do
session session
-- | Redirect to the given route. -- | Redirect to the given route.
redirect :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a redirect :: MonadIO mo => RedirectType -> Route master -> GHandlerT sub master mo a
redirect rt url = redirectParams rt url [] redirect rt url = redirectParams rt url []
-- | Redirects to the given route with the associated query-string parameters. -- | Redirects to the given route with the associated query-string parameters.
redirectParams :: MonadIO mo redirectParams :: MonadIO mo
=> RedirectType -> Route master -> [(Text, Text)] => RedirectType -> Route master -> [(Text, Text)]
-> GGHandler sub master mo a -> GHandlerT sub master mo a
redirectParams rt url params = do redirectParams rt url params = do
r <- getUrlRenderParams r <- getUrlRenderParams
redirectString rt $ r url params redirectString rt $ r url params
-- | Redirect to the given URL. -- | Redirect to the given URL.
redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GHandlerT sub master mo a
redirectText rt = liftIO . throwIO . HCRedirect rt redirectText rt = liftIO . throwIO . HCRedirect rt
redirectString = redirectText redirectString = redirectText
{-# DEPRECATED redirectString "Use redirectText instead" #-} {-# DEPRECATED redirectString "Use redirectText instead" #-}
@ -473,16 +475,16 @@ ultDestKey = "_ULT"
-- --
-- An ultimate destination is stored in the user session and can be loaded -- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'. -- later by 'redirectUltDest'.
setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo () setUltDest :: MonadIO mo => Route master -> GHandlerT sub master mo ()
setUltDest dest = do setUltDest dest = do
render <- getUrlRender render <- getUrlRender
setUltDestString $ render dest setUltDestString $ render dest
-- | Same as 'setUltDest', but use the given string. -- | Same as 'setUltDest', but use the given string.
setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo () setUltDestText :: MonadIO mo => Text -> GHandlerT sub master mo ()
setUltDestText = setSession ultDestKey setUltDestText = setSession ultDestKey
setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo () setUltDestString :: MonadIO mo => Text -> GHandlerT sub master mo ()
setUltDestString = setSession ultDestKey setUltDestString = setSession ultDestKey
{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-} {-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
@ -490,7 +492,7 @@ setUltDestString = setSession ultDestKey
-- --
-- If this is a 404 handler, there is no current page, and then this call does -- If this is a 404 handler, there is no current page, and then this call does
-- nothing. -- nothing.
setUltDest' :: MonadIO mo => GGHandler sub master mo () setUltDest' :: MonadIO mo => GHandlerT sub master mo ()
setUltDest' = do setUltDest' = do
route <- getCurrentRoute route <- getCurrentRoute
case route of case route of
@ -504,7 +506,7 @@ setUltDest' = do
-- | Sets the ultimate destination to the referer request header, if present. -- | Sets the ultimate destination to the referer request header, if present.
-- --
-- This function will not overwrite an existing ultdest. -- This function will not overwrite an existing ultdest.
setUltDestReferer :: MonadIO mo => GGHandler sub master mo () setUltDestReferer :: MonadIO mo => GHandlerT sub master mo ()
setUltDestReferer = do setUltDestReferer = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
maybe maybe
@ -521,14 +523,14 @@ setUltDestReferer = do
redirectUltDest :: MonadIO mo redirectUltDest :: MonadIO mo
=> RedirectType => RedirectType
-> Route master -- ^ default destination if nothing in session -> Route master -- ^ default destination if nothing in session
-> GGHandler sub master mo a -> GHandlerT sub master mo a
redirectUltDest rt def = do redirectUltDest rt def = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
deleteSession ultDestKey deleteSession ultDestKey
maybe (redirect rt def) (redirectText rt) mdest maybe (redirect rt def) (redirectText rt) mdest
-- | Remove a previously set ultimate destination. See 'setUltDest'. -- | Remove a previously set ultimate destination. See 'setUltDest'.
clearUltDest :: MonadIO mo => GGHandler sub master mo () clearUltDest :: MonadIO mo => GHandlerT sub master mo ()
clearUltDest = deleteSession ultDestKey clearUltDest = deleteSession ultDestKey
msgKey :: Text msgKey :: Text
@ -537,13 +539,13 @@ msgKey = "_MSG"
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessage :: MonadIO mo => Html -> GGHandler sub master mo () setMessage :: MonadIO mo => Html -> GHandlerT sub master mo ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo () setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT sub y mo ()
setMessageI msg = do setMessageI msg = do
mr <- getMessageRender mr <- getMessageRender
setMessage $ toHtml $ mr msg setMessage $ toHtml $ mr msg
@ -552,7 +554,7 @@ setMessageI msg = do
-- variable. -- variable.
-- --
-- See 'setMessage'. -- See 'setMessage'.
getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html) getMessage :: MonadIO mo => GHandlerT sub master mo (Maybe Html)
getMessage = do getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey deleteSession msgKey
@ -562,7 +564,7 @@ getMessage = do
-- --
-- For some backends, this is more efficient than reading in the file to -- 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. -- memory, since they can optimize file sending via a system call to sendfile.
sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a sendFile :: MonadIO mo => ContentType -> FilePath -> GHandlerT sub master mo a
sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
-- | Same as 'sendFile', but only sends part of a file. -- | Same as 'sendFile', but only sends part of a file.
@ -571,25 +573,25 @@ sendFilePart :: MonadIO mo
-> FilePath -> FilePath
-> Integer -- ^ offset -> Integer -- ^ offset
-> Integer -- ^ count -> Integer -- ^ count
-> GGHandler sub master mo a -> GHandlerT sub master mo a
sendFilePart ct fp off count = sendFilePart ct fp off count =
liftIO . throwIO $ 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 -- | Bypass remaining handler code and output the given content with a 200
-- status code. -- status code.
sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a sendResponse :: (MonadIO mo, HasReps c) => c -> GHandlerT sub master mo a
sendResponse = liftIO . throwIO . HCContent H.status200 sendResponse = liftIO . throwIO . HCContent H.status200
. chooseRep . chooseRep
-- | Bypass remaining handler code and output the given content with the given -- | Bypass remaining handler code and output the given content with the given
-- status code. -- status code.
sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GHandlerT s m mo a
sendResponseStatus s = liftIO . throwIO . HCContent s sendResponseStatus s = liftIO . throwIO . HCContent s
. chooseRep . chooseRep
-- | Send a 201 "Created" response with the given route as the Location -- | Send a 201 "Created" response with the given route as the Location
-- response header. -- response header.
sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a sendResponseCreated :: MonadIO mo => Route m -> GHandlerT s m mo a
sendResponseCreated url = do sendResponseCreated url = do
r <- getUrlRender r <- getUrlRender
liftIO . throwIO $ HCCreated $ r url liftIO . throwIO $ HCCreated $ r url
@ -599,7 +601,7 @@ sendResponseCreated url = do
-- that you have already specified. This function short-circuits. It should be -- 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, -- considered only for very specific needs. If you are not sure if you need it,
-- you don't. -- you don't.
sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b sendWaiResponse :: MonadIO mo => W.Response -> GHandlerT s m mo b
sendWaiResponse = liftIO . throwIO . HCWai sendWaiResponse = liftIO . throwIO . HCWai
-- | Return a 404 not found page. Also denotes no handler available. -- | Return a 404 not found page. Also denotes no handler available.
@ -607,7 +609,7 @@ notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound notFound = failure NotFound
-- | Return a 405 method not supported page. -- | Return a 405 method not supported page.
badMethod :: MonadIO mo => GGHandler s m mo a badMethod :: MonadIO mo => GHandlerT s m mo a
badMethod = do badMethod = do
w <- waiRequest w <- waiRequest
failure $ BadMethod $ W.requestMethod w failure $ BadMethod $ W.requestMethod w
@ -617,7 +619,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied permissionDenied = failure . PermissionDenied
-- | Return a 403 permission denied page. -- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT s y mo a
permissionDeniedI msg = do permissionDeniedI msg = do
mr <- getMessageRender mr <- getMessageRender
permissionDenied $ mr msg permissionDenied $ mr msg
@ -627,56 +629,62 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs invalidArgs = failure . InvalidArgs
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GHandlerT s y mo a
invalidArgsI msg = do invalidArgsI msg = do
mr <- getMessageRender mr <- getMessageRender
invalidArgs $ map mr msg invalidArgs $ map mr msg
------- Headers ------- Headers
-- | Set the cookie on the client. -- | Set the cookie on the client.
--
-- Note: although the value used for key and value is 'Text', you should only
-- use ASCII values to be HTTP compliant.
setCookie :: MonadIO mo setCookie :: MonadIO mo
=> Int -- ^ minutes to timeout => Int -- ^ minutes to timeout
-> H.Ascii -- ^ key -> Text -- ^ key
-> H.Ascii -- ^ value -> Text -- ^ value
-> GGHandler sub master mo () -> GHandlerT sub master mo ()
setCookie a b = addHeader . AddCookie a b setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8
-- | Unset the cookie on the client. -- | Unset the cookie on the client.
deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo () deleteCookie :: MonadIO mo => Text -> GHandlerT sub master mo ()
deleteCookie = addHeader . DeleteCookie deleteCookie = addHeader . DeleteCookie . encodeUtf8
-- | Set the language in the user session. Will show up in 'languages' on the -- | Set the language in the user session. Will show up in 'languages' on the
-- next request. -- next request.
setLanguage :: MonadIO mo => Text -> GGHandler sub master mo () setLanguage :: MonadIO mo => Text -> GHandlerT sub master mo ()
setLanguage = setSession langKey setLanguage = setSession langKey
-- | Set an arbitrary response header. -- | Set an arbitrary response header.
--
-- Note that, while the data type used here is 'Text', you must provide only
-- ASCII value to be HTTP compliant.
setHeader :: MonadIO mo setHeader :: MonadIO mo
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo () => Text -> Text -> GHandlerT sub master mo ()
setHeader a = addHeader . Header a setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
-- | Set the Cache-Control header to indicate this response should be cached -- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds. -- for the given number of seconds.
cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo () cacheSeconds :: MonadIO mo => Int -> GHandlerT s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat cacheSeconds i = setHeader "Cache-Control" $ T.concat
[ "max-age=" [ "max-age="
, show i , T.pack $ show i
, ", public" , ", public"
] ]
-- | Set the Expires header to some date in 2037. In other words, this content -- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired. -- is never (realistically) expired.
neverExpires :: MonadIO mo => GGHandler s m mo () neverExpires :: MonadIO mo => GHandlerT s m mo ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
-- | Set an Expires header in the past, meaning this content should not be -- | Set an Expires header in the past, meaning this content should not be
-- cached. -- cached.
alreadyExpired :: MonadIO mo => GGHandler s m mo () alreadyExpired :: MonadIO mo => GHandlerT s m mo ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date. -- | Set an Expires header to the given date.
expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo () expiresAt :: MonadIO mo => UTCTime -> GHandlerT s m mo ()
expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123 expiresAt = setHeader "Expires" . formatRFC1123
-- | Set a variable in the user's session. -- | Set a variable in the user's session.
-- --
@ -686,18 +694,18 @@ expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
setSession :: MonadIO mo setSession :: MonadIO mo
=> Text -- ^ key => Text -- ^ key
-> Text -- ^ value -> Text -- ^ value
-> GGHandler sub master mo () -> GHandlerT sub master mo ()
setSession k = modify . modSession . Map.insert k setSession k = modify . modSession . Map.insert k
-- | Unsets a session variable. See 'setSession'. -- | Unsets a session variable. See 'setSession'.
deleteSession :: MonadIO mo => Text -> GGHandler sub master mo () deleteSession :: MonadIO mo => Text -> GHandlerT sub master mo ()
deleteSession = modify . modSession . Map.delete deleteSession = modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x } modSession f x = x { ghsSession = f $ ghsSession x }
-- | Internal use only, not to be confused with 'setHeader'. -- | Internal use only, not to be confused with 'setHeader'.
addHeader :: MonadIO mo => Header -> GGHandler sub master mo () addHeader :: MonadIO mo => Header -> GHandlerT sub master mo ()
addHeader = tell . Endo . (:) addHeader = tell . Endo . (:)
getStatus :: ErrorResponse -> H.Status getStatus :: ErrorResponse -> H.Status
@ -720,18 +728,18 @@ data RedirectType = RedirectPermanent
| RedirectSeeOther | RedirectSeeOther
deriving (Show, Eq) deriving (Show, Eq)
localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a localNoCurrent :: Monad mo => GHandlerT s m mo a -> GHandlerT s m mo a
localNoCurrent = localNoCurrent =
local (\hd -> hd { handlerRoute = Nothing }) local (\hd -> hd { handlerRoute = Nothing })
-- | Lookup for session data. -- | Lookup for session data.
lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text) lookupSession :: MonadIO mo => Text -> GHandlerT s m mo (Maybe Text)
lookupSession n = do lookupSession n = do
m <- liftM ghsSession get m <- liftM ghsSession get
return $ Map.lookup n m return $ Map.lookup n m
-- | Get all session variables. -- | Get all session variables.
getSession :: MonadIO mo => GGHandler s m mo SessionMap getSession :: MonadIO mo => GHandlerT s m mo SessionMap
getSession = liftM ghsSession get getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b) handlerToYAR :: (HasReps a, HasReps b)
@ -744,7 +752,7 @@ handlerToYAR :: (HasReps a, HasReps b)
-> Maybe (Route s) -> Maybe (Route s)
-> SessionMap -> SessionMap
-> GHandler s m b -> GHandler s m b
-> Iteratee ByteString IO YesodAppResult -> ResourceT IO YesodAppResult
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
unYesodApp ya eh' rr types sessionMap unYesodApp ya eh' rr types sessionMap
where where
@ -766,8 +774,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
let hs' = maybe finalHeaders finalHeaders' mlen let hs' = maybe finalHeaders finalHeaders' mlen
in W.ResponseBuilder s hs' b in W.ResponseBuilder s hs' b
ContentFile fp p -> W.ResponseFile s finalHeaders fp p ContentFile fp p -> W.ResponseFile s finalHeaders fp p
ContentEnum e -> ContentSource body -> W.ResponseSource s finalHeaders body
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where where
finalHeaders = renderHeaders hs ct sessionFinal finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", S8.pack $ show len) finalHeaders' len = ("Content-Length", S8.pack $ show len)
@ -817,12 +824,17 @@ headerToPair cp getExpires (AddCookie minutes key value) =
}) })
headerToPair cp _ (DeleteCookie key) = headerToPair cp _ (DeleteCookie key) =
( "Set-Cookie" ( "Set-Cookie"
, key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT" , S.concat
[ key
, "=; path="
, cp
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
]
) )
headerToPair _ _ (Header key value) = (key, value) headerToPair _ _ (Header key value) = (CI.mk key, value)
-- | Get a unique identifier. -- | Get a unique identifier.
newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text newIdent :: MonadIO mo => GHandlerT sub master mo String -- FIXME use Text
newIdent = do newIdent = do
x <- get x <- get
let i' = ghsIdent x + 1 let i' = ghsIdent x + 1
@ -830,8 +842,8 @@ newIdent = do
return $ 'h' : show i' return $ 'h' : show i'
liftIOHandler :: MonadIO mo liftIOHandler :: MonadIO mo
=> GGHandler sub master IO a => GHandlerT sub master IO a
-> GGHandler sub master mo a -> GHandlerT sub master mo a
liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- | Redirect to a POST resource. -- | Redirect to a POST resource.
@ -840,7 +852,7 @@ liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- POST form, and some Javascript to automatically submit the form. This can be -- 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 -- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server. -- changes on the server.
redirectToPost :: MonadIO mo => Route master -> GGHandler sub master mo a redirectToPost :: MonadIO mo => Route master -> GHandlerT sub master mo a
redirectToPost dest = hamletToRepHtml redirectToPost dest = hamletToRepHtml
#if GHC7 #if GHC7
[hamlet| [hamlet|
@ -862,35 +874,35 @@ redirectToPost dest = hamletToRepHtml
-- | Converts the given Hamlet template into 'Content', which can be used in a -- | Converts the given Hamlet template into 'Content', which can be used in a
-- Yesod 'Response'. -- Yesod 'Response'.
hamletToContent :: Monad mo hamletToContent :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo Content => HtmlUrl (Route master) -> GHandlerT sub master mo Content
hamletToContent h = do hamletToContent h = do
render <- getUrlRenderParams render <- getUrlRenderParams
return $ toContent $ h render return $ toContent $ h render
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo hamletToRepHtml :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo RepHtml => HtmlUrl (Route master) -> GHandlerT sub master mo RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent hamletToRepHtml = liftM RepHtml . hamletToContent
-- | Get the request\'s 'W.Request' value. -- | Get the request\'s 'W.Request' value.
waiRequest :: Monad mo => GGHandler sub master mo W.Request waiRequest :: Monad mo => GHandlerT sub master mo W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text) getMessageRender :: (Monad mo, RenderMessage master message) => GHandlerT s master mo (message -> Text)
getMessageRender = do getMessageRender = do
m <- getYesod m <- getYesod
l <- reqLangs `liftM` getRequest l <- reqLangs `liftM` getRequest
return $ renderMessage m l return $ renderMessage m l
cacheLookup :: MonadIO mo => CacheKey a -> GGHandler sub master mo (Maybe a) cacheLookup :: MonadIO mo => CacheKey a -> GHandlerT sub master mo (Maybe a)
cacheLookup k = do cacheLookup k = do
gs <- get gs <- get
return $ Cache.lookup k $ ghsCache gs return $ Cache.lookup k $ ghsCache gs
cacheInsert :: MonadIO mo => CacheKey a -> a -> GGHandler sub master mo () cacheInsert :: MonadIO mo => CacheKey a -> a -> GHandlerT sub master mo ()
cacheInsert k v = modify $ \gs -> cacheInsert k v = modify $ \gs ->
gs { ghsCache = Cache.insert k v $ ghsCache gs } gs { ghsCache = Cache.insert k v $ ghsCache gs }
cacheDelete :: MonadIO mo => CacheKey a -> GGHandler sub master mo () cacheDelete :: MonadIO mo => CacheKey a -> GHandlerT sub master mo ()
cacheDelete k = modify $ \gs -> cacheDelete k = modify $ \gs ->
gs { ghsCache = Cache.delete k $ ghsCache gs } gs { ghsCache = Cache.delete k $ ghsCache gs }

9
yesod-core/Yesod/Internal.hs
View File

@ -39,11 +39,10 @@ import Data.Typeable (Typeable)
import Control.Exception (Exception) import Control.Exception (Exception)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI)
import Data.String (IsString) import Data.String (IsString)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Builder (Builder)
import Network.HTTP.Types (Ascii)
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
@ -65,9 +64,9 @@ instance Exception ErrorResponse
----- header stuff ----- header stuff
-- | Headers to be added to a 'Result'. -- | Headers to be added to a 'Result'.
data Header = data Header =
AddCookie Int A.Ascii A.Ascii AddCookie Int Ascii Ascii
| DeleteCookie A.Ascii | DeleteCookie Ascii
| Header (CI A.Ascii) A.Ascii | Header Ascii Ascii
deriving (Eq, Show) deriving (Eq, Show)
langKey :: IsString a => a langKey :: IsString a => a

2
yesod-core/Yesod/Internal/Core.hs
View File

@ -281,7 +281,7 @@ class RenderRoute (Route a) => Yesod a where
yepnopeJs _ = Nothing yepnopeJs _ = Nothing
messageLoggerHandler :: (Yesod m, MonadIO mo) messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo () => Loc -> LogLevel -> Text -> GHandlerT s m mo ()
messageLoggerHandler loc level msg = do messageLoggerHandler loc level msg = do
y <- getYesod y <- getYesod
liftIO $ messageLogger y loc level msg liftIO $ messageLogger y loc level msg

12
yesod-core/Yesod/Internal/Dispatch.hs
View File

@ -30,7 +30,7 @@ import qualified Data.Text
Alright, let's explain how routing works. We want to take a [String] and found Alright, let's explain how routing works. We want to take a [String] and found
out which route it applies to. For static pieces, we need to ensure an exact out which route it applies to. For static pieces, we need to ensure an exact
match against the segment. For a single or multi piece, we need to check the match against the segment. For a single or multi piece, we need to check the
result of fromSinglePiece/fromMultiPiece, respectively. result of fromPathPiece/fromMultiPathPiece, respectively.
We want to create a tree of case statements basically resembling: We want to create a tree of case statements basically resembling:
@ -51,7 +51,7 @@ case segments of
case as of case as of
[] -> Nothing [] -> Nothing
b:bs -> b:bs ->
case fromSinglePiece b of case fromPathPiece b of
Left _ -> Nothing Left _ -> Nothing
Right name -> Right name ->
case bs of case bs of
@ -59,7 +59,7 @@ case segments of
case cs of case cs of
[] -> Nothing [] -> Nothing
d:ds -> d:ds ->
case fromSinglePiece d of case fromPathPiece d of
Left _ -> Nothing Left _ -> Nothing
Right age -> Right age ->
case ds of case ds of
@ -219,7 +219,7 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
next <- newName "next" next <- newName "next"
fsp <- [|fromSinglePiece|] fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next) let exp' = CaseE (fsp `AppE` VarE next)
[ Match [ Match
(ConP (mkName "Nothing") []) (ConP (mkName "Nothing") [])
@ -243,7 +243,7 @@ mkSimpleExp segments [MultiPiece _] frontVars x = do
srest <- [|[]|] srest <- [|[]|]
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
fmp <- [|fromMultiPiece|] fmp <- [|fromPathMultiPiece|]
let exp = CaseE (fmp `AppE` segments) let exp = CaseE (fmp `AppE` segments)
[ Match [ Match
(ConP (mkName "Nothing") []) (ConP (mkName "Nothing") [])
@ -301,7 +301,7 @@ mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
next <- newName "next" next <- newName "next"
fsp <- [|fromSinglePiece|] fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next) let exp' = CaseE (fsp `AppE` VarE next)
[ Match [ Match
(ConP (mkName "Nothing") []) (ConP (mkName "Nothing") [])

8
yesod-core/Yesod/Internal/RouteParsing.hs
View File

@ -85,7 +85,7 @@ createParse res = do
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp) mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
mkPat' be [MultiPiece s] parse = do mkPat' be [MultiPiece s] parse = do
v <- newName $ "var" ++ s v <- newName $ "var" ++ s
fmp <- [|fromMultiPiece|] fmp <- [|fromPathMultiPiece|]
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
return ([VarP v], parse') return ([VarP v], parse')
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last" mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
@ -94,7 +94,7 @@ createParse res = do
let sp = LitP $ StringL s let sp = LitP $ StringL s
return (sp : x, parse') return (sp : x, parse')
mkPat' be (SinglePiece s:rest) parse = do mkPat' be (SinglePiece s:rest) parse = do
fsp <- [|fromSinglePiece|] fsp <- [|fromPathPiece|]
v <- newName $ "var" ++ s v <- newName $ "var" ++ s
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
(x, parse'') <- mkPat' be rest parse' (x, parse'') <- mkPat' be rest parse'
@ -137,13 +137,13 @@ createRender = mapM go
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs' return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
mkBod ((i, SinglePiece _):xs) = do mkBod ((i, SinglePiece _):xs) = do
let x' = VarE $ mkName $ "var" ++ show i let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toSinglePiece|] tsp <- [|toPathPiece|]
let x'' = tsp `AppE` x' let x'' = tsp `AppE` x'
xs' <- mkBod xs xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` x'' `AppE` xs' return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) = do mkBod ((i, MultiPiece _):_) = do
let x' = VarE $ mkName $ "var" ++ show i let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toMultiPiece|] tmp <- [|toPathMultiPiece|]
return $ tmp `AppE` x' return $ tmp `AppE` x'
-- | Whether the set of resources cover all possible URLs. -- | Whether the set of resources cover all possible URLs.

16
yesod-core/Yesod/Internal/TestApi.hs
View File

@ -6,22 +6,6 @@
-- --
module Yesod.Internal.TestApi module Yesod.Internal.TestApi
( randomString, parseWaiRequest' ( randomString, parseWaiRequest'
, catchIter
) where ) where
import Yesod.Internal.Request (randomString, parseWaiRequest') import Yesod.Internal.Request (randomString, parseWaiRequest')
import Control.Exception (Exception, catch)
import Data.Enumerator (Iteratee (..), Step (..))
import Data.ByteString (ByteString)
import Prelude hiding (catch)
catchIter :: Exception e
=> Iteratee ByteString IO a
-> (e -> Iteratee ByteString IO a)
-> Iteratee ByteString IO a
catchIter (Iteratee mstep) f = Iteratee $ do
step <- mstep `catch` (runIteratee . f)
return $ case step of
Continue k -> Continue $ \s -> catchIter (k s) f
Yield b s -> Yield b s
Error e -> Error e

10
yesod-core/Yesod/Request.hs
View File

@ -52,20 +52,20 @@ import Data.Text (Text)
-- * Accept-Language HTTP header. -- * Accept-Language HTTP header.
-- --
-- This is handled by parseWaiRequest (not exposed). -- This is handled by parseWaiRequest (not exposed).
languages :: Monad mo => GGHandler s m mo [Text] languages :: Monad mo => GHandlerT s m mo [Text]
languages = reqLangs `liftM` getRequest languages = reqLangs `liftM` getRequest
lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x) lookup' a = map snd . filter (\x -> a == fst x)
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text] lookupGetParams :: Monad mo => Text -> GHandlerT s m mo [Text]
lookupGetParams pn = do lookupGetParams pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqGetParams rr return $ lookup' pn $ reqGetParams rr
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupGetParam :: Monad mo => Text -> GHandlerT s m mo (Maybe Text)
lookupGetParam = liftM listToMaybe . lookupGetParams lookupGetParam = liftM listToMaybe . lookupGetParams
-- | Lookup for POST parameters. -- | Lookup for POST parameters.
@ -91,11 +91,11 @@ lookupFiles pn = do
return $ lookup' pn files return $ lookup' pn files
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupCookie :: Monad mo => Text -> GHandlerT s m mo (Maybe Text)
lookupCookie = liftM listToMaybe . lookupCookies lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text] lookupCookies :: Monad mo => Text -> GHandlerT s m mo [Text]
lookupCookies pn = do lookupCookies pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqCookies rr return $ lookup' pn $ reqCookies rr

10
yesod-core/Yesod/Widget.hs
View File

@ -64,7 +64,7 @@ import Text.Cassius
import Text.Julius import Text.Julius
import Text.Coffee import Text.Coffee
import Yesod.Handler import Yesod.Handler
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod (Route, GHandler, GHandlerT, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams , getMessageRender, getUrlRenderParams
) )
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
@ -189,7 +189,7 @@ setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempt
-- | Set the page title. Calling 'setTitle' multiple times overrides previously -- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values. -- set values.
setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) () setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GHandlerT sub master m) ()
setTitleI msg = do setTitleI msg = do
mr <- lift getMessageRender mr <- lift getMessageRender
setTitle $ toHtml $ mr msg setTitle $ toHtml $ mr msg
@ -280,7 +280,7 @@ addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavasc
-- | Add Coffesscript to the page's script tag. Requires the coffeescript -- | Add Coffesscript to the page's script tag. Requires the coffeescript
-- executable to be present at runtime. -- executable to be present at runtime.
addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) () addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GHandlerT sub master m) ()
addCoffee c = do addCoffee c = do
render <- lift getUrlRenderParams render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c t <- liftIO $ renderCoffee render c
@ -288,7 +288,7 @@ addCoffee c = do
-- | Add a new script tag to the body with the contents of this Coffesscript -- | Add a new script tag to the body with the contents of this Coffesscript
-- template. Requires the coffeescript executable to be present at runtime. -- template. Requires the coffeescript executable to be present at runtime.
addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) () addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GHandlerT sub master m) ()
addCoffeeBody c = do addCoffeeBody c = do
render <- lift getUrlRenderParams render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c t <- liftIO $ renderCoffee render c
@ -338,7 +338,7 @@ rules = do
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, RenderMessage master message) ihamletToRepHtml :: (Monad mo, RenderMessage master message)
=> HtmlUrlI18n message (Route master) => HtmlUrlI18n message (Route master)
-> GGHandler sub master mo RepHtml -> GHandlerT sub master mo RepHtml
ihamletToRepHtml ih = do ihamletToRepHtml ih = do
urender <- getUrlRenderParams urender <- getUrlRenderParams
mrender <- getMessageRender mrender <- getMessageRender

13
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -11,10 +11,6 @@ import Network.Wai.Test
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Yesod.Internal.TestApi
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import Control.Exception (SomeException)
data App = App data App = App
@ -61,7 +57,6 @@ errorHandlingTest = describe "Test.ErrorHandling"
[ it "says not found" caseNotFound [ it "says not found" caseNotFound
, it "says 'There was an error' before runRequestBody" caseBefore , it "says 'There was an error' before runRequestBody" caseBefore
, it "says 'There was an error' after runRequestBody" caseAfter , it "says 'There was an error' after runRequestBody" caseAfter
, it "catchIter handles internal exceptions" caseCatchIter
] ]
runner :: Session () -> IO () runner :: Session () -> IO ()
@ -101,11 +96,3 @@ caseAfter = runner $ do
} }
assertStatus 500 res assertStatus 500 res
assertBodyContains "bin12345" res assertBodyContains "bin12345" res
caseCatchIter :: IO ()
caseCatchIter = E.run_ $ E.enumList 8 (replicate 1000 "foo") E.$$ flip catchIter ignorer $ do
_ <- EL.consume
error "foo"
where
ignorer :: SomeException -> E.Iteratee a IO ()
ignorer _ = return ()

1
yesod-core/test/YesodCoreTest/YesodTest.hs
View File

@ -6,7 +6,6 @@ module YesodCoreTest.YesodTest
, module Network.Wai , module Network.Wai
, module Network.Wai.Test , module Network.Wai.Test
, module Test.Hspec , module Test.Hspec
, module Test.Hspec.HUnit
) where ) where
import Yesod.Core hiding (Request) import Yesod.Core hiding (Request)

21
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core name: yesod-core
version: 0.9.4 version: 0.10.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -46,12 +46,12 @@ library
build-depends: wai-test build-depends: wai-test
build-depends: time >= 1.1.4 build-depends: time >= 1.1.4
, wai >= 0.4 && < 0.5 , wai >= 1.0 && < 1.1
, wai-extra >= 0.4.1 && < 0.5 , wai-extra >= 1.0 && < 1.1
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, text >= 0.7 && < 0.12 , text >= 0.7 && < 0.12
, template-haskell , template-haskell
, path-pieces >= 0.0 && < 0.1 , path-pieces >= 0.1 && < 0.2
, hamlet >= 0.10.6 && < 0.11 , hamlet >= 0.10.6 && < 0.11
, shakespeare >= 0.10 && < 0.11 , shakespeare >= 0.10 && < 0.11
, shakespeare-js >= 0.10.4 && < 0.11 , shakespeare-js >= 0.10.4 && < 0.11
@ -65,21 +65,20 @@ library
, old-locale >= 1.0.0.2 && < 1.1 , old-locale >= 1.0.0.2 && < 1.1
, failure >= 0.1 && < 0.2 , failure >= 0.1 && < 0.2
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
, monad-control >= 0.2 && < 0.4 , monad-control >= 0.3 && < 0.4
, transformers-base >= 0.4 , transformers-base >= 0.4
, enumerator >= 0.4.8 && < 0.5
, cookie >= 0.3 && < 0.4 , cookie >= 0.3 && < 0.4
, blaze-html >= 0.4.1.3 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5
, http-types >= 0.6.5 && < 0.7 , http-types >= 0.6.5 && < 0.7
, case-insensitive >= 0.2 , case-insensitive >= 0.2
, parsec >= 2 && < 3.2 , parsec >= 2 && < 3.2
, directory >= 1 && < 1.2 , directory >= 1 && < 1.2
, data-object >= 0.3 && < 0.4
, data-object-yaml >= 0.3 && < 0.4
, vector >= 0.9 && < 0.10 , vector >= 0.9 && < 0.10
, aeson >= 0.3 , aeson >= 0.5
, fast-logger >= 0.0.1 , fast-logger >= 0.0.1
, wai-logger >= 0.0.1 , wai-logger >= 0.0.1
, conduit >= 0.0 && < 0.1
, lifted-base >= 0.1 && < 0.2
exposed-modules: Yesod.Content exposed-modules: Yesod.Content
Yesod.Core Yesod.Core
@ -89,7 +88,6 @@ library
Yesod.Request Yesod.Request
Yesod.Widget Yesod.Widget
Yesod.Message Yesod.Message
Yesod.Config
Yesod.Internal.TestApi Yesod.Internal.TestApi
other-modules: Yesod.Internal other-modules: Yesod.Internal
Yesod.Internal.Cache Yesod.Internal.Cache
@ -117,7 +115,7 @@ test-suite tests
main-is: test.hs main-is: test.hs
cpp-options: -DTEST cpp-options: -DTEST
build-depends: hspec >= 0.8 && < 0.10 build-depends: hspec >= 0.8 && < 0.10
,wai-test >= 0.1.2 && < 0.2 ,wai-test
,wai ,wai
,yesod-core ,yesod-core
,bytestring ,bytestring
@ -129,7 +127,6 @@ test-suite tests
, random , random
,HUnit ,HUnit
,QuickCheck >= 2 && < 3 ,QuickCheck >= 2 && < 3
, enumerator
ghc-options: -Wall ghc-options: -Wall
source-repository head source-repository head

49
yesod-default/Yesod/Default/Config.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module Yesod.Default.Config module Yesod.Default.Config
( DefaultEnv (..) ( DefaultEnv (..)
, fromArgs , fromArgs
@ -18,10 +19,9 @@ import Data.Char (toUpper, toLower)
import System.Console.CmdArgs hiding (args) import System.Console.CmdArgs hiding (args)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad (join) import Data.Yaml
import Data.Object
import Data.Object.Yaml
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.HashMap.Strict as M
-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and -- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
-- Production environments -- Production environments
@ -55,13 +55,13 @@ fromArgs = fromArgsExtra (const $ const $ return ())
-- | Same as 'fromArgs', but allows you to specify how to parse the 'appExtra' -- | Same as 'fromArgs', but allows you to specify how to parse the 'appExtra'
-- record. -- record.
fromArgsExtra :: (DefaultEnv -> TextObject -> IO extra) fromArgsExtra :: (DefaultEnv -> Value -> IO extra)
-> IO (AppConfig DefaultEnv extra) -> IO (AppConfig DefaultEnv extra)
fromArgsExtra = fromArgsWith defaultArgConfig fromArgsExtra = fromArgsWith defaultArgConfig
fromArgsWith :: (Read env, Show env) fromArgsWith :: (Read env, Show env)
=> ArgConfig => ArgConfig
-> (env -> TextObject -> IO extra) -> (env -> Value -> IO extra)
-> IO (AppConfig env extra) -> IO (AppConfig env extra)
fromArgsWith argConfig getExtra = do fromArgsWith argConfig getExtra = do
args <- cmdArgs argConfig args <- cmdArgs argConfig
@ -103,12 +103,12 @@ data ConfigSettings environment extra = ConfigSettings
-- environment. Usually, you will use 'DefaultEnv' for this type. -- environment. Usually, you will use 'DefaultEnv' for this type.
csEnv :: environment csEnv :: environment
-- | Load any extra data, to be used by the application. -- | Load any extra data, to be used by the application.
, csLoadExtra :: environment -> TextObject -> IO extra , csLoadExtra :: environment -> Value -> IO extra
-- | Return the path to the YAML config file. -- | Return the path to the YAML config file.
, csFile :: environment -> IO FilePath , csFile :: environment -> IO FilePath
-- | Get the sub-object (if relevant) from the given YAML source which -- | Get the sub-object (if relevant) from the given YAML source which
-- contains the specific settings for the current environment. -- contains the specific settings for the current environment.
, csGetObject :: environment -> TextObject -> IO TextObject , csGetObject :: environment -> Value -> IO Value
} }
-- | Default config settings. -- | Default config settings.
@ -117,14 +117,17 @@ configSettings env0 = ConfigSettings
{ csEnv = env0 { csEnv = env0
, csLoadExtra = \_ _ -> return () , csLoadExtra = \_ _ -> return ()
, csFile = \_ -> return "config/settings.yml" , csFile = \_ -> return "config/settings.yml"
, csGetObject = \env obj -> do , csGetObject = \env v -> do
envs <- fromMapping obj envs <-
case v of
Object obj -> return obj
_ -> fail "Expected Object"
let senv = show env let senv = show env
tenv = T.pack senv tenv = T.pack senv
maybe maybe
(error $ "Could not find environment: " ++ senv) (error $ "Could not find environment: " ++ senv)
return return
(lookup tenv envs) (M.lookup tenv envs)
} }
-- | Load an @'AppConfig'@. -- | Load an @'AppConfig'@.
@ -160,10 +163,14 @@ loadConfig :: ConfigSettings environment extra
-> IO (AppConfig environment extra) -> IO (AppConfig environment extra)
loadConfig (ConfigSettings env loadExtra getFile getObject) = do loadConfig (ConfigSettings env loadExtra getFile getObject) = do
fp <- getFile env fp <- getFile env
topObj <- join $ decodeFile fp mtopObj <- decodeFile fp
topObj <- maybe (fail "Invalid YAML file") return mtopObj
obj <- getObject env topObj obj <- getObject env topObj
m <-
case obj of
Object m -> return m
_ -> fail "Expected map"
m <- maybe (fail "Expected map") return $ fromMapping obj
let mssl = lookupScalar "ssl" m let mssl = lookupScalar "ssl" m
let mhost = lookupScalar "host" m let mhost = lookupScalar "host" m
let mport = lookupScalar "port" m let mport = lookupScalar "port" m
@ -192,6 +199,11 @@ loadConfig (ConfigSettings env loadExtra getFile getObject) = do
} }
where where
lookupScalar k m =
case M.lookup k m of
Just (String t) -> return t
Just _ -> fail $ "Invalid value for: " ++ show k
Nothing -> fail $ "Not found: " ++ show k
toBool :: Text -> Bool toBool :: Text -> Bool
toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"]) toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
@ -216,11 +228,12 @@ safeRead name' t = case reads s of
withYamlEnvironment :: Show e withYamlEnvironment :: Show e
=> FilePath -- ^ the yaml file => FilePath -- ^ the yaml file
-> e -- ^ the environment you want to load -> e -- ^ the environment you want to load
-> (TextObject -> IO a) -- ^ what to do with the mapping -> (Value -> IO a) -- ^ what to do with the mapping
-> IO a -> IO a
withYamlEnvironment fp env f = do withYamlEnvironment fp env f = do
obj <- join $ decodeFile fp mval <- decodeFile fp
envs <- fromMapping obj case mval of
conf <- maybe (fail $ "Could not find environment: " ++ show env) return Nothing -> fail $ "Invalid YAML file: " ++ show fp
$ lookup (T.pack $ show env) envs Just (Object obj)
f conf | Just v <- M.lookup (T.pack $ show env) obj -> f v
_ -> fail $ "Could not find environment: " ++ show env

2
yesod-default/Yesod/Default/Main.hs
View File

@ -7,7 +7,7 @@ module Yesod.Default.Main
, defaultDevelAppWith , defaultDevelAppWith
) where ) where
import Yesod.Core hiding (AppConfig (..)) import Yesod.Core
import Yesod.Default.Config import Yesod.Default.Config
import Yesod.Logger (Logger, makeDefaultLogger, logString, flushLogger) import Yesod.Logger (Logger, makeDefaultLogger, logString, flushLogger)
import Network.Wai (Application) import Network.Wai (Application)

14
yesod-default/yesod-default.cabal
View File

@ -1,5 +1,5 @@
name: yesod-default name: yesod-default
version: 0.5.0 version: 0.6.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Patrick Brisbin author: Patrick Brisbin
@ -18,11 +18,11 @@ library
cpp-options: -DWINDOWS cpp-options: -DWINDOWS
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9.4 && < 0.10 , yesod-core >= 0.10 && < 0.11
, cmdargs >= 0.8 , cmdargs >= 0.8
, warp >= 0.4 && < 0.5 , warp >= 1.0 && < 1.1
, wai >= 0.4 && < 0.5 , wai >= 1.0 && < 1.1
, wai-extra >= 0.4.4 && < 0.5 , wai-extra >= 1.0 && < 1.1
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, text >= 0.9 , text >= 0.9
@ -30,8 +30,8 @@ library
, shakespeare-css >= 0.10.5 && < 0.11 , shakespeare-css >= 0.10.5 && < 0.11
, shakespeare-js >= 0.10.4 && < 0.11 , shakespeare-js >= 0.10.4 && < 0.11
, template-haskell , template-haskell
, data-object >= 0.3 && < 0.4 , yaml >= 0.5 && < 0.6
, data-object-yaml >= 0.3 && < 0.4 , unordered-containers
if !os(windows) if !os(windows)
build-depends: unix build-depends: unix

105
yesod-form/Yesod/Form/Fields.hs
View File

@ -67,6 +67,7 @@ import Text.Blaze.Renderer.String (renderHtml)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack) import Data.Text (Text, unpack, pack)
import qualified Data.Text as T
import qualified Data.Text.Read import qualified Data.Text.Read
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
@ -75,8 +76,8 @@ import qualified Data.Map as Map
import Yesod.Handler (newIdent, liftIOHandler) import Yesod.Handler (newIdent, liftIOHandler)
import Yesod.Request (FileInfo) import Yesod.Request (FileInfo)
import Yesod.Core (toSinglePiece, GGHandler, SinglePiece) import Yesod.Core (toPathPiece, GHandler, GHandlerT, PathPiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
@ -110,9 +111,9 @@ intField = Field
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s _ -> Left $ MsgInvalidInteger s
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="number" :isReq:required="" value="#{showVal val}">
|] |]
} }
where where
@ -126,9 +127,9 @@ doubleField = Field
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidNumber s _ -> Left $ MsgInvalidNumber s
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{showVal val}">
|] |]
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
@ -136,9 +137,9 @@ doubleField = Field
dayField :: RenderMessage master FormMessage => Field sub master Day dayField :: RenderMessage master FormMessage => Field sub master Day
dayField = Field dayField = Field
{ fieldParse = blank $ parseDate . unpack { fieldParse = blank $ parseDate . unpack
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}">
|] |]
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
@ -146,9 +147,9 @@ dayField = Field
timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
timeField = Field timeField = Field
{ fieldParse = blank $ parseTime . unpack { fieldParse = blank $ parseTime . unpack
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate "" theClass}" :isReq:required="" value="#{showVal val}">
|] |]
} }
where where
@ -161,9 +162,10 @@ timeField = Field
htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField :: RenderMessage master FormMessage => Field sub master Html
htmlField = Field htmlField = Field
{ fieldParse = blank $ Right . preEscapedText . sanitizeBalance { fieldParse = blank $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name theClass val _isReq -> addHamlet
-- FIXME: There was a class="html" attribute, for what purpose?
[HAMLET|\ [HAMLET|\
<textarea id="#{theId}" name="#{name}" .html>#{showVal val} <textarea id="#{theId}" name="#{name}" :not (null theClass):class=#{T.intercalate " " theClass}>#{showVal val}
|] |]
} }
where showVal = either id (pack . renderHtml) where showVal = either id (pack . renderHtml)
@ -189,36 +191,36 @@ instance ToHtml Textarea where
textareaField :: RenderMessage master FormMessage => Field sub master Textarea textareaField :: RenderMessage master FormMessage => Field sub master Textarea
textareaField = Field textareaField = Field
{ fieldParse = blank $ Right . Textarea { fieldParse = blank $ Right . Textarea
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name theClass val _isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<textarea id="#{theId}" name="#{name}">#{either id unTextarea val} <textarea id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}">#{either id unTextarea val}
|] |]
} }
hiddenField :: RenderMessage master FormMessage => Field sub master Text hiddenField :: RenderMessage master FormMessage => Field sub master Text
hiddenField = Field hiddenField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name theClass val _isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}"> <input type="hidden" id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" value="#{either id id val}">
|] |]
} }
textField :: RenderMessage master FormMessage => Field sub master Text textField :: RenderMessage master FormMessage => Field sub master Text
textField = Field textField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val isReq -> , fieldView = \theId name theClass val isReq ->
[WHAMLET| [WHAMLET|
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required value="#{either id id val}">
|] |]
} }
passwordField :: RenderMessage master FormMessage => Field sub master Text passwordField :: RenderMessage master FormMessage => Field sub master Text
passwordField = Field passwordField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="password" :isReq:required="" value="#{either id id val}">
|] |]
} }
@ -266,9 +268,9 @@ emailField = Field
\s -> if Email.isValid (unpack s) \s -> if Email.isValid (unpack s)
then Right s then Right s
else Left $ MsgInvalidEmail s else Left $ MsgInvalidEmail s
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="email" :isReq:required="" value="#{either id id val}">
|] |]
} }
@ -276,9 +278,9 @@ type AutoFocus = Bool
searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = blank Right { fieldParse = blank Right
, fieldView = \theId name val isReq -> do , fieldView = \theId name theClass val isReq -> do
[WHAMLET|\ [WHAMLET|\
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|] |]
when autoFocus $ do when autoFocus $ do
-- we want this javascript to be placed immediately after the field -- we want this javascript to be placed immediately after the field
@ -296,30 +298,30 @@ urlField = Field
case parseURI $ unpack s of case parseURI $ unpack s of
Nothing -> Left $ MsgInvalidUrl s Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s Just _ -> Right s
, fieldView = \theId name val isReq -> , fieldView = \theId name theClass val isReq ->
[WHAMLET| [WHAMLET|
<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}> <input ##{theId} name=#{name} :not (null theClass):class="#{T.intercalate " " theClass}" type=url :isReq:required value=#{either id id val}>
|] |]
} }
selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
selectField = selectField' . optionsPairs selectField = selectField' . optionsPairs
selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a selectField' :: (Eq a, RenderMessage master FormMessage) => GHandlerT sub master IO (OptionList a) -> Field sub master a
selectField' = selectFieldHelper selectField' = selectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) -- inside (\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|]) -- inside
multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a] multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
multiSelectField = multiSelectFieldHelper multiSelectField = multiSelectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|]) (\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) (\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|])
radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
radioField = radioField' . optionsPairs radioField = radioField' . optionsPairs
radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a radioField' :: (Eq a, RenderMessage master FormMessage) => GHandlerT sub master IO (OptionList a) -> Field sub master a
radioField' = selectFieldHelper radioField' = selectFieldHelper
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|]) (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
(\theId name isSel -> [WHAMLET| (\theId name isSel -> [WHAMLET|
@ -327,25 +329,25 @@ radioField' = selectFieldHelper
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked> <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
<label for=#{theId}-none>_{MsgSelectNone} <label for=#{theId}-none>_{MsgSelectNone}
|]) |])
(\theId name value isSel text -> [WHAMLET| (\theId name theClass value isSel text -> [WHAMLET|
<div> <div>
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked> <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked :not (null theClass):class="#{T.intercalate " " theClass}">
<label for=#{theId}-#{value}>#{text} <label for=#{theId}-#{value}>#{text}
|]) |])
boolField :: RenderMessage master FormMessage => Field sub master Bool boolField :: RenderMessage master FormMessage => Field sub master Bool
boolField = Field boolField = Field
{ fieldParse = return . boolParser { fieldParse = return . boolParser
, fieldView = \theId name val isReq -> [WHAMLET| , fieldView = \theId name theClass val isReq -> [WHAMLET|
$if not isReq $if not isReq
<input id=#{theId}-none type=radio name=#{name} value=none checked> <input id=#{theId}-none :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=none checked>
<label for=#{theId}-none>_{MsgSelectNone} <label for=#{theId}-none>_{MsgSelectNone}
<input id=#{theId}-yes type=radio name=#{name} value=yes :showVal id val:checked> <input id=#{theId}-yes :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=yes :showVal id val:checked>
<label for=#{theId}-yes>_{MsgBoolYes} <label for=#{theId}-yes>_{MsgBoolYes}
<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked> <input id=#{theId}-no :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=no :showVal not val:checked>
<label for=#{theId}-no>_{MsgBoolNo} <label for=#{theId}-no>_{MsgBoolNo}
|] |]
} }
@ -361,15 +363,16 @@ boolField = Field
multiSelectFieldHelper :: (Show a, Eq a) multiSelectFieldHelper :: (Show a, Eq a)
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ()) => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ()) -> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())
-> [(Text, a)] -> Field sub master [a] -> [(Text, a)] -> Field sub master [a]
multiSelectFieldHelper outside inside opts = Field multiSelectFieldHelper outside inside opts = Field
{ fieldParse = return . selectParser { fieldParse = return . selectParser
, fieldView = \theId name vals _ -> , fieldView = \theId name theClass vals _ ->
outside theId name $ do outside theId name $ do
flip mapM_ pairs $ \pair -> inside flip mapM_ pairs $ \pair -> inside
theId theId
name name
theClass
(pack $ show $ fst pair) (pack $ show $ fst pair)
((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values ((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
(fst $ snd pair) (fst $ snd pair)
@ -399,45 +402,47 @@ data Option a = Option
, optionExternalValue :: Text , optionExternalValue :: Text
} }
optionsPairs :: [(Text, a)] -> GGHandler sub master IO (OptionList a) optionsPairs :: [(Text, a)] -> GHandlerT sub master IO (OptionList a)
optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option
{ optionDisplay = display { optionDisplay = display
, optionInternalValue = internal , optionInternalValue = internal
, optionExternalValue = pack $ show external , optionExternalValue = pack $ show external
}) [1 :: Int ..] }) [1 :: Int ..]
optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO (OptionList a) optionsEnum :: (Show a, Enum a, Bounded a) => GHandlerT sub master IO (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO) optionsPersist :: ( YesodPersist master, PersistEntity a
, SinglePiece (Key (YesodPersistBackend master) a) , PersistQuery (YesodPersistBackend master) (GHandler sub master)
, PathPiece (Key (YesodPersistBackend master) a)
) )
=> [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO (OptionList (Key (YesodPersistBackend master) a, a)) => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GHandler sub master (OptionList (Key (YesodPersistBackend master) a, a))
optionsPersist filts ords toDisplay = fmap mkOptionList $ do optionsPersist filts ords toDisplay = fmap mkOptionList $ do
pairs <- runDB $ selectList filts ords pairs <- runDB $ selectList filts ords
return $ map (\(key, value) -> Option return $ map (\(key, value) -> Option
{ optionDisplay = toDisplay value { optionDisplay = toDisplay value
, optionInternalValue = (key, value) , optionInternalValue = (key, value)
, optionExternalValue = toSinglePiece key , optionExternalValue = toPathPiece key
}) pairs }) pairs
selectFieldHelper selectFieldHelper
:: (Eq a, RenderMessage master FormMessage) :: (Eq a, RenderMessage master FormMessage)
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ()) => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Bool -> GWidget sub master ()) -> (Text -> Text -> Bool -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ()) -> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())
-> GGHandler sub master IO (OptionList a) -> Field sub master a -> GHandlerT sub master IO (OptionList a) -> Field sub master a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x -> do { fieldParse = \x -> do
opts <- opts' opts <- opts'
return $ selectParser opts x return $ selectParser opts x
, fieldView = \theId name val isReq -> do , fieldView = \theId name theClass val isReq -> do
opts <- fmap olOptions $ lift $ liftIOHandler opts' opts <- fmap olOptions $ lift $ liftIOHandler opts'
outside theId name $ do outside theId name $ do
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
flip mapM_ opts $ \opt -> inside flip mapM_ opts $ \opt -> inside
theId theId
name name
theClass
(optionExternalValue opt) (optionExternalValue opt)
((render opts val) == optionExternalValue opt) ((render opts val) == optionExternalValue opt)
(optionDisplay opt) (optionDisplay opt)
@ -471,12 +476,13 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
let t = renderMessage master langs MsgValueRequired let t = renderMessage master langs MsgValueRequired
in (FormFailure [t], Just $ toHtml t) in (FormFailure [t], Just $ toHtml t)
Just fi -> (FormSuccess fi, Nothing) Just fi -> (FormSuccess fi, Nothing)
let theClass = fsClass fs
let fv = FieldView let fv = FieldView
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id' , fvId = id'
, fvInput = [WHAMLET| , fvInput = [WHAMLET|
<input type=file name=#{name} ##{id'}> <input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}">
|] |]
, fvErrors = errs , fvErrors = errs
, fvRequired = True , fvRequired = True
@ -499,12 +505,13 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
case Map.lookup name fenv of case Map.lookup name fenv of
Nothing -> (FormSuccess Nothing, Nothing) Nothing -> (FormSuccess Nothing, Nothing)
Just fi -> (FormSuccess $ Just fi, Nothing) Just fi -> (FormSuccess $ Just fi, Nothing)
let theClass = fsClass fs
let fv = FieldView let fv = FieldView
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id' , fvId = id'
, fvInput = [WHAMLET| , fvInput = [WHAMLET|
<input type=file name=#{name} ##{id'}> <input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}">
|] |]
, fvErrors = errs , fvErrors = errs
, fvRequired = False , fvRequired = False

8
yesod-form/Yesod/Form/Functions.hs
View File

@ -40,7 +40,7 @@ import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
import Text.Blaze (Html, toHtml) import Text.Blaze (Html, toHtml)
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod) import Yesod.Handler (GHandler, GHandlerT, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..)) import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..))
import Yesod.Widget (GWidget, whamlet) import Yesod.Widget (GWidget, whamlet)
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..)) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..))
@ -137,7 +137,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
{ fvLabel = toHtml $ mr2 fsLabel { fvLabel = toHtml $ mr2 fsLabel
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
, fvId = theId , fvId = theId
, fvInput = fieldView theId name val isReq , fvInput = fieldView theId name fsClass val isReq
, fvErrors = , fvErrors =
case res of case res of
FormFailure [e] -> Just $ toHtml e FormFailure [e] -> Just $ toHtml e
@ -157,7 +157,7 @@ aopt :: RenderMessage master msg
-> AForm sub master (Maybe a) -> AForm sub master (Maybe a)
aopt a b = formToAForm . mopt a b aopt a b = formToAForm . mopt a b
runFormGeneric :: MonadIO m => MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype) runFormGeneric :: MonadIO m => MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandlerT sub master m (a, Enctype)
runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1) runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1)
-- | This function is used to both initially render a form and to later extract -- | This function is used to both initially render a form and to later extract
@ -299,7 +299,7 @@ checkBool :: RenderMessage master msg
checkBool b s = check $ \x -> if b x then Right x else Left s checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: RenderMessage master msg checkM :: RenderMessage master msg
=> (a -> GGHandler sub master IO (Either msg a)) => (a -> GHandlerT sub master IO (Either msg a))
-> Field sub master a -> Field sub master a
-> Field sub master a -> Field sub master a
checkM f field = field checkM f field = field

4
yesod-form/Yesod/Form/Input.hs
View File

@ -11,7 +11,7 @@ module Yesod.Form.Input
import Yesod.Form.Types import Yesod.Form.Types
import Data.Text (Text) import Data.Text (Text)
import Control.Applicative (Applicative (..)) import Control.Applicative (Applicative (..))
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler) import Yesod.Handler (GHandler, GHandlerT, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler)
import Yesod.Request (reqGetParams, languages) import Yesod.Request (reqGetParams, languages)
import Control.Monad (liftM) import Control.Monad (liftM)
import Yesod.Message (RenderMessage (..), SomeMessage (..)) import Yesod.Message (RenderMessage (..), SomeMessage (..))
@ -19,7 +19,7 @@ import qualified Data.Map as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
type DText = [Text] -> [Text] type DText = [Text] -> [Text]
newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) } newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GHandlerT sub master IO (Either DText a) }
instance Functor (FormInput sub master) where instance Functor (FormInput sub master) where
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
instance Applicative (FormInput sub master) where instance Applicative (FormInput sub master) where

15
yesod-form/Yesod/Form/Jquery.hs
View File

@ -20,6 +20,7 @@ import Yesod.Form
import Yesod.Widget import Yesod.Widget
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
timeToTimeOfDay) timeToTimeOfDay)
import qualified Data.Text as T
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Default import Data.Default
import Text.Hamlet (shamlet) import Text.Hamlet (shamlet)
@ -78,9 +79,9 @@ jqueryDayField jds = Field
Right Right
. readMay . readMay
. unpack . unpack
, fieldView = \theId name val isReq -> do , fieldView = \theId name theClass val isReq -> do
addHtml [HTML|\ addHtml [HTML|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}">
|] |]
addScript' urlJqueryJs addScript' urlJqueryJs
addScript' urlJqueryUiJs addScript' urlJqueryUiJs
@ -129,9 +130,9 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime
jqueryDayTimeField = Field jqueryDayTimeField = Field
{ fieldParse = blank $ parseUTCTime . unpack { fieldParse = blank $ parseUTCTime . unpack
, fieldView = \theId name val isReq -> do , fieldView = \theId name theClass val isReq -> do
addHtml [HTML|\ addHtml [HTML|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" :isReq:required="" value="#{showVal val}">
|] |]
addScript' urlJqueryJs addScript' urlJqueryJs
addScript' urlJqueryUiJs addScript' urlJqueryUiJs
@ -159,9 +160,9 @@ jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master
=> Route master -> Field sub master Text => Route master -> Field sub master Text
jqueryAutocompleteField src = Field jqueryAutocompleteField src = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val isReq -> do , fieldView = \theId name theClass val isReq -> do
addHtml [HTML|\ addHtml [HTML|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete> <input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|] |]
addScript' urlJqueryJs addScript' urlJqueryJs
addScript' urlJqueryUiJs addScript' urlJqueryUiJs
@ -171,7 +172,7 @@ $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
|] |]
} }
addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) () addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- lift getYesod
addScriptEither $ f y addScriptEither $ f y

5
yesod-form/Yesod/Form/MassInput.hs
View File

@ -14,7 +14,7 @@ import Yesod.Form.Functions
import Yesod.Form.Fields (boolField) import Yesod.Form.Fields (boolField)
import Yesod.Widget (GWidget, whamlet) import Yesod.Widget (GWidget, whamlet)
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
import Yesod.Handler (newIdent, GGHandler) import Yesod.Handler (newIdent, GHandler)
import Text.Blaze (Html) import Text.Blaze (Html)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (pack) import Data.Text (pack)
@ -53,7 +53,7 @@ up i = do
IntCons _ is' -> put is' >> newFormIdent >> return () IntCons _ is' -> put is' >> newFormIdent >> return ()
up $ i - 1 up $ i - 1
inputList :: (m ~ GGHandler sub master IO, xml ~ GWidget sub master (), RenderMessage master FormMessage) inputList :: (m ~ GHandler sub master, xml ~ GWidget sub master (), RenderMessage master FormMessage)
=> Html => Html
-> ([[FieldView sub master]] -> xml) -> ([[FieldView sub master]] -> xml)
-> (Maybe a -> AForm sub master a) -> (Maybe a -> AForm sub master a)
@ -111,6 +111,7 @@ withDelete af = do
, fsTooltip = Nothing , fsTooltip = Nothing
, fsName = Just deleteName , fsName = Just deleteName
, fsId = Nothing , fsId = Nothing
, fsClass = []
} $ Just False } $ Just False
(res, xml) <- aFormToForm af (res, xml) <- aFormToForm af
return $ Right (res, xml $ xml2 []) return $ Right (res, xml $ xml2 [])

5
yesod-form/Yesod/Form/Nic.hs
View File

@ -20,6 +20,7 @@ import Text.Blaze.Renderer.String (renderHtml)
import Text.Blaze (preEscapedText) import Text.Blaze (preEscapedText)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
class YesodNic a where class YesodNic a where
@ -30,14 +31,14 @@ class YesodNic a where
nicHtmlField :: YesodNic master => Field sub master Html nicHtmlField :: YesodNic master => Field sub master Html
nicHtmlField = Field nicHtmlField = Field
{ fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe
, fieldView = \theId name val _isReq -> do , fieldView = \theId name theClass val _isReq -> do
addHtml addHtml
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
[shamlet| [shamlet|
#else #else
[$shamlet| [$shamlet|
#endif #endif
<textarea id="#{theId}" name="#{name}" .html>#{showVal val} <textarea id="#{theId}" :not (null theClass):class="#{T.intercalate " " theClass}" name="#{name}" .html>#{showVal val}
|] |]
addScript' urlNicEdit addScript' urlNicEdit
addJulius addJulius

17
yesod-form/Yesod/Form/Types.hs
View File

@ -10,7 +10,6 @@ module Yesod.Form.Types
, FileEnv , FileEnv
, Ints (..) , Ints (..)
-- * Form -- * Form
, Form
, MForm , MForm
, AForm (..) , AForm (..)
-- * Build forms -- * Build forms
@ -27,7 +26,7 @@ import Text.Blaze (Html, ToHtml (toHtml))
import Control.Applicative ((<$>), Applicative (..)) import Control.Applicative ((<$>), Applicative (..))
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.String (IsString (..)) import Data.String (IsString (..))
import Yesod.Core (GGHandler, GWidget, SomeMessage) import Yesod.Core (GHandlerT, GWidget, SomeMessage)
import qualified Data.Map as Map import qualified Data.Map as Map
-- | A form can produce three different results: there was no data available, -- | A form can produce three different results: there was no data available,
@ -75,12 +74,10 @@ type Env = Map.Map Text [Text]
type FileEnv = Map.Map Text FileInfo type FileEnv = Map.Map Text FileInfo
type Lang = Text type Lang = Text
type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandlerT sub master IO) a
{-# DEPRECATED Form "Use MForm instead" #-}
type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a
newtype AForm sub master a = AForm newtype AForm sub master a = AForm
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GGHandler sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype) { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandlerT sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype)
} }
instance Functor (AForm sub master) where instance Functor (AForm sub master) where
fmap f (AForm a) = fmap f (AForm a) =
@ -102,10 +99,11 @@ data FieldSettings msg = FieldSettings
, fsTooltip :: Maybe msg , fsTooltip :: Maybe msg
, fsId :: Maybe Text , fsId :: Maybe Text
, fsName :: Maybe Text , fsName :: Maybe Text
, fsClass :: [Text]
} }
instance (a ~ Text) => IsString (FieldSettings a) where instance (a ~ Text) => IsString (FieldSettings a) where
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing fromString s = FieldSettings (fromString s) Nothing Nothing Nothing []
data FieldView sub master = FieldView data FieldView sub master = FieldView
{ fvLabel :: Html { fvLabel :: Html
@ -117,10 +115,11 @@ data FieldView sub master = FieldView
} }
data Field sub master a = Field data Field sub master a = Field
{ fieldParse :: [Text] -> GGHandler sub master IO (Either (SomeMessage master) (Maybe a)) { fieldParse :: [Text] -> GHandlerT sub master IO (Either (SomeMessage master) (Maybe a))
-- | ID, name, (invalid text OR legimiate result), required? -- | ID, name, class, (invalid text OR legimiate result), required?
, fieldView :: Text , fieldView :: Text
-> Text -> Text
-> [Text]
-> Either Text a -> Either Text a
-> Bool -> Bool
-> GWidget sub master () -> GWidget sub master ()

15
yesod-form/yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form name: yesod-form
version: 0.3.4.2 version: 0.4.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -14,25 +14,24 @@ description: Form handling support for Yesod Web Framework
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9 && < 0.10 , yesod-core >= 0.10 && < 0.11
, yesod-persistent >= 0.2 && < 0.3 , yesod-persistent >= 0.3 && < 0.4
, time >= 1.1.4 , time >= 1.1.4
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11
, shakespeare-js >= 0.10 && < 0.11 , shakespeare-js >= 0.10 && < 0.11
, persistent >= 0.6 && < 0.7 , persistent >= 0.7 && < 0.8
, yesod-persistent >= 0.2 && < 0.3
, template-haskell , template-haskell
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, data-default >= 0.3 && < 0.4 , data-default >= 0.3 && < 0.4
, xss-sanitize >= 0.3.0.1 && < 0.4 , xss-sanitize >= 0.3.0.1 && < 0.4
, blaze-builder >= 0.2.1.4 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4
, network >= 2.2 && < 2.4 , network >= 2.2 && < 2.4
, email-validate >= 0.2.6 && < 0.3 , email-validate >= 0.2.6 && < 0.3
, blaze-html >= 0.4.1.3 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, text >= 0.9 && < 0.12 , text >= 0.9 && < 1.0
, wai >= 0.4 && < 0.5 , wai >= 1.0 && < 1.1
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
exposed-modules: Yesod.Form exposed-modules: Yesod.Form
Yesod.Form.Class Yesod.Form.Class

53
yesod-json/Yesod/Json.hs
View File

@ -7,14 +7,13 @@ module Yesod.Json
, jsonToRepJson , jsonToRepJson
-- * Convert to a JSON value -- * Convert to a JSON value
, parseJsonBody , parseJsonBody
-- * Compatibility wrapper for old API -- * Produce JSON values
, Json , J.Value (..)
, jsonScalar , object
, jsonList , array
, jsonMap
) where ) where
import Yesod.Handler (GHandler) import Yesod.Handler (GHandler, waiRequest)
import Yesod.Content import Yesod.Content
( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml)
, RepJson (RepJson), Content (ContentBuilder) , RepJson (RepJson), Content (ContentBuilder)
@ -24,33 +23,23 @@ import Yesod.Widget (GWidget)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.Encode as JE import qualified Data.Aeson.Encode as JE
import Data.Aeson.Encode (fromValue) import Data.Aeson.Encode (fromValue)
import Data.Attoparsec.Enumerator (iterParser) import Data.Conduit.Attoparsec (sinkParser)
import Data.Text (pack) import Data.Text (Text)
import Control.Arrow (first)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
#if MIN_VERSION_aeson(0, 4, 0)
import Data.HashMap.Strict (fromList)
#else
import Data.Map (fromList)
#endif
import qualified Data.Vector as V import qualified Data.Vector as V
import Text.Julius (ToJavascript (..)) import Text.Julius (ToJavascript (..))
import Data.Text.Lazy.Builder (fromLazyText) import Data.Text.Lazy.Builder (fromLazyText)
import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.Encoding (decodeUtf8)
#if MIN_VERSION_aeson(0, 5, 0)
import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder (toLazyText)
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
#endif import Data.Conduit (($$))
import Network.Wai (requestBody)
instance ToContent J.Value where instance ToContent J.Value where
#if MIN_VERSION_aeson(0, 5, 0)
toContent = flip ContentBuilder Nothing toContent = flip ContentBuilder Nothing
. Blaze.fromLazyText . Blaze.fromLazyText
. toLazyText . toLazyText
. fromValue . fromValue
#else
toContent = flip ContentBuilder Nothing . fromValue
#endif
-- | Provide both an HTML and JSON representation for a piece of data, using -- | Provide both an HTML and JSON representation for a piece of data, using
-- the default layout for the HTML output ('defaultLayout'). -- the default layout for the HTML output ('defaultLayout').
@ -70,19 +59,17 @@ jsonToRepJson = return . RepJson . toContent
-- --
-- /Since: 0.2.3/ -- /Since: 0.2.3/
parseJsonBody :: GHandler sub master J.Value parseJsonBody :: GHandler sub master J.Value
parseJsonBody = lift $ iterParser J.json' parseJsonBody = do
req <- waiRequest
lift $ requestBody req $$ sinkParser J.json'
type Json = J.Value
jsonScalar :: String -> Json
jsonScalar = J.String . pack
jsonList :: [Json] -> Json
jsonList = J.Array . V.fromList
jsonMap :: [(String, Json)] -> Json
jsonMap = J.Object . fromList . map (first pack)
instance ToJavascript J.Value where instance ToJavascript J.Value where
toJavascript = fromLazyText . decodeUtf8 . JE.encode toJavascript = fromLazyText . decodeUtf8 . JE.encode
-- | Convert a list of pairs to an 'J.Object'.
object :: [(Text, J.Value)] -> J.Value
object = J.object
-- | Convert a list of values to an 'J.Array'.
array :: [J.Value] -> J.Value
array = J.Array . V.fromList

15
yesod-json/yesod-json.cabal
View File

@ -1,5 +1,5 @@
name: yesod-json name: yesod-json
version: 0.2.3 version: 0.3.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -14,16 +14,17 @@ description: Generate content for Yesod using the aeson package.
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9 && < 0.10 , yesod-core >= 0.10 && < 0.11
, aeson >= 0.3 , aeson >= 0.5
, text >= 0.8 && < 0.12 , text >= 0.8 && < 1.0
, shakespeare-js >= 0.10 && < 0.11 , shakespeare-js >= 0.10 && < 0.11
, vector >= 0.9 , vector >= 0.9
, containers >= 0.2 && < 0.5 , containers >= 0.2
, unordered-containers
, blaze-builder , blaze-builder
, attoparsec-enumerator >= 0.3 && < 0.4 , attoparsec-conduit >= 0.0 && < 0.1
, conduit >= 0.0 && < 0.1
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, wai >= 1.0 && < 1.1
exposed-modules: Yesod.Json exposed-modules: Yesod.Json
ghc-options: -Wall ghc-options: -Wall

2
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -34,7 +34,7 @@ newtype RepAtom = RepAtom Content
instance HasReps RepAtom where instance HasReps RepAtom where
chooseRep (RepAtom c) _ = return (typeAtom, c) chooseRep (RepAtom c) _ = return (typeAtom, c)
atomFeed :: Monad mo => Feed (Route master) -> GGHandler sub master mo RepAtom atomFeed :: Feed (Route master) -> GHandler sub master RepAtom
atomFeed = liftM RepAtom . hamletToContent . template atomFeed = liftM RepAtom . hamletToContent . template
template :: Feed url -> HtmlUrl url template :: Feed url -> HtmlUrl url

4
yesod-newsfeed/Yesod/Feed.hs
View File

@ -25,7 +25,7 @@ import Yesod.FeedTypes
import Yesod.AtomFeed import Yesod.AtomFeed
import Yesod.RssFeed import Yesod.RssFeed
import Yesod.Content (HasReps (chooseRep), typeAtom, typeRss) import Yesod.Content (HasReps (chooseRep), typeAtom, typeRss)
import Yesod.Handler (Route, GGHandler) import Yesod.Handler (Route, GHandler)
data RepAtomRss = RepAtomRss RepAtom RepRss data RepAtomRss = RepAtomRss RepAtom RepRss
instance HasReps RepAtomRss where instance HasReps RepAtomRss where
@ -33,7 +33,7 @@ instance HasReps RepAtomRss where
[ (typeAtom, a) [ (typeAtom, a)
, (typeRss, r) , (typeRss, r)
] ]
newsFeed :: Monad mo => Feed (Route master) -> GGHandler sub master mo RepAtomRss newsFeed :: Feed (Route master) -> GHandler sub master RepAtomRss
newsFeed f = do newsFeed f = do
a <- atomFeed f a <- atomFeed f
r <- rssFeed f r <- rssFeed f

2
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -31,7 +31,7 @@ instance HasReps RepRss where
chooseRep (RepRss c) _ = return (typeRss, c) chooseRep (RepRss c) _ = return (typeRss, c)
-- | Generate the feed -- | Generate the feed
rssFeed :: Monad mo => Feed (Route master) -> GGHandler sub master mo RepRss rssFeed :: Feed (Route master) -> GHandler sub master RepRss
rssFeed = liftM RepRss . hamletToContent . template rssFeed = liftM RepRss . hamletToContent . template
template :: Feed url -> HtmlUrl url template :: Feed url -> HtmlUrl url

4
yesod-newsfeed/yesod-newsfeed.cabal
View File

@ -1,5 +1,5 @@
name: yesod-newsfeed name: yesod-newsfeed
version: 0.3.2 version: 0.4.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin
@ -14,7 +14,7 @@ description: Helper functions and data types for producing News feeds.
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9 && < 0.10 , yesod-core >= 0.10 && < 0.11
, time >= 1.1.4 , time >= 1.1.4
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10

11
yesod-persistent/Yesod/Persist.hs
View File

@ -6,25 +6,26 @@ module Yesod.Persist
, get404 , get404
, getBy404 , getBy404
, module Database.Persist , module Database.Persist
, module Database.Persist.Query
, module Database.Persist.TH , module Database.Persist.TH
) where ) where
import Database.Persist import Database.Persist
import Database.Persist.Query
import Database.Persist.TH import Database.Persist.TH
import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO)
import Control.Failure (Failure) import Control.Failure (Failure)
import Yesod.Handler import Yesod.Handler
type YesodDB sub master = YesodPersistBackend master (GGHandler sub master IO) type YesodDB sub master = YesodPersistBackend master (GHandler sub master)
class YesodPersist master where class YesodPersist master where
type YesodPersistBackend master :: (* -> *) -> * -> * type YesodPersistBackend master :: (* -> *) -> * -> *
runDB :: MonadIO monad => YesodDB sub master a -> GGHandler sub master monad a runDB :: YesodDB sub master a -> GHandler sub master a
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist. -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
get404 :: (PersistBackend t m, PersistEntity val, Monad (t m), get404 :: (PersistStore t m, PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t) Failure ErrorResponse m, MonadTrans t)
=> Key t val -> t m val => Key t val -> t m val
get404 key = do get404 key = do
@ -35,7 +36,7 @@ get404 key = do
-- | Get the given entity by unique key, or return a 404 not found if it doesn't -- | Get the given entity by unique key, or return a 404 not found if it doesn't
-- exist. -- exist.
getBy404 :: (PersistBackend t m, PersistEntity val, Monad (t m), getBy404 :: (PersistUnique t m, PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t) Failure ErrorResponse m, MonadTrans t)
=> Unique val t -> t m (Key t val, val) => Unique val t -> t m (Key t val, val)
getBy404 key = do getBy404 key = do

8
yesod-persistent/yesod-persistent.cabal
View File

@ -1,5 +1,5 @@
name: yesod-persistent name: yesod-persistent
version: 0.2.2 version: 0.3.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -14,9 +14,9 @@ description: Some helpers for using Persistent from Yesod.
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.8 && < 0.10 , yesod-core >= 0.10 && < 0.11
, persistent >= 0.6 && < 0.7 , persistent >= 0.7 && < 0.8
, persistent-template >= 0.6 && < 0.7 , persistent-template >= 0.7 && < 0.8
, failure >= 0.1 && < 0.2 , failure >= 0.1 && < 0.2
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
exposed-modules: Yesod.Persist exposed-modules: Yesod.Persist

83
yesod-sitemap/Yesod/Helpers/Sitemap.hs
View File

@ -1,83 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
---------------------------------------------------------
--
-- Module : Yesod.Helpers.Sitemap
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Stable
-- Portability : portable
--
-- Generating Google sitemap files.
--
---------------------------------------------------------
-- | Generates XML sitemap files.
--
-- See <http://www.sitemaps.org/>.
module Yesod.Helpers.Sitemap
( sitemap
, robots
, SitemapUrl (..)
, SitemapChangeFreq (..)
) where
import Yesod.Content (RepXml (..), RepPlain (..), toContent, formatW3)
import Yesod.Handler (Route, GHandler, getUrlRender)
import Yesod.Handler (hamletToContent)
import Text.Hamlet (Hamlet, xhamlet)
import Data.Time (UTCTime)
import Data.Monoid (mappend)
data SitemapChangeFreq = Always
| Hourly
| Daily
| Weekly
| Monthly
| Yearly
| Never
showFreq :: SitemapChangeFreq -> String
showFreq Always = "always"
showFreq Hourly = "hourly"
showFreq Daily = "daily"
showFreq Weekly = "weekly"
showFreq Monthly = "monthly"
showFreq Yearly = "yearly"
showFreq Never = "never"
data SitemapUrl url = SitemapUrl
{ sitemapLoc :: url
, sitemapLastMod :: UTCTime
, sitemapChangeFreq :: SitemapChangeFreq
, priority :: Double
}
template :: [SitemapUrl url] -> Hamlet url
template urls =
#if __GLASGOW_HASKELL__ >= 700
[xhamlet|
#else
[$xhamlet|
#endif
<urlset xmlns="http://www.sitemaps.org/schemas/sitemap/0.9">
$forall url <- urls
<url>
<loc>@{sitemapLoc url}
<lastmod>#{formatW3 (sitemapLastMod url)}
<changefreq>#{showFreq (sitemapChangeFreq url)}
<priority>#{show (priority url)}
|]
sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml
sitemap = fmap RepXml . hamletToContent . template
-- | A basic robots file which just lists the "Sitemap: " line.
robots :: Route master -- ^ sitemap url
-> GHandler sub master RepPlain
robots smurl = do
render <- getUrlRender
return $ RepPlain $ toContent $ "Sitemap: " `mappend` render smurl

4
yesod-sitemap/yesod-sitemap.cabal
View File

@ -1,5 +1,5 @@
name: yesod-sitemap name: yesod-sitemap
version: 0.2.2 version: 0.3.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -14,7 +14,7 @@ description: Generate XML sitemaps.
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9 && < 0.10 , yesod-core >= 0.10 && < 0.11
, time >= 1.1.4 , time >= 1.1.4
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
exposed-modules: Yesod.Sitemap exposed-modules: Yesod.Sitemap

8
yesod-static/Yesod/Static.hs
View File

@ -68,9 +68,9 @@ import qualified Data.ByteString as S
import Network.HTTP.Types (status301) import Network.HTTP.Types (status301)
import System.PosixCompat.Files (getFileStatus, modificationTime) import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime) import System.Posix.Types (EpochTime)
import qualified Data.Enumerator as E import qualified Data.Conduit as C
import qualified Data.Enumerator.List as EL import qualified Data.Conduit.Binary as CB
import qualified Data.Enumerator.Binary as EB import qualified Data.Conduit.List as CL
import Network.Wai.Application.Static import Network.Wai.Application.Static
( StaticSettings (..) ( StaticSettings (..)
@ -282,7 +282,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
-- descriptors -- descriptors
base64md5File :: Prelude.FilePath -> IO String base64md5File :: Prelude.FilePath -> IO String
base64md5File file = do base64md5File file = do
bss <- E.run_ $ EB.enumFile file E.$$ EL.consume bss <- C.runResourceT $ CB.sourceFile file C.$$ CL.consume
return $ base64md5 $ L.fromChunks bss return $ base64md5 $ L.fromChunks bss
-- FIXME I'd like something streaming instead -- FIXME I'd like something streaming instead
{- {-

48
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static name: yesod-static
version: 0.3.2.1 version: 0.10.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -26,7 +26,7 @@ library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
, old-time >= 1.0 , old-time >= 1.0
, yesod-core >= 0.9 && < 0.10 , yesod-core >= 0.10 && < 0.11
, base64-bytestring >= 0.1.0.1 && < 0.2 , base64-bytestring >= 0.1.0.1 && < 0.2
, pureMD5 >= 2.1.0.3 && < 2.2 , pureMD5 >= 2.1.0.3 && < 2.2
, cereal >= 0.3 && < 0.4 , cereal >= 0.3 && < 0.4
@ -34,43 +34,43 @@ library
, template-haskell , template-haskell
, directory >= 1.0 && < 1.2 , directory >= 1.0 && < 1.2
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, wai-app-static >= 0.3.2.1 && < 0.4 , wai-app-static >= 1.0 && < 1.1
, wai >= 0.4 && < 0.5 , wai >= 1.0 && < 1.1
, text >= 0.9 && < 0.12 , text >= 0.9 && < 1.0
, file-embed >= 0.0.4.1 && < 0.5 , file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.6.5 && < 0.7 , http-types >= 0.6.5 && < 0.7
, unix-compat >= 0.2 , unix-compat >= 0.2
, enumerator >= 0.4.8 && < 0.5 , conduit >= 0.0
exposed-modules: Yesod.Static exposed-modules: Yesod.Static
ghc-options: -Wall ghc-options: -Wall
test-suite tests test-suite tests
hs-source-dirs: ., test hs-source-dirs: test
main-is: tests.hs main-is: tests.hs
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
cpp-options: -DTEST cpp-options: -DTEST
build-depends: build-depends:
hspec >= 0.8 && < 0.10 hspec >= 0.8 && < 0.10
, HUnit , HUnit
, yesod-static
-- copy from above -- copy from above
, base >= 4 && < 5 , base
, containers >= 0.2 && < 0.5 , containers
, old-time >= 1.0 , old-time
, yesod-core >= 0.9 && < 0.10 , yesod-core
, base64-bytestring >= 0.1.0.1 && < 0.2 , base64-bytestring
, pureMD5 >= 2.1.0.3 && < 2.2 , pureMD5
, cereal >= 0.3 && < 0.4 , cereal
, bytestring >= 0.9.1.4 && < 0.10 , bytestring
, template-haskell , template-haskell
, directory >= 1.0 && < 1.2 , directory
, transformers >= 0.2.2 && < 0.3 , transformers
, wai-app-static >= 0.3.2.1 && < 0.4 , wai-app-static
, wai >= 0.4 && < 0.5 , wai
, text >= 0.9 && < 0.12 , text
, file-embed >= 0.0.4.1 && < 0.5 , file-embed
, http-types >= 0.6.5 && < 0.7 , http-types
, unix-compat >= 0.2 , unix-compat
, enumerator >= 0.4.8 && < 0.5
ghc-options: -Wall ghc-options: -Wall

4
yesod/Scaffolding/Scaffolder.hs
View File

@ -66,8 +66,8 @@ scaffold = do
backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends
let (backend, importGenericDB, dbMonad, importPersist, mkPersistSettings) = let (backend, importGenericDB, dbMonad, importPersist, mkPersistSettings) =
case backendC of case backendC of
"s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlSettings") "s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlMkSettings")
"p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlSettings") "p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlMkSettings")
"m" -> (MongoDB, "MongoDB", "Action", "MongoDB", "MkPersistSettings { mpsBackend = ConT ''Action }") "m" -> (MongoDB, "MongoDB", "Action", "MongoDB", "MkPersistSettings { mpsBackend = ConT ''Action }")
"t" -> (Tiny, "","","",undefined) "t" -> (Tiny, "","","",undefined)
_ -> error $ "Invalid backend: " ++ backendC _ -> error $ "Invalid backend: " ++ backendC

9
yesod/Yesod.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-- | This module simply re-exports from other modules for your convenience. -- | This module simply re-exports from other modules for your convenience.
module Yesod module Yesod
( -- * Re-exports from yesod-core ( -- * Re-exports from yesod-core
@ -15,11 +14,7 @@ module Yesod
, Application , Application
, lift , lift
, liftIO , liftIO
#if MIN_VERSION_monad_control(0, 3, 0)
, MonadBaseControl , MonadBaseControl
#else
, MonadControlIO
#endif
-- * Utilities -- * Utilities
, showIntegral , showIntegral
, readIntegral , readIntegral
@ -54,11 +49,7 @@ import Network.Wai (Application)
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
#if MIN_VERSION_monad_control(0, 3, 0)
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
#else
import Control.Monad.IO.Control (MonadControlIO)
#endif
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
import System.IO (stderr, hPutStrLn) import System.IO (stderr, hPutStrLn)

16
yesod/scaffold/Application.hs.cg
View File

@ -19,7 +19,7 @@ import Network.Wai.Middleware.RequestLogger (logHandleDev)
import Yesod.Logger (Logger) import Yesod.Logger (Logger)
import Network.Wai.Middleware.RequestLogger (logStdout) import Network.Wai.Middleware.RequestLogger (logStdout)
#endif #endif
import qualified Database.Persist.Base~importMigration~ import qualified Database.Persist.Store~importMigration~
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
import Handler.Root import Handler.Root
@ -33,12 +33,12 @@ mkYesodDispatch "~sitearg~" resources~sitearg~
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
with~sitearg~ :: AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO () with~sitearg~ :: AppConfig DefaultEnv Extra -> Logger -> (Application -> IO ()) -> IO ()
with~sitearg~ conf logger f = do with~sitearg~ conf logger f = do
s <- staticSite s <- staticSite
dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf) dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf)
$ either error return . Database.Persist.Base.loadConfig $ either error return . Database.Persist.Store.loadConfig
Database.Persist.Base.withPool (dbconf :: Settings.PersistConfig) $ \p -> do~runMigration~ Database.Persist.Store.withPool (dbconf :: Settings.PersistConfig) $ \p -> do~runMigration~
let h = ~sitearg~ conf logger s p let h = ~sitearg~ conf logger s p
defaultRunner (f . logWare) h defaultRunner (f . logWare) h
where where
@ -50,4 +50,10 @@ with~sitearg~ conf logger f = do
-- for yesod devel -- for yesod devel
withDevelAppPort :: Dynamic withDevelAppPort :: Dynamic
withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~ withDevelAppPort =
toDyn $ defaultDevelAppWith loader with~sitearg~
where
loader = loadConfig (configSettings Development)
{ csLoadExtra = loadExtra
}

13
yesod/scaffold/Foundation.hs.cg
View File

@ -16,7 +16,7 @@ module Foundation
) where ) where
import Prelude import Prelude
import Yesod hiding (Form, AppConfig (..), withYamlEnvironment) import Yesod
import Yesod.Static (Static, base64md5, StaticRoute(..)) import Yesod.Static (Static, base64md5, StaticRoute(..))
import Settings.StaticFiles import Settings.StaticFiles
import Yesod.Auth import Yesod.Auth
@ -29,9 +29,9 @@ import Yesod.Logger (logLazyText)
#endif #endif
import qualified Settings import qualified Settings
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Database.Persist.Base import qualified Database.Persist.Store
import Database.Persist.~importGenericDB~ import Database.Persist.~importGenericDB~
import Settings (widgetFile) import Settings (widgetFile, Extra)
import Model import Model
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import Web.ClientSession (getKey) import Web.ClientSession (getKey)
@ -47,10 +47,10 @@ import Network.Mail.Mime (sendmail)
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data ~sitearg~ = ~sitearg~ data ~sitearg~ = ~sitearg~
{ settings :: AppConfig DefaultEnv () { settings :: AppConfig DefaultEnv Extra
, getLogger :: Logger , getLogger :: Logger
, getStatic :: Static -- ^ Settings for static file serving. , getStatic :: Static -- ^ Settings for static file serving.
, connPool :: Database.Persist.Base.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool. , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
} }
-- Set up i18n messages. See the message folder. -- Set up i18n messages. See the message folder.
@ -125,8 +125,7 @@ instance Yesod ~sitearg~ where
-- How to run database actions. -- How to run database actions.
instance YesodPersist ~sitearg~ where instance YesodPersist ~sitearg~ where
type YesodPersistBackend ~sitearg~ = ~dbMonad~ type YesodPersistBackend ~sitearg~ = ~dbMonad~
runDB f = liftIOHandler runDB f = fmap connPool getYesod >>= Database.Persist.Store.runPool (undefined :: Settings.PersistConfig) f
$ fmap connPool getYesod >>= Database.Persist.Base.runPool (undefined :: Settings.PersistConfig) f
instance YesodAuth ~sitearg~ where instance YesodAuth ~sitearg~ where
type AuthId ~sitearg~ = UserId type AuthId ~sitearg~ = UserId

4
yesod/scaffold/Model.hs.cg
View File

@ -3,11 +3,13 @@ module Model where
import Prelude import Prelude
import Yesod import Yesod
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Quasi
~modelImports~ ~modelImports~
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
-- at: -- at:
-- http://www.yesodweb.com/book/persistent/ -- http://www.yesodweb.com/book/persistent/
share [mkPersist ~mkPersistSettings~, mkMigrate "migrateAll"] $(persistFile "config/models") share [mkPersist ~mkPersistSettings~, mkMigrate "migrateAll"]
$(persistFile upperCaseSettings "config/models")

11
yesod/scaffold/Settings.hs.cg
View File

@ -8,15 +8,18 @@ module Settings
, PersistConfig , PersistConfig
, staticRoot , staticRoot
, staticDir , staticDir
, Extra (..)
, loadExtra
) where ) where
import Prelude (FilePath, String) import Prelude
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Database.Persist.~importPersist~ (~configPersist~) import Database.Persist.~importPersist~ (~configPersist~)
import Yesod.Default.Config import Yesod.Default.Config
import qualified Yesod.Default.Util import qualified Yesod.Default.Util
import Data.Text (Text) import Data.Text (Text)
import Data.Yaml
-- | Which Persistent backend this site is using. -- | Which Persistent backend this site is using.
type PersistConfig = ~configPersist~ type PersistConfig = ~configPersist~
@ -54,3 +57,9 @@ widgetFile = Yesod.Default.Util.widgetFileReload
#else #else
widgetFile = Yesod.Default.Util.widgetFileNoReload widgetFile = Yesod.Default.Util.widgetFileNoReload
#endif #endif
data Extra = Extra
loadExtra :: DefaultEnv -> Value -> IO Extra
loadExtra _ _ = return Extra

9
yesod/scaffold/main.hs.cg
View File

@ -1,7 +1,8 @@
import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain)
import Application (with~sitearg~)
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgsExtra)
import Yesod.Default.Main (defaultMain)
import Settings (loadExtra)
import Application (with~sitearg~)
main :: IO () main :: IO ()
main = defaultMain fromArgs with~sitearg~ main = defaultMain (fromArgsExtra loadExtra) with~sitearg~

21
yesod/scaffold/project.cabal.cg
View File

@ -74,24 +74,25 @@ executable ~project~
FlexibleContexts FlexibleContexts
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 0.9.3.4 && < 0.10 , yesod >= 0.10 && < 0.11
, yesod-core >= 0.9.3 && < 0.10 , yesod-core >= 0.10 && < 0.11
, yesod-auth >= 0.7.3 && < 0.8 , yesod-auth >= 0.8 && < 0.9
, yesod-static >= 0.3.1 && < 0.4 , yesod-static >= 0.10 && < 0.11
, yesod-default >= 0.5 && < 0.6 , yesod-default >= 0.6 && < 0.7
, yesod-form >= 0.3.4 && < 0.4 , yesod-form >= 0.4 && < 0.5
, mime-mail >= 0.3.0.3 && < 0.5 , mime-mail >= 0.3.0.3 && < 0.5
, clientsession >= 0.7.3 && < 0.8 , clientsession >= 0.7.3 && < 0.8
, bytestring >= 0.9 && < 0.10 , bytestring >= 0.9 && < 0.10
, text >= 0.11 && < 0.12 , text >= 0.11 && < 0.12
, persistent >= 0.6.2 && < 0.7 , persistent >= 0.7 && < 0.8
, persistent-~backendLower~ >= 0.6 && < 0.7 , persistent-~backendLower~ >= 0.7 && < 0.8
, template-haskell , template-haskell
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11
, shakespeare-js >= 0.10 && < 0.11 , shakespeare-js >= 0.10 && < 0.11
, shakespeare-text >= 0.10 && < 0.11 , shakespeare-text >= 0.10 && < 0.11
, hjsmin >= 0.0.14 && < 0.1 , hjsmin >= 0.0.14 && < 0.1
, monad-control ~monadControlVersion~ , monad-control >= 0.3 && < 0.4
, wai-extra >= 0.4.6 && < 0.5 , wai-extra >= 1.0 && < 1.1
, yaml >= 0.5 && < 0.6

13
yesod/scaffold/tiny/Application.hs.cg
View File

@ -5,9 +5,10 @@ module Application
) where ) where
import Import import Import
import Settings (loadExtra)
import Settings.StaticFiles (staticSite) import Settings.StaticFiles (staticSite)
import Yesod.Default.Config import Yesod.Default.Config
import Yesod.Default.Main (defaultDevelApp, defaultRunner) import Yesod.Default.Main (defaultDevelAppWith, defaultRunner)
import Yesod.Default.Handlers (getFaviconR, getRobotsR) import Yesod.Default.Handlers (getFaviconR, getRobotsR)
import Yesod.Logger (Logger) import Yesod.Logger (Logger)
import Network.Wai (Application) import Network.Wai (Application)
@ -25,7 +26,7 @@ mkYesodDispatch "~sitearg~" resources~sitearg~
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
with~sitearg~ :: AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO () with~sitearg~ :: AppConfig DefaultEnv Extra -> Logger -> (Application -> IO ()) -> IO ()
with~sitearg~ conf logger f = do with~sitearg~ conf logger f = do
s <- staticSite s <- staticSite
let h = ~sitearg~ conf logger s let h = ~sitearg~ conf logger s
@ -33,4 +34,10 @@ with~sitearg~ conf logger f = do
-- for yesod devel -- for yesod devel
withDevelAppPort :: Dynamic withDevelAppPort :: Dynamic
withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~ withDevelAppPort =
toDyn $ defaultDevelAppWith loader with~sitearg~
where
loader = loadConfig (configSettings Development)
{ csLoadExtra = loadExtra
}

6
yesod/scaffold/tiny/Foundation.hs.cg
View File

@ -13,14 +13,14 @@ module Foundation
) where ) where
import Prelude import Prelude
import Yesod.Core hiding (AppConfig (..)) import Yesod.Core
import Yesod.Default.Config import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Static (Static, base64md5, StaticRoute(..)) import Yesod.Static (Static, base64md5, StaticRoute(..))
import Settings.StaticFiles import Settings.StaticFiles
import Yesod.Logger (Logger, logMsg, formatLogText) import Yesod.Logger (Logger, logMsg, formatLogText)
import qualified Settings import qualified Settings
import Settings (widgetFile) import Settings (Extra, widgetFile)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Web.ClientSession (getKey) import Web.ClientSession (getKey)
@ -31,7 +31,7 @@ import Text.Hamlet (hamletFile)
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data ~sitearg~ = ~sitearg~ data ~sitearg~ = ~sitearg~
{ settings :: AppConfig DefaultEnv () { settings :: AppConfig DefaultEnv Extra
, getLogger :: Logger , getLogger :: Logger
, getStatic :: Static -- ^ Settings for static file serving. , getStatic :: Static -- ^ Settings for static file serving.
} }

10
yesod/scaffold/tiny/Settings.hs.cg
View File

@ -7,14 +7,17 @@ module Settings
( widgetFile ( widgetFile
, staticRoot , staticRoot
, staticDir , staticDir
, Extra (..)
, loadExtra
) where ) where
import Prelude (FilePath, String) import Prelude
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Yesod.Default.Config import Yesod.Default.Config
import qualified Yesod.Default.Util import qualified Yesod.Default.Util
import Data.Text (Text) import Data.Text (Text)
import Data.Yaml
-- | The location of static files on your system. This is a file system -- | The location of static files on your system. This is a file system
-- path. The default value works properly with your scaffolded site. -- path. The default value works properly with your scaffolded site.
@ -43,3 +46,8 @@ widgetFile = Yesod.Default.Util.widgetFileReload
#else #else
widgetFile = Yesod.Default.Util.widgetFileNoReload widgetFile = Yesod.Default.Util.widgetFileNoReload
#endif #endif
data Extra = Extra
loadExtra :: DefaultEnv -> Value -> IO Extra
loadExtra _ _ = return Extra

9
yesod/scaffold/tiny/project.cabal.cg
View File

@ -66,16 +66,17 @@ executable ~project~
TypeFamilies TypeFamilies
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9.3 && < 0.10 , yesod-core >= 0.10 && < 0.11
, yesod-static >= 0.3.1 && < 0.4 , yesod-static >= 0.10 && < 0.11
, yesod-default >= 0.5 && < 0.6 , yesod-default >= 0.6 && < 0.7
, clientsession >= 0.7.3 && < 0.8 , clientsession >= 0.7.3 && < 0.8
, bytestring >= 0.9 && < 0.10 , bytestring >= 0.9 && < 0.10
, text >= 0.11 && < 0.12 , text >= 0.11 && < 0.12
, template-haskell , template-haskell
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-text >= 0.10 && < 0.11 , shakespeare-text >= 0.10 && < 0.11
, wai >= 0.4.2 && < 0.5 , wai >= 1.0 && < 1.1
, transformers >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3
, monad-control >= 0.3 && < 0.4 , monad-control >= 0.3 && < 0.4
, yaml >= 0.5 && < 0.6

20
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod name: yesod
version: 0.9.4.1 version: 0.10.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -71,19 +71,19 @@ library
cpp-options: -DGHC7 cpp-options: -DGHC7
else else
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
build-depends: yesod-core >= 0.9.3.4 && < 0.10 build-depends: yesod-core >= 0.10 && < 0.11
, yesod-auth >= 0.7 && < 0.8 , yesod-auth >= 0.8 && < 0.9
, yesod-json >= 0.2.2 && < 0.3 , yesod-json >= 0.3 && < 0.4
, yesod-persistent >= 0.2 && < 0.3 , yesod-persistent >= 0.3 && < 0.4
, yesod-form >= 0.3 && < 0.4 , yesod-form >= 0.4 && < 0.5
, monad-control >= 0.2 && < 0.4 , monad-control >= 0.3 && < 0.4
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, wai >= 0.4 && < 0.5 , wai >= 1.0 && < 1.1
, wai-extra >= 0.4.6 && < 0.5 , wai-extra >= 1.0 && < 1.1
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-js >= 0.10 && < 0.11 , shakespeare-js >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11
, warp >= 0.4 && < 0.5 , warp >= 1.0 && < 1.1
, blaze-html >= 0.4.1.3 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5
exposed-modules: Yesod exposed-modules: Yesod
ghc-options: -Wall ghc-options: -Wall