diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 0034ae5d..73178147 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -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) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index d6ae02a8..3aaa68e9 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -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 diff --git a/yesod-auth/Yesod/Auth/Facebook.hs b/yesod-auth/Yesod/Auth/Facebook.hs index c4dbd1c0..28ec3868 100644 --- a/yesod-auth/Yesod/Auth/Facebook.hs +++ b/yesod-auth/Yesod/Auth/Facebook.hs @@ -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) diff --git a/yesod-auth/Yesod/Auth/HashDB.hs b/yesod-auth/Yesod/Auth/HashDB.hs index 5494d61b..583f6af9 100644 --- a/yesod-auth/Yesod/Auth/HashDB.hs +++ b/yesod-auth/Yesod/Auth/HashDB.hs @@ -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 diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index c99d4776..f898fdda 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -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 diff --git a/yesod-core/Yesod/Config.hs b/yesod-core/Yesod/Config.hs deleted file mode 100644 index e7bd4a11..00000000 --- a/yesod-core/Yesod/Config.hs +++ /dev/null @@ -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 diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index 6244474c..292859ac 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -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. diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 4a78bec7..d96d656b 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -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) diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index abe49064..a5998bfc 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -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 diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index bd7d30ea..36c29819 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -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 } diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index 9b97cd6b..594e52de 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -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 diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 9d468747..f61a59ef 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -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 diff --git a/yesod-core/Yesod/Internal/Dispatch.hs b/yesod-core/Yesod/Internal/Dispatch.hs index 5be1fc0e..5b0aa73f 100644 --- a/yesod-core/Yesod/Internal/Dispatch.hs +++ b/yesod-core/Yesod/Internal/Dispatch.hs @@ -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") []) diff --git a/yesod-core/Yesod/Internal/RouteParsing.hs b/yesod-core/Yesod/Internal/RouteParsing.hs index dcb475c4..e1f9f734 100644 --- a/yesod-core/Yesod/Internal/RouteParsing.hs +++ b/yesod-core/Yesod/Internal/RouteParsing.hs @@ -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. diff --git a/yesod-core/Yesod/Internal/TestApi.hs b/yesod-core/Yesod/Internal/TestApi.hs index 8ff18528..ffb1387e 100644 --- a/yesod-core/Yesod/Internal/TestApi.hs +++ b/yesod-core/Yesod/Internal/TestApi.hs @@ -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 diff --git a/yesod-core/Yesod/Request.hs b/yesod-core/Yesod/Request.hs index 3d42e3cb..a0559e51 100644 --- a/yesod-core/Yesod/Request.hs +++ b/yesod-core/Yesod/Request.hs @@ -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 diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 24918358..aa45eb30 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 271469d7..16118e46 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -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 () diff --git a/yesod-core/test/YesodCoreTest/YesodTest.hs b/yesod-core/test/YesodCoreTest/YesodTest.hs index 30790f95..9150f5ad 100644 --- a/yesod-core/test/YesodCoreTest/YesodTest.hs +++ b/yesod-core/test/YesodCoreTest/YesodTest.hs @@ -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) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4fa15091..6d44c1e6 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.9.4 +version: 0.10.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/yesod-default/Yesod/Default/Config.hs b/yesod-default/Yesod/Default/Config.hs index 4a35c090..73967342 100644 --- a/yesod-default/Yesod/Default/Config.hs +++ b/yesod-default/Yesod/Default/Config.hs @@ -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 diff --git a/yesod-default/Yesod/Default/Main.hs b/yesod-default/Yesod/Default/Main.hs index fd0638f8..20221cbf 100644 --- a/yesod-default/Yesod/Default/Main.hs +++ b/yesod-default/Yesod/Default/Main.hs @@ -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) diff --git a/yesod-default/yesod-default.cabal b/yesod-default/yesod-default.cabal index ca3cd30f..e449e653 100644 --- a/yesod-default/yesod-default.cabal +++ b/yesod-default/yesod-default.cabal @@ -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 diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index ad94b825..53ef9903 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -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|\ - + |] } 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|\ - + |] } 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|\ - + |] } 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|\ - + |] } 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|\ -