Merge branch 'beta'
This commit is contained in:
Michael Snoyman
commit
8e623d04a6
@ -73,7 +73,7 @@ data Creds m = Creds
|
||||
, 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
|
||||
|
||||
-- | Default destination on successful login, if no other
|
||||
@ -133,7 +133,7 @@ setCreds doRedirects creds = do
|
||||
Just ar -> do setMessageI Msg.InvalidLogin
|
||||
redirect RedirectTemporary ar
|
||||
Just aid -> do
|
||||
setSession credsKey $ toSinglePiece aid
|
||||
setSession credsKey $ toPathPiece aid
|
||||
when doRedirects $ do
|
||||
setMessageI Msg.NowLoggedIn
|
||||
redirectUltDest RedirectTemporary $ loginDest y
|
||||
@ -189,12 +189,12 @@ maybeAuthId = do
|
||||
ms <- lookupSession credsKey
|
||||
case ms of
|
||||
Nothing -> return Nothing
|
||||
Just s -> return $ fromSinglePiece s
|
||||
Just s -> return $ fromPathPiece s
|
||||
|
||||
maybeAuth :: ( YesodAuth m
|
||||
, b ~ YesodPersistBackend m
|
||||
, Key b val ~ AuthId m
|
||||
, PersistBackend b (GGHandler s m IO)
|
||||
, PersistStore b (GHandler s m)
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Maybe (Key b val, val))
|
||||
@ -209,7 +209,7 @@ requireAuthId = maybeAuthId >>= maybe redirectLogin return
|
||||
requireAuth :: ( YesodAuth m
|
||||
, b ~ YesodPersistBackend m
|
||||
, Key b val ~ AuthId m
|
||||
, PersistBackend b (GGHandler s m IO)
|
||||
, PersistStore b (GHandler s m)
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Key b val, val)
|
||||
|
||||
@ -60,7 +60,7 @@ data EmailCreds m = EmailCreds
|
||||
, emailCredsVerkey :: Maybe VerKey
|
||||
}
|
||||
|
||||
class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where
|
||||
class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where
|
||||
type AuthEmailId m
|
||||
|
||||
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
|
||||
@ -102,7 +102,7 @@ authEmail =
|
||||
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
|
||||
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
|
||||
dispatch "GET" ["verify", eid, verkey] =
|
||||
case fromSinglePiece eid of
|
||||
case fromPathPiece eid of
|
||||
Nothing -> notFound
|
||||
Just eid' -> getVerifyR eid' verkey >>= sendResponse
|
||||
dispatch "POST" ["login"] = postLoginR >>= sendResponse
|
||||
@ -142,7 +142,7 @@ postRegisterR = do
|
||||
return (lid, key)
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ verify (toSinglePiece lid) verKey
|
||||
let verUrl = render $ tm $ verify (toPathPiece lid) verKey
|
||||
sendVerifyEmail email verKey verUrl
|
||||
defaultLayout $ do
|
||||
setTitleI Msg.ConfirmationEmailSentTitle
|
||||
|
||||
@ -49,7 +49,7 @@ facebookLogout = PluginR "facebook" ["logout"]
|
||||
-- @Nothing@ if it's not found (probably because the user is not
|
||||
-- logged in via Facebook). Note that the returned access token
|
||||
-- may have expired.
|
||||
getFacebookAccessToken :: MonadIO mo => GGHandler sub master mo (Maybe Facebook.AccessToken)
|
||||
getFacebookAccessToken :: GHandler sub master (Maybe Facebook.AccessToken)
|
||||
getFacebookAccessToken =
|
||||
liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey)
|
||||
|
||||
|
||||
@ -137,7 +137,8 @@ setPassword pwd u = do salt <- randomSalt
|
||||
-- the database values.
|
||||
validateUser :: ( YesodPersist yesod
|
||||
, b ~ YesodPersistBackend yesod
|
||||
, PersistBackend b (GGHandler sub yesod IO)
|
||||
, PersistStore b (GHandler sub yesod)
|
||||
, PersistUnique b (GHandler sub yesod)
|
||||
, PersistEntity user
|
||||
, HashDBUser user
|
||||
) =>
|
||||
@ -163,7 +164,8 @@ login = PluginR "hashdb" ["login"]
|
||||
postLoginR :: ( YesodAuth y, YesodPersist y
|
||||
, b ~ YesodPersistBackend y
|
||||
, 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))
|
||||
-> GHandler Auth y ()
|
||||
postLoginR uniq = do
|
||||
@ -186,7 +188,8 @@ getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
|
||||
, HashDBUser user, PersistEntity user
|
||||
, Key b user ~ AuthId 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
|
||||
-> (Text -> Maybe (Unique user b)) -- ^ gets user ID
|
||||
-> Creds master -- ^ the creds argument
|
||||
@ -213,7 +216,8 @@ authHashDB :: ( YesodAuth m, YesodPersist m
|
||||
, HashDBUser user
|
||||
, PersistEntity user
|
||||
, 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
|
||||
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
|
||||
[QQ(hamlet)|
|
||||
@ -252,8 +256,8 @@ authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Generate data base instances for a valid user
|
||||
share2 (mkPersist sqlSettings) (mkMigrate "migrateUsers")
|
||||
[QQ(persist)|
|
||||
share2 (mkPersist sqlMkSettings) (mkMigrate "migrateUsers")
|
||||
[QQ(persistUpperCase)|
|
||||
User
|
||||
username Text Eq
|
||||
password Text
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-auth
|
||||
version: 0.7.9
|
||||
version: 0.8.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -21,10 +21,10 @@ library
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
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
|
||||
, yesod-core >= 0.9.3.4 && < 0.10
|
||||
, wai >= 0.4 && < 0.5
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, wai >= 1.0 && < 1.1
|
||||
, template-haskell
|
||||
, pureMD5 >= 2.0 && < 2.2
|
||||
, random >= 1.0.0.2 && < 1.1
|
||||
@ -32,19 +32,19 @@ library
|
||||
, text >= 0.7 && < 0.12
|
||||
, mime-mail >= 0.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
|
||||
, shakespeare-css >= 0.10 && < 0.11
|
||||
, yesod-json >= 0.2 && < 0.3
|
||||
, yesod-json >= 0.3 && < 0.4
|
||||
, containers
|
||||
, unordered-containers
|
||||
, yesod-form >= 0.3 && < 0.4
|
||||
, yesod-form >= 0.4 && < 0.5
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, persistent >= 0.6 && < 0.7
|
||||
, persistent-template >= 0.6 && < 0.7
|
||||
, persistent >= 0.7 && < 0.8
|
||||
, persistent-template >= 0.7 && < 0.8
|
||||
, SHA >= 1.4.1.3 && < 1.6
|
||||
, http-enumerator >= 0.6 && < 0.8
|
||||
, aeson >= 0.3
|
||||
, http-conduit >= 1.0 && < 1.1
|
||||
, aeson >= 0.5
|
||||
, pwstore-fast >= 2.2 && < 3
|
||||
|
||||
exposed-modules: Yesod.Auth
|
||||
|
||||
@ -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
|
||||
@ -54,7 +54,6 @@ import System.Locale
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified Data.Text.Lazy.Encoding
|
||||
|
||||
import Data.Enumerator (Enumerator)
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
@ -62,9 +61,10 @@ import Text.Hamlet (Html)
|
||||
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.String (IsString (fromString))
|
||||
import Network.Wai (FilePart)
|
||||
import Data.Conduit (Source)
|
||||
|
||||
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)
|
||||
|
||||
-- | Zero-length enumerator.
|
||||
|
||||
@ -34,7 +34,6 @@ module Yesod.Core
|
||||
, module Yesod.Request
|
||||
, module Yesod.Widget
|
||||
, module Yesod.Message
|
||||
, module Yesod.Config
|
||||
) where
|
||||
|
||||
import Yesod.Internal.Core
|
||||
@ -44,7 +43,6 @@ import Yesod.Handler
|
||||
import Yesod.Request
|
||||
import Yesod.Widget
|
||||
import Yesod.Message
|
||||
import Yesod.Config
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Text (Text)
|
||||
|
||||
@ -15,8 +15,8 @@ module Yesod.Dispatch
|
||||
, mkYesodDispatch
|
||||
, mkYesodSubDispatch
|
||||
-- ** Path pieces
|
||||
, SinglePiece (..)
|
||||
, MultiPiece (..)
|
||||
, PathPiece (..)
|
||||
, PathMultiPiece (..)
|
||||
, Texts
|
||||
-- * Convert to WAI
|
||||
, toWaiApp
|
||||
@ -31,7 +31,7 @@ import Yesod.Handler
|
||||
import Yesod.Internal.Dispatch
|
||||
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 Language.Haskell.TH.Syntax
|
||||
|
||||
|
||||
@ -28,7 +28,7 @@ module Yesod.Handler
|
||||
, YesodSubRoute (..)
|
||||
-- * Handler monad
|
||||
, GHandler
|
||||
, GGHandler
|
||||
, GHandlerT
|
||||
-- ** Read information from handler
|
||||
, getYesod
|
||||
, getYesodSub
|
||||
@ -148,8 +148,6 @@ import qualified Data.Text.Lazy as TL
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString as S
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Enumerator (Iteratee (..), run_, ($$))
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
|
||||
import Yesod.Content
|
||||
@ -160,17 +158,21 @@ import qualified Network.Wai.Parse as NWP
|
||||
import Data.Monoid (mappend, mempty, Endo (..))
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
import Text.Blaze (toHtml, preEscapedText)
|
||||
import Yesod.Internal.TestApi (catchIter)
|
||||
|
||||
import qualified Yesod.Internal.Cache as Cache
|
||||
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Data.IORef as I
|
||||
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.
|
||||
type family Route a
|
||||
@ -206,22 +208,22 @@ handlerSubDataMaybe tm ts route hd = hd
|
||||
, handlerRoute = route
|
||||
}
|
||||
|
||||
get :: MonadIO monad => GGHandler sub master monad GHState
|
||||
get :: MonadIO monad => GHandlerT sub master monad GHState
|
||||
get = do
|
||||
hd <- ask
|
||||
liftIO $ I.readIORef $ handlerState hd
|
||||
|
||||
put :: MonadIO monad => GHState -> GGHandler sub master monad ()
|
||||
put :: MonadIO monad => GHState -> GHandlerT sub master monad ()
|
||||
put g = do
|
||||
hd <- ask
|
||||
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
|
||||
hd <- ask
|
||||
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 }
|
||||
|
||||
-- | 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)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> GGHandler sub master mo a
|
||||
-> GGHandler sub' master mo a
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandlerT sub' master mo a
|
||||
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
|
||||
|
||||
toMasterHandlerDyn :: Monad mo
|
||||
=> (Route sub -> Route master)
|
||||
-> GGHandler sub' master mo sub
|
||||
-> GHandlerT sub' master mo sub
|
||||
-> Route sub
|
||||
-> GGHandler sub master mo a
|
||||
-> GGHandler sub' master mo a
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandlerT sub' master mo a
|
||||
toMasterHandlerDyn tm getSub route h = do
|
||||
sub <- getSub
|
||||
withReaderT (handlerSubData tm (const sub) route) h
|
||||
@ -258,8 +260,8 @@ instance (anySub ~ anySub'
|
||||
toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> GGHandler sub master mo a
|
||||
-> GGHandler sub' master mo a
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandlerT sub' master mo a
|
||||
toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
|
||||
|
||||
-- | 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
|
||||
-- special responses. It is declared as a newtype to make compiler errors more
|
||||
-- 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
|
||||
{ ghsSession :: SessionMap
|
||||
@ -290,7 +292,7 @@ newtype YesodApp = YesodApp
|
||||
-> Request
|
||||
-> [ContentType]
|
||||
-> SessionMap
|
||||
-> Iteratee ByteString IO YesodAppResult
|
||||
-> ResourceT IO YesodAppResult
|
||||
}
|
||||
|
||||
data YesodAppResult
|
||||
@ -310,10 +312,10 @@ instance Show HandlerContents where
|
||||
show _ = "Cannot show a HandlerContents"
|
||||
instance Exception HandlerContents
|
||||
|
||||
getRequest :: Monad mo => GGHandler s m mo Request
|
||||
getRequest :: Monad mo => GHandlerT s m mo Request
|
||||
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
|
||||
|
||||
runRequestBody :: GHandler s m RequestBodyContents
|
||||
@ -327,9 +329,9 @@ runRequestBody = do
|
||||
put x { ghsRBC = Just rbc }
|
||||
return rbc
|
||||
|
||||
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
|
||||
rbHelper :: W.Request -> ResourceT IO RequestBodyContents
|
||||
rbHelper req =
|
||||
(map fix1 *** map fix2) <$> iter
|
||||
(map fix1 *** map fix2) <$> (requestBody req $$ iter)
|
||||
where
|
||||
iter = NWP.parseRequestBody NWP.lbsSink req
|
||||
fix1 = go *** go
|
||||
@ -338,15 +340,15 @@ rbHelper req =
|
||||
go = decodeUtf8With lenientDecode
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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
|
||||
x <- handlerRender `liftM` ask
|
||||
return $ flip x []
|
||||
@ -354,17 +356,17 @@ getUrlRender = do
|
||||
-- | The URL rendering function with query-string parameters.
|
||||
getUrlRenderParams
|
||||
:: Monad m
|
||||
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
|
||||
=> GHandlerT sub master m (Route master -> [(Text, Text)] -> Text)
|
||||
getUrlRenderParams = handlerRender `liftM` ask
|
||||
|
||||
-- | Get the route requested by the user. If this is a 404 response- where the
|
||||
-- user requested an invalid route- this function will return 'Nothing'.
|
||||
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
|
||||
getCurrentRoute :: Monad m => GHandlerT sub master m (Maybe (Route sub))
|
||||
getCurrentRoute = handlerRoute `liftM` ask
|
||||
|
||||
-- | Get the function to promote a route for a subsite to a route for the
|
||||
-- master site.
|
||||
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
|
||||
getRouteToMaster :: Monad m => GHandlerT sub master m (Route sub -> Route master)
|
||||
getRouteToMaster = handlerToMaster `liftM` ask
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
@ -399,7 +401,7 @@ runHandler handler mrender sroute tomr master sub =
|
||||
, handlerToMaster = tomr
|
||||
, handlerState = istate
|
||||
}
|
||||
contents' <- catchIter (fmap Right $ runReaderT handler hd)
|
||||
contents' <- catch (fmap Right $ runReaderT handler hd)
|
||||
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
||||
$ fromException e)
|
||||
state <- liftIO $ I.readIORef istate
|
||||
@ -425,7 +427,7 @@ runHandler handler mrender sroute tomr master sub =
|
||||
return $ YARPlain
|
||||
(getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent
|
||||
finalSession
|
||||
HCSendFile ct fp p -> catchIter
|
||||
HCSendFile ct fp p -> catch
|
||||
(sendFile' ct fp p)
|
||||
(handleError . toErrorHandler)
|
||||
HCCreated loc -> do
|
||||
@ -449,19 +451,19 @@ safeEh er = YesodApp $ \_ _ _ session -> do
|
||||
session
|
||||
|
||||
-- | 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 []
|
||||
|
||||
-- | Redirects to the given route with the associated query-string parameters.
|
||||
redirectParams :: MonadIO mo
|
||||
=> RedirectType -> Route master -> [(Text, Text)]
|
||||
-> GGHandler sub master mo a
|
||||
-> GHandlerT sub master mo a
|
||||
redirectParams rt url params = do
|
||||
r <- getUrlRenderParams
|
||||
redirectString rt $ r url params
|
||||
|
||||
-- | 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
|
||||
redirectString = redirectText
|
||||
{-# DEPRECATED redirectString "Use redirectText instead" #-}
|
||||
@ -473,16 +475,16 @@ ultDestKey = "_ULT"
|
||||
--
|
||||
-- An ultimate destination is stored in the user session and can be loaded
|
||||
-- later by 'redirectUltDest'.
|
||||
setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo ()
|
||||
setUltDest :: MonadIO mo => Route master -> GHandlerT sub master mo ()
|
||||
setUltDest dest = do
|
||||
render <- getUrlRender
|
||||
setUltDestString $ render dest
|
||||
|
||||
-- | 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
|
||||
|
||||
setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo ()
|
||||
setUltDestString :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
setUltDestString = setSession ultDestKey
|
||||
{-# 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
|
||||
-- nothing.
|
||||
setUltDest' :: MonadIO mo => GGHandler sub master mo ()
|
||||
setUltDest' :: MonadIO mo => GHandlerT sub master mo ()
|
||||
setUltDest' = do
|
||||
route <- getCurrentRoute
|
||||
case route of
|
||||
@ -504,7 +506,7 @@ setUltDest' = do
|
||||
-- | Sets the ultimate destination to the referer request header, if present.
|
||||
--
|
||||
-- This function will not overwrite an existing ultdest.
|
||||
setUltDestReferer :: MonadIO mo => GGHandler sub master mo ()
|
||||
setUltDestReferer :: MonadIO mo => GHandlerT sub master mo ()
|
||||
setUltDestReferer = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
maybe
|
||||
@ -521,14 +523,14 @@ setUltDestReferer = do
|
||||
redirectUltDest :: MonadIO mo
|
||||
=> RedirectType
|
||||
-> Route master -- ^ default destination if nothing in session
|
||||
-> GGHandler sub master mo a
|
||||
-> GHandlerT sub master mo a
|
||||
redirectUltDest rt def = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
deleteSession ultDestKey
|
||||
maybe (redirect rt def) (redirectText rt) mdest
|
||||
|
||||
-- | 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
|
||||
|
||||
msgKey :: Text
|
||||
@ -537,13 +539,13 @@ msgKey = "_MSG"
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- 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
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- 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
|
||||
mr <- getMessageRender
|
||||
setMessage $ toHtml $ mr msg
|
||||
@ -552,7 +554,7 @@ setMessageI msg = do
|
||||
-- variable.
|
||||
--
|
||||
-- See 'setMessage'.
|
||||
getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html)
|
||||
getMessage :: MonadIO mo => GHandlerT sub master mo (Maybe Html)
|
||||
getMessage = do
|
||||
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
|
||||
deleteSession msgKey
|
||||
@ -562,7 +564,7 @@ getMessage = do
|
||||
--
|
||||
-- For some backends, this is more efficient than reading in the file to
|
||||
-- memory, since they can optimize file sending via a system call to sendfile.
|
||||
sendFile :: 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
|
||||
|
||||
-- | Same as 'sendFile', but only sends part of a file.
|
||||
@ -571,25 +573,25 @@ sendFilePart :: MonadIO mo
|
||||
-> FilePath
|
||||
-> Integer -- ^ offset
|
||||
-> Integer -- ^ count
|
||||
-> GGHandler sub master mo a
|
||||
-> GHandlerT sub master mo a
|
||||
sendFilePart ct fp off count =
|
||||
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with a 200
|
||||
-- status code.
|
||||
sendResponse :: (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
|
||||
. chooseRep
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with the given
|
||||
-- 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
|
||||
. chooseRep
|
||||
|
||||
-- | Send a 201 "Created" response with the given route as the Location
|
||||
-- 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
|
||||
r <- getUrlRender
|
||||
liftIO . throwIO $ HCCreated $ r url
|
||||
@ -599,7 +601,7 @@ sendResponseCreated url = do
|
||||
-- that you have already specified. This function short-circuits. It should be
|
||||
-- considered only for very specific needs. If you are not sure if you need it,
|
||||
-- you don't.
|
||||
sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b
|
||||
sendWaiResponse :: MonadIO mo => W.Response -> GHandlerT s m mo b
|
||||
sendWaiResponse = liftIO . throwIO . HCWai
|
||||
|
||||
-- | Return a 404 not found page. Also denotes no handler available.
|
||||
@ -607,7 +609,7 @@ notFound :: Failure ErrorResponse m => m a
|
||||
notFound = failure NotFound
|
||||
|
||||
-- | 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
|
||||
w <- waiRequest
|
||||
failure $ BadMethod $ W.requestMethod w
|
||||
@ -617,7 +619,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
|
||||
permissionDenied = failure . PermissionDenied
|
||||
|
||||
-- | 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
|
||||
mr <- getMessageRender
|
||||
permissionDenied $ mr msg
|
||||
@ -627,56 +629,62 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
|
||||
invalidArgs = failure . InvalidArgs
|
||||
|
||||
-- | 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
|
||||
mr <- getMessageRender
|
||||
invalidArgs $ map mr msg
|
||||
|
||||
------- Headers
|
||||
-- | 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
|
||||
=> Int -- ^ minutes to timeout
|
||||
-> H.Ascii -- ^ key
|
||||
-> H.Ascii -- ^ value
|
||||
-> GGHandler sub master mo ()
|
||||
setCookie a b = addHeader . AddCookie a b
|
||||
-> Text -- ^ key
|
||||
-> Text -- ^ value
|
||||
-> GHandlerT sub master mo ()
|
||||
setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8
|
||||
|
||||
-- | Unset the cookie on the client.
|
||||
deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo ()
|
||||
deleteCookie = addHeader . DeleteCookie
|
||||
deleteCookie :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
deleteCookie = addHeader . DeleteCookie . encodeUtf8
|
||||
|
||||
-- | Set the language in the user session. Will show up in 'languages' on the
|
||||
-- next request.
|
||||
setLanguage :: MonadIO mo => Text -> GGHandler sub master mo ()
|
||||
setLanguage :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
setLanguage = setSession langKey
|
||||
|
||||
-- | 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
|
||||
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
|
||||
setHeader a = addHeader . Header a
|
||||
=> Text -> Text -> GHandlerT sub master mo ()
|
||||
setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
|
||||
|
||||
-- | Set the Cache-Control header to indicate this response should be cached
|
||||
-- for the given number of seconds.
|
||||
cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo ()
|
||||
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
|
||||
cacheSeconds :: MonadIO mo => Int -> GHandlerT s m mo ()
|
||||
cacheSeconds i = setHeader "Cache-Control" $ T.concat
|
||||
[ "max-age="
|
||||
, show i
|
||||
, T.pack $ show i
|
||||
, ", public"
|
||||
]
|
||||
|
||||
-- | Set the Expires header to some date in 2037. In other words, this content
|
||||
-- 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"
|
||||
|
||||
-- | Set an Expires header in the past, meaning this content should not be
|
||||
-- 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"
|
||||
|
||||
-- | Set an Expires header to the given date.
|
||||
expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo ()
|
||||
expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
|
||||
expiresAt :: MonadIO mo => UTCTime -> GHandlerT s m mo ()
|
||||
expiresAt = setHeader "Expires" . formatRFC1123
|
||||
|
||||
-- | Set a variable in the user's session.
|
||||
--
|
||||
@ -686,18 +694,18 @@ expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
|
||||
setSession :: MonadIO mo
|
||||
=> Text -- ^ key
|
||||
-> Text -- ^ value
|
||||
-> GGHandler sub master mo ()
|
||||
-> GHandlerT sub master mo ()
|
||||
setSession k = modify . modSession . Map.insert k
|
||||
|
||||
-- | 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
|
||||
|
||||
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
|
||||
modSession f x = x { ghsSession = f $ ghsSession x }
|
||||
|
||||
-- | 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 . (:)
|
||||
|
||||
getStatus :: ErrorResponse -> H.Status
|
||||
@ -720,18 +728,18 @@ data RedirectType = RedirectPermanent
|
||||
| RedirectSeeOther
|
||||
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 =
|
||||
local (\hd -> hd { handlerRoute = Nothing })
|
||||
|
||||
-- | 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
|
||||
m <- liftM ghsSession get
|
||||
return $ Map.lookup n m
|
||||
|
||||
-- | Get all session variables.
|
||||
getSession :: MonadIO mo => GGHandler s m mo SessionMap
|
||||
getSession :: MonadIO mo => GHandlerT s m mo SessionMap
|
||||
getSession = liftM ghsSession get
|
||||
|
||||
handlerToYAR :: (HasReps a, HasReps b)
|
||||
@ -744,7 +752,7 @@ handlerToYAR :: (HasReps a, HasReps b)
|
||||
-> Maybe (Route s)
|
||||
-> SessionMap
|
||||
-> GHandler s m b
|
||||
-> Iteratee ByteString IO YesodAppResult
|
||||
-> ResourceT IO YesodAppResult
|
||||
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
|
||||
unYesodApp ya eh' rr types sessionMap
|
||||
where
|
||||
@ -766,8 +774,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
|
||||
let hs' = maybe finalHeaders finalHeaders' mlen
|
||||
in W.ResponseBuilder s hs' b
|
||||
ContentFile fp p -> W.ResponseFile s finalHeaders fp p
|
||||
ContentEnum e ->
|
||||
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
|
||||
ContentSource body -> W.ResponseSource s finalHeaders body
|
||||
where
|
||||
finalHeaders = renderHeaders hs ct sessionFinal
|
||||
finalHeaders' len = ("Content-Length", S8.pack $ show len)
|
||||
@ -817,12 +824,17 @@ headerToPair cp getExpires (AddCookie minutes key value) =
|
||||
})
|
||||
headerToPair cp _ (DeleteCookie key) =
|
||||
( "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.
|
||||
newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text
|
||||
newIdent :: MonadIO mo => GHandlerT sub master mo String -- FIXME use Text
|
||||
newIdent = do
|
||||
x <- get
|
||||
let i' = ghsIdent x + 1
|
||||
@ -830,8 +842,8 @@ newIdent = do
|
||||
return $ 'h' : show i'
|
||||
|
||||
liftIOHandler :: MonadIO mo
|
||||
=> GGHandler sub master IO a
|
||||
-> GGHandler sub master mo a
|
||||
=> GHandlerT sub master IO a
|
||||
-> GHandlerT sub master mo a
|
||||
liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
|
||||
|
||||
-- | 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
|
||||
-- useful when you need to post a plain link somewhere that needs to cause
|
||||
-- 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
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
@ -862,35 +874,35 @@ redirectToPost dest = hamletToRepHtml
|
||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
||||
-- Yesod 'Response'.
|
||||
hamletToContent :: Monad mo
|
||||
=> HtmlUrl (Route master) -> GGHandler sub master mo Content
|
||||
=> HtmlUrl (Route master) -> GHandlerT sub master mo Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRenderParams
|
||||
return $ toContent $ h render
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: Monad mo
|
||||
=> HtmlUrl (Route master) -> GGHandler sub master mo RepHtml
|
||||
=> HtmlUrl (Route master) -> GHandlerT sub master mo RepHtml
|
||||
hamletToRepHtml = liftM RepHtml . hamletToContent
|
||||
|
||||
-- | 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
|
||||
|
||||
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
|
||||
m <- getYesod
|
||||
l <- reqLangs `liftM` getRequest
|
||||
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
|
||||
gs <- get
|
||||
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 ->
|
||||
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 ->
|
||||
gs { ghsCache = Cache.delete k $ ghsCache gs }
|
||||
|
||||
@ -39,11 +39,10 @@ import Data.Typeable (Typeable)
|
||||
import Control.Exception (Exception)
|
||||
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.HTTP.Types as A
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.String (IsString)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text.Lazy.Builder (Builder)
|
||||
import Network.HTTP.Types (Ascii)
|
||||
|
||||
#if GHC7
|
||||
#define HAMLET hamlet
|
||||
@ -65,9 +64,9 @@ instance Exception ErrorResponse
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
data Header =
|
||||
AddCookie Int A.Ascii A.Ascii
|
||||
| DeleteCookie A.Ascii
|
||||
| Header (CI A.Ascii) A.Ascii
|
||||
AddCookie Int Ascii Ascii
|
||||
| DeleteCookie Ascii
|
||||
| Header Ascii Ascii
|
||||
deriving (Eq, Show)
|
||||
|
||||
langKey :: IsString a => a
|
||||
|
||||
@ -281,7 +281,7 @@ class RenderRoute (Route a) => Yesod a where
|
||||
yepnopeJs _ = Nothing
|
||||
|
||||
messageLoggerHandler :: (Yesod m, MonadIO mo)
|
||||
=> Loc -> LogLevel -> Text -> GGHandler s m mo ()
|
||||
=> Loc -> LogLevel -> Text -> GHandlerT s m mo ()
|
||||
messageLoggerHandler loc level msg = do
|
||||
y <- getYesod
|
||||
liftIO $ messageLogger y loc level msg
|
||||
|
||||
@ -30,7 +30,7 @@ import qualified Data.Text
|
||||
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
|
||||
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:
|
||||
|
||||
@ -51,7 +51,7 @@ case segments of
|
||||
case as of
|
||||
[] -> Nothing
|
||||
b:bs ->
|
||||
case fromSinglePiece b of
|
||||
case fromPathPiece b of
|
||||
Left _ -> Nothing
|
||||
Right name ->
|
||||
case bs of
|
||||
@ -59,7 +59,7 @@ case segments of
|
||||
case cs of
|
||||
[] -> Nothing
|
||||
d:ds ->
|
||||
case fromSinglePiece d of
|
||||
case fromPathPiece d of
|
||||
Left _ -> Nothing
|
||||
Right age ->
|
||||
case ds of
|
||||
@ -219,7 +219,7 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
|
||||
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
|
||||
nothing <- [|Nothing|]
|
||||
next <- newName "next"
|
||||
fsp <- [|fromSinglePiece|]
|
||||
fsp <- [|fromPathPiece|]
|
||||
let exp' = CaseE (fsp `AppE` VarE next)
|
||||
[ Match
|
||||
(ConP (mkName "Nothing") [])
|
||||
@ -243,7 +243,7 @@ mkSimpleExp segments [MultiPiece _] frontVars x = do
|
||||
srest <- [|[]|]
|
||||
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
|
||||
nothing <- [|Nothing|]
|
||||
fmp <- [|fromMultiPiece|]
|
||||
fmp <- [|fromPathMultiPiece|]
|
||||
let exp = CaseE (fmp `AppE` segments)
|
||||
[ Match
|
||||
(ConP (mkName "Nothing") [])
|
||||
@ -301,7 +301,7 @@ mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
|
||||
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
|
||||
nothing <- [|Nothing|]
|
||||
next <- newName "next"
|
||||
fsp <- [|fromSinglePiece|]
|
||||
fsp <- [|fromPathPiece|]
|
||||
let exp' = CaseE (fsp `AppE` VarE next)
|
||||
[ Match
|
||||
(ConP (mkName "Nothing") [])
|
||||
|
||||
@ -85,7 +85,7 @@ createParse res = do
|
||||
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
|
||||
mkPat' be [MultiPiece s] parse = do
|
||||
v <- newName $ "var" ++ s
|
||||
fmp <- [|fromMultiPiece|]
|
||||
fmp <- [|fromPathMultiPiece|]
|
||||
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
|
||||
return ([VarP v], parse')
|
||||
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
|
||||
@ -94,7 +94,7 @@ createParse res = do
|
||||
let sp = LitP $ StringL s
|
||||
return (sp : x, parse')
|
||||
mkPat' be (SinglePiece s:rest) parse = do
|
||||
fsp <- [|fromSinglePiece|]
|
||||
fsp <- [|fromPathPiece|]
|
||||
v <- newName $ "var" ++ s
|
||||
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
|
||||
(x, parse'') <- mkPat' be rest parse'
|
||||
@ -137,13 +137,13 @@ createRender = mapM go
|
||||
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
|
||||
mkBod ((i, SinglePiece _):xs) = do
|
||||
let x' = VarE $ mkName $ "var" ++ show i
|
||||
tsp <- [|toSinglePiece|]
|
||||
tsp <- [|toPathPiece|]
|
||||
let x'' = tsp `AppE` x'
|
||||
xs' <- mkBod xs
|
||||
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
|
||||
mkBod ((i, MultiPiece _):_) = do
|
||||
let x' = VarE $ mkName $ "var" ++ show i
|
||||
tmp <- [|toMultiPiece|]
|
||||
tmp <- [|toPathMultiPiece|]
|
||||
return $ tmp `AppE` x'
|
||||
|
||||
-- | Whether the set of resources cover all possible URLs.
|
||||
|
||||
@ -6,22 +6,6 @@
|
||||
--
|
||||
module Yesod.Internal.TestApi
|
||||
( randomString, parseWaiRequest'
|
||||
, catchIter
|
||||
) where
|
||||
|
||||
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
|
||||
|
||||
@ -52,20 +52,20 @@ import Data.Text (Text)
|
||||
-- * Accept-Language HTTP header.
|
||||
--
|
||||
-- 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
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookup' a = map snd . filter (\x -> a == fst x)
|
||||
|
||||
-- | 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
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqGetParams rr
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Lookup for POST parameters.
|
||||
@ -91,11 +91,11 @@ lookupFiles pn = do
|
||||
return $ lookup' pn files
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqCookies rr
|
||||
|
||||
@ -64,7 +64,7 @@ import Text.Cassius
|
||||
import Text.Julius
|
||||
import Text.Coffee
|
||||
import Yesod.Handler
|
||||
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
(Route, GHandler, GHandlerT, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
, getMessageRender, getUrlRenderParams
|
||||
)
|
||||
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 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
|
||||
mr <- lift getMessageRender
|
||||
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
|
||||
-- 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
|
||||
render <- lift getUrlRenderParams
|
||||
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
|
||||
-- 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
|
||||
render <- lift getUrlRenderParams
|
||||
t <- liftIO $ renderCoffee render c
|
||||
@ -338,7 +338,7 @@ rules = do
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
|
||||
=> HtmlUrlI18n message (Route master)
|
||||
-> GGHandler sub master mo RepHtml
|
||||
-> GHandlerT sub master mo RepHtml
|
||||
ihamletToRepHtml ih = do
|
||||
urender <- getUrlRenderParams
|
||||
mrender <- getMessageRender
|
||||
|
||||
@ -11,10 +11,6 @@ import Network.Wai.Test
|
||||
import Text.Hamlet (hamlet)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
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
|
||||
|
||||
@ -61,7 +57,6 @@ errorHandlingTest = describe "Test.ErrorHandling"
|
||||
[ it "says not found" caseNotFound
|
||||
, it "says 'There was an error' before runRequestBody" caseBefore
|
||||
, it "says 'There was an error' after runRequestBody" caseAfter
|
||||
, it "catchIter handles internal exceptions" caseCatchIter
|
||||
]
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
@ -101,11 +96,3 @@ caseAfter = runner $ do
|
||||
}
|
||||
assertStatus 500 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 ()
|
||||
|
||||
@ -6,7 +6,6 @@ module YesodCoreTest.YesodTest
|
||||
, module Network.Wai
|
||||
, module Network.Wai.Test
|
||||
, module Test.Hspec
|
||||
, module Test.Hspec.HUnit
|
||||
) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-core
|
||||
version: 0.9.4
|
||||
version: 0.10.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -46,12 +46,12 @@ library
|
||||
build-depends: wai-test
|
||||
|
||||
build-depends: time >= 1.1.4
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4.1 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, text >= 0.7 && < 0.12
|
||||
, template-haskell
|
||||
, path-pieces >= 0.0 && < 0.1
|
||||
, path-pieces >= 0.1 && < 0.2
|
||||
, hamlet >= 0.10.6 && < 0.11
|
||||
, shakespeare >= 0.10 && < 0.11
|
||||
, shakespeare-js >= 0.10.4 && < 0.11
|
||||
@ -65,21 +65,20 @@ library
|
||||
, old-locale >= 1.0.0.2 && < 1.1
|
||||
, failure >= 0.1 && < 0.2
|
||||
, containers >= 0.2 && < 0.5
|
||||
, monad-control >= 0.2 && < 0.4
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
, transformers-base >= 0.4
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, cookie >= 0.3 && < 0.4
|
||||
, blaze-html >= 0.4.1.3 && < 0.5
|
||||
, http-types >= 0.6.5 && < 0.7
|
||||
, case-insensitive >= 0.2
|
||||
, parsec >= 2 && < 3.2
|
||||
, directory >= 1 && < 1.2
|
||||
, data-object >= 0.3 && < 0.4
|
||||
, data-object-yaml >= 0.3 && < 0.4
|
||||
, vector >= 0.9 && < 0.10
|
||||
, aeson >= 0.3
|
||||
, aeson >= 0.5
|
||||
, fast-logger >= 0.0.1
|
||||
, wai-logger >= 0.0.1
|
||||
, conduit >= 0.0 && < 0.1
|
||||
, lifted-base >= 0.1 && < 0.2
|
||||
|
||||
exposed-modules: Yesod.Content
|
||||
Yesod.Core
|
||||
@ -89,7 +88,6 @@ library
|
||||
Yesod.Request
|
||||
Yesod.Widget
|
||||
Yesod.Message
|
||||
Yesod.Config
|
||||
Yesod.Internal.TestApi
|
||||
other-modules: Yesod.Internal
|
||||
Yesod.Internal.Cache
|
||||
@ -117,7 +115,7 @@ test-suite tests
|
||||
main-is: test.hs
|
||||
cpp-options: -DTEST
|
||||
build-depends: hspec >= 0.8 && < 0.10
|
||||
,wai-test >= 0.1.2 && < 0.2
|
||||
,wai-test
|
||||
,wai
|
||||
,yesod-core
|
||||
,bytestring
|
||||
@ -129,7 +127,6 @@ test-suite tests
|
||||
, random
|
||||
,HUnit
|
||||
,QuickCheck >= 2 && < 3
|
||||
, enumerator
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module Yesod.Default.Config
|
||||
( DefaultEnv (..)
|
||||
, fromArgs
|
||||
@ -18,10 +19,9 @@ import Data.Char (toUpper, toLower)
|
||||
import System.Console.CmdArgs hiding (args)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad (join)
|
||||
import Data.Object
|
||||
import Data.Object.Yaml
|
||||
import Data.Yaml
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
|
||||
-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
|
||||
-- Production environments
|
||||
@ -55,13 +55,13 @@ fromArgs = fromArgsExtra (const $ const $ return ())
|
||||
|
||||
-- | Same as 'fromArgs', but allows you to specify how to parse the 'appExtra'
|
||||
-- record.
|
||||
fromArgsExtra :: (DefaultEnv -> TextObject -> IO extra)
|
||||
fromArgsExtra :: (DefaultEnv -> Value -> IO extra)
|
||||
-> IO (AppConfig DefaultEnv extra)
|
||||
fromArgsExtra = fromArgsWith defaultArgConfig
|
||||
|
||||
fromArgsWith :: (Read env, Show env)
|
||||
=> ArgConfig
|
||||
-> (env -> TextObject -> IO extra)
|
||||
-> (env -> Value -> IO extra)
|
||||
-> IO (AppConfig env extra)
|
||||
fromArgsWith argConfig getExtra = do
|
||||
args <- cmdArgs argConfig
|
||||
@ -103,12 +103,12 @@ data ConfigSettings environment extra = ConfigSettings
|
||||
-- environment. Usually, you will use 'DefaultEnv' for this type.
|
||||
csEnv :: environment
|
||||
-- | 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.
|
||||
, csFile :: environment -> IO FilePath
|
||||
-- | Get the sub-object (if relevant) from the given YAML source which
|
||||
-- contains the specific settings for the current environment.
|
||||
, csGetObject :: environment -> TextObject -> IO TextObject
|
||||
, csGetObject :: environment -> Value -> IO Value
|
||||
}
|
||||
|
||||
-- | Default config settings.
|
||||
@ -117,14 +117,17 @@ configSettings env0 = ConfigSettings
|
||||
{ csEnv = env0
|
||||
, csLoadExtra = \_ _ -> return ()
|
||||
, csFile = \_ -> return "config/settings.yml"
|
||||
, csGetObject = \env obj -> do
|
||||
envs <- fromMapping obj
|
||||
, csGetObject = \env v -> do
|
||||
envs <-
|
||||
case v of
|
||||
Object obj -> return obj
|
||||
_ -> fail "Expected Object"
|
||||
let senv = show env
|
||||
tenv = T.pack senv
|
||||
maybe
|
||||
(error $ "Could not find environment: " ++ senv)
|
||||
return
|
||||
(lookup tenv envs)
|
||||
(M.lookup tenv envs)
|
||||
}
|
||||
|
||||
-- | Load an @'AppConfig'@.
|
||||
@ -160,10 +163,14 @@ loadConfig :: ConfigSettings environment extra
|
||||
-> IO (AppConfig environment extra)
|
||||
loadConfig (ConfigSettings env loadExtra getFile getObject) = do
|
||||
fp <- getFile env
|
||||
topObj <- join $ decodeFile fp
|
||||
mtopObj <- decodeFile fp
|
||||
topObj <- maybe (fail "Invalid YAML file") return mtopObj
|
||||
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 mhost = lookupScalar "host" m
|
||||
let mport = lookupScalar "port" m
|
||||
@ -192,6 +199,11 @@ loadConfig (ConfigSettings env loadExtra getFile getObject) = do
|
||||
}
|
||||
|
||||
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 = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
|
||||
|
||||
@ -216,11 +228,12 @@ safeRead name' t = case reads s of
|
||||
withYamlEnvironment :: Show e
|
||||
=> FilePath -- ^ the yaml file
|
||||
-> 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
|
||||
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
|
||||
mval <- decodeFile fp
|
||||
case mval of
|
||||
Nothing -> fail $ "Invalid YAML file: " ++ show fp
|
||||
Just (Object obj)
|
||||
| Just v <- M.lookup (T.pack $ show env) obj -> f v
|
||||
_ -> fail $ "Could not find environment: " ++ show env
|
||||
|
||||
@ -7,7 +7,7 @@ module Yesod.Default.Main
|
||||
, defaultDevelAppWith
|
||||
) where
|
||||
|
||||
import Yesod.Core hiding (AppConfig (..))
|
||||
import Yesod.Core
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Logger (Logger, makeDefaultLogger, logString, flushLogger)
|
||||
import Network.Wai (Application)
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-default
|
||||
version: 0.5.0
|
||||
version: 0.6.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Patrick Brisbin
|
||||
@ -18,11 +18,11 @@ library
|
||||
cpp-options: -DWINDOWS
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9.4 && < 0.10
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, cmdargs >= 0.8
|
||||
, warp >= 0.4 && < 0.5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4.4 && < 0.5
|
||||
, warp >= 1.0 && < 1.1
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, text >= 0.9
|
||||
@ -30,8 +30,8 @@ library
|
||||
, shakespeare-css >= 0.10.5 && < 0.11
|
||||
, shakespeare-js >= 0.10.4 && < 0.11
|
||||
, template-haskell
|
||||
, data-object >= 0.3 && < 0.4
|
||||
, data-object-yaml >= 0.3 && < 0.4
|
||||
, yaml >= 0.5 && < 0.6
|
||||
, unordered-containers
|
||||
|
||||
if !os(windows)
|
||||
build-depends: unix
|
||||
|
||||
@ -67,6 +67,7 @@ import Text.Blaze.Renderer.String (renderHtml)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text (Text, unpack, pack)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Read
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
|
||||
@ -75,8 +76,8 @@ import qualified Data.Map as Map
|
||||
import Yesod.Handler (newIdent, liftIOHandler)
|
||||
import Yesod.Request (FileInfo)
|
||||
|
||||
import Yesod.Core (toSinglePiece, GGHandler, SinglePiece)
|
||||
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend)
|
||||
import Yesod.Core (toPathPiece, GHandler, GHandlerT, PathPiece)
|
||||
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
|
||||
import Control.Arrow ((&&&))
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
@ -110,9 +111,9 @@ intField = Field
|
||||
Right (a, "") -> Right a
|
||||
_ -> Left $ MsgInvalidInteger s
|
||||
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val isReq -> addHamlet
|
||||
[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
|
||||
@ -126,9 +127,9 @@ doubleField = Field
|
||||
Right (a, "") -> Right a
|
||||
_ -> Left $ MsgInvalidNumber s
|
||||
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val isReq -> addHamlet
|
||||
[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)
|
||||
@ -136,9 +137,9 @@ doubleField = Field
|
||||
dayField :: RenderMessage master FormMessage => Field sub master Day
|
||||
dayField = Field
|
||||
{ fieldParse = blank $ parseDate . unpack
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val isReq -> addHamlet
|
||||
[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)
|
||||
@ -146,9 +147,9 @@ dayField = Field
|
||||
timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
|
||||
timeField = Field
|
||||
{ fieldParse = blank $ parseTime . unpack
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val isReq -> addHamlet
|
||||
[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
|
||||
@ -161,9 +162,10 @@ timeField = Field
|
||||
htmlField :: RenderMessage master FormMessage => Field sub master Html
|
||||
htmlField = Field
|
||||
{ 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|\
|
||||
<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)
|
||||
@ -189,36 +191,36 @@ instance ToHtml Textarea where
|
||||
textareaField :: RenderMessage master FormMessage => Field sub master Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = blank $ Right . Textarea
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val _isReq -> addHamlet
|
||||
[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 = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val _isReq -> addHamlet
|
||||
[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 = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq ->
|
||||
, fieldView = \theId name theClass val isReq ->
|
||||
[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 = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val isReq -> addHamlet
|
||||
[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)
|
||||
then Right s
|
||||
else Left $ MsgInvalidEmail s
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
, fieldView = \theId name theClass val isReq -> addHamlet
|
||||
[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 autoFocus = Field
|
||||
{ fieldParse = blank Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
, fieldView = \theId name theClass val isReq -> do
|
||||
[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
|
||||
-- we want this javascript to be placed immediately after the field
|
||||
@ -296,30 +298,30 @@ urlField = Field
|
||||
case parseURI $ unpack s of
|
||||
Nothing -> Left $ MsgInvalidUrl s
|
||||
Just _ -> Right s
|
||||
, fieldView = \theId name val isReq ->
|
||||
, fieldView = \theId name theClass val isReq ->
|
||||
[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 = 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
|
||||
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
|
||||
(\_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 = multiSelectFieldHelper
|
||||
(\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 = 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
|
||||
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
|
||||
(\theId name isSel -> [WHAMLET|
|
||||
@ -327,25 +329,25 @@ radioField' = selectFieldHelper
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|
||||
<label for=#{theId}-none>_{MsgSelectNone}
|
||||
|])
|
||||
(\theId name value isSel text -> [WHAMLET|
|
||||
(\theId name theClass value isSel text -> [WHAMLET|
|
||||
<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}
|
||||
|])
|
||||
|
||||
boolField :: RenderMessage master FormMessage => Field sub master Bool
|
||||
boolField = Field
|
||||
{ fieldParse = return . boolParser
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
, fieldView = \theId name theClass val isReq -> [WHAMLET|
|
||||
$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}
|
||||
|
||||
|
||||
<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}
|
||||
|
||||
<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}
|
||||
|]
|
||||
}
|
||||
@ -361,15 +363,16 @@ boolField = Field
|
||||
|
||||
multiSelectFieldHelper :: (Show a, Eq a)
|
||||
=> (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]
|
||||
multiSelectFieldHelper outside inside opts = Field
|
||||
{ fieldParse = return . selectParser
|
||||
, fieldView = \theId name vals _ ->
|
||||
, fieldView = \theId name theClass vals _ ->
|
||||
outside theId name $ do
|
||||
flip mapM_ pairs $ \pair -> inside
|
||||
theId
|
||||
name
|
||||
theClass
|
||||
(pack $ show $ fst pair)
|
||||
((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
|
||||
(fst $ snd pair)
|
||||
@ -399,45 +402,47 @@ data Option a = Option
|
||||
, 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
|
||||
{ optionDisplay = display
|
||||
, optionInternalValue = internal
|
||||
, optionExternalValue = pack $ show external
|
||||
}) [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]
|
||||
|
||||
optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)
|
||||
, SinglePiece (Key (YesodPersistBackend master) a)
|
||||
optionsPersist :: ( YesodPersist master, PersistEntity 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
|
||||
pairs <- runDB $ selectList filts ords
|
||||
return $ map (\(key, value) -> Option
|
||||
{ optionDisplay = toDisplay value
|
||||
, optionInternalValue = (key, value)
|
||||
, optionExternalValue = toSinglePiece key
|
||||
, optionExternalValue = toPathPiece key
|
||||
}) pairs
|
||||
|
||||
selectFieldHelper
|
||||
:: (Eq a, RenderMessage master FormMessage)
|
||||
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
|
||||
-> (Text -> Text -> Bool -> GWidget sub master ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
|
||||
-> GGHandler sub master IO (OptionList a) -> Field sub master a
|
||||
-> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())
|
||||
-> GHandlerT sub master IO (OptionList a) -> Field sub master a
|
||||
selectFieldHelper outside onOpt inside opts' = Field
|
||||
{ fieldParse = \x -> do
|
||||
opts <- opts'
|
||||
return $ selectParser opts x
|
||||
, fieldView = \theId name val isReq -> do
|
||||
, fieldView = \theId name theClass val isReq -> do
|
||||
opts <- fmap olOptions $ lift $ liftIOHandler opts'
|
||||
outside theId name $ do
|
||||
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
|
||||
flip mapM_ opts $ \opt -> inside
|
||||
theId
|
||||
name
|
||||
theClass
|
||||
(optionExternalValue opt)
|
||||
((render opts val) == optionExternalValue opt)
|
||||
(optionDisplay opt)
|
||||
@ -471,12 +476,13 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
|
||||
let t = renderMessage master langs MsgValueRequired
|
||||
in (FormFailure [t], Just $ toHtml t)
|
||||
Just fi -> (FormSuccess fi, Nothing)
|
||||
let theClass = fsClass fs
|
||||
let fv = FieldView
|
||||
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
|
||||
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
|
||||
, fvId = id'
|
||||
, fvInput = [WHAMLET|
|
||||
<input type=file name=#{name} ##{id'}>
|
||||
<input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}">
|
||||
|]
|
||||
, fvErrors = errs
|
||||
, fvRequired = True
|
||||
@ -499,12 +505,13 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
|
||||
case Map.lookup name fenv of
|
||||
Nothing -> (FormSuccess Nothing, Nothing)
|
||||
Just fi -> (FormSuccess $ Just fi, Nothing)
|
||||
let theClass = fsClass fs
|
||||
let fv = FieldView
|
||||
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
|
||||
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
|
||||
, fvId = id'
|
||||
, fvInput = [WHAMLET|
|
||||
<input type=file name=#{name} ##{id'}>
|
||||
<input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}">
|
||||
|]
|
||||
, fvErrors = errs
|
||||
, fvRequired = False
|
||||
|
||||
@ -40,7 +40,7 @@ import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (liftM, join)
|
||||
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.Widget (GWidget, whamlet)
|
||||
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..))
|
||||
@ -137,7 +137,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
{ fvLabel = toHtml $ mr2 fsLabel
|
||||
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
|
||||
, fvId = theId
|
||||
, fvInput = fieldView theId name val isReq
|
||||
, fvInput = fieldView theId name fsClass val isReq
|
||||
, fvErrors =
|
||||
case res of
|
||||
FormFailure [e] -> Just $ toHtml e
|
||||
@ -157,7 +157,7 @@ aopt :: RenderMessage master msg
|
||||
-> AForm sub master (Maybe a)
|
||||
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)
|
||||
|
||||
-- | 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
|
||||
|
||||
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
|
||||
checkM f field = field
|
||||
|
||||
@ -11,7 +11,7 @@ module Yesod.Form.Input
|
||||
import Yesod.Form.Types
|
||||
import Data.Text (Text)
|
||||
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 Control.Monad (liftM)
|
||||
import Yesod.Message (RenderMessage (..), SomeMessage (..))
|
||||
@ -19,7 +19,7 @@ import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
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
|
||||
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
|
||||
instance Applicative (FormInput sub master) where
|
||||
|
||||
@ -20,6 +20,7 @@ import Yesod.Form
|
||||
import Yesod.Widget
|
||||
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
|
||||
timeToTimeOfDay)
|
||||
import qualified Data.Text as T
|
||||
import Data.Char (isSpace)
|
||||
import Data.Default
|
||||
import Text.Hamlet (shamlet)
|
||||
@ -78,9 +79,9 @@ jqueryDayField jds = Field
|
||||
Right
|
||||
. readMay
|
||||
. unpack
|
||||
, fieldView = \theId name val isReq -> do
|
||||
, fieldView = \theId name theClass val isReq -> do
|
||||
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' urlJqueryUiJs
|
||||
@ -129,9 +130,9 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
|
||||
jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime
|
||||
jqueryDayTimeField = Field
|
||||
{ fieldParse = blank $ parseUTCTime . unpack
|
||||
, fieldView = \theId name val isReq -> do
|
||||
, fieldView = \theId name theClass val isReq -> do
|
||||
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' urlJqueryUiJs
|
||||
@ -159,9 +160,9 @@ jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master
|
||||
=> Route master -> Field sub master Text
|
||||
jqueryAutocompleteField src = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
, fieldView = \theId name theClass val isReq -> do
|
||||
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' 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
|
||||
y <- lift getYesod
|
||||
addScriptEither $ f y
|
||||
|
||||
@ -14,7 +14,7 @@ import Yesod.Form.Functions
|
||||
import Yesod.Form.Fields (boolField)
|
||||
import Yesod.Widget (GWidget, whamlet)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Handler (newIdent, GGHandler)
|
||||
import Yesod.Handler (newIdent, GHandler)
|
||||
import Text.Blaze (Html)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (pack)
|
||||
@ -53,7 +53,7 @@ up i = do
|
||||
IntCons _ is' -> put is' >> newFormIdent >> return ()
|
||||
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
|
||||
-> ([[FieldView sub master]] -> xml)
|
||||
-> (Maybe a -> AForm sub master a)
|
||||
@ -111,6 +111,7 @@ withDelete af = do
|
||||
, fsTooltip = Nothing
|
||||
, fsName = Just deleteName
|
||||
, fsId = Nothing
|
||||
, fsClass = []
|
||||
} $ Just False
|
||||
(res, xml) <- aFormToForm af
|
||||
return $ Right (res, xml $ xml2 [])
|
||||
|
||||
@ -20,6 +20,7 @@ import Text.Blaze.Renderer.String (renderHtml)
|
||||
import Text.Blaze (preEscapedText)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (Text, pack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe (listToMaybe)
|
||||
|
||||
class YesodNic a where
|
||||
@ -30,14 +31,14 @@ class YesodNic a where
|
||||
nicHtmlField :: YesodNic master => Field sub master Html
|
||||
nicHtmlField = Field
|
||||
{ fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe
|
||||
, fieldView = \theId name val _isReq -> do
|
||||
, fieldView = \theId name theClass val _isReq -> do
|
||||
addHtml
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
[shamlet|
|
||||
#else
|
||||
[$shamlet|
|
||||
#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
|
||||
addJulius
|
||||
|
||||
@ -10,7 +10,6 @@ module Yesod.Form.Types
|
||||
, FileEnv
|
||||
, Ints (..)
|
||||
-- * Form
|
||||
, Form
|
||||
, MForm
|
||||
, AForm (..)
|
||||
-- * Build forms
|
||||
@ -27,7 +26,7 @@ import Text.Blaze (Html, ToHtml (toHtml))
|
||||
import Control.Applicative ((<$>), Applicative (..))
|
||||
import Control.Monad (liftM)
|
||||
import Data.String (IsString (..))
|
||||
import Yesod.Core (GGHandler, GWidget, SomeMessage)
|
||||
import Yesod.Core (GHandlerT, GWidget, SomeMessage)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- | 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 Lang = Text
|
||||
type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler 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
|
||||
type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandlerT sub master IO) a
|
||||
|
||||
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
|
||||
fmap f (AForm a) =
|
||||
@ -102,10 +99,11 @@ data FieldSettings msg = FieldSettings
|
||||
, fsTooltip :: Maybe msg
|
||||
, fsId :: Maybe Text
|
||||
, fsName :: Maybe Text
|
||||
, fsClass :: [Text]
|
||||
}
|
||||
|
||||
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
|
||||
{ fvLabel :: Html
|
||||
@ -117,10 +115,11 @@ data FieldView sub master = FieldView
|
||||
}
|
||||
|
||||
data Field sub master a = Field
|
||||
{ fieldParse :: [Text] -> GGHandler sub master IO (Either (SomeMessage master) (Maybe a))
|
||||
-- | ID, name, (invalid text OR legimiate result), required?
|
||||
{ fieldParse :: [Text] -> GHandlerT sub master IO (Either (SomeMessage master) (Maybe a))
|
||||
-- | ID, name, class, (invalid text OR legimiate result), required?
|
||||
, fieldView :: Text
|
||||
-> Text
|
||||
-> [Text]
|
||||
-> Either Text a
|
||||
-> Bool
|
||||
-> GWidget sub master ()
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-form
|
||||
version: 0.3.4.2
|
||||
version: 0.4.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,25 +14,24 @@ description: Form handling support for Yesod Web Framework
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, yesod-persistent >= 0.2 && < 0.3
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, yesod-persistent >= 0.3 && < 0.4
|
||||
, time >= 1.1.4
|
||||
, hamlet >= 0.10 && < 0.11
|
||||
, shakespeare-css >= 0.10 && < 0.11
|
||||
, shakespeare-js >= 0.10 && < 0.11
|
||||
, persistent >= 0.6 && < 0.7
|
||||
, yesod-persistent >= 0.2 && < 0.3
|
||||
, persistent >= 0.7 && < 0.8
|
||||
, template-haskell
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, data-default >= 0.3 && < 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
|
||||
, email-validate >= 0.2.6 && < 0.3
|
||||
, blaze-html >= 0.4.1.3 && < 0.5
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, text >= 0.9 && < 0.12
|
||||
, wai >= 0.4 && < 0.5
|
||||
, text >= 0.9 && < 1.0
|
||||
, wai >= 1.0 && < 1.1
|
||||
, containers >= 0.2 && < 0.5
|
||||
exposed-modules: Yesod.Form
|
||||
Yesod.Form.Class
|
||||
|
||||
@ -7,14 +7,13 @@ module Yesod.Json
|
||||
, jsonToRepJson
|
||||
-- * Convert to a JSON value
|
||||
, parseJsonBody
|
||||
-- * Compatibility wrapper for old API
|
||||
, Json
|
||||
, jsonScalar
|
||||
, jsonList
|
||||
, jsonMap
|
||||
-- * Produce JSON values
|
||||
, J.Value (..)
|
||||
, object
|
||||
, array
|
||||
) where
|
||||
|
||||
import Yesod.Handler (GHandler)
|
||||
import Yesod.Handler (GHandler, waiRequest)
|
||||
import Yesod.Content
|
||||
( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml)
|
||||
, RepJson (RepJson), Content (ContentBuilder)
|
||||
@ -24,33 +23,23 @@ import Yesod.Widget (GWidget)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encode as JE
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
import Data.Attoparsec.Enumerator (iterParser)
|
||||
import Data.Text (pack)
|
||||
import Control.Arrow (first)
|
||||
import Data.Conduit.Attoparsec (sinkParser)
|
||||
import Data.Text (Text)
|
||||
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 Text.Julius (ToJavascript (..))
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
import Data.Text.Lazy.Encoding (decodeUtf8)
|
||||
#if MIN_VERSION_aeson(0, 5, 0)
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
|
||||
#endif
|
||||
import Data.Conduit (($$))
|
||||
import Network.Wai (requestBody)
|
||||
|
||||
instance ToContent J.Value where
|
||||
#if MIN_VERSION_aeson(0, 5, 0)
|
||||
toContent = flip ContentBuilder Nothing
|
||||
. Blaze.fromLazyText
|
||||
. toLazyText
|
||||
. fromValue
|
||||
#else
|
||||
toContent = flip ContentBuilder Nothing . fromValue
|
||||
#endif
|
||||
|
||||
-- | Provide both an HTML and JSON representation for a piece of data, using
|
||||
-- the default layout for the HTML output ('defaultLayout').
|
||||
@ -70,19 +59,17 @@ jsonToRepJson = return . RepJson . toContent
|
||||
--
|
||||
-- /Since: 0.2.3/
|
||||
parseJsonBody :: GHandler sub master J.Value
|
||||
parseJsonBody = lift $ iterParser 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)
|
||||
parseJsonBody = do
|
||||
req <- waiRequest
|
||||
lift $ requestBody req $$ sinkParser J.json'
|
||||
|
||||
instance ToJavascript J.Value where
|
||||
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
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-json
|
||||
version: 0.2.3
|
||||
version: 0.3.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,16 +14,17 @@ description: Generate content for Yesod using the aeson package.
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, aeson >= 0.3
|
||||
, text >= 0.8 && < 0.12
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, aeson >= 0.5
|
||||
, text >= 0.8 && < 1.0
|
||||
, shakespeare-js >= 0.10 && < 0.11
|
||||
, vector >= 0.9
|
||||
, containers >= 0.2 && < 0.5
|
||||
, unordered-containers
|
||||
, containers >= 0.2
|
||||
, 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
|
||||
, wai >= 1.0 && < 1.1
|
||||
exposed-modules: Yesod.Json
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
@ -34,7 +34,7 @@ newtype RepAtom = RepAtom Content
|
||||
instance HasReps RepAtom where
|
||||
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
|
||||
|
||||
template :: Feed url -> HtmlUrl url
|
||||
|
||||
@ -25,7 +25,7 @@ import Yesod.FeedTypes
|
||||
import Yesod.AtomFeed
|
||||
import Yesod.RssFeed
|
||||
import Yesod.Content (HasReps (chooseRep), typeAtom, typeRss)
|
||||
import Yesod.Handler (Route, GGHandler)
|
||||
import Yesod.Handler (Route, GHandler)
|
||||
|
||||
data RepAtomRss = RepAtomRss RepAtom RepRss
|
||||
instance HasReps RepAtomRss where
|
||||
@ -33,7 +33,7 @@ instance HasReps RepAtomRss where
|
||||
[ (typeAtom, a)
|
||||
, (typeRss, r)
|
||||
]
|
||||
newsFeed :: Monad mo => Feed (Route master) -> GGHandler sub master mo RepAtomRss
|
||||
newsFeed :: Feed (Route master) -> GHandler sub master RepAtomRss
|
||||
newsFeed f = do
|
||||
a <- atomFeed f
|
||||
r <- rssFeed f
|
||||
|
||||
@ -31,7 +31,7 @@ instance HasReps RepRss where
|
||||
chooseRep (RepRss c) _ = return (typeRss, c)
|
||||
|
||||
-- | 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
|
||||
|
||||
template :: Feed url -> HtmlUrl url
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-newsfeed
|
||||
version: 0.3.2
|
||||
version: 0.4.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -14,7 +14,7 @@ description: Helper functions and data types for producing News feeds.
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, time >= 1.1.4
|
||||
, hamlet >= 0.10 && < 0.11
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
|
||||
@ -6,25 +6,26 @@ module Yesod.Persist
|
||||
, get404
|
||||
, getBy404
|
||||
, module Database.Persist
|
||||
, module Database.Persist.Query
|
||||
, module Database.Persist.TH
|
||||
) where
|
||||
|
||||
import Database.Persist
|
||||
import Database.Persist.Query
|
||||
import Database.Persist.TH
|
||||
import Control.Monad.Trans.Class (MonadTrans (..))
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Failure (Failure)
|
||||
|
||||
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
|
||||
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.
|
||||
get404 :: (PersistBackend t m, PersistEntity val, Monad (t m),
|
||||
get404 :: (PersistStore t m, PersistEntity val, Monad (t m),
|
||||
Failure ErrorResponse m, MonadTrans t)
|
||||
=> Key t val -> t m val
|
||||
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
|
||||
-- exist.
|
||||
getBy404 :: (PersistBackend t m, PersistEntity val, Monad (t m),
|
||||
getBy404 :: (PersistUnique t m, PersistEntity val, Monad (t m),
|
||||
Failure ErrorResponse m, MonadTrans t)
|
||||
=> Unique val t -> t m (Key t val, val)
|
||||
getBy404 key = do
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-persistent
|
||||
version: 0.2.2
|
||||
version: 0.3.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,9 +14,9 @@ description: Some helpers for using Persistent from Yesod.
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.8 && < 0.10
|
||||
, persistent >= 0.6 && < 0.7
|
||||
, persistent-template >= 0.6 && < 0.7
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, persistent >= 0.7 && < 0.8
|
||||
, persistent-template >= 0.7 && < 0.8
|
||||
, failure >= 0.1 && < 0.2
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
exposed-modules: Yesod.Persist
|
||||
|
||||
@ -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
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-sitemap
|
||||
version: 0.2.2
|
||||
version: 0.3.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,7 +14,7 @@ description: Generate XML sitemaps.
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, time >= 1.1.4
|
||||
, hamlet >= 0.10 && < 0.11
|
||||
exposed-modules: Yesod.Sitemap
|
||||
|
||||
@ -68,9 +68,9 @@ import qualified Data.ByteString as S
|
||||
import Network.HTTP.Types (status301)
|
||||
import System.PosixCompat.Files (getFileStatus, modificationTime)
|
||||
import System.Posix.Types (EpochTime)
|
||||
import qualified Data.Enumerator as E
|
||||
import qualified Data.Enumerator.List as EL
|
||||
import qualified Data.Enumerator.Binary as EB
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
import Network.Wai.Application.Static
|
||||
( StaticSettings (..)
|
||||
@ -282,7 +282,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
|
||||
-- descriptors
|
||||
base64md5File :: Prelude.FilePath -> IO String
|
||||
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
|
||||
-- FIXME I'd like something streaming instead
|
||||
{-
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-static
|
||||
version: 0.3.2.1
|
||||
version: 0.10.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -26,7 +26,7 @@ library
|
||||
build-depends: base >= 4 && < 5
|
||||
, containers >= 0.2 && < 0.5
|
||||
, old-time >= 1.0
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, base64-bytestring >= 0.1.0.1 && < 0.2
|
||||
, pureMD5 >= 2.1.0.3 && < 2.2
|
||||
, cereal >= 0.3 && < 0.4
|
||||
@ -34,43 +34,43 @@ library
|
||||
, template-haskell
|
||||
, directory >= 1.0 && < 1.2
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, wai-app-static >= 0.3.2.1 && < 0.4
|
||||
, wai >= 0.4 && < 0.5
|
||||
, text >= 0.9 && < 0.12
|
||||
, wai-app-static >= 1.0 && < 1.1
|
||||
, wai >= 1.0 && < 1.1
|
||||
, text >= 0.9 && < 1.0
|
||||
, file-embed >= 0.0.4.1 && < 0.5
|
||||
, http-types >= 0.6.5 && < 0.7
|
||||
, unix-compat >= 0.2
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, conduit >= 0.0
|
||||
exposed-modules: Yesod.Static
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite tests
|
||||
hs-source-dirs: ., test
|
||||
hs-source-dirs: test
|
||||
main-is: tests.hs
|
||||
type: exitcode-stdio-1.0
|
||||
cpp-options: -DTEST
|
||||
build-depends:
|
||||
hspec >= 0.8 && < 0.10
|
||||
, HUnit
|
||||
, yesod-static
|
||||
-- copy from above
|
||||
, base >= 4 && < 5
|
||||
, containers >= 0.2 && < 0.5
|
||||
, old-time >= 1.0
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, base64-bytestring >= 0.1.0.1 && < 0.2
|
||||
, pureMD5 >= 2.1.0.3 && < 2.2
|
||||
, cereal >= 0.3 && < 0.4
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, base
|
||||
, containers
|
||||
, old-time
|
||||
, yesod-core
|
||||
, base64-bytestring
|
||||
, pureMD5
|
||||
, cereal
|
||||
, bytestring
|
||||
, template-haskell
|
||||
, directory >= 1.0 && < 1.2
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, wai-app-static >= 0.3.2.1 && < 0.4
|
||||
, wai >= 0.4 && < 0.5
|
||||
, text >= 0.9 && < 0.12
|
||||
, file-embed >= 0.0.4.1 && < 0.5
|
||||
, http-types >= 0.6.5 && < 0.7
|
||||
, unix-compat >= 0.2
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, directory
|
||||
, transformers
|
||||
, wai-app-static
|
||||
, wai
|
||||
, text
|
||||
, file-embed
|
||||
, http-types
|
||||
, unix-compat
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
@ -66,8 +66,8 @@ scaffold = do
|
||||
backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends
|
||||
let (backend, importGenericDB, dbMonad, importPersist, mkPersistSettings) =
|
||||
case backendC of
|
||||
"s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlSettings")
|
||||
"p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlSettings")
|
||||
"s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlMkSettings")
|
||||
"p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlMkSettings")
|
||||
"m" -> (MongoDB, "MongoDB", "Action", "MongoDB", "MkPersistSettings { mpsBackend = ConT ''Action }")
|
||||
"t" -> (Tiny, "","","",undefined)
|
||||
_ -> error $ "Invalid backend: " ++ backendC
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | This module simply re-exports from other modules for your convenience.
|
||||
module Yesod
|
||||
( -- * Re-exports from yesod-core
|
||||
@ -15,11 +14,7 @@ module Yesod
|
||||
, Application
|
||||
, lift
|
||||
, liftIO
|
||||
#if MIN_VERSION_monad_control(0, 3, 0)
|
||||
, MonadBaseControl
|
||||
#else
|
||||
, MonadControlIO
|
||||
#endif
|
||||
-- * Utilities
|
||||
, showIntegral
|
||||
, readIntegral
|
||||
@ -54,11 +49,7 @@ import Network.Wai (Application)
|
||||
import Network.Wai.Middleware.RequestLogger
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
#if MIN_VERSION_monad_control(0, 3, 0)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
#else
|
||||
import Control.Monad.IO.Control (MonadControlIO)
|
||||
#endif
|
||||
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import System.IO (stderr, hPutStrLn)
|
||||
|
||||
@ -19,7 +19,7 @@ import Network.Wai.Middleware.RequestLogger (logHandleDev)
|
||||
import Yesod.Logger (Logger)
|
||||
import Network.Wai.Middleware.RequestLogger (logStdout)
|
||||
#endif
|
||||
import qualified Database.Persist.Base~importMigration~
|
||||
import qualified Database.Persist.Store~importMigration~
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
import Handler.Root
|
||||
@ -33,12 +33,12 @@ mkYesodDispatch "~sitearg~" resources~sitearg~
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
with~sitearg~ :: AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO ()
|
||||
with~sitearg~ :: AppConfig DefaultEnv Extra -> Logger -> (Application -> IO ()) -> IO ()
|
||||
with~sitearg~ conf logger f = do
|
||||
s <- staticSite
|
||||
dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf)
|
||||
$ either error return . Database.Persist.Base.loadConfig
|
||||
Database.Persist.Base.withPool (dbconf :: Settings.PersistConfig) $ \p -> do~runMigration~
|
||||
$ either error return . Database.Persist.Store.loadConfig
|
||||
Database.Persist.Store.withPool (dbconf :: Settings.PersistConfig) $ \p -> do~runMigration~
|
||||
let h = ~sitearg~ conf logger s p
|
||||
defaultRunner (f . logWare) h
|
||||
where
|
||||
@ -50,4 +50,10 @@ with~sitearg~ conf logger f = do
|
||||
|
||||
-- for yesod devel
|
||||
withDevelAppPort :: Dynamic
|
||||
withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~
|
||||
withDevelAppPort =
|
||||
toDyn $ defaultDevelAppWith loader with~sitearg~
|
||||
where
|
||||
loader = loadConfig (configSettings Development)
|
||||
{ csLoadExtra = loadExtra
|
||||
}
|
||||
|
||||
|
||||
@ -16,7 +16,7 @@ module Foundation
|
||||
) where
|
||||
|
||||
import Prelude
|
||||
import Yesod hiding (Form, AppConfig (..), withYamlEnvironment)
|
||||
import Yesod
|
||||
import Yesod.Static (Static, base64md5, StaticRoute(..))
|
||||
import Settings.StaticFiles
|
||||
import Yesod.Auth
|
||||
@ -29,9 +29,9 @@ import Yesod.Logger (logLazyText)
|
||||
#endif
|
||||
import qualified Settings
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Database.Persist.Base
|
||||
import qualified Database.Persist.Store
|
||||
import Database.Persist.~importGenericDB~
|
||||
import Settings (widgetFile)
|
||||
import Settings (widgetFile, Extra)
|
||||
import Model
|
||||
import Text.Jasmine (minifym)
|
||||
import Web.ClientSession (getKey)
|
||||
@ -47,10 +47,10 @@ import Network.Mail.Mime (sendmail)
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
-- access to the data present here.
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ settings :: AppConfig DefaultEnv ()
|
||||
{ settings :: AppConfig DefaultEnv Extra
|
||||
, getLogger :: Logger
|
||||
, 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.
|
||||
@ -125,8 +125,7 @@ instance Yesod ~sitearg~ where
|
||||
-- How to run database actions.
|
||||
instance YesodPersist ~sitearg~ where
|
||||
type YesodPersistBackend ~sitearg~ = ~dbMonad~
|
||||
runDB f = liftIOHandler
|
||||
$ fmap connPool getYesod >>= Database.Persist.Base.runPool (undefined :: Settings.PersistConfig) f
|
||||
runDB f = fmap connPool getYesod >>= Database.Persist.Store.runPool (undefined :: Settings.PersistConfig) f
|
||||
|
||||
instance YesodAuth ~sitearg~ where
|
||||
type AuthId ~sitearg~ = UserId
|
||||
|
||||
@ -3,11 +3,13 @@ module Model where
|
||||
import Prelude
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Quasi
|
||||
~modelImports~
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
-- http://www.yesodweb.com/book/persistent/
|
||||
share [mkPersist ~mkPersistSettings~, mkMigrate "migrateAll"] $(persistFile "config/models")
|
||||
share [mkPersist ~mkPersistSettings~, mkMigrate "migrateAll"]
|
||||
$(persistFile upperCaseSettings "config/models")
|
||||
|
||||
|
||||
@ -8,15 +8,18 @@ module Settings
|
||||
, PersistConfig
|
||||
, staticRoot
|
||||
, staticDir
|
||||
, Extra (..)
|
||||
, loadExtra
|
||||
) where
|
||||
|
||||
import Prelude (FilePath, String)
|
||||
import Prelude
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Database.Persist.~importPersist~ (~configPersist~)
|
||||
import Yesod.Default.Config
|
||||
import qualified Yesod.Default.Util
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml
|
||||
|
||||
-- | Which Persistent backend this site is using.
|
||||
type PersistConfig = ~configPersist~
|
||||
@ -54,3 +57,9 @@ widgetFile = Yesod.Default.Util.widgetFileReload
|
||||
#else
|
||||
widgetFile = Yesod.Default.Util.widgetFileNoReload
|
||||
#endif
|
||||
|
||||
data Extra = Extra
|
||||
|
||||
loadExtra :: DefaultEnv -> Value -> IO Extra
|
||||
loadExtra _ _ = return Extra
|
||||
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Application (with~sitearg~)
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgsExtra)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Settings (loadExtra)
|
||||
import Application (with~sitearg~)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain fromArgs with~sitearg~
|
||||
main = defaultMain (fromArgsExtra loadExtra) with~sitearg~
|
||||
|
||||
@ -74,24 +74,25 @@ executable ~project~
|
||||
FlexibleContexts
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 0.9.3.4 && < 0.10
|
||||
, yesod-core >= 0.9.3 && < 0.10
|
||||
, yesod-auth >= 0.7.3 && < 0.8
|
||||
, yesod-static >= 0.3.1 && < 0.4
|
||||
, yesod-default >= 0.5 && < 0.6
|
||||
, yesod-form >= 0.3.4 && < 0.4
|
||||
, yesod >= 0.10 && < 0.11
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, yesod-auth >= 0.8 && < 0.9
|
||||
, yesod-static >= 0.10 && < 0.11
|
||||
, yesod-default >= 0.6 && < 0.7
|
||||
, yesod-form >= 0.4 && < 0.5
|
||||
, mime-mail >= 0.3.0.3 && < 0.5
|
||||
, clientsession >= 0.7.3 && < 0.8
|
||||
, bytestring >= 0.9 && < 0.10
|
||||
, text >= 0.11 && < 0.12
|
||||
, persistent >= 0.6.2 && < 0.7
|
||||
, persistent-~backendLower~ >= 0.6 && < 0.7
|
||||
, persistent >= 0.7 && < 0.8
|
||||
, persistent-~backendLower~ >= 0.7 && < 0.8
|
||||
, template-haskell
|
||||
, hamlet >= 0.10 && < 0.11
|
||||
, shakespeare-css >= 0.10 && < 0.11
|
||||
, shakespeare-js >= 0.10 && < 0.11
|
||||
, shakespeare-text >= 0.10 && < 0.11
|
||||
, hjsmin >= 0.0.14 && < 0.1
|
||||
, monad-control ~monadControlVersion~
|
||||
, wai-extra >= 0.4.6 && < 0.5
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, yaml >= 0.5 && < 0.6
|
||||
|
||||
|
||||
@ -5,9 +5,10 @@ module Application
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Settings (loadExtra)
|
||||
import Settings.StaticFiles (staticSite)
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Main (defaultDevelApp, defaultRunner)
|
||||
import Yesod.Default.Main (defaultDevelAppWith, defaultRunner)
|
||||
import Yesod.Default.Handlers (getFaviconR, getRobotsR)
|
||||
import Yesod.Logger (Logger)
|
||||
import Network.Wai (Application)
|
||||
@ -25,7 +26,7 @@ mkYesodDispatch "~sitearg~" resources~sitearg~
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
with~sitearg~ :: AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO ()
|
||||
with~sitearg~ :: AppConfig DefaultEnv Extra -> Logger -> (Application -> IO ()) -> IO ()
|
||||
with~sitearg~ conf logger f = do
|
||||
s <- staticSite
|
||||
let h = ~sitearg~ conf logger s
|
||||
@ -33,4 +34,10 @@ with~sitearg~ conf logger f = do
|
||||
|
||||
-- for yesod devel
|
||||
withDevelAppPort :: Dynamic
|
||||
withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~
|
||||
withDevelAppPort =
|
||||
toDyn $ defaultDevelAppWith loader with~sitearg~
|
||||
where
|
||||
loader = loadConfig (configSettings Development)
|
||||
{ csLoadExtra = loadExtra
|
||||
}
|
||||
|
||||
|
||||
@ -13,14 +13,14 @@ module Foundation
|
||||
) where
|
||||
|
||||
import Prelude
|
||||
import Yesod.Core hiding (AppConfig (..))
|
||||
import Yesod.Core
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Static (Static, base64md5, StaticRoute(..))
|
||||
import Settings.StaticFiles
|
||||
import Yesod.Logger (Logger, logMsg, formatLogText)
|
||||
import qualified Settings
|
||||
import Settings (widgetFile)
|
||||
import Settings (Extra, widgetFile)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Web.ClientSession (getKey)
|
||||
@ -31,7 +31,7 @@ import Text.Hamlet (hamletFile)
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
-- access to the data present here.
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ settings :: AppConfig DefaultEnv ()
|
||||
{ settings :: AppConfig DefaultEnv Extra
|
||||
, getLogger :: Logger
|
||||
, getStatic :: Static -- ^ Settings for static file serving.
|
||||
}
|
||||
|
||||
@ -7,14 +7,17 @@ module Settings
|
||||
( widgetFile
|
||||
, staticRoot
|
||||
, staticDir
|
||||
, Extra (..)
|
||||
, loadExtra
|
||||
) where
|
||||
|
||||
import Prelude (FilePath, String)
|
||||
import Prelude
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Yesod.Default.Config
|
||||
import qualified Yesod.Default.Util
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml
|
||||
|
||||
-- | The location of static files on your system. This is a file system
|
||||
-- path. The default value works properly with your scaffolded site.
|
||||
@ -43,3 +46,8 @@ widgetFile = Yesod.Default.Util.widgetFileReload
|
||||
#else
|
||||
widgetFile = Yesod.Default.Util.widgetFileNoReload
|
||||
#endif
|
||||
|
||||
data Extra = Extra
|
||||
|
||||
loadExtra :: DefaultEnv -> Value -> IO Extra
|
||||
loadExtra _ _ = return Extra
|
||||
|
||||
@ -66,16 +66,17 @@ executable ~project~
|
||||
TypeFamilies
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9.3 && < 0.10
|
||||
, yesod-static >= 0.3.1 && < 0.4
|
||||
, yesod-default >= 0.5 && < 0.6
|
||||
, yesod-core >= 0.10 && < 0.11
|
||||
, yesod-static >= 0.10 && < 0.11
|
||||
, yesod-default >= 0.6 && < 0.7
|
||||
, clientsession >= 0.7.3 && < 0.8
|
||||
, bytestring >= 0.9 && < 0.10
|
||||
, text >= 0.11 && < 0.12
|
||||
, template-haskell
|
||||
, hamlet >= 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
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
, yaml >= 0.5 && < 0.6
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod
|
||||
version: 0.9.4.1
|
||||
version: 0.10.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -71,19 +71,19 @@ library
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: yesod-core >= 0.9.3.4 && < 0.10
|
||||
, yesod-auth >= 0.7 && < 0.8
|
||||
, yesod-json >= 0.2.2 && < 0.3
|
||||
, yesod-persistent >= 0.2 && < 0.3
|
||||
, yesod-form >= 0.3 && < 0.4
|
||||
, monad-control >= 0.2 && < 0.4
|
||||
build-depends: yesod-core >= 0.10 && < 0.11
|
||||
, yesod-auth >= 0.8 && < 0.9
|
||||
, yesod-json >= 0.3 && < 0.4
|
||||
, yesod-persistent >= 0.3 && < 0.4
|
||||
, yesod-form >= 0.4 && < 0.5
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4.6 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, hamlet >= 0.10 && < 0.11
|
||||
, shakespeare-js >= 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
|
||||
exposed-modules: Yesod
|
||||
ghc-options: -Wall
|
||||
|
||||
Loading…
Reference in New Issue
Block a user