From 604ca3dc365177709dea008ef23426879669b33c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 17:47:13 +0200 Subject: [PATCH 001/126] monad-peel --- Yesod.hs | 4 ++-- Yesod/Handler.hs | 14 ++------------ Yesod/Widget.hs | 13 ++----------- yesod.cabal | 9 +++++---- 4 files changed, 11 insertions(+), 29 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 948e1b01..25b55099 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,7 +13,7 @@ module Yesod , Application , lift , liftIO - , MonadInvertIO + , MonadPeelIO , mempty , showIntegral , readIntegral @@ -41,7 +41,7 @@ import Yesod.Hamlet import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Data.Monoid (mempty) -import Control.Monad.Invert (MonadInvertIO) +import Control.Monad.IO.Peel (MonadPeelIO) showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 608ac2aa..be1740d5 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -112,8 +112,7 @@ import Control.Failure (Failure (failure)) import Text.Hamlet -import Control.Monad.Invert (MonadInvertIO (..)) -import Control.Monad (liftM) +import Control.Monad.IO.Peel (MonadPeelIO) import qualified Data.Map as Map import qualified Data.ByteString.Char8 as S8 @@ -210,7 +209,7 @@ newtype GHandler sub master a = GHandler { unGHandler :: GHInner sub master a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) type GHInner s m = ReaderT (HandlerData s m) ( @@ -222,15 +221,6 @@ type GHInner s m = type SessionMap = Map.Map String String -instance MonadInvertIO (GHandler s m) where - newtype InvertedIO (GHandler s m) a = - InvGHandlerIO - { runInvGHandlerIO :: InvertedIO (GHInner s m) a - } - type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ())) - invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler - revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f - type Endo a = a -> a -- | An extension of the basic WAI 'W.Application' datatype to provide extra diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index efff5338..7be74bb9 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -46,7 +46,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Yesod.Internal -import Control.Monad.Invert (MonadInvertIO (..)) +import Control.Monad.IO.Peel (MonadPeelIO) import Control.Monad (liftM) import qualified Data.Map as Map @@ -54,7 +54,7 @@ import qualified Data.Map as Map -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) type GWInner sub master = WriterT (Body (Route master)) ( WriterT (Last Title) ( @@ -69,15 +69,6 @@ type GWInner sub master = instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y -instance MonadInvertIO (GWidget s m) where - newtype InvertedIO (GWidget s m) a = - InvGWidgetIO - { runInvGWidgetIO :: InvertedIO (GWInner s m) a - } - type InvertedArg (GWidget s m) = - (Int, (HandlerData s m, (Map.Map String String, ()))) - invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget - revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f instance HamletValue (GWidget s m ()) where newtype HamletMonad (GWidget s m ()) a = diff --git a/yesod.cabal b/yesod.cabal index c28800ed..ff1d5f72 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.8 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -36,7 +36,7 @@ library , text >= 0.5 && < 0.12 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6.2 && < 0.7 - , hamlet >= 0.5.1 && < 0.7 + , hamlet >= 0.6 && < 0.7 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 @@ -45,8 +45,8 @@ library , cereal >= 0.2 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.3.0 && < 0.4 - , neither >= 0.1.0 && < 0.2 + , persistent >= 0.4 && < 0.5 + , neither >= 0.2 && < 0.3 , network >= 2.2.1.5 && < 2.4 , email-validate >= 0.2.5 && < 0.3 , web-routes >= 0.23 && < 0.24 @@ -54,6 +54,7 @@ library , data-default >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 + , monad-peel >= 0.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 0a85092ae79f76aab555373f32bbde739955478f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 18:12:55 +0200 Subject: [PATCH 002/126] wai 0.3 --- Yesod/Content.hs | 19 +++++++++++-------- Yesod/Dispatch.hs | 44 +++++++++++++++++++++++++++++++++----------- Yesod/Handler.hs | 5 ++++- Yesod/Json.hs | 1 + yesod.cabal | 5 +++-- 5 files changed, 52 insertions(+), 22 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 7d4d5683..e8fe59b0 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -8,7 +8,7 @@ module Yesod.Content ( -- * Content - Content + Content (..) , emptyContent , ToContent (..) -- * Mime types @@ -57,8 +57,6 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text) import qualified Data.Text as T -import qualified Network.Wai as W - import Data.Time import System.Locale @@ -72,11 +70,16 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) #endif -type Content = W.ResponseBody +import Data.Enumerator (Enumerator) +import Blaze.ByteString.Builder (Builder) + +data Content = ContentLBS L.ByteString + | ContentEnum (forall a. Enumerator Builder IO a) + | ContentFile FilePath -- | Zero-length enumerator. emptyContent :: Content -emptyContent = W.ResponseLBS L.empty +emptyContent = ContentLBS L.empty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -86,13 +89,13 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent = W.ResponseLBS . L.fromChunks . return + toContent = ContentLBS . L.fromChunks . return instance ToContent L.ByteString where - toContent = W.ResponseLBS + toContent = ContentLBS instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = ContentLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index afd94551..f95af393 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -43,7 +43,7 @@ import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPathFunc) +import Network.Wai.Middleware.CleanPath (cleanPath) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -75,6 +75,9 @@ import System.Random (randomR, newStdGen) import qualified Data.Map as Map +import Control.Applicative ((<$>)) +import Data.Enumerator (($$), run_) + #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -234,15 +237,25 @@ sessionName :: String sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI --- handler. You can use 'basicHandler' if you wish. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiApp a = do +-- handler. This is the same as 'toWaiAppPlain', except it includes three +-- middlewares: GZIP compression, JSON-P and path cleaning. This is the +-- recommended approach for most users. +toWaiApp :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiApp y = do + a <- toWaiAppPlain y + return $ gzip False + $ jsonp + a + +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. This differs from 'toWaiApp' in that it only uses the cleanpath +-- middleware. +toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiAppPlain a = do key' <- if enableClientSessions a then Just `fmap` encryptKey a else return Nothing - return $ gzip - $ jsonp - $ cleanPathFunc (splitPath a) (B.pack $ approot a) + return $ cleanPath (splitPath a) (B.pack $ approot a) $ toWaiApp' a key' toWaiApp' :: (Yesod y, YesodSite y) @@ -250,7 +263,7 @@ toWaiApp' :: (Yesod y, YesodSite y) -> Maybe Key -> [String] -> W.Request - -> IO W.Response + -> IO (W.Response a) toWaiApp' y key' segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -318,7 +331,12 @@ toWaiApp' y key' segments env = do : hs hs'' = map (headerToPair getExpires) hs' hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ W.Response s hs''' c + return $ + case c of + ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentFile fp -> W.ResponseFile s hs''' fp + ContentEnum e -> W.ResponseEnumerator $ \iter -> + run_ $ e $$ iter s hs''' httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack @@ -399,8 +417,12 @@ nonceKey :: String nonceKey = "_NONCE" rbHelper :: W.Request -> IO RequestBodyContents -rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (bsToChars *** bsToChars) +rbHelper req = + (map fix1 *** map fix2) <$> run_ (enum $$ iter) + where + enum = W.requestBody req + iter = parseRequestBody lbsSink req + fix1 = bsToChars *** bsToChars fix2 (x, NWP.FileInfo a b c) = (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index be1740d5..7bb01d74 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -311,7 +311,7 @@ runHandler handler mrender sroute tomr ma tosa = let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = - return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) + return (W.status200, headers [], ct, ContentFile fp, finalSession) case contents of HCContent status a -> do (ct, c) <- chooseRep a cts @@ -559,3 +559,6 @@ testSuite = testGroup "Yesod.Handler" ] #endif + +-- FIXME add a sendEnum that uses a ResponseEnumerator and bypasses all status +-- and header stuff diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 3e96aca3..bd22f66e 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,4 +1,5 @@ -- | Efficient generation of JSON documents. +-- FIXME remove this module, possibly make a blaze-json {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/yesod.cabal b/yesod.cabal index ff1d5f72..6276a1d3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -29,8 +29,8 @@ library else build-depends: base >= 4 && < 4.3 build-depends: time >= 1.1.4 && < 1.3 - , wai >= 0.2.0 && < 0.3 - , wai-extra >= 0.2.4 && < 0.3 + , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 @@ -55,6 +55,7 @@ library , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 + , enumerator >= 0.4 && < 0.5 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 68e5969ecfb7ae4d8e592224ec8981f8db6c6d12 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 20:30:26 +0200 Subject: [PATCH 003/126] Removed type variable on Response et al --- Yesod/Dispatch.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f95af393..bc508a39 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -240,7 +240,7 @@ sessionName = "_SESSION" -- handler. This is the same as 'toWaiAppPlain', except it includes three -- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- recommended approach for most users. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiApp y = do a <- toWaiAppPlain y return $ gzip False @@ -250,7 +250,7 @@ toWaiApp y = do -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it only uses the cleanpath -- middleware. -toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiAppPlain a = do key' <- if enableClientSessions a then Just `fmap` encryptKey a @@ -263,7 +263,7 @@ toWaiApp' :: (Yesod y, YesodSite y) -> Maybe Key -> [String] -> W.Request - -> IO (W.Response a) + -> IO W.Response toWaiApp' y key' segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now From b2e95911d853bf098e95c49ce29f470e8e14f94e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 21:38:01 +0200 Subject: [PATCH 004/126] Full support for ResponseEnumerator --- Yesod/Dispatch.hs | 51 +++++++++++++++++++++-------------------- Yesod/Handler.hs | 58 +++++++++++++++++++++++++++++++++-------------- 2 files changed, 68 insertions(+), 41 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index bc508a39..27847cfc 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -313,30 +313,33 @@ toWaiApp' y key' segments env = do let ya = runHandler h render eurl' id y id let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' - (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = - case key' of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration y) - sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ - case c of - ContentLBS lbs -> W.ResponseLBS s hs''' lbs - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' + yar <- unYesodApp ya eh rr types sessionMap + case yar of + YARPlain s hs ct c sessionFinal -> do + let sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> + encodeSession key'' exp' host + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal + let hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", charsToBs ct) : hs'' + return $ + case c of + ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentFile fp -> W.ResponseFile s hs''' fp + ContentEnum e -> W.ResponseEnumerator $ \iter -> + run_ $ e $$ iter s hs''' + YAREnum e -> return $ W.ResponseEnumerator e httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7bb01d74..1420a8f4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -51,6 +51,7 @@ module Yesod.Handler , sendResponse , sendResponseStatus , sendResponseCreated + , sendResponseEnumerator -- * Setting headers , setCookie , deleteCookie @@ -85,6 +86,7 @@ module Yesod.Handler , localNoCurrent , HandlerData , ErrorResponse (..) + , YesodAppResult (..) #if TEST , testSuite #endif @@ -232,15 +234,20 @@ newtype YesodApp = YesodApp -> Request -> [ContentType] -> SessionMap - -> IO (W.Status, [Header], ContentType, Content, SessionMap) + -> IO YesodAppResult } +data YesodAppResult + = YAREnum (forall a. W.ResponseEnumerator a) + | YARPlain W.Status [Header] ContentType Content SessionMap + data HandlerContents = HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String | HCCreated String + | HCEnum (forall a. W.ResponseEnumerator a) instance Failure ErrorResponse (GHandler sub master) where failure = GHandler . lift . throwMEither . HCError @@ -307,34 +314,46 @@ runHandler handler mrender sroute tomr ma tosa = ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) let contents = meither id (HCContent W.status200 . chooseRep) contents' let handleError e = do - (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession - let hs' = headers hs - return (getStatus e, hs', ct, c, sess) + yar <- unYesodApp (eh e) safeEh rr cts finalSession + case yar of + YARPlain _ hs ct c sess -> + let hs' = headers hs + in return $ YARPlain (getStatus e) hs' ct c sess + YAREnum _ -> return yar let sendFile' ct fp = - return (W.status200, headers [], ct, ContentFile fp, finalSession) + return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession case contents of HCContent status a -> do (ct, c) <- chooseRep a cts - return (status, headers [], ct, c, finalSession) + return $ YARPlain status (headers []) ct c finalSession HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] - return (getRedirectStatus rt, hs, typePlain, emptyContent, - finalSession) + return $ YARPlain + (getRedirectStatus rt) hs typePlain emptyContent + finalSession HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) - HCCreated loc -> do + HCCreated loc -> do -- FIXME add status201 to WAI let hs = Header "Location" loc : headers [] - return (W.Status 201 (S8.pack "Created"), hs, typePlain, - emptyContent, - finalSession) + return $ YARPlain + (W.Status 201 (S8.pack "Created")) + hs + typePlain + emptyContent + finalSession + HCEnum e -> return $ YAREnum e safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.status500, [], typePlain, toContent "Internal Server Error", - session) + return $ YARPlain + W.status500 + [] + typePlain + (toContent "Internal Server Error") + session -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a @@ -439,6 +458,14 @@ sendResponseCreated url = do r <- getUrlRender GHandler $ lift $ throwMEither $ HCCreated $ r url +-- | Send a 'W.ResponseEnumerator'. Please note: this function is rarely +-- necessary, and will /disregard/ any changes to response headers and session +-- that you have already specified. This function short-circuits. It should be +-- considered only for they specific needs. If you are not sure if you need it, +-- you don't. +sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b +sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum + -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound @@ -559,6 +586,3 @@ testSuite = testGroup "Yesod.Handler" ] #endif - --- FIXME add a sendEnum that uses a ResponseEnumerator and bypasses all status --- and header stuff From 522203f81277c92d61f463f8e95ca26d2deddf8f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 22:05:54 +0200 Subject: [PATCH 005/126] Removed Yesod.Form hierarchy All of this code will be included in a separate yesod-form package to allow for more flexibility in API changes, plus to make it more natural to swap in other packages such as digestive-functors. --- Yesod.hs | 2 - Yesod/Form.hs | 341 ---------------------------------- Yesod/Form/Class.hs | 61 ------ Yesod/Form/Core.hs | 369 ------------------------------------- Yesod/Form/Fields.hs | 409 ----------------------------------------- Yesod/Form/Jquery.hs | 235 ----------------------- Yesod/Form/Nic.hs | 61 ------ Yesod/Form/Profiles.hs | 235 ----------------------- Yesod/Helpers/Crud.hs | 208 --------------------- Yesod/Widget.hs | 4 +- hellowidget.hs | 161 ---------------- yesod.cabal | 10 +- 12 files changed, 2 insertions(+), 2094 deletions(-) delete mode 100644 Yesod/Form.hs delete mode 100644 Yesod/Form/Class.hs delete mode 100644 Yesod/Form/Core.hs delete mode 100644 Yesod/Form/Fields.hs delete mode 100644 Yesod/Form/Jquery.hs delete mode 100644 Yesod/Form/Nic.hs delete mode 100644 Yesod/Form/Profiles.hs delete mode 100644 Yesod/Helpers/Crud.hs delete mode 100644 hellowidget.hs diff --git a/Yesod.hs b/Yesod.hs index 25b55099..f3be2aa7 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -6,7 +6,6 @@ module Yesod , module Yesod.Yesod , module Yesod.Handler , module Yesod.Dispatch - , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json , module Yesod.Widget @@ -34,7 +33,6 @@ import Yesod.Handler hiding (runHandler) #endif import Yesod.Request -import Yesod.Form import Yesod.Widget import Network.Wai (Application) import Yesod.Hamlet diff --git a/Yesod/Form.hs b/Yesod/Form.hs deleted file mode 100644 index 9d9d054d..00000000 --- a/Yesod/Form.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | Parse forms (and query strings). -module Yesod.Form - ( -- * Data types - GForm - , FormResult (..) - , Enctype (..) - , FormFieldSettings (..) - , Textarea (..) - , FieldInfo (..) - -- ** Utilities - , formFailures - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - -- * Unwrapping functions - , generateForm - , runFormGet - , runFormMonadGet - , runFormPost - , runFormPostNoNonce - , runFormMonadPost - , runFormGet' - , runFormPost' - -- ** High-level form post unwrappers - , runFormTable - , runFormDivs - -- * Field/form helpers - , fieldsToTable - , fieldsToDivs - , fieldsToPlain - , checkForm - -- * Type classes - , module Yesod.Form.Class - -- * Template Haskell - , mkToForm - , module Yesod.Form.Fields - ) where - -import Yesod.Form.Core -import Yesod.Form.Fields -import Yesod.Form.Class -import Yesod.Form.Profiles (Textarea (..)) -import Yesod.Widget (GWidget) - -import Text.Hamlet -import Yesod.Request -import Yesod.Handler -import Control.Applicative hiding (optional) -import Data.Maybe (fromMaybe, mapMaybe) -import "transformers" Control.Monad.IO.Class -import Control.Monad ((<=<)) -import Language.Haskell.TH.Syntax -import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) -import Data.Char (toUpper, isUpper) -import Control.Arrow ((&&&)) -import Data.List (group, sort) - --- | Display only the actual input widget code, without any decoration. -fieldsToPlain :: FormField sub y a -> Form sub y a -fieldsToPlain = mapFormXml $ mapM_ fiInput - --- | Display the label, tooltip, input code and errors in a single row of a --- table. -fieldsToTable :: FormField sub y a -> Form sub y a -fieldsToTable = mapFormXml $ mapM_ go - where - go fi = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%tr.$clazz.fi$ - %td - %label!for=$fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ - %td - ^fiInput.fi^ - $maybe fiErrors.fi err - %td.errors $err$ -|] - clazz fi = if fiRequired fi then "required" else "optional" - --- | Display the label, tooltip, input code and errors in a single div. -fieldsToDivs :: FormField sub y a -> Form sub y a -fieldsToDivs = mapFormXml $ mapM_ go - where - go fi = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -.$clazz.fi$ - %label!for=$fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ - ^fiInput.fi^ - $maybe fiErrors.fi err - %div.errors $err$ -|] - clazz fi = if fiRequired fi then "required" else "optional" - --- | Run a form against POST parameters, without CSRF protection. -runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormPostNoNonce f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f - --- | Run a form against POST parameters. --- --- This function includes CSRF protection by checking a nonce value. You must --- therefore embed this nonce in the form as a hidden field; that is the --- meaning of the fourth element in the tuple. -runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) -runFormPost f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - nonce <- fmap reqNonce getRequest - (res, xml, enctype) <- runFormGeneric pp files f - let res' = - case res of - FormSuccess x -> - if lookup nonceName pp == Just nonce - then FormSuccess x - else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] - _ -> res - return (res', xml, enctype, hidden nonce) - where - hidden nonce = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input!type=hidden!name=$nonceName$!value=$nonce$ -|] - -nonceName :: String -nonceName = "_nonce" - --- | Run a form against POST parameters. Please note that this does not provide --- CSRF protection. -runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadPost f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f - --- | Run a form against POST parameters, disregarding the resulting HTML and --- returning an error response on invalid input. Note: this does /not/ perform --- CSRF protection. -runFormPost' :: GForm sub y xml a -> GHandler sub y a -runFormPost' f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - x <- runFormGeneric pp files f - helper x - --- | Create a table-styled form. --- --- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of --- some of the boiler-plate in creating forms. In particular, is automatically --- creates the form element, sets the method, action and enctype attributes, --- adds the CSRF-protection nonce hidden field and inserts a submit button. -runFormTable :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormTable dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form - let widget' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@dest@!enctype=$enctype$ - %table - ^widget^ - %tr - %td!colspan=2 - $nonce$ - %input!type=submit!value=$inputLabel$ -|] - return (res, widget') - --- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. -runFormDivs :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormDivs dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form - let widget' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@dest@!enctype=$enctype$ - ^widget^ - %div - $nonce$ - %input!type=submit!value=$inputLabel$ -|] - return (res, widget') - --- | Run a form against GET parameters, disregarding the resulting HTML and --- returning an error response on invalid input. -runFormGet' :: GForm sub y xml a -> GHandler sub y a -runFormGet' = helper <=< runFormGet - -helper :: (FormResult a, b, c) -> GHandler sub y a -helper (FormSuccess a, _, _) = return a -helper (FormFailure e, _, _) = invalidArgs e -helper (FormMissing, _, _) = invalidArgs ["No input found"] - --- | Generate a form, feeding it no data. The third element in the result tuple --- is a nonce hidden field. -generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) -generateForm f = do - (_, b, c) <- runFormGeneric [] [] f - nonce <- fmap reqNonce getRequest - return (b, c, -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input!type=hidden!name=$nonceName$!value=$nonce$ -|]) - --- | Run a form against GET parameters. -runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - -runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - --- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: PersistEntity v => v -> Q [Dec] -mkToForm = - fmap return . derive . entityDef - where - afterPeriod s = - case dropWhile (/= '.') s of - ('.':t) -> t - _ -> s - beforePeriod s = - case break (== '.') s of - (t, '.':_) -> Just t - _ -> Nothing - getSuperclass (_, _, z) = getTFF' z >>= beforePeriod - getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z - getTFF' [] = Nothing - getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x - getTFF' (_:x) = getTFF' x - getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z - getLabel' [] = Nothing - getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x - getLabel' (_:x) = getLabel' x - getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z - getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x - getTooltip' (_:x) = getTooltip' x - getTooltip' [] = Nothing - getId (_, _, z) = fromMaybe "" $ getId' z - getId' (('i':'d':'=':x):_) = Just x - getId' (_:x) = getId' x - getId' [] = Nothing - getName (_, _, z) = fromMaybe "" $ getName' z - getName' (('n':'a':'m':'e':'=':x):_) = Just x - getName' (_:x) = getName' x - getName' [] = Nothing - derive :: EntityDef -> Q Dec - derive t = do - let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t - ap <- [|(<*>)|] - just <- [|pure|] - nothing <- [|Nothing|] - let just' = just `AppE` ConE (mkName $ entityName t) - string' <- [|string|] - ftt <- [|fieldsToTable|] - ffs' <- [|FormFieldSettings|] - let stm "" = nothing - stm x = just `AppE` LitE (StringL x) - let go_ = go ap just' ffs' stm string' ftt - let c1 = Clause [ ConP (mkName "Nothing") [] - ] - (NormalB $ go_ $ zip cols $ map (const nothing) cols) - [] - xs <- mapM (const $ newName "x") cols - let xs' = map (AppE just . VarE) xs - let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) - $ map VarP xs]] - (NormalB $ go_ $ zip cols xs') - [] - let y = mkName "y" - let ctx = map (\x -> ClassP (mkName x) [VarT y]) - $ map head $ group $ sort - $ mapMaybe getSuperclass - $ entityColumns t - return $ InstanceD ctx ( ConT ''ToForm - `AppT` ConT (mkName $ entityName t) - `AppT` VarT y) - [FunD (mkName "toForm") [c1, c2]] - go ap just' ffs' stm string' ftt a = - let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a - in ftt `AppE` x - go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = - let label' = LitE $ StringL label - tooltip' = string' `AppE` LitE (StringL tooltip) - ffs = ffs' `AppE` - label' `AppE` - tooltip' `AppE` - (stm theId) `AppE` - (stm name) - in VarE (mkName tff) `AppE` ffs `AppE` ex - ap' ap x y = InfixE (Just x) ap (Just y) - -toLabel :: String -> String -toLabel "" = "" -toLabel (x:rest) = toUpper x : go rest - where - go "" = "" - go (c:cs) - | isUpper c = ' ' : c : go cs - | otherwise = c : go cs - -formFailures :: FormResult a -> Maybe [String] -formFailures (FormFailure x) = Just x -formFailures _ = Nothing diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs deleted file mode 100644 index 290b15d7..00000000 --- a/Yesod/Form/Class.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Yesod.Form.Class - ( ToForm (..) - , ToFormField (..) - ) where - -import Text.Hamlet -import Yesod.Form.Fields -import Yesod.Form.Core -import Yesod.Form.Profiles (Textarea) -import Data.Int (Int64) -import Data.Time (Day, TimeOfDay) - -class ToForm a y where - toForm :: Formlet sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> FormletField sub y a - -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) y where - toFormField = maybeStringField - -instance ToFormField Int y where - toFormField = intField -instance ToFormField (Maybe Int) y where - toFormField = maybeIntField -instance ToFormField Int64 y where - toFormField = intField -instance ToFormField (Maybe Int64) y where - toFormField = maybeIntField - -instance ToFormField Double y where - toFormField = doubleField -instance ToFormField (Maybe Double) y where - toFormField = maybeDoubleField - -instance ToFormField Day y where - toFormField = dayField -instance ToFormField (Maybe Day) y where - toFormField = maybeDayField - -instance ToFormField TimeOfDay y where - toFormField = timeField -instance ToFormField (Maybe TimeOfDay) y where - toFormField = maybeTimeField - -instance ToFormField Bool y where - toFormField = boolField - -instance ToFormField Html y where - toFormField = htmlField -instance ToFormField (Maybe Html) y where - toFormField = maybeHtmlField - -instance ToFormField Textarea y where - toFormField = textareaField -instance ToFormField (Maybe Textarea) y where - toFormField = maybeTextareaField diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs deleted file mode 100644 index be5fcbe0..00000000 --- a/Yesod/Form/Core.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | Users of the forms library should not need to use this module in general. --- It is intended only for writing custom forms and form fields. -module Yesod.Form.Core - ( FormResult (..) - , GForm (..) - , newFormIdent - , deeperFormIdent - , shallowerFormIdent - , Env - , FileEnv - , Enctype (..) - , Ints (..) - , requiredFieldHelper - , optionalFieldHelper - , fieldsToInput - , mapFormXml - , checkForm - , checkField - , askParams - , askFiles - , liftForm - , IsForm (..) - , RunForm (..) - , GFormMonad - -- * Data types - , FieldInfo (..) - , FormFieldSettings (..) - , FieldProfile (..) - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - ) where - -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Class (lift) -import Yesod.Handler -import Yesod.Widget -import Data.Monoid (Monoid (..)) -import Control.Applicative -import Yesod.Request -import Control.Monad (liftM) -import Text.Hamlet -import Data.String -import Control.Monad (join) - --- | A form can produce three different results: there was no data available, --- the data was invalid, or there was a successful parse. --- --- The 'Applicative' instance will concatenate the failure messages in two --- 'FormResult's. -data FormResult a = FormMissing - | FormFailure [String] - | FormSuccess a - deriving Show -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing -instance Monoid m => Monoid (FormResult m) where - mempty = pure mempty - mappend x y = mappend <$> x <*> y - --- | The encoding type required by a form. The 'Show' instance produces values --- that can be inserted directly into HTML. -data Enctype = UrlEncoded | Multipart - deriving (Eq, Enum, Bounded) -instance ToHtml Enctype where - toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded" - toHtml Multipart = unsafeByteString "multipart/form-data" -instance Monoid Enctype where - mempty = UrlEncoded - mappend UrlEncoded UrlEncoded = UrlEncoded - mappend _ _ = Multipart - -data Ints = IntCons Int Ints | IntSingle Int -instance Show Ints where - show (IntSingle i) = show i - show (IntCons i is) = show i ++ '-' : show is - -incrInts :: Ints -> Ints -incrInts (IntSingle i) = IntSingle $ i + 1 -incrInts (IntCons i is) = (i + 1) `IntCons` is - --- | A generic form, allowing you to specifying the subsite datatype, master --- site datatype, a datatype for the form XML and the return type. -newtype GForm s m xml a = GForm - { deform :: FormInner s m (FormResult a, xml, Enctype) - } - -type GFormMonad s m a = WriterT Enctype (FormInner s m) a - -type FormInner s m = - StateT Ints ( - ReaderT Env ( - ReaderT FileEnv ( - GHandler s m - ))) - -type Env = [(String, String)] -type FileEnv = [(String, FileInfo)] - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m String -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ 'f' : show i' - -deeperFormIdent :: Monad m => StateT Ints m () -deeperFormIdent = do - i <- get - let i' = 1 `IntCons` incrInts i - put i' - -shallowerFormIdent :: Monad m => StateT Ints m () -shallowerFormIdent = do - IntCons _ i <- get - put i - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ liftM (first3 $ fmap f) g - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ do - (f1, f2, f3) <- f - (g1, g2, g3) <- g - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) - --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'. -requiredFieldHelper - :: IsForm f - => FieldProfile (FormSub f) (FormMaster f) (FormType f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -class IsForm f where - type FormSub f - type FormMaster f - type FormType f - toForm :: FormInner - (FormSub f) - (FormMaster f) - (FormResult (FormType f), - FieldInfo (FormSub f) (FormMaster f), - Enctype) -> f -instance IsForm (FormField s m a) where - type FormSub (FormField s m a) = s - type FormMaster (FormField s m a) = m - type FormType (FormField s m a) = a - toForm x = GForm $ do - (a, b, c) <- x - return (a, [b], c) -instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where - type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s - type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m - type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a - toForm x = do - (res, fi, enctype) <- lift x - tell enctype - return (res, fi) - -class RunForm f where - type RunFormSub f - type RunFormMaster f - type RunFormType f - runFormGeneric :: Env -> FileEnv -> f - -> GHandler (RunFormSub f) - (RunFormMaster f) - (RunFormType f) - -instance RunForm (GForm s m xml a) where - type RunFormSub (GForm s m xml a) = s - type RunFormMaster (GForm s m xml a) = m - type RunFormType (GForm s m xml a) = - (FormResult a, xml, Enctype) - runFormGeneric env fe (GForm f) = - runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe - -instance RunForm (GFormMonad s m a) where - type RunFormSub (GFormMonad s m a) = s - type RunFormMaster (GFormMonad s m a) = m - type RunFormType (GFormMonad s m a) = (a, Enctype) - runFormGeneric e fe f = - runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper - :: (IsForm f, Maybe b ~ FormType f) - => FieldProfile (FormSub f) (FormMaster f) b - -> FormFieldSettings - -> Maybe (Maybe b) - -> f -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val False - , fiErrors = case res of - FormFailure x -> Just $ string $ unlines x - _ -> Nothing - , fiRequired = False - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ do - (res, xml, enc) <- g - return (res, f xml, enc) - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - , fiRequired :: Bool - } - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: String - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings s mempty Nothing Nothing - --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - -- | ID, name, value, required - , fpWidget :: String -> String -> String -> Bool -> GWidget sub y () - } - -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] - --- | Add a validation check to a form. --- --- Note that if there is a validation error, this message will /not/ --- automatically appear on the form; for that, you need to use 'checkField'. -checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b -checkForm f (GForm form) = GForm $ do - (res, xml, enc) <- form - let res' = case res of - FormSuccess a -> f a - FormFailure e -> FormFailure e - FormMissing -> FormMissing - return (res', xml, enc) - --- | Add a validation check to a 'FormField'. --- --- Unlike 'checkForm', the validation error will appear in the generated HTML --- of the form. -checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b -checkField f (GForm form) = GForm $ do - (res, xml, enc) <- form - let (res', merr) = - case res of - FormSuccess a -> - case f a of - Left e -> (FormFailure [e], Just e) - Right x -> (FormSuccess x, Nothing) - FormFailure e -> (FormFailure e, Nothing) - FormMissing -> (FormMissing, Nothing) - let xml' = - case merr of - Nothing -> xml - Just err -> flip map xml $ \fi -> fi - { fiErrors = Just $ - case fiErrors fi of - Nothing -> string err - Just x -> x - } - return (res', xml', enc) - -askParams :: Monad m => StateT Ints (ReaderT Env m) Env -askParams = lift ask - -askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv -askFiles = lift $ lift ask - -liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a -liftForm = lift . lift . lift diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs deleted file mode 100644 index ad3fb22a..00000000 --- a/Yesod/Form/Fields.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Fields - ( -- * Fields - -- ** Required - stringField - , passwordField - , textareaField - , hiddenField - , intField - , doubleField - , dayField - , timeField - , htmlField - , selectField - , boolField - , emailField - , searchField - , urlField - , fileField - -- ** Optional - , maybeStringField - , maybePasswordField - , maybeTextareaField - , maybeHiddenField - , maybeIntField - , maybeDoubleField - , maybeDayField - , maybeTimeField - , maybeHtmlField - , maybeSelectField - , maybeEmailField - , maybeSearchField - , maybeUrlField - , maybeFileField - -- * Inputs - -- ** Required - , stringInput - , intInput - , boolInput - , dayInput - , emailInput - , urlInput - -- ** Optional - , maybeStringInput - , maybeDayInput - , maybeIntInput - ) where - -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Request (FileInfo) -import Yesod.Widget (GWidget) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.Time (Day, TimeOfDay) -import Text.Hamlet -import Data.Monoid -import Control.Monad (join) -import Data.Maybe (fromMaybe) - -stringField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeStringField = optionalFieldHelper stringFieldProfile - -passwordField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -passwordField = requiredFieldHelper passwordFieldProfile - -maybePasswordField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybePasswordField = optionalFieldHelper passwordFieldProfile - -intInput :: Integral i => String -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i) -maybeIntInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper intFieldProfile (nameSettings n) Nothing - -intField :: (Integral (FormType f), IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -intField = requiredFieldHelper intFieldProfile - -maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeIntField = optionalFieldHelper intFieldProfile - -doubleField :: (IsForm f, FormType f ~ Double) - => FormFieldSettings -> Maybe Double -> f -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) - => FormFieldSettings -> Maybe (Maybe Double) -> f -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -dayField :: (IsForm f, FormType f ~ Day) - => FormFieldSettings -> Maybe Day -> f -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField :: (IsForm f, FormType f ~ Maybe Day) - => FormFieldSettings -> Maybe (Maybe Day) -> f -maybeDayField = optionalFieldHelper dayFieldProfile - -timeField :: (IsForm f, FormType f ~ TimeOfDay) - => FormFieldSettings -> Maybe TimeOfDay -> f -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) - => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f -maybeTimeField = optionalFieldHelper timeFieldProfile - -boolField :: (IsForm f, FormType f ~ Bool) - => FormFieldSettings -> Maybe Bool -> f -boolField ffs orig = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - name <- maybe newFormIdent return $ ffsName ffs - theId <- maybe newFormIdent return $ ffsId ffs - let (res, val) = - if null env - then (FormMissing, fromMaybe False orig) - else case lookup name env of - Nothing -> (FormSuccess False, False) - Just "" -> (FormSuccess False, False) - Just "false" -> (FormSuccess False, False) - Just _ -> (FormSuccess True, True) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%input#$theId$!type=checkbox!name=$name$!:val:checked -|] - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -htmlField :: (IsForm f, FormType f ~ Html) - => FormFieldSettings -> Maybe Html -> f -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) - => FormFieldSettings -> Maybe (Maybe Html) -> f -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -selectField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, String)] - -> FormFieldSettings - -> Maybe x - -> f -selectField pairs ffs initial = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) - => [(x, String)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeSelectField pairs ffs initial' = toForm $ do - env <- askParams - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let input = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) - -stringInput :: String -> FormInput sub master String -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: String -> FormInput sub master (Maybe String) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: String -> FormInput sub master Bool -boolInput n = GForm $ do - env <- askParams - let res = case lookup n env of - Nothing -> FormSuccess False - Just "" -> FormSuccess False - Just "false" -> FormSuccess False - Just _ -> FormSuccess True - let xml = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input#$n$!type=checkbox!name=$n$ -|] - return (res, [xml], UrlEncoded) - -dayInput :: String -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: String -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - -nameSettings :: String -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -urlField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: String -> FormInput sub master String -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: String -> FormInput sub master String -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -searchField :: (IsForm f, FormType f ~ String) - => AutoFocus -> FormFieldSettings -> Maybe String -> f -searchField = requiredFieldHelper . searchFieldProfile - -maybeSearchField :: (IsForm f, FormType f ~ Maybe String) - => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f -maybeSearchField = optionalFieldHelper . searchFieldProfile - -textareaField :: (IsForm f, FormType f ~ Textarea) - => FormFieldSettings -> Maybe Textarea -> f -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeHiddenField = optionalFieldHelper hiddenFieldProfile - -fileField :: (IsForm f, FormType f ~ FileInfo) - => FormFieldSettings -> f -fileField ffs = toForm $ do - env <- lift ask - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = - if null env && null fenv - then FormMissing - else case lookup name fenv of - Nothing -> FormFailure ["File is required"] - Just x -> FormSuccess x - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, Multipart) - -maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo) - => FormFieldSettings -> f -maybeFileField ffs = toForm $ do - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = FormSuccess $ lookup name fenv - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name False - , fiErrors = Nothing - , fiRequired = True - } - return (res, fi, Multipart) - -fileWidget :: String -> String -> Bool -> GWidget s m () -fileWidget theId name isReq = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%input#$theId$!type=file!name=$name$!:isReq:required -|] diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs deleted file mode 100644 index d527bcd0..00000000 --- a/Yesod/Form/Jquery.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Some fields spiced up with jQuery UI. -module Yesod.Form.Jquery - ( YesodJquery (..) - , jqueryDayField - , maybeJqueryDayField - , jqueryDayTimeField - , jqueryDayTimeFieldProfile - , jqueryAutocompleteField - , maybeJqueryAutocompleteField - , jqueryDayFieldProfile - , googleHostedJqueryUiCss - , JqueryDaySettings (..) - , Default (..) - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Widget -import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, - timeToTimeOfDay) -import Yesod.Hamlet -import Data.Char (isSpace) -import Data.Default - -#if GHC7 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - --- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. -googleHostedJqueryUiCss :: String -> String -googleHostedJqueryUiCss theme = concat - [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/" - , theme - , "/jquery-ui.css" - ] - -class YesodJquery a where - -- | The jQuery 1.4 Javascript file. - urlJqueryJs :: a -> Either (Route a) String - urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js" - - -- | The jQuery UI 1.8 Javascript file. - urlJqueryUiJs :: a -> Either (Route a) String - urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js" - - -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. - urlJqueryUiCss :: a -> Either (Route a) String - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" - - -- | jQuery UI time picker add-on. - urlJqueryUiDateTimePicker :: a -> Either (Route a) String - urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" - -jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile - -maybeJqueryDayField - :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile - -jqueryDayFieldProfile :: YesodJquery y - => JqueryDaySettings -> FieldProfile sub y Day -jqueryDayFieldProfile jds = FieldProfile - { fpParse = maybe - (Left "Invalid day, must be in YYYY-MM-DD format") - Right - . readMay - , fpRender = show - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").datepicker({ - dateFormat:'yy-mm-dd', - changeMonth:%jsBool.jdsChangeMonth.jds%, - changeYear:%jsBool.jdsChangeYear.jds%, - numberOfMonths:%mos.jdsNumberOfMonths.jds%, - yearRange:"%jdsYearRange.jds%" -})}); -|] - } - where - jsBool True = "true" - jsBool False = "false" - mos (Left i) = show i - mos (Right (x, y)) = concat - [ "[" - , show x - , "," - , show y - , "]" - ] - -ifRight :: Either a b -> (b -> c) -> Either a c -ifRight e f = case e of - Left l -> Left l - Right r -> Right $ f r - -showLeadingZero :: (Show a) => a -> String -showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t - -jqueryDayTimeField - :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f)) - => FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile - --- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) -jqueryDayTimeUTCTime :: UTCTime -> String -jqueryDayTimeUTCTime (UTCTime day utcTime) = - let timeOfDay = timeToTimeOfDay utcTime - in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay - where - showTimeOfDay (TimeOfDay hour minute _) = - let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") - in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm - -jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime -jqueryDayTimeFieldProfile = FieldProfile - { fpParse = parseUTCTime - , fpRender = jqueryDayTimeUTCTime - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addScript' urlJqueryUiDateTimePicker - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); -|] - } - -parseUTCTime :: String -> Either String UTCTime -parseUTCTime s = - let (dateS, timeS) = break isSpace (dropWhile isSpace s) - dateE = parseDate dateS - in case dateE of - Left l -> Left l - Right date -> - ifRight (parseTime timeS) - (UTCTime date . timeOfDayToTime) - -jqueryAutocompleteField - :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile - -maybeJqueryAutocompleteField - :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryAutocompleteField src = - optionalFieldHelper $ jqueryAutocompleteFieldProfile src - -jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String -jqueryAutocompleteFieldProfile src = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); -|] - } - -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y - -addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () -addStylesheet' f = do - y <- liftHandler getYesod - addStylesheetEither $ f y - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -data JqueryDaySettings = JqueryDaySettings - { jdsChangeMonth :: Bool - , jdsChangeYear :: Bool - , jdsYearRange :: String - , jdsNumberOfMonths :: Either Int (Int, Int) - } - -instance Default JqueryDaySettings where - def = JqueryDaySettings - { jdsChangeMonth = False - , jdsChangeYear = False - , jdsYearRange = "c-10:c+10" - , jdsNumberOfMonths = Left 1 - } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs deleted file mode 100644 index 66447a4a..00000000 --- a/Yesod/Form/Nic.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Provide the user with a rich text editor. -module Yesod.Form.Nic - ( YesodNic (..) - , nicHtmlField - , maybeNicHtmlField - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Hamlet -import Yesod.Widget -import Text.HTML.SanitizeXSS (sanitizeBalance) - -import Yesod.Internal (lbsToChars) - -class YesodNic a where - -- | NIC Editor Javascript file. - urlNicEdit :: a -> Either (Route a) String - urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" - -nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe Html -> f -nicHtmlField = requiredFieldHelper nicHtmlFieldProfile - -maybeNicHtmlField - :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile - -nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html -nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance - , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> do - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %textarea.html#$theId$!name=$name$ $val$ -|] - addScript' urlNicEdit - addJulius -#if GHC7 - [julius| -#else - [$julius| -#endif -bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")}); -|] - } - -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs deleted file mode 100644 index e224e50b..00000000 --- a/Yesod/Form/Profiles.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Profiles - ( stringFieldProfile - , passwordFieldProfile - , textareaFieldProfile - , hiddenFieldProfile - , intFieldProfile - , dayFieldProfile - , timeFieldProfile - , htmlFieldProfile - , emailFieldProfile - , searchFieldProfile - , AutoFocus - , urlFieldProfile - , doubleFieldProfile - , parseDate - , parseTime - , Textarea (..) - ) where - -import Yesod.Form.Core -import Yesod.Widget -import Text.Hamlet -import Text.Cassius -import Data.Time (Day, TimeOfDay(..)) -import qualified Text.Email.Validate as Email -import Network.URI (parseURI) -import Database.Persist (PersistField) -import Text.HTML.SanitizeXSS (sanitizeBalance) -import Control.Monad (when) - -import qualified Blaze.ByteString.Builder.Html.Utf8 as B -import Blaze.ByteString.Builder (writeByteString) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -import Yesod.Internal (lbsToChars) - -#if GHC7 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - -intFieldProfile :: Integral i => FieldProfile sub y i -intFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMayI - , fpRender = showI - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - } - where - showI x = show (fromIntegral x :: Integer) - readMayI s = case reads s of - (x, _):_ -> Just $ fromInteger x - [] -> Nothing - -doubleFieldProfile :: FieldProfile sub y Double -doubleFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid number") Right . readMay - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - } - -dayFieldProfile :: FieldProfile sub y Day -dayFieldProfile = FieldProfile - { fpParse = parseDate - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - } - -timeFieldProfile :: FieldProfile sub y TimeOfDay -timeFieldProfile = FieldProfile - { fpParse = parseTime - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - } - -htmlFieldProfile :: FieldProfile sub y Html -htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance - , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%textarea.html#$theId$!name=$name$ $val$ -|] - } - --- | A newtype wrapper around a 'String' that converts newlines to HTML --- br-tags. -newtype Textarea = Textarea { unTextarea :: String } - deriving (Show, Read, Eq, PersistField) -instance ToHtml Textarea where - toHtml = - Html . fromWriteList writeHtmlEscapedChar . unTextarea - where - -- Taken from blaze-builder and modified with newline handling. - writeHtmlEscapedChar '\n' = writeByteString "
" - writeHtmlEscapedChar c = B.writeHtmlEscapedChar c - -textareaFieldProfile :: FieldProfile sub y Textarea -textareaFieldProfile = FieldProfile - { fpParse = Right . Textarea - , fpRender = unTextarea - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%textarea#$theId$!name=$name$ $val$ -|] - } - -hiddenFieldProfile :: FieldProfile sub y String -hiddenFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%input!type=hidden#$theId$!name=$name$!value=$val$ -|] - } - -stringFieldProfile :: FieldProfile sub y String -stringFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - } - -passwordFieldProfile :: FieldProfile s m String -passwordFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=password!:isReq:required!value=$val$ -|] - } - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - -parseDate :: String -> Either String Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -parseTime :: String -> Either String TimeOfDay -parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = - parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = - let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 - in parseTimeHelper (h1', h2', m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = - parseTimeHelper (h1, h2, m1, m2, s1, s2) -parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" - -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either [Char] TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s - | otherwise = Right $ TimeOfDay h m s - where - h = read [h1, h2] - m = read [m1, m2] - s = fromInteger $ read [s1, s2] - -emailFieldProfile :: FieldProfile s y String -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid s - then Right s - else Left "Invalid e-mail address" - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ -|] - } - -type AutoFocus = Bool -searchFieldProfile :: AutoFocus -> FieldProfile s y String -searchFieldProfile autoFocus = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!type=search!:isReq:required!:autoFocus:autofocus!value=$val$ -|] - when autoFocus $ do - addHtml $ [HAMLET| |] - addCassius [CASSIUS| - #$theId$ - -webkit-appearance: textfield - |] - } - -urlFieldProfile :: FieldProfile s y String -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI s of - Nothing -> Left "Invalid URL" - Just _ -> Right s - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ -|] - } diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs deleted file mode 100644 index 7690da70..00000000 --- a/Yesod/Helpers/Crud.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Yesod.Helpers.Crud - ( Item (..) - , Crud (..) - , CrudRoute (..) - , defaultCrud - ) where - -import Yesod.Yesod -import Yesod.Widget -import Yesod.Dispatch -import Yesod.Content -import Yesod.Handler -import Text.Hamlet -import Yesod.Form -import Language.Haskell.TH.Syntax - --- | An entity which can be displayed by the Crud subsite. -class Item a where - -- | The title of an entity, to be displayed in the list of all entities. - itemTitle :: a -> String - --- | Defines all of the CRUD operations (Create, Read, Update, Delete) --- necessary to implement this subsite. When using the "Yesod.Form" module and --- 'ToForm' typeclass, you can probably just use 'defaultCrud'. -data Crud master item = Crud - { crudSelect :: GHandler (Crud master item) master [(Key item, item)] - , crudReplace :: Key item -> item -> GHandler (Crud master item) master () - , crudInsert :: item -> GHandler (Crud master item) master (Key item) - , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item) - , crudDelete :: Key item -> GHandler (Crud master item) master () - } - -mkYesodSub "Crud master item" - [ ClassP ''Yesod [VarT $ mkName "master"] - , ClassP ''Item [VarT $ mkName "item"] - , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] - , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] - ] -#if GHC7 - [parseRoutes| -#else - [$parseRoutes| -#endif -/ CrudListR GET -/add CrudAddR GET POST -/edit/#String CrudEditR GET POST -/delete/#String CrudDeleteR GET POST -|] - -getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) - => GHandler (Crud master item) master RepHtml -getCrudListR = do - items <- getYesodSub >>= crudSelect - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Items" - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Items -%ul - $forall items item - %li - %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ - $itemTitle.snd.item$ -%p - %a!href=@toMaster.CrudAddR@ Add new item -|] - -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -getCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - False - -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -postCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - True - -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => String -> GHandler (Crud master item) master RepHtml -getCrudEditR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - False - -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => String -> GHandler (Crud master item) master RepHtml -postCrudEditR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - True - -getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => String -> GHandler (Crud master item) master RepHtml -getCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Confirm delete" - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@toMaster.CrudDeleteR.s@ - %h1 Really delete? - %p Do you really want to delete $itemTitle.item$? - %p - %input!type=submit!value=Yes - \ $ - %a!href=@toMaster.CrudListR@ No -|] - -postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => String -> GHandler (Crud master item) master RepHtml -postCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - toMaster <- getRouteToMaster - crudDelete crud itemId - redirect RedirectTemporary $ toMaster CrudListR - -itemReadId :: SinglePiece x => String -> Maybe x -itemReadId = either (const Nothing) Just . fromSinglePiece - -crudHelper - :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) - => String -> Maybe (Key a, a) -> Bool - -> GHandler (Crud master a) master RepHtml -crudHelper title me isPost = do - crud <- getYesodSub - (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me - toMaster <- getRouteToMaster - case (isPost, errs) of - (True, FormSuccess a) -> do - eid <- case me of - Just (eid, _) -> do - crudReplace crud eid a - return eid - Nothing -> crudInsert crud a - redirect RedirectTemporary $ toMaster $ CrudEditR - $ toSinglePiece eid - _ -> return () - defaultLayout $ do - setTitle $ string title - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%p - %a!href=@toMaster.CrudListR@ Return to list -%h1 $title$ -%form!method=post!enctype=$enctype$ - %table - ^form^ - %tr - %td!colspan=2 - $hidden$ - %input!type=submit - $maybe me e - \ $ - %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete -|] - --- | A default 'Crud' value which relies about persistent and "Yesod.Form". -defaultCrud - :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)), - YesodPersist a) - => a -> Crud a i -defaultCrud = const Crud - { crudSelect = runDB $ selectList [] [] 0 0 - , crudReplace = \a -> runDB . replace a - , crudInsert = runDB . insert - , crudGet = runDB . get - , crudDelete = runDB . delete - } diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 7be74bb9..8a4c4cb8 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -40,15 +40,13 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) +import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Yesod.Internal import Control.Monad.IO.Peel (MonadPeelIO) -import Control.Monad (liftM) -import qualified Data.Map as Map -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of diff --git a/hellowidget.hs b/hellowidget.hs deleted file mode 100644 index 3c73e81a..00000000 --- a/hellowidget.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} -import Yesod -import Yesod.Widget -import Yesod.Helpers.Static -import Yesod.Form.Jquery -import Yesod.Form.Core -import Data.Monoid -import Yesod.Form.Nic -import Control.Applicative -import qualified Data.ByteString.Lazy as L -import System.Directory -import Control.Monad.Trans.Class -import Data.Default - -data HW = HW { hwStatic :: Static } -mkYesod "HW" [$parseRoutes| -/ RootR GET -/form FormR -/static StaticR Static hwStatic -/autocomplete AutoCompleteR GET -/customform CustomFormR GET -|] -instance Yesod HW where - approot _ = "" - addStaticContent ext _ content = do - let fn = (base64md5 content) ++ '.' : ext - liftIO $ createDirectoryIfMissing True "static/tmp" - liftIO $ L.writeFile ("static/tmp/" ++ fn) content - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - -type Handler = GHandler HW HW - -instance YesodNic HW -instance YesodJquery HW where - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness" -wrapper h = [$hamlet| -#wrapper ^h^ -%footer Brought to you by Yesod Widgets™ -|] -getRootR = defaultLayout $ wrapper $ do - i <- newIdent - setTitle $ string "Hello Widgets" - addCassius [$cassius| -#$i$ - color: red -|] - addStylesheet $ StaticR $ StaticRoute ["style.css"] [] - addStylesheetRemote "http://localhost:3000/static/style2.css" - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScript $ StaticR $ StaticRoute ["script.js"] [] - addHamlet [$hamlet| -%h1#$i$ Welcome to my first widget!!! -%p - %a!href=@RootR@ Recursive link. -%p - %a!href=@FormR@ Check out the form. -%p - %a!href=@CustomFormR@ Custom form arrangement. -%p.noscript Your script did not load. :( -|] - addHtmlHead [$hamlet|%meta!keywords=haskell|] - -handleFormR = do - (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,,) - <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing - <*> stringField ("Another field") (Just "some default text") - <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) - <*> jqueryDayField def - { jdsChangeMonth = True - , jdsChangeYear = True - , jdsYearRange = "1900:c+10" - , jdsNumberOfMonths = Right (2, 3) - } ("A day field") Nothing - <*> timeField ("A time field") Nothing - <*> boolField FormFieldSettings - { ffsLabel = "A checkbox" - , ffsTooltip = "" - , ffsId = Nothing - , ffsName = Nothing - } (Just False) - <*> jqueryAutocompleteField AutoCompleteR - (FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing - <*> nicHtmlField ("HTML") - (Just $ string "You can put rich text here") - <*> maybeEmailField ("An e-mail addres") Nothing - <*> maybeTextareaField "A text area" Nothing - <*> maybeFileField "Any file" - <*> maybePasswordField "Enter a password" Nothing - let (mhtml, mfile) = case res of - FormSuccess (_, _, _, _, _, _, _, x, _, _, y, _) -> (Just x, y) - _ -> (Nothing, Nothing) - let txt = case res of - FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _, _) -> Just x - _ -> Nothing - defaultLayout $ do - addCassius [$cassius| -.tooltip - color: #666 - font-style: italic -|] - addCassius [$cassius| -textarea.html - width: 300px - height: 150px -|] - addWidget [$hamlet| -$maybe formFailures.res failures - %ul.errors - $forall failures f - %li $f$ -%form!method=post!enctype=$enctype$ - $hidden$ - %table - ^form^ - %tr - %td!colspan=2 - %input!type=submit - $maybe mhtml html - $html$ - $maybe txt t - $t$ - $maybe mfile f - $show.f$ -|] - setTitle $ string "Form" - -main = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt - -getAutoCompleteR :: Handler RepJson -getAutoCompleteR = do - term <- runFormGet' $ stringInput "term" - jsonToRepJson $ jsonList - [ jsonScalar $ term ++ "foo" - , jsonScalar $ term ++ "bar" - , jsonScalar $ term ++ "baz" - ] - -data Person = Person String Int -getCustomFormR = do - let customForm = GForm $ do - (a1, [b1], c1) <- deform $ stringInput "name" - (a2, [b2], c2) <- deform $ intInput "age" - let b = do - b1' <- extractBody b1 - b2' <- extractBody b2 - addHamlet [$hamlet| -%p This is a custom layout. -%h1 Name Follows! -%p ^b1'^ -%p Age: ^b2'^ -|] - return (Person <$> a1 <*> a2, b , c1 `mappend` c2) - (_, wform, enctype) <- runFormGet customForm - defaultLayout $ do - form <- extractBody wform - addHamlet [$hamlet| -%form - ^form^ - %div - %input!type=submit -|] diff --git a/yesod.cabal b/yesod.cabal index 6276a1d3..fdff1e9b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -59,10 +59,6 @@ library exposed-modules: Yesod Yesod.Content Yesod.Dispatch - Yesod.Form - Yesod.Form.Core - Yesod.Form.Jquery - Yesod.Form.Nic Yesod.Hamlet Yesod.Handler Yesod.Json @@ -70,13 +66,9 @@ library Yesod.Widget Yesod.Yesod Yesod.Helpers.AtomFeed - Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - other-modules: Yesod.Form.Class - Yesod.Internal - Yesod.Form.Fields - Yesod.Form.Profiles + other-modules: Yesod.Internal ghc-options: -Wall executable yesod From b50cbd440dccae9e28afddda29674076c7cdf6ce Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 20 Dec 2010 18:55:33 +0200 Subject: [PATCH 006/126] reqRequestBody doc update --- Yesod/Request.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index d526ff65..48cc4236 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -100,6 +100,13 @@ data Request = Request -- thunk, which essentially means it will be computed once at most, but -- only if requested. This allows avoidance of the potentially costly -- parsing of POST bodies for pages which do not use them. + -- + -- Additionally, since the request body is not read until needed, you can + -- directly access the 'W.requestBody' record in 'reqWaiRequest' and + -- perform other forms of parsing. For example, when designing a web + -- service, you may want to accept JSON-encoded data. Just be aware that + -- if you do such parsing, the standard POST form parsing functions will + -- no longer work. , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. From 48e8b1d9ca8d68a52f3c5489fbd5ca3469485dcc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Dec 2010 00:07:33 +0200 Subject: [PATCH 007/126] Using cookie package --- Yesod/Content.hs | 5 ----- Yesod/Dispatch.hs | 17 +++++++++++++---- yesod.cabal | 1 + 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index e8fe59b0..10a83557 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -45,7 +45,6 @@ module Yesod.Content -- * Utilities , formatW3 , formatRFC1123 - , formatCookieExpires #if TEST , testSuite #endif @@ -260,7 +259,3 @@ formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> String formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" - --- | Format a 'UTCTime' for a cookie. -formatCookieExpires :: UTCTime -> String -formatCookieExpires = formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 27847cfc..174c707b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -52,6 +52,9 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (toLazyByteString) import Control.Concurrent.MVar import Control.Arrow ((***)) @@ -63,6 +66,7 @@ import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS import Data.Char (isUpper) +import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) import Data.Serialize import qualified Data.Serialize as Ser @@ -447,10 +451,15 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> Header -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = - let expires = getExpires minutes - in ("Set-Cookie", charsToBs - $ key ++ "=" ++ value ++"; path=/; expires=" - ++ formatCookieExpires expires) + ("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie + { setCookieName = B.pack key -- FIXME check for non-ASCII + , setCookieValue = B.pack value -- FIXME check for non-ASCII + , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookieExpires = Just $ getExpires minutes + , setCookieDomain = Nothing + }) + where + builderToBS = S.concat . L.toChunks . toLazyByteString headerToPair _ (DeleteCookie key) = ("Set-Cookie", charsToBs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") diff --git a/yesod.cabal b/yesod.cabal index fdff1e9b..136a3083 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -56,6 +56,7 @@ library , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 + , cookie >= 0.0 && < 0.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 8d7d5ce167f0450d1b6c159cda9f0945ca3572f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Dec 2010 00:07:50 +0200 Subject: [PATCH 008/126] ContentBuilder and responseBuilder --- Yesod/Content.hs | 13 +++++++------ Yesod/Dispatch.hs | 2 +- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 10a83557..65a77038 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -70,15 +70,16 @@ import Test.HUnit hiding (Test) #endif import Data.Enumerator (Enumerator) -import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) +import Data.Monoid (mempty) -data Content = ContentLBS L.ByteString +data Content = ContentBuilder Builder | ContentEnum (forall a. Enumerator Builder IO a) | ContentFile FilePath -- | Zero-length enumerator. emptyContent :: Content -emptyContent = ContentLBS L.empty +emptyContent = ContentBuilder mempty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -88,13 +89,13 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent = ContentLBS . L.fromChunks . return + toContent = ContentBuilder . fromByteString instance ToContent L.ByteString where - toContent = ContentLBS + toContent = ContentBuilder . fromLazyByteString instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = ContentLBS . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 174c707b..26f629bc 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -339,7 +339,7 @@ toWaiApp' y key' segments env = do hs''' = ("Content-Type", charsToBs ct) : hs'' return $ case c of - ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentBuilder b -> W.responseBuilder s hs''' b ContentFile fp -> W.ResponseFile s hs''' fp ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s hs''' From ccafe0fb4488ce173b51f35e751431841a5ea324 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Dec 2010 00:24:15 +0200 Subject: [PATCH 009/126] Removed persistent dependency --- Yesod/Dispatch.hs | 4 ++-- Yesod/Yesod.hs | 22 ---------------------- yesod.cabal | 3 +-- 3 files changed, 3 insertions(+), 26 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 26f629bc..d45654ac 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -27,10 +27,10 @@ module Yesod.Dispatch ) where #if TEST -import Yesod.Yesod hiding (testSuite, Key) +import Yesod.Yesod hiding (testSuite) import Yesod.Handler hiding (testSuite) #else -import Yesod.Yesod hiding (Key) +import Yesod.Yesod import Yesod.Handler #endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 74288fa3..1015e322 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -11,10 +11,6 @@ module Yesod.Yesod Yesod (..) , YesodSite (..) , YesodSubSite (..) - -- ** Persistence - , YesodPersist (..) - , module Database.Persist - , get404 -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -50,9 +46,6 @@ import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import Database.Persist -import Control.Monad.Trans.Class (MonadTrans (..)) -import Control.Failure (Failure) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -377,21 +370,6 @@ defaultErrorHandler (BadMethod m) = %p Method "$m$" not supported |] -class YesodPersist y where - type YesodDB y :: (* -> *) -> * -> * - runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y 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), - Failure ErrorResponse m, MonadTrans t) - => Key val -> t m val -get404 key = do - mres <- get key - case mres of - Nothing -> lift notFound - Just res -> return res - -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only diff --git a/yesod.cabal b/yesod.cabal index 136a3083..51a43131 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -34,7 +34,7 @@ library , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 - , template-haskell >= 2.4 && < 2.6 + , template-haskell , web-routes-quasi >= 0.6.2 && < 0.7 , hamlet >= 0.6 && < 0.7 , blaze-builder >= 0.2.1 && < 0.3 @@ -45,7 +45,6 @@ library , cereal >= 0.2 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.4 && < 0.5 , neither >= 0.2 && < 0.3 , network >= 2.2.1.5 && < 2.4 , email-validate >= 0.2.5 && < 0.3 From 7e738c582bca30265cb9d3e4d9b45813bcc181e9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Dec 2010 17:32:24 +0200 Subject: [PATCH 010/126] yesodVersion --- Yesod/Yesod.hs | 7 +++++++ yesod.cabal | 1 + 2 files changed, 8 insertions(+) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 1015e322..39f81eae 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -23,6 +23,8 @@ module Yesod.Yesod , defaultErrorHandler -- * Data types , AuthResult (..) + -- * Misc + , yesodVersion #if TEST , testSuite #endif @@ -39,6 +41,8 @@ import Yesod.Json import Yesod.Handler #endif +import qualified Paths_yesod +import Data.Version (showVersion) import Yesod.Widget import Yesod.Request import Yesod.Hamlet @@ -525,3 +529,6 @@ redirectToPost dest = hamletToRepHtml %p Javascript has been disabled; please click on the button below to be redirected. %input!type=submit!value=Continue |] >>= sendResponse + +yesodVersion :: String +yesodVersion = showVersion Paths_yesod.version diff --git a/yesod.cabal b/yesod.cabal index 51a43131..27edae04 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -69,6 +69,7 @@ library Yesod.Helpers.Sitemap Yesod.Helpers.Static other-modules: Yesod.Internal + Paths_yesod ghc-options: -Wall executable yesod From 7a60813c226afe965af57fa70ead008acec255d6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Dec 2010 08:17:21 +0200 Subject: [PATCH 011/126] Removed Yesod.Json, using json-types --- Yesod.hs | 3 - Yesod/Content.hs | 5 ++ Yesod/Json.hs | 141 ----------------------------------------------- Yesod/Yesod.hs | 13 +++-- yesod.cabal | 3 +- 5 files changed, 15 insertions(+), 150 deletions(-) delete mode 100644 Yesod/Json.hs diff --git a/Yesod.hs b/Yesod.hs index f3be2aa7..31dd3b88 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -7,7 +7,6 @@ module Yesod , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Hamlet - , module Yesod.Json , module Yesod.Widget , Application , lift @@ -20,13 +19,11 @@ module Yesod #if TEST import Yesod.Content hiding (testSuite) -import Yesod.Json hiding (testSuite) import Yesod.Dispatch hiding (testSuite) import Yesod.Yesod hiding (testSuite) import Yesod.Handler hiding (runHandler, testSuite) #else import Yesod.Content -import Yesod.Json import Yesod.Dispatch import Yesod.Yesod import Yesod.Handler hiding (runHandler) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 65a77038..9be7a2f8 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -73,6 +73,9 @@ import Data.Enumerator (Enumerator) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) +import qualified Data.JSON.Types as J +import qualified Text.JSON.Enumerator as J + data Content = ContentBuilder Builder | ContentEnum (forall a. Enumerator Builder IO a) | ContentFile FilePath @@ -98,6 +101,8 @@ instance ToContent Text where toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack +instance ToContent J.Value where + toContent = ContentBuilder . J.renderValue -- | A function which gives targetted representations of content based on the -- content-types the user accepts. diff --git a/Yesod/Json.hs b/Yesod/Json.hs deleted file mode 100644 index bd22f66e..00000000 --- a/Yesod/Json.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | Efficient generation of JSON documents. --- FIXME remove this module, possibly make a blaze-json -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Json - ( -- * Monad - Json - , jsonToContent - , jsonToRepJson - -- * Generate Json output - , jsonScalar - , jsonList - , jsonMap - , jsonRaw -#if TEST - , testSuite -#endif - ) - where - -import qualified Data.ByteString.Char8 as S -import Data.Char (isControl) -import Yesod.Handler (GHandler) -import Numeric (showHex) -import Data.Monoid (Monoid (..)) -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char.Utf8 (writeChar) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -import Data.ByteString.Lazy.Char8 (unpack) -import Yesod.Content hiding (testSuite) -#else -import Yesod.Content -#endif - --- | A monad for generating Json output. It wraps the Builder monoid from the --- blaze-builder package. --- --- This is an opaque type to avoid any possible insertion of non-JSON content. --- Due to the limited nature of the JSON format, you can create any valid JSON --- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json = Json { unJson :: Builder } - deriving Monoid - --- | Extract the final result from the given 'Json' value. --- --- See also: applyLayoutJson in "Yesod.Yesod". -jsonToContent :: Json -> GHandler sub master Content -jsonToContent = return . toContent . toLazyByteString . unJson - --- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: Json -> GHandler sub master RepJson -jsonToRepJson = fmap RepJson . jsonToContent - --- | Outputs a single scalar. This function essentially: --- --- * Performs JSON encoding. --- --- * Wraps the resulting string in quotes. -jsonScalar :: String -> Json -jsonScalar s = Json $ mconcat - [ fromByteString "\"" - , fromWriteList writeJsonChar s - , fromByteString "\"" - ] - where - writeJsonChar '\b' = writeByteString "\\b" - writeJsonChar '\f' = writeByteString "\\f" - writeJsonChar '\n' = writeByteString "\\n" - writeJsonChar '\r' = writeByteString "\\r" - writeJsonChar '\t' = writeByteString "\\t" - writeJsonChar '"' = writeByteString "\\\"" - writeJsonChar '\\' = writeByteString "\\\\" - writeJsonChar c - | not $ isControl c = writeChar c - | c < '\x10' = writeString $ '\\' : 'u' : '0' : '0' : '0' : hexxs - | c < '\x100' = writeString $ '\\' : 'u' : '0' : '0' : hexxs - | c < '\x1000' = writeString $ '\\' : 'u' : '0' : hexxs - where hexxs = showHex (fromEnum c) "" - writeJsonChar c = writeChar c - writeString = writeByteString . S.pack - --- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. -jsonList :: [Json] -> Json -jsonList [] = Json $ fromByteString "[]" -jsonList (x:xs) = mconcat - [ Json $ fromByteString "[" - , x - , mconcat $ map go xs - , Json $ fromByteString "]" - ] - where - go = mappend (Json $ fromByteString ",") - --- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. -jsonMap :: [(String, Json)] -> Json -jsonMap [] = Json $ fromByteString "{}" -jsonMap (x:xs) = mconcat - [ Json $ fromByteString "{" - , go x - , mconcat $ map go' xs - , Json $ fromByteString "}" - ] - where - go' y = mappend (Json $ fromByteString ",") $ go y - go (k, v) = mconcat - [ jsonScalar k - , Json $ fromByteString ":" - , v - ] - --- | Outputs raw JSON data without performing any escaping. Use with caution: --- this is the only function in this module that allows you to create broken --- JSON documents. -jsonRaw :: S.ByteString -> Json -jsonRaw = Json . fromByteString - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Json" - [ testCase "simple output" caseSimpleOutput - ] - -caseSimpleOutput :: Assertion -caseSimpleOutput = do - let j = do - jsonMap - [ ("foo" , jsonList - [ jsonScalar "bar" - , jsonScalar "baz" - ]) - ] - "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (toLazyByteString $ unJson j) - -#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 39f81eae..ee094a15 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -18,6 +18,7 @@ module Yesod.Yesod , maybeAuthorized , widgetToPageContent , defaultLayoutJson + , jsonToRepJson , redirectToPost -- * Defaults , defaultErrorHandler @@ -32,12 +33,10 @@ module Yesod.Yesod #if TEST import Yesod.Content hiding (testSuite) -import Yesod.Json hiding (testSuite) import Yesod.Handler hiding (testSuite) import qualified Data.ByteString.UTF8 as BSU #else import Yesod.Content -import Yesod.Json import Yesod.Handler #endif @@ -60,6 +59,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Web.Routes +import qualified Data.JSON.Types as J #if TEST import Test.Framework (testGroup, Test) @@ -302,12 +302,15 @@ breadcrumbs = do -- the default layout for the HTML output ('defaultLayout'). defaultLayoutJson :: Yesod master => GWidget sub master () - -> Json + -> J.Value -> GHandler sub master RepHtmlJson defaultLayoutJson w json = do RepHtml html' <- defaultLayout w - json' <- jsonToContent json - return $ RepHtmlJson html' json' + return $ RepHtmlJson html' $ toContent json + +-- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. +jsonToRepJson :: J.Value -> GHandler sub master RepJson +jsonToRepJson = return . RepJson . toContent applyLayout' :: Yesod master => Html -- ^ title diff --git a/yesod.cabal b/yesod.cabal index 27edae04..5aaaf0f4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -56,12 +56,13 @@ library , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 , cookie >= 0.0 && < 0.1 + , json-enumerator >= 0.0 && < 0.1 + , json-types >= 0.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch Yesod.Hamlet Yesod.Handler - Yesod.Json Yesod.Request Yesod.Widget Yesod.Yesod From fccefcd1dd2e004afc4b1e322a10657f28221cde Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Dec 2010 14:53:56 +0200 Subject: [PATCH 012/126] Rename to yesod-core --- Yesod/Yesod.hs | 4 ++-- yesod.cabal => yesod-core.cabal | 19 +++---------------- 2 files changed, 5 insertions(+), 18 deletions(-) rename yesod.cabal => yesod-core.cabal (88%) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index ee094a15..bb6bd498 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -40,7 +40,7 @@ import Yesod.Content import Yesod.Handler #endif -import qualified Paths_yesod +import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Widget import Yesod.Request @@ -534,4 +534,4 @@ redirectToPost dest = hamletToRepHtml |] >>= sendResponse yesodVersion :: String -yesodVersion = showVersion Paths_yesod.version +yesodVersion = showVersion Paths_yesod_core.version diff --git a/yesod.cabal b/yesod-core.cabal similarity index 88% rename from yesod.cabal rename to yesod-core.cabal index 5aaaf0f4..39f97acf 100644 --- a/yesod.cabal +++ b/yesod-core.cabal @@ -1,4 +1,4 @@ -name: yesod +name: yesod-core version: 0.7.0 license: BSD3 license-file: LICENSE @@ -14,7 +14,6 @@ stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/ -extra-source-files: scaffold/*.cg flag test description: Build the executable to run unit tests @@ -70,21 +69,9 @@ library Yesod.Helpers.Sitemap Yesod.Helpers.Static other-modules: Yesod.Internal - Paths_yesod + Paths_yesod_core ghc-options: -Wall -executable yesod - if flag(ghc7) - build-depends: base >= 4.3 && < 5 - cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - build-depends: parsec >= 2.1 && < 4 - ghc-options: -Wall - main-is: scaffold.hs - other-modules: CodeGen - extensions: TemplateHaskell - executable runtests if flag(ghc7) build-depends: base >= 4.3 && < 5 @@ -106,4 +93,4 @@ executable runtests source-repository head type: git - location: git://github.com/snoyberg/yesod.git + location: git://github.com/snoyberg/yesod-core.git From a9e713921ea95b70c55437bb6111ddc423d43903 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Dec 2010 14:57:29 +0200 Subject: [PATCH 013/126] Removed extraneous modules, Yesod.Yesod -> Yesod.Core --- Yesod.hs | 48 ------- Yesod/{Yesod.hs => Core.hs} | 2 +- Yesod/Dispatch.hs | 4 +- Yesod/Helpers/AtomFeed.hs | 96 -------------- Yesod/Helpers/Sitemap.hs | 79 ----------- Yesod/Helpers/Static.hs | 252 ------------------------------------ yesod-core.cabal | 8 +- 7 files changed, 5 insertions(+), 484 deletions(-) delete mode 100644 Yesod.hs rename Yesod/{Yesod.hs => Core.hs} (99%) delete mode 100644 Yesod/Helpers/AtomFeed.hs delete mode 100644 Yesod/Helpers/Sitemap.hs delete mode 100644 Yesod/Helpers/Static.hs diff --git a/Yesod.hs b/Yesod.hs deleted file mode 100644 index 31dd3b88..00000000 --- a/Yesod.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} --- | This module simply re-exports from other modules for your convenience. -module Yesod - ( module Yesod.Request - , module Yesod.Content - , module Yesod.Yesod - , module Yesod.Handler - , module Yesod.Dispatch - , module Yesod.Hamlet - , module Yesod.Widget - , Application - , lift - , liftIO - , MonadPeelIO - , mempty - , showIntegral - , readIntegral - ) where - -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Dispatch hiding (testSuite) -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (runHandler, testSuite) -#else -import Yesod.Content -import Yesod.Dispatch -import Yesod.Yesod -import Yesod.Handler hiding (runHandler) -#endif - -import Yesod.Request -import Yesod.Widget -import Network.Wai (Application) -import Yesod.Hamlet -import Control.Monad.Trans.Class (lift) -import Control.Monad.IO.Class (liftIO) -import Data.Monoid (mempty) -import Control.Monad.IO.Peel (MonadPeelIO) - -showIntegral :: Integral a => a -> String -showIntegral x = show (fromIntegral x :: Integer) - -readIntegral :: Num a => String -> Maybe a -readIntegral s = - case reads s of - (i, _):_ -> Just $ fromInteger i - [] -> Nothing diff --git a/Yesod/Yesod.hs b/Yesod/Core.hs similarity index 99% rename from Yesod/Yesod.hs rename to Yesod/Core.hs index bb6bd498..77527f6f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Core.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | The basic typeclass for a Yesod application. -module Yesod.Yesod +module Yesod.Core ( -- * Type classes Yesod (..) , YesodSite (..) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index d45654ac..7086e673 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -27,10 +27,10 @@ module Yesod.Dispatch ) where #if TEST -import Yesod.Yesod hiding (testSuite) +import Yesod.Core hiding (testSuite) import Yesod.Handler hiding (testSuite) #else -import Yesod.Yesod +import Yesod.Core import Yesod.Handler #endif diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs deleted file mode 100644 index 8a5ea4a8..00000000 --- a/Yesod/Helpers/AtomFeed.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.AtomFeed --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating atom news feeds. --- ---------------------------------------------------------- - --- | Generation of Atom newsfeeds. See --- . -module Yesod.Helpers.AtomFeed - ( AtomFeed (..) - , AtomFeedEntry (..) - , atomFeed - , atomLink - , RepAtom (..) - ) where - -import Yesod -import Data.Time.Clock (UTCTime) - -newtype RepAtom = RepAtom Content -instance HasReps RepAtom where - chooseRep (RepAtom c) _ = return (typeAtom, c) - -atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom -atomFeed = fmap RepAtom . hamletToContent . template - -data AtomFeed url = AtomFeed - { atomTitle :: String - , atomLinkSelf :: url - , atomLinkHome :: url - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry url] - } - -data AtomFeedEntry url = AtomFeedEntry - { atomEntryLink :: url - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: Html - } - -template :: AtomFeed url -> Hamlet url -template arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif - -%feed!xmlns="http://www.w3.org/2005/Atom" - %title $atomTitle.arg$ - %link!rel=self!href=@atomLinkSelf.arg@ - %link!href=@atomLinkHome.arg@ - %updated $formatW3.atomUpdated.arg$ - %id @atomLinkHome.arg@ - $forall atomEntries.arg entry - ^entryTemplate.entry^ -|] - -entryTemplate :: AtomFeedEntry url -> Hamlet url -entryTemplate arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%entry - %id @atomEntryLink.arg@ - %link!href=@atomEntryLink.arg@ - %updated $formatW3.atomEntryUpdated.arg$ - %title $atomEntryTitle.arg$ - %content!type=html $cdata.atomEntryContent.arg$ -|] - --- | Generates a link tag in the head of a widget. -atomLink :: Route m - -> String -- ^ title - -> GWidget s m () -atomLink u title = addHamletHead -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ -|] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs deleted file mode 100644 index 34807eb5..00000000 --- a/Yesod/Helpers/Sitemap.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Sitemap --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating Google sitemap files. --- ---------------------------------------------------------- - --- | Generates XML sitemap files. --- --- See . -module Yesod.Helpers.Sitemap - ( sitemap - , robots - , SitemapUrl (..) - , SitemapChangeFreq (..) - ) where - -import Yesod -import Data.Time (UTCTime) - -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 GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" - $forall urls url - %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 sub -- ^ sitemap url - -> GHandler sub master RepPlain -robots smurl = do - tm <- getRouteToMaster - render <- getUrlRender - return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs deleted file mode 100644 index 7a9048f5..00000000 --- a/Yesod/Helpers/Static.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Static --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- - --- | Serve static files from a Yesod app. --- --- This is most useful for standalone testing. When running on a production --- server (like Apache), just let the server do the static serving. --- --- In fact, in an ideal setup you'll serve your static files from a separate --- domain name to save time on transmitting cookies. In that case, you may wish --- to use 'urlRenderOverride' to redirect requests to this subsite to a --- separate domain name. -module Yesod.Helpers.Static - ( -- * Subsite - Static (..) - , StaticRoute (..) - -- * Lookup files in filesystem - , fileLookupDir - , staticFiles - -- * Embed files - , mkEmbedFiles - , getStaticHandler - -- * Hashing - , base64md5 -#if TEST - , testSuite -#endif - ) where - -import System.Directory -import Control.Monad -import Data.Maybe (fromMaybe) - -import Yesod hiding (lift) -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Web.Routes - -import qualified Data.ByteString.Lazy as L -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Base64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Serialize - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - --- | A function for looking up file contents. For serving from the file system, --- see 'fileLookupDir'. -data Static = Static - { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content)) - -- | Mapping from file extension to content type. See 'typeByExt'. - , staticTypes :: [(String, ContentType)] - } - --- | Manually construct a static route. --- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. --- For example, --- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] --- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' --- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. --- E.g. When generating image galleries. -data StaticRoute = StaticRoute [String] [(String, String)] - deriving (Eq, Show, Read) - -type instance Route Static = StaticRoute - -instance YesodSubSite Static master where - getSubSite = Site - { handleSite = \_ (StaticRoute ps _) m -> - case m of - "GET" -> Just $ fmap chooseRep $ getStaticRoute ps - _ -> Nothing - , formatPathSegments = \(StaticRoute x y) -> (x, y) - , parsePathSegments = \x -> Right $ StaticRoute x [] - } - --- | Lookup files in a specific directory. --- --- If you are just using this in combination with the static subsite (you --- probably are), the handler itself checks that no unsafe paths are being --- requested. In particular, no path segments may begin with a single period, --- so hidden files and parent directories are safe. --- --- For the second argument to this function, you can just use 'typeByExt'. -fileLookupDir :: FilePath -> [(String, ContentType)] -> Static -fileLookupDir dir = Static $ \fp -> do - let fp' = dir ++ '/' : fp - exists <- doesFileExist fp' - if exists - then return $ Just $ Left fp' - else return Nothing - --- | Lookup files in a specific directory, and embed them into the haskell source. --- --- A variation of fileLookupDir which allows subsites distributed via cabal to include --- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler --- for dispatching static content for a subsite. -mkEmbedFiles :: FilePath -> Q Exp -mkEmbedFiles d = do - fs <- qRunIO $ getFileList d - clauses <- mapM (mkClause . intercalate "/") fs - defC <- defaultClause - return $ static $ clauses ++ [defC] - where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f - f = mkName "f" - fun clauses = FunD f clauses - defaultClause = do - b <- [| return Nothing |] - return $ Clause [WildP] (NormalB b) [] - - mkClause path = do - content <- qRunIO $ readFile $ d ++ '/':path - let pat = LitP $ StringL path - foldAppE = foldl1 AppE - content' = return $ LitE $ StringL $ content - body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] - return $ Clause [pat] body [] - --- | Dispatch static route for a subsite --- --- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. --- Instead of a subsite route: --- /static StaticR Static getStatic --- Use a normal route: --- /static/*Strings StaticR GET --- --- Then, define getStaticR something like: --- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR --- */ end CPP comment -getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep -getStaticHandler static toSubR pieces = do - toMasterR <- getRouteToMaster - toMasterHandler (toMasterR . toSubR) toSub route handler - where route = StaticRoute pieces [] - toSub _ = static - staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) - handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" - -getStaticRoute :: [String] - -> GHandler Static master (ContentType, Content) -getStaticRoute fp' = do - Static fl ctypes <- getYesodSub - when (any isUnsafe fp') notFound - let fp = intercalate "/" fp' - content <- liftIO $ fl fp - case content of - Nothing -> notFound - Just (Left fp'') -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes - sendFile ctype fp'' - Just (Right bs) -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes - return (ctype, bs) - where - isUnsafe [] = True - isUnsafe ('.':_) = True - isUnsafe _ = False - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileList :: FilePath -> IO [[String]] -getFileList = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles fp = do - fs <- qRunIO $ getFileList fp - concat `fmap` mapM go fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - go f = do - let name = mkName $ intercalate "_" $ map (map replace') f - f' <- lift f - let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - let qs = ListE [TupE [LitE $ StringL hash, ListE []]] - return - [ SigD name $ ConT ''Route `AppT` ConT ''Static - , FunD name - [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] - ] - ] - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Helpers.Static" - [ testCase "get file list" caseGetFileList - ] - -caseGetFileList :: Assertion -caseGetFileList = do - x <- getFileList "test" - x @?= [["foo"], ["bar", "baz"]] - -#endif - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map go - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - go '+' = '-' - go '/' = '_' - go c = c diff --git a/yesod-core.cabal b/yesod-core.cabal index 39f97acf..14c025cb 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -57,17 +57,13 @@ library , cookie >= 0.0 && < 0.1 , json-enumerator >= 0.0 && < 0.1 , json-types >= 0.1 && < 0.2 - exposed-modules: Yesod - Yesod.Content + exposed-modules: Yesod.Content + Yesod.Core Yesod.Dispatch Yesod.Hamlet Yesod.Handler Yesod.Request Yesod.Widget - Yesod.Yesod - Yesod.Helpers.AtomFeed - Yesod.Helpers.Sitemap - Yesod.Helpers.Static other-modules: Yesod.Internal Paths_yesod_core ghc-options: -Wall From 9f7223ea5e487d556db64668bfe8de298b9f7d01 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Dec 2010 15:52:25 +0200 Subject: [PATCH 014/126] Removed Yesod.Hamlet (code does not compile) --- Yesod/Content.hs | 4 ++++ Yesod/Core.hs | 1 - Yesod/Hamlet.hs | 59 ------------------------------------------------ Yesod/Widget.hs | 36 +++++++++++++++++++++++++++-- yesod-core.cabal | 2 +- 5 files changed, 39 insertions(+), 63 deletions(-) delete mode 100644 Yesod/Hamlet.hs diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 9be7a2f8..e0f17041 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -75,6 +75,8 @@ import Data.Monoid (mempty) import qualified Data.JSON.Types as J import qualified Text.JSON.Enumerator as J +import Text.Hamlet (Html) +import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) data Content = ContentBuilder Builder | ContentEnum (forall a. Enumerator Builder IO a) @@ -103,6 +105,8 @@ instance ToContent String where toContent = toContent . T.pack instance ToContent J.Value where toContent = ContentBuilder . J.renderValue +instance ToContent Html where + toContent = ContentBuilder . renderHtmlBuilder -- | A function which gives targetted representations of content based on the -- content-types the user accepts. diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 77527f6f..7b0c9a19 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -44,7 +44,6 @@ import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Widget import Yesod.Request -import Yesod.Hamlet import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs deleted file mode 100644 index e472981e..00000000 --- a/Yesod/Hamlet.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Hamlet - ( -- * Hamlet library - -- ** Hamlet - hamlet - , xhamlet - , Hamlet - , Html - , renderHamlet - , renderHtml - , string - , preEscapedString - , cdata - -- ** Julius - , julius - , Julius - , renderJulius - -- ** Cassius - , cassius - , Cassius - , renderCassius - -- * Convert to something displayable - , hamletToContent - , hamletToRepHtml - -- * Page templates - , PageContent (..) - ) - where - -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Content -import Yesod.Handler - --- | Content for a web page. By providing this datatype, we can easily create --- generic site templates, which would have the type signature: --- --- > PageContent url -> Hamlet url -data PageContent url = PageContent - { pageTitle :: Html - , pageHead :: Hamlet url - , pageBody :: Hamlet url - } - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ renderHamlet render h - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 8a4c4cb8..e1c20b9a 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -9,6 +9,7 @@ module Yesod.Widget ( -- * Datatype GWidget (..) , liftHandler + , PageContent (..) -- * Creating -- ** Head of page , setTitle @@ -31,7 +32,11 @@ module Yesod.Widget , addScriptEither -- * Utilities , extractBody - , newIdent + , newIdent -- FIXME this should be a function on Handler, not Widget + -- * Helpers for specific content + -- ** Hamlet + , hamletToContent + , hamletToRepHtml ) where import Data.Monoid @@ -40,11 +45,15 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) +import Yesod.Handler + ( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod + , getUrlRenderParams + ) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Yesod.Internal +import Yesod.Content (RepHtml (RepHtml), Content, toContent) import Control.Monad.IO.Peel (MonadPeelIO) @@ -187,3 +196,26 @@ extractBody (GWidget w) = GWidget $ mapWriterT (fmap go) w where go ((), Body h) = (h, Body mempty) + +-- | Content for a web page. By providing this datatype, we can easily create +-- generic site templates, which would have the type signature: +-- +-- > PageContent url -> Hamlet url +data PageContent url = PageContent + { pageTitle :: Html + , pageHead :: Hamlet url + , pageBody :: Hamlet url + } + +-- FIXME these ideally belong somewhere else, I'm just not sure where + +-- | Converts the given Hamlet template into 'Content', which can be used in a +-- Yesod 'Response'. +hamletToContent :: Hamlet (Route master) -> GHandler sub master Content +hamletToContent h = do + render <- getUrlRenderParams + return $ toContent $ h render + +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml +hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/yesod-core.cabal b/yesod-core.cabal index 14c025cb..dfb33498 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -57,10 +57,10 @@ library , cookie >= 0.0 && < 0.1 , json-enumerator >= 0.0 && < 0.1 , json-types >= 0.1 && < 0.2 + , blaze-html >= 0.3.0.4 && < 0.4 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch - Yesod.Hamlet Yesod.Handler Yesod.Request Yesod.Widget From 888336029f0dd90d2b4fd64945d2ce66fe922076 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Dec 2010 15:55:23 +0200 Subject: [PATCH 015/126] Removed unneeded files --- ChangeLog.md | 90 ------------ CodeGen.hs | 41 ------ blog.hs | 108 -------------- blog2.hs | 71 --------- freeform.hs | 40 ------ haddock.sh | 2 - helloworld.hs | 7 - mail.hs | 14 -- scaffold.hs | 87 ------------ scaffold/Controller_hs.cg | 40 ------ scaffold/LICENSE.cg | 26 ---- scaffold/Model_hs.cg | 22 --- scaffold/Root_hs.cg | 20 --- scaffold/Settings_hs.cg | 147 ------------------- scaffold/cabal.cg | 58 -------- scaffold/database.cg | 6 - scaffold/default-layout_cassius.cg | 3 - scaffold/default-layout_hamlet.cg | 10 -- scaffold/devel-server_hs.cg | 20 --- scaffold/dir-name.cg | 5 - scaffold/fastcgi_hs.cg | 6 - scaffold/favicon_ico.cg | Bin 1150 -> 0 bytes scaffold/homepage_cassius.cg | 5 - scaffold/homepage_hamlet.cg | 13 -- scaffold/homepage_julius.cg | 4 - scaffold/pconn1.cg | 1 - scaffold/pconn2.cg | 1 - scaffold/project-name.cg | 4 - scaffold/simple-server_hs.cg | 6 - scaffold/site-arg.cg | 5 - scaffold/sitearg_hs.cg | 221 ----------------------------- scaffold/welcome.cg | 6 - 32 files changed, 1089 deletions(-) delete mode 100644 ChangeLog.md delete mode 100644 CodeGen.hs delete mode 100644 blog.hs delete mode 100644 blog2.hs delete mode 100644 freeform.hs delete mode 100755 haddock.sh delete mode 100644 helloworld.hs delete mode 100644 mail.hs delete mode 100644 scaffold.hs delete mode 100644 scaffold/Controller_hs.cg delete mode 100644 scaffold/LICENSE.cg delete mode 100644 scaffold/Model_hs.cg delete mode 100644 scaffold/Root_hs.cg delete mode 100644 scaffold/Settings_hs.cg delete mode 100644 scaffold/cabal.cg delete mode 100644 scaffold/database.cg delete mode 100644 scaffold/default-layout_cassius.cg delete mode 100644 scaffold/default-layout_hamlet.cg delete mode 100644 scaffold/devel-server_hs.cg delete mode 100644 scaffold/dir-name.cg delete mode 100644 scaffold/fastcgi_hs.cg delete mode 100644 scaffold/favicon_ico.cg delete mode 100644 scaffold/homepage_cassius.cg delete mode 100644 scaffold/homepage_hamlet.cg delete mode 100644 scaffold/homepage_julius.cg delete mode 100644 scaffold/pconn1.cg delete mode 100644 scaffold/pconn2.cg delete mode 100644 scaffold/project-name.cg delete mode 100644 scaffold/simple-server_hs.cg delete mode 100644 scaffold/site-arg.cg delete mode 100644 scaffold/sitearg_hs.cg delete mode 100644 scaffold/welcome.cg diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 index d9808462..00000000 --- a/ChangeLog.md +++ /dev/null @@ -1,90 +0,0 @@ -### Yesod 0.5.0 (August 29, 2010) - -* Forms no longer have special types for special views; instead, there is a -toFormField attribute when declaring entities to specify a form rendering -function. - -* URL settings for jQuery and Nic are now in their own typeclasses. This will -be the approach used in the future when adding more widgets and forms that -require Javascript libraries. - -* You can explicitly specify the id and name attributes to be used in forms if -you like. When omitted, a unique name is automatically generated. - -* The isAuthorized function now takes a function specifying whether the -request is a write request. This should make it simpler to develop read/write -authorization systems. Bonus points: if you use HTTP request methods properly, -the isWriteRequest function will automatically determine whether a request is -a read or write request. - -* You can now specify splitPath and joinPath functions yourself. Previously, -the built-in versions had very specific URL rules, such as enforcing a -trailing slash. If you want something more flexible, you can override these -functions. - -* addStaticContent is used to serve CSS and Javascript code from widgets from -external files. This allows caching to take place as you'd normally like. - -* Static files served from the static subsite can have a hash string added to -the query string; this is done automatically when using the getStaticFiles -function. This allows you to set your expires headers far in the future. - -* A new Yesod.Mail module provides datatypes and functions for creating -multipart MIME email messages and sending them via the sendmail executable. -Since these functions generate lazy bytestrings, you can use any delivery -mechanism you want. - -* Change the type of defaultLayout to use Widgets instead of PageContent. This -makes it easier to avoid double-including scripts and stylesheets. - -* Major reworking of the Auth subsite to make it easier to use. - -* Update of the site scaffolder to include much more functionality. Also -removed the Handler type alias from the library, as the scaffolder now -provides that. - -### New in Yesod 0.4.0 - -A big thanks on this release to Simon Michael, who pointed out a number of -places where the docs were unclear, the API was unintuitive, or the names were -inconsistent. - -* Widgets. These allow you to create composable pieces of a webpage that -keep track of their own Javascript and CSS. It includes a function for -obtaining unique identifiers to avoid name collisions, and does automatic -dependency combining; in other words, if you have two widgets that depend on -jQuery, the combined widget will only include it once. - -* Combined the Yesod.Form and Yesod.Formable module into a single, consistent, -widget-based API. It includes basic input functions as well as fancier -Javascript-driven functions; for example, there is a plain day entry field, -and a day entry field which automatically loads the jQuery UI date picker. - -* Added the yesod executable which performs basic scaffolding. - -* Cleaned up a bunch of API function names for consistency. For example, -Yesod.Request now has a logical lookupGetName, lookupPostName, etc naming -scheme. - -* Changed the type of basicHandler to require less typing, and added -basicHandler' which allows you to modify the line output to STDOUT (or skip it -altogether). - -* Switched the Handler monad from ContT to MEitherT (provided by the neither -package). ContT does not have a valid MonadCatchIO instance, which is used for -the sqlite persitent backend. - -* Facebook support in the Auth helper. - -* Ensure that HTTP request methods are given in ALL CAPS. - -* Cleaned up signatures of many methods in the Yesod typeclass. In particular, -due to changes in web-routes-quasi, many of those functions can now live in -the Handler monad, making it easier to use standard functions on them. - -* The static file helper now has extensible file-extension-to-mimetype -mappings. - -* Added the sendResponse function for handler short-circuiting. - -* Renamed Routes to Route. diff --git a/CodeGen.hs b/CodeGen.hs deleted file mode 100644 index 632c2a7c..00000000 --- a/CodeGen.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | A code generation template haskell. Everything is taken as literal text, --- with ~var~ variable interpolation. -module CodeGen (codegen) where - -import Language.Haskell.TH.Syntax -import Text.ParserCombinators.Parsec -import qualified Data.ByteString.Lazy as L -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -data Token = VarToken String | LitToken String | EmptyToken - -codegen :: FilePath -> Q Exp -codegen fp = do - s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg" - let s = init $ LT.unpack $ LT.decodeUtf8 s' - case parse (many parseToken) s s of - Left e -> error $ show e - Right tokens' -> do - let tokens'' = map toExp tokens' - concat' <- [|concat|] - return $ concat' `AppE` ListE tokens'' - -toExp :: Token -> Exp -toExp (LitToken s) = LitE $ StringL s -toExp (VarToken s) = VarE $ mkName s -toExp EmptyToken = LitE $ StringL "" - -parseToken :: Parser Token -parseToken = - parseVar <|> parseLit - where - parseVar = do - _ <- char '~' - s <- many alphaNum - _ <- char '~' - return $ if null s then EmptyToken else VarToken s - parseLit = do - s <- many1 $ noneOf "~" - return $ LitToken s diff --git a/blog.hs b/blog.hs deleted file mode 100644 index 722e0515..00000000 --- a/blog.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} -import Yesod -import Yesod.Helpers.Auth -import Yesod.Helpers.Crud -import Database.Persist.Sqlite -import Data.Time (Day) - -share2 mkPersist mkIsForm [$persist| -Entry - title String "label=Entry title" "tooltip=Make it something cool" - posted JqueryDay Desc - content NicHtml - deriving -|] -instance Item Entry where - itemTitle = entryTitle - -getAuth = const $ Auth - { authIsOpenIdEnabled = False - , authRpxnowApiKey = Nothing - , authEmailSettings = Nothing - -- | client id, secret and requested permissions - , authFacebook = Just (clientId, secret, ["email"]) - } - where - clientId = "134280699924829" - secret = "a7685e10c8977f5435e599aaf1d232eb" - -data Blog = Blog Connection -type EntryCrud = Crud Blog Entry -mkYesod "Blog" [$parseRoutes| -/ RootR GET -/entry/#EntryId EntryR GET -/admin AdminR EntryCrud defaultCrud -/auth AuthR Auth getAuth -|] -instance Yesod Blog where - approot _ = "http://localhost:3000" - defaultLayout p = do - mcreds <- maybeCreds - admin <- maybeAuthorized $ AdminR CrudListR - hamletToContent [$hamlet| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666} - %body - %p - %a!href=@RootR@ Homepage - $maybe admin a - \ | $ - %a!href=@a@ Admin - \ | $ - $maybe mcreds c - Welcome $ - $maybe credsDisplayName.c dn - $dn$ - $nothing - $credsIdent.c$ - \ $ - %a!href=@AuthR.Logout@ Logout - $nothing - %a!href=@AuthR.StartFacebookR@ Facebook Connect - ^pageBody.p^ - %p - Powered by Yesod Web Framework -|] - isAuthorized AdminR{} = do - mc <- maybeCreds - let x = (mc >>= credsEmail) == Just "michael@snoyman.com" - return $ if x then Nothing else Just "Permission denied" - isAuthorized _ = return Nothing -instance YesodAuth Blog where - defaultDest _ = RootR - defaultLoginRoute _ = RootR -instance YesodPersist Blog where - type YesodDB Blog = SqliteReader - runDB db = do - Blog conn <- getYesod - runSqlite db conn - -getRootR = do - entries <- runDB $ select [] [EntryPostedDesc] - applyLayoutW $ do - setTitle $ string "Blog tutorial homepage" - addBody [$hamlet| -%h1 All Entries -%ul - $forall entries entry - %li - %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ -|] - -getEntryR :: EntryId -> Handler Blog RepHtml -getEntryR eid = do - entry <- runDB (get eid) >>= maybe notFound return - applyLayoutW $ do - setTitle $ string $ entryTitle entry - addBody [$hamlet| -%h1 $entryTitle.entry$ -%h2 $show.unJqueryDay.entryPosted.entry$ -#content $unNicHtml.entryContent.entry$ -|] -main = withSqlite "blog.db3" $ \conn -> do - flip runSqlite conn $ initialize (undefined :: Entry) - toWaiApp (Blog conn) >>= basicHandler 3000 diff --git a/blog2.hs b/blog2.hs deleted file mode 100644 index 3a58325f..00000000 --- a/blog2.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -import Yesod -import Yesod.Helpers.Crud -import Yesod.Form.Jquery -import Yesod.Form.Nic -import Database.Persist.Sqlite -import Database.Persist.TH -import Data.Time (Day) - -share2 mkToForm mkPersist [$persist| -Entry - title String id=thetitle - day Day Desc toFormField=YesodJquery.jqueryDayField name=day - content Html' toFormField=YesodNic.nicHtmlField - deriving -|] - -instance Item Entry where - itemTitle = entryTitle - -data Blog = Blog { pool :: Pool Connection } - -type EntryCrud = Crud Blog Entry - -mkYesod "Blog" [$parseRoutes| -/ RootR GET -/entry/#EntryId EntryR GET -/admin AdminR EntryCrud defaultCrud -|] - -instance Yesod Blog where - approot _ = "http://localhost:3000" -instance YesodJquery Blog -instance YesodNic Blog - -instance YesodPersist Blog where - type YesodDB Blog = SqliteReader - runDB db = fmap pool getYesod>>= runSqlite db - -getRootR = do - entries <- runDB $ selectList [] [EntryDayDesc] 0 0 - applyLayoutW $ do - setTitle $ string "Yesod Blog Tutorial Homepage" - addBody [$hamlet| -%h1 Archive -%ul - $forall entries entry - %li - %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ -%p - %a!href=@AdminR.CrudListR@ Admin -|] - -getEntryR entryid = do - entry <- runDB $ get404 entryid - applyLayoutW $ do - setTitle $ string $ entryTitle entry - addBody [$hamlet| -%h1 $entryTitle.entry$ -%h2 $show.entryDay.entry$ -$entryContent.entry$ -|] - -withBlog f = withSqlite ":memory:" 8 $ \p -> do - flip runSqlite p $ do - initialize (undefined :: Entry) - f $ Blog p - -main = withBlog $ basicHandler 3000 diff --git a/freeform.hs b/freeform.hs deleted file mode 100644 index 3f8b263a..00000000 --- a/freeform.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} -import Yesod -import Control.Applicative - -data FreeForm = FreeForm -mkYesod "FreeForm" [$parseRoutes| -/ RootR GET -|] -instance Yesod FreeForm where approot _ = "" - -data Person = Person String Int String - deriving Show - -getRootR = do - ((merr, mperson, form), enctype) <- runFormMonadGet $ do - (name, namef) <- stringField "Name" Nothing - (age, agef) <- intField "Age" $ Just 25 - (color, colorf) <- stringField "Color" Nothing - let (merr, mperson) = - case Person <$> name <*> age <*> color of - FormSuccess p -> (Nothing, Just p) - FormFailure e -> (Just e, Nothing) - FormMissing -> (Nothing, Nothing) - let form = [$hamlet| -Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^. -|] - return (merr, mperson, form) - defaultLayout [$hamlet| -$maybe merr err - %ul!style=color:red - $forall err e - %li $e$ -$maybe mperson person - %p Last person: $show.person$ -%form!method=get!action=@RootR@!enctype=$enctype$ - %p ^form^ - %input!type=submit!value=Submit -|] - -main = basicHandler 3000 FreeForm diff --git a/haddock.sh b/haddock.sh deleted file mode 100755 index 337c58c7..00000000 --- a/haddock.sh +++ /dev/null @@ -1,2 +0,0 @@ -cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html' -scp -r dist/doc/html/yesod snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock/ diff --git a/helloworld.hs b/helloworld.hs deleted file mode 100644 index 2a3f8723..00000000 --- a/helloworld.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} -import Yesod -data HelloWorld = HelloWorld -mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] -instance Yesod HelloWorld where approot _ = "" -getHome = return $ RepPlain $ toContent "Hello World!" -main = basicHandler 3000 HelloWorld diff --git a/mail.hs b/mail.hs deleted file mode 100644 index 8e39e0e2..00000000 --- a/mail.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Yesod.Mail -import qualified Data.ByteString.Lazy.Char8 as L -import System.Environment - -main = do - [dest] <- getArgs - let p1 = Part "text/html" None Inline $ L.pack "

Hello World!!!

" - lbs <- L.readFile "mail.hs" - let p2 = Part "text/plain" Base64 (Attachment "mail.hs") lbs - let mail = Mail - [("To", dest), ("Subject", "mail quine")] - "Plain stuff. Mime-clients should not show it." - [p1, p2] - renderSendMail mail diff --git a/scaffold.hs b/scaffold.hs deleted file mode 100644 index cfca5303..00000000 --- a/scaffold.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -import CodeGen -import System.IO -import System.Directory -import qualified Data.ByteString.Char8 as S -import Language.Haskell.TH.Syntax -import Data.Time (getCurrentTime, utctDay, toGregorian) -import Control.Applicative ((<$>)) -import qualified Data.ByteString.Lazy as L -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -qq :: String -#if GHC7 -qq = "" -#else -qq = "$" -#endif - -main :: IO () -main = do - putStr $(codegen "welcome") - hFlush stdout - name <- getLine - - putStr $(codegen "project-name") - hFlush stdout - project <- getLine - - putStr $(codegen "dir-name") - hFlush stdout - dirRaw <- getLine - let dir = if null dirRaw then project else dirRaw - - putStr $(codegen "site-arg") - hFlush stdout - sitearg <- getLine - - putStr $(codegen "database") - hFlush stdout - backendS <- getLine - let pconn1 = $(codegen "pconn1") - let pconn2 = $(codegen "pconn2") - let (lower, upper, connstr1, connstr2) = - case backendS of - "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3") - "p" -> ("postgresql", "Postgresql", pconn1, pconn2) - _ -> error $ "Invalid backend: " ++ backendS - - putStrLn "That's it! I'm creating your files now..." - - let fst3 (x, _, _) = x - year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime - - let writeFile' fp s = do - putStrLn $ "Generating " ++ fp - L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s - mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp - - mkDir "Handler" - mkDir "hamlet" - mkDir "cassius" - mkDir "julius" - - writeFile' "simple-server.hs" $(codegen "simple-server_hs") - writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") - writeFile' "devel-server.hs" $(codegen "devel-server_hs") - writeFile' (project ++ ".cabal") $(codegen "cabal") - writeFile' "LICENSE" $(codegen "LICENSE") - writeFile' (sitearg ++ ".hs") $(codegen "sitearg_hs") - writeFile' "Controller.hs" $(codegen "Controller_hs") - writeFile' "Handler/Root.hs" $(codegen "Root_hs") - writeFile' "Model.hs" $(codegen "Model_hs") - writeFile' "Settings.hs" $(codegen "Settings_hs") - writeFile' "cassius/default-layout.cassius" - $(codegen "default-layout_cassius") - writeFile' "hamlet/default-layout.hamlet" - $(codegen "default-layout_hamlet") - writeFile' "hamlet/homepage.hamlet" $(codegen "homepage_hamlet") - writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") - writeFile' "julius/homepage.julius" $(codegen "homepage_julius") - - S.writeFile (dir ++ "/favicon.ico") - $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do - pack <- [|S.pack|] - return $ pack `AppE` LitE (StringL $ S.unpack bs)) diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg deleted file mode 100644 index 96885c3d..00000000 --- a/scaffold/Controller_hs.cg +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Controller - ( with~sitearg~ - ) where - -import ~sitearg~ -import Settings -import Yesod.Helpers.Static -import Yesod.Helpers.Auth -import Database.Persist.GenericSql - --- Import all relevant handler modules here. -import Handler.Root - --- This line actually creates our YesodSite instance. It is the second half --- of the call to mkYesodData which occurs in ~sitearg~.hs. Please see --- the comments there for more details. -mkYesodDispatch "~sitearg~" resources~sitearg~ - --- Some default handlers that ship with the Yesod site template. You will --- very rarely need to modify this. -getFaviconR :: Handler () -getFaviconR = sendFile "image/x-icon" "favicon.ico" - -getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent "User-agent: *" - --- This function allocates resources (such as a database connection pool), --- performs initialization and creates a WAI application. This is also the --- place to put your migrate statements to have automatic database --- migrations handled by Yesod. -with~sitearg~ :: (Application -> IO a) -> IO a -with~sitearg~ f = Settings.withConnectionPool $ \p -> do - runConnectionPool (runMigration migrateAll) p - let h = ~sitearg~ s p - toWaiApp h >>= f - where - s = fileLookupDir Settings.staticdir typeByExt - diff --git a/scaffold/LICENSE.cg b/scaffold/LICENSE.cg deleted file mode 100644 index 7830a89e..00000000 --- a/scaffold/LICENSE.cg +++ /dev/null @@ -1,26 +0,0 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright ~year~, ~name~. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg deleted file mode 100644 index d97260a5..00000000 --- a/scaffold/Model_hs.cg +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} -module Model where - -import Yesod -import Database.Persist.TH (share2) -import Database.Persist.GenericSql (mkMigrate) - --- You can define all of your database entities here. You can find more --- information on persistent and how to declare entities at: --- http://docs.yesodweb.com/book/persistent/ -share2 mkPersist (mkMigrate "migrateAll") [~qq~persist| -User - ident String - password String Maybe Update - UniqueUser ident -Email - email String - user UserId Maybe Update - verkey String Maybe Update - UniqueEmail email -|] - diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg deleted file mode 100644 index 2c3f42f9..00000000 --- a/scaffold/Root_hs.cg +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} -module Handler.Root where - -import ~sitearg~ - --- This is a handler function for the GET request method on the RootR --- resource pattern. All of your resource patterns are defined in --- ~sitearg~.hs; look for the line beginning with mkYesodData. --- --- The majority of the code you will write in Yesod lives in these handler --- functions. You can spread them across multiple files if you are so --- inclined, or create a single monolithic file. -getRootR :: Handler RepHtml -getRootR = do - mu <- maybeAuth - defaultLayout $ do - h2id <- newIdent - setTitle "~project~ homepage" - addWidget $(widgetFile "homepage") - diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg deleted file mode 100644 index dad79c92..00000000 --- a/scaffold/Settings_hs.cg +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} --- | Settings are centralized, as much as possible, into this file. This --- includes database connection settings, static file locations, etc. --- In addition, you can configure a number of different aspects of Yesod --- by overriding methods in the Yesod typeclass. That instance is --- declared in the ~sitearg~.hs file. -module Settings - ( hamletFile - , cassiusFile - , juliusFile - , widgetFile - , connStr - , ConnectionPool - , withConnectionPool - , runConnectionPool - , approot - , staticroot - , staticdir - ) where - -import qualified Text.Hamlet as H -import qualified Text.Cassius as H -import qualified Text.Julius as H -import Language.Haskell.TH.Syntax -import Database.Persist.~upper~ -import Yesod (MonadInvertIO, addWidget, addCassius, addJulius) -import Data.Monoid (mempty) -import System.Directory (doesFileExist) - --- | The base URL for your application. This will usually be different for --- development and production. Yesod automatically constructs URLs for you, --- so this value must be accurate to create valid links. -approot :: String -#ifdef PRODUCTION --- You probably want to change this. If your domain name was "yesod.com", --- you would probably want it to be: --- > approot = "http://www.yesod.com" --- Please note that there is no trailing slash. -approot = "http://localhost:3000" -#else -approot = "http://localhost:3000" -#endif - --- | The location of static files on your system. This is a file system --- path. The default value works properly with your scaffolded site. -staticdir :: FilePath -staticdir = "static" - --- | The base URL for your static files. As you can see by the default --- value, this can simply be "static" appended to your application root. --- A powerful optimization can be serving static files from a separate --- domain name. This allows you to use a web server optimized for static --- files, more easily set expires and cache values, and avoid possibly --- costly transference of cookies on static files. For more information, --- please see: --- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain --- --- If you change the resource pattern for StaticR in ~sitearg~.hs, you will --- have to make a corresponding change here. --- --- To see how this value is used, see urlRenderOverride in ~sitearg~.hs -staticroot :: String -staticroot = approot ++ "/static" - --- | The database connection string. The meaning of this string is backend- --- specific. -connStr :: String -#ifdef PRODUCTION -connStr = "~connstr2~" -#else -connStr = "~connstr1~" -#endif - --- | Your application will keep a connection pool and take connections from --- there as necessary instead of continually creating new connections. This --- value gives the maximum number of connections to be open at a given time. --- If your application requests a connection when all connections are in --- use, that request will fail. Try to choose a number that will work well --- with the system resources available to you while providing enough --- connections for your expected load. --- --- Also, connections are returned to the pool as quickly as possible by --- Yesod to avoid resource exhaustion. A connection is only considered in --- use while within a call to runDB. -connectionCount :: Int -connectionCount = 10 - --- The rest of this file contains settings which rarely need changing by a --- user. - --- The following three functions are used for calling HTML, CSS and --- Javascript templates from your Haskell code. During development, --- the "Debug" versions of these functions are used so that changes to --- the templates are immediately reflected in an already running --- application. When making a production compile, the non-debug version --- is used for increased performance. --- --- You can see an example of how to call these functions in Handler/Root.hs --- --- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer --- used; to get the same auto-loading effect, it is recommended that you --- use the devel server. - -toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath -toHamletFile x = "hamlet/" ++ x ++ ".hamlet" -toCassiusFile x = "cassius/" ++ x ++ ".cassius" -toJuliusFile x = "julius/" ++ x ++ ".julius" - -hamletFile :: FilePath -> Q Exp -hamletFile = H.hamletFile . toHamletFile - -cassiusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -cassiusFile = H.cassiusFile . toCassiusFile -#else -cassiusFile = H.cassiusFileDebug . toCassiusFile -#endif - -juliusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -juliusFile = H.juliusFile . toJuliusFile -#else -juliusFile = H.juliusFileDebug . toJuliusFile -#endif - -widgetFile :: FilePath -> Q Exp -widgetFile x = do - let h = unlessExists toHamletFile hamletFile - let c = unlessExists toCassiusFile cassiusFile - let j = unlessExists toJuliusFile juliusFile - [|addWidget $h >> addCassius $c >> addJulius $j|] - where - unlessExists tofn f = do - e <- qRunIO $ doesFileExist $ tofn x - if e then f x else [|mempty|] - --- The next two functions are for allocating a connection pool and running --- database actions using a pool, respectively. It is used internally --- by the scaffolded application, and therefore you will rarely need to use --- them yourself. -withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a -withConnectionPool = with~upper~Pool connStr connectionCount - -runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a -runConnectionPool = runSqlPool - diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg deleted file mode 100644 index cbd36003..00000000 --- a/scaffold/cabal.cg +++ /dev/null @@ -1,58 +0,0 @@ -name: ~project~ -version: 0.0.0 -license: BSD3 -license-file: LICENSE -author: ~name~ -maintainer: ~name~ -synopsis: The greatest Yesod web application ever. -description: I'm sure you can say something clever here if you try. -category: Web -stability: Experimental -cabal-version: >= 1.6 -build-type: Simple -homepage: http://~project~.yesodweb.com/ - -Flag production - Description: Build the production executable. - Default: False - -executable simple-server - if flag(production) - Buildable: False - main-is: simple-server.hs - build-depends: base >= 4 && < 5 - , yesod >= 0.6 && < 0.7 - , yesod-auth >= 0.2 && < 0.3 - , mime-mail >= 0.0 && < 0.1 - , wai-extra - , directory - , bytestring - , text - , persistent >= 0.3.1.1 - , persistent-~lower~ - , template-haskell - , hamlet - , web-routes - , hjsmin >= 0.0.4 && < 0.1 - ghc-options: -Wall - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies - -executable devel-server - if flag(production) - Buildable: False - else - build-depends: wai-handler-devel >= 0.1.0 && < 0.2 - main-is: devel-server.hs - ghc-options: -Wall -O2 - -executable fastcgi - if flag(production) - Buildable: True - build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 - else - Buildable: False - cpp-options: -DPRODUCTION - main-is: fastcgi.hs - ghc-options: -Wall -threaded - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies - diff --git a/scaffold/database.cg b/scaffold/database.cg deleted file mode 100644 index 25c13784..00000000 --- a/scaffold/database.cg +++ /dev/null @@ -1,6 +0,0 @@ -Yesod uses Persistent for its (you guessed it) persistence layer. -This tool will build in either SQLite or PostgreSQL support for you. If you -want to use a different backend, you'll have to make changes manually. -If you're not sure, stick with SQLite: it has no dependencies. - -So, what'll it be? s for sqlite, p for postgresql: diff --git a/scaffold/default-layout_cassius.cg b/scaffold/default-layout_cassius.cg deleted file mode 100644 index 77177469..00000000 --- a/scaffold/default-layout_cassius.cg +++ /dev/null @@ -1,3 +0,0 @@ -body - font-family: sans-serif - diff --git a/scaffold/default-layout_hamlet.cg b/scaffold/default-layout_hamlet.cg deleted file mode 100644 index 3bcfae41..00000000 --- a/scaffold/default-layout_hamlet.cg +++ /dev/null @@ -1,10 +0,0 @@ -!!! -%html - %head - %title $pageTitle.pc$ - ^pageHead.pc^ - %body - $maybe mmsg msg - #message $msg$ - ^pageBody.pc^ - diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg deleted file mode 100644 index 9235a5c6..00000000 --- a/scaffold/devel-server_hs.cg +++ /dev/null @@ -1,20 +0,0 @@ -import Network.Wai.Handler.DevelServer (run) -import Control.Concurrent (forkIO) - -main :: IO () -main = do - mapM_ putStrLn - [ "Starting your server process. Code changes will be automatically" - , "loaded as you save your files. Type \"quit\" to exit." - , "You can view your app at http://localhost:3000/" - , "" - ] - _ <- forkIO $ run 3000 "Controller" "with~sitearg~" ["hamlet"] - go - where - go = do - x <- getLine - case x of - 'q':_ -> putStrLn "Quitting, goodbye!" - _ -> go - diff --git a/scaffold/dir-name.cg b/scaffold/dir-name.cg deleted file mode 100644 index dc74c147..00000000 --- a/scaffold/dir-name.cg +++ /dev/null @@ -1,5 +0,0 @@ -Now where would you like me to place your generated files? I'm smart enough -to create the directories, don't worry about that. If you leave this answer -blank, we'll place the files in ~project~. - -Directory name: diff --git a/scaffold/fastcgi_hs.cg b/scaffold/fastcgi_hs.cg deleted file mode 100644 index d946d7c7..00000000 --- a/scaffold/fastcgi_hs.cg +++ /dev/null @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.FastCGI (run) - -main :: IO () -main = with~sitearg~ run - diff --git a/scaffold/favicon_ico.cg b/scaffold/favicon_ico.cg deleted file mode 100644 index 4613ed03a65f518e28cd421beb06f346bedf0e1e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1150 zcmai!--{Aa6vuBE1--NoL@%*DMlV4SK@YvvbI>1A&%MMFkx;b$VAM=knRM14tGhdn zKgLy=5mzPMY}H+Vu&V{pO1TjD=7Wf6r+Z!QAk#oIeCOPI=6udMocV#!IeacHA$+}o zo}EYNDnjTc7ItCJnI9X3@ICbb07$KV|JU`z1{-_7V*QpAa;xoT`|fl){U=V%jmKkM zUP?ZfL-t`y4ghcTK{L>TeNS~3Wum?8R@Qb{lUXuR5r9uw(Z zGsh>fWFUNI)74OObbpxffv_6U5s`ecrsqt5O6m+})Dt7SRk8z{T?G;>sPm8acq=Tdb;L;6h= z3dKjxV7&NYJ3n2lp> with~sitearg~ (run 3000) - diff --git a/scaffold/site-arg.cg b/scaffold/site-arg.cg deleted file mode 100644 index f49604c5..00000000 --- a/scaffold/site-arg.cg +++ /dev/null @@ -1,5 +0,0 @@ -Great, we'll be creating ~project~ today, and placing it in ~dir~. -What's going to be the name of your foundation datatype? This name must -start with a capital letter. - -Foundation: diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg deleted file mode 100644 index f83f8335..00000000 --- a/scaffold/sitearg_hs.cg +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} -module ~sitearg~ - ( ~sitearg~ (..) - , ~sitearg~Route (..) - , resources~sitearg~ - , Handler - , Widget - , maybeAuth - , requireAuth - , module Yesod - , module Settings - , module Model - , StaticRoute (..) - , AuthRoute (..) - ) where - -import Yesod -import Yesod.Helpers.Static -import Yesod.Helpers.Auth -import Yesod.Helpers.Auth.OpenId -import Yesod.Helpers.Auth.Email -import qualified Settings -import System.Directory -import qualified Data.ByteString.Lazy as L -import Web.Routes.Site (Site (formatPathSegments)) -import Database.Persist.GenericSql -import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) -import Model -import Data.Maybe (isJust) -import Control.Monad (join, unless) -import Network.Mail.Mime -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Encoding -import Text.Jasmine (minifym) - --- | The site argument for your application. This can be a good place to --- keep settings and values requiring initialization before your application --- starts running, such as database connections. Every handler will have --- access to the data present here. -data ~sitearg~ = ~sitearg~ - { getStatic :: Static -- ^ Settings for static file serving. - , connPool :: Settings.ConnectionPool -- ^ Database connection pool. - } - --- | A useful synonym; most of the handler functions in your application --- will need to be of this type. -type Handler = GHandler ~sitearg~ ~sitearg~ - --- | A useful synonym; most of the widgets functions in your application --- will need to be of this type. -type Widget = GWidget ~sitearg~ ~sitearg~ - --- This is where we define all of the routes in our application. For a full --- explanation of the syntax, please see: --- http://docs.yesodweb.com/book/web-routes-quasi/ --- --- This function does three things: --- --- * Creates the route datatype ~sitearg~Route. Every valid URL in your --- application can be represented as a value of this type. --- * Creates the associated type: --- type instance Route ~sitearg~ = ~sitearg~Route --- * Creates the value resources~sitearg~ which contains information on the --- resources declared below. This is used in Controller.hs by the call to --- mkYesodDispatch --- --- What this function does *not* do is create a YesodSite instance for --- ~sitearg~. Creating that instance requires all of the handler functions --- for our application to be in scope. However, the handler functions --- usually require access to the ~sitearg~Route datatype. Therefore, we --- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" [~qq~parseRoutes| -/static StaticR Static getStatic -/auth AuthR Auth getAuth - -/favicon.ico FaviconR GET -/robots.txt RobotsR GET - -/ RootR GET -|] - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod ~sitearg~ where - approot _ = Settings.approot - - defaultLayout widget = do - mmsg <- getMessage - pc <- widgetToPageContent $ do - widget - addCassius $(Settings.cassiusFile "default-layout") - hamletToRepHtml $(Settings.hamletFile "default-layout") - - -- This is done to provide an optimization for serving static files from - -- a separate domain. Please see the staticroot setting in Settings.hs - urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ format s - where - format = formatPathSegments ss - ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) - ss = getSubSite - urlRenderOverride _ _ = Nothing - - -- The page to be redirected to when authentication is required. - authRoute _ = Just $ AuthR LoginR - - -- This function creates static content files in the static folder - -- and names them based on a hash of their content. This allows - -- expiration dates to be set far in the future without worry of - -- users receiving stale content. - addStaticContent ext' _ content = do - let fn = base64md5 content ++ '.' : ext' - let content' = - if ext' == "js" - then case minifym content of - Left _ -> content - Right y -> y - else content - let statictmp = Settings.staticdir ++ "/tmp/" - liftIO $ createDirectoryIfMissing True statictmp - let fn' = statictmp ++ fn - exists <- liftIO $ doesFileExist fn' - unless exists $ liftIO $ L.writeFile fn' content' - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - --- How to run database actions. -instance YesodPersist ~sitearg~ where - type YesodDB ~sitearg~ = SqlPersist - runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db - -instance YesodAuth ~sitearg~ where - type AuthId ~sitearg~ = UserId - - -- Where to send a user after successful login - loginDest _ = RootR - -- Where to send a user after logout - logoutDest _ = RootR - - getAuthId creds = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (uid, _) -> return $ Just uid - Nothing -> do - fmap Just $ insert $ User (credsIdent creds) Nothing - - showAuthId _ = showIntegral - readAuthId _ = readIntegral - - authPlugins = [ authOpenId - , authEmail - ] - -instance YesodAuthEmail ~sitearg~ where - type AuthEmailId ~sitearg~ = EmailId - - showAuthEmailId _ = showIntegral - readAuthEmailId _ = readIntegral - - addUnverified email verkey = - runDB $ insert $ Email email Nothing $ Just verkey - sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail - { mailHeaders = - [ ("From", "noreply") - , ("To", email) - , ("Subject", "Verify your email address") - ] - , mailParts = [[textPart, htmlPart]] - } - where - textPart = Part - { partType = "text/plain; charset=utf-8" - , partEncoding = None - , partFilename = Nothing - , partContent = Data.Text.Lazy.Encoding.encodeUtf8 - $ Data.Text.Lazy.pack $ unlines - [ "Please confirm your email address by clicking on the link below." - , "" - , verurl - , "" - , "Thank you" - ] - } - htmlPart = Part - { partType = "text/html; charset=utf-8" - , partEncoding = None - , partFilename = Nothing - , partContent = renderHtml [~qq~hamlet| -%p Please confirm your email address by clicking on the link below. -%p - %a!href=$verurl$ $verurl$ -%p Thank you -|] - } - getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get - setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key] - verifyAccount eid = runDB $ do - me <- get eid - case me of - Nothing -> return Nothing - Just e -> do - let email = emailEmail e - case emailUser e of - Just uid -> return $ Just uid - Nothing -> do - uid <- insert $ User email Nothing - update eid [EmailUser $ Just uid, EmailVerkey Nothing] - return $ Just uid - getPassword = runDB . fmap (join . fmap userPassword) . get - setPassword uid pass = runDB $ update uid [UserPassword $ Just pass] - getEmailCreds email = runDB $ do - me <- getBy $ UniqueEmail email - case me of - Nothing -> return Nothing - Just (eid, e) -> return $ Just EmailCreds - { emailCredsId = eid - , emailCredsAuthId = emailUser e - , emailCredsStatus = isJust $ emailUser e - , emailCredsVerkey = emailVerkey e - } - getEmail = runDB . fmap (fmap emailEmail) . get - diff --git a/scaffold/welcome.cg b/scaffold/welcome.cg deleted file mode 100644 index ac3742a7..00000000 --- a/scaffold/welcome.cg +++ /dev/null @@ -1,6 +0,0 @@ -Welcome to the Yesod scaffolder. -I'm going to be creating a skeleton Yesod project for you. - -What is your name? We're going to put this in the cabal and LICENSE files. - -Your name: From d7dd2fd051f51af4810be0a6bec98903f8612866 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 20:32:49 +0200 Subject: [PATCH 016/126] Fixed Hamlet version --- README | 2 -- Yesod/Core.hs | 7 +++++-- yesod-core.cabal | 3 +-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/README b/README index c738f600..987fd1b3 100644 --- a/README +++ b/README @@ -1,3 +1 @@ -After installing, type "yesod init" to start a new project. - Learn more at http://docs.yesodweb.com/ diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 7b0c9a19..776dfb66 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -59,6 +59,7 @@ import Text.Cassius import Text.Julius import Web.Routes import qualified Data.JSON.Types as J +import Blaze.ByteString.Builder (toLazyByteString) #if TEST import Test.Framework (testGroup, Test) @@ -408,10 +409,12 @@ widgetToPageContent (GWidget w) = do let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' let stylesheets = map (locationToHamlet . unStylesheet) $ runUniqueList stylesheets' - let cssToHtml (Css b) = Html b + -- FIXME change hamlet: cassius and julius should be structured datatypes so we don't need to do this + let unsafeLazyByteString = mconcat . map unsafeByteString . L.toChunks + let cssToHtml (Css b) = unsafeLazyByteString $ toLazyByteString b celper :: Cassius url -> Hamlet url celper = fmap cssToHtml - jsToHtml (Javascript b) = Html b + jsToHtml (Javascript b) = unsafeLazyByteString $ toLazyByteString b jelper :: Julius url -> Hamlet url jelper = fmap jsToHtml diff --git a/yesod-core.cabal b/yesod-core.cabal index dfb33498..5f3a7760 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -31,11 +31,10 @@ library , wai >= 0.3 && < 0.4 , wai-extra >= 0.3 && < 0.4 , bytestring >= 0.9.1.4 && < 0.10 - , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 , template-haskell , web-routes-quasi >= 0.6.2 && < 0.7 - , hamlet >= 0.6 && < 0.7 + , hamlet >= 0.7 && < 0.8 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 From 1d523ce8d1dfb35fe31c4eb63e2b1f80586f3da8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 20:34:43 +0200 Subject: [PATCH 017/126] Removed unneeded deps --- yesod-core.cabal | 6 ------ 1 file changed, 6 deletions(-) diff --git a/yesod-core.cabal b/yesod-core.cabal index 5f3a7760..56cd8fb7 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -38,17 +38,11 @@ library , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 - , pureMD5 >= 1.1.0.0 && < 2.2 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.2 && < 0.4 - , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1 , neither >= 0.2 && < 0.3 - , network >= 2.2.1.5 && < 2.4 - , email-validate >= 0.2.5 && < 0.3 , web-routes >= 0.23 && < 0.24 - , xss-sanitize >= 0.2.3 && < 0.3 - , data-default >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 From 3a47bf948e8285a1c6550cf2732fb6bde2f5d068 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 20:41:13 +0200 Subject: [PATCH 018/126] Removed json-* deps --- Yesod/Content.hs | 4 ---- Yesod/Core.hs | 17 ----------------- yesod-core.cabal | 2 -- 3 files changed, 23 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index e0f17041..74f044ed 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -73,8 +73,6 @@ import Data.Enumerator (Enumerator) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) -import qualified Data.JSON.Types as J -import qualified Text.JSON.Enumerator as J import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) @@ -103,8 +101,6 @@ instance ToContent Text where toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack -instance ToContent J.Value where - toContent = ContentBuilder . J.renderValue instance ToContent Html where toContent = ContentBuilder . renderHtmlBuilder diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 776dfb66..2b244462 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -17,8 +17,6 @@ module Yesod.Core -- * Utitlities , maybeAuthorized , widgetToPageContent - , defaultLayoutJson - , jsonToRepJson , redirectToPost -- * Defaults , defaultErrorHandler @@ -58,7 +56,6 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Web.Routes -import qualified Data.JSON.Types as J import Blaze.ByteString.Builder (toLazyByteString) #if TEST @@ -298,20 +295,6 @@ breadcrumbs = do (title, next) <- breadcrumb this go ((this, title) : back) next --- | Provide both an HTML and JSON representation for a piece of data, using --- the default layout for the HTML output ('defaultLayout'). -defaultLayoutJson :: Yesod master - => GWidget sub master () - -> J.Value - -> GHandler sub master RepHtmlJson -defaultLayoutJson w json = do - RepHtml html' <- defaultLayout w - return $ RepHtmlJson html' $ toContent json - --- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: J.Value -> GHandler sub master RepJson -jsonToRepJson = return . RepJson . toContent - applyLayout' :: Yesod master => Html -- ^ title -> Hamlet (Route master) -- ^ body diff --git a/yesod-core.cabal b/yesod-core.cabal index 56cd8fb7..03836cbb 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -48,8 +48,6 @@ library , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 , cookie >= 0.0 && < 0.1 - , json-enumerator >= 0.0 && < 0.1 - , json-types >= 0.1 && < 0.2 , blaze-html >= 0.3.0.4 && < 0.4 exposed-modules: Yesod.Content Yesod.Core From 1718c5bf1e0ff2c28d46ee793756596c75ed2348 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 20:49:47 +0200 Subject: [PATCH 019/126] Including content length field for ContentBuilder --- Yesod/Content.hs | 20 ++++++++++++-------- Yesod/Dispatch.hs | 9 ++++++++- 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 74f044ed..7a7bd274 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -53,7 +53,7 @@ module Yesod.Content import Data.Maybe (mapMaybe) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Text.Lazy (Text) +import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Data.Time @@ -76,33 +76,37 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) -data Content = ContentBuilder Builder +data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentEnum (forall a. Enumerator Builder IO a) | ContentFile FilePath -- | Zero-length enumerator. emptyContent :: Content -emptyContent = ContentBuilder mempty +emptyContent = ContentBuilder mempty $ Just 0 -- | Anything which can be converted into 'Content'. Most of the time, you will --- want to use the 'ContentEnum' constructor. An easier approach will be to use +-- want to use the 'ContentBuilder' constructor. An easier approach will be to use -- a pre-defined 'toContent' function, such as converting your data into a lazy -- bytestring and then calling 'toContent' on that. +-- +-- Please note that the built-in instances for lazy data structures ('String', +-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include +-- the content length for the 'ContentBuilder' constructor. class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent = ContentBuilder . fromByteString + toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs instance ToContent L.ByteString where - toContent = ContentBuilder . fromLazyByteString + toContent = flip ContentBuilder Nothing . fromLazyByteString instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where - toContent = toContent . T.pack + toContent = toContent . pack instance ToContent Html where - toContent = ContentBuilder . renderHtmlBuilder + toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing -- | A function which gives targetted representations of content based on the -- content-types the user accepts. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 7086e673..d782a2d3 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -339,7 +339,14 @@ toWaiApp' y key' segments env = do hs''' = ("Content-Type", charsToBs ct) : hs'' return $ case c of - ContentBuilder b -> W.responseBuilder s hs''' b + ContentBuilder b mlen -> + let hs'''' = + case mlen of + Nothing -> hs''' + Just len -> + ("Content-Length", B.pack $ show len) + : hs''' + in W.responseBuilder s hs'''' b ContentFile fp -> W.ResponseFile s hs''' fp ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s hs''' From 920d9cbea87cb04d7281ec49bd4b3b8806307bea Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 21:00:38 +0200 Subject: [PATCH 020/126] Fixed up tests --- Yesod/Content.hs | 6 +++--- Yesod/Core.hs | 33 ++++++++++++++--------------- Yesod/Dispatch.hs | 54 ++++++----------------------------------------- Yesod/Handler.hs | 14 +++++------- runtests.hs | 18 ++++++---------- 5 files changed, 36 insertions(+), 89 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 7a7bd274..aaf57d60 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -46,7 +46,7 @@ module Yesod.Content , formatW3 , formatRFC1123 #if TEST - , testSuite + , contentTestSuite #endif ) where @@ -245,8 +245,8 @@ ext = reverse . fst . break (== '.') . reverse #if TEST ---- Testing -testSuite :: Test -testSuite = testGroup "Yesod.Resource" +contentTestSuite :: Test +contentTestSuite = testGroup "Yesod.Resource" [ testProperty "ext" propExt , testCase "typeByExt" caseTypeByExt ] diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 2b244462..ee31f54e 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -25,18 +25,12 @@ module Yesod.Core -- * Misc , yesodVersion #if TEST - , testSuite + , coreTestSuite #endif ) where -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Handler hiding (testSuite) -import qualified Data.ByteString.UTF8 as BSU -#else import Yesod.Content import Yesod.Handler -#endif import qualified Paths_yesod_core import Data.Version (showVersion) @@ -63,6 +57,8 @@ import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) +import qualified Data.Text +import qualified Data.Text.Encoding #endif #if GHC7 @@ -447,8 +443,8 @@ $maybe jscript j return $ PageContent title head'' body #if TEST -testSuite :: Test -testSuite = testGroup "Yesod.Yesod" +coreTestSuite :: Test +coreTestSuite = testGroup "Yesod.Yesod" [ testProperty "join/split path" propJoinSplitPath , testCase "join/split path [\".\"]" caseJoinSplitPathDquote , testCase "utf8 split path" caseUtf8SplitPath @@ -460,34 +456,37 @@ data TmpRoute = TmpRoute deriving Eq type instance Route TmpYesod = TmpRoute instance Yesod TmpYesod where approot _ = "" +fromString :: String -> S8.ByteString +fromString = Data.Text.Encoding.encodeUtf8 . Data.Text.pack + propJoinSplitPath :: [String] -> Bool propJoinSplitPath ss = - splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) + splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' []) == Right ss' where ss' = filter (not . null) ss caseJoinSplitPathDquote :: Assertion caseJoinSplitPathDquote = do - splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."] - splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."] + splitPath TmpYesod (fromString "/x%2E/") @?= Right ["x."] + splitPath TmpYesod (fromString "/y./") @?= Right ["y."] joinPath TmpYesod "" ["z."] [] @?= "/z./" x @?= Right ss where - x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) + x = splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' []) ss' = filter (not . null) ss ss = ["a."] caseUtf8SplitPath :: Assertion caseUtf8SplitPath = do Right ["שלום"] @=? - splitPath TmpYesod (BSU.fromString "/שלום/") + splitPath TmpYesod (fromString "/שלום/") Right ["page", "Fooé"] @=? - splitPath TmpYesod (BSU.fromString "/page/Fooé/") + splitPath TmpYesod (fromString "/page/Fooé/") Right ["\156"] @=? - splitPath TmpYesod (BSU.fromString "/\156/") + splitPath TmpYesod (fromString "/\156/") Right ["ð"] @=? - splitPath TmpYesod (BSU.fromString "/%C3%B0/") + splitPath TmpYesod (fromString "/%C3%B0/") caseUtf8JoinPath :: Assertion caseUtf8JoinPath = do diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index d782a2d3..35dae927 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -12,27 +12,20 @@ module Yesod.Dispatch , mkYesodData , mkYesodSubData , mkYesodDispatch - , mkYesodSubDispatch + , mkYesodSubDispatch -- ** Path pieces , SinglePiece (..) , MultiPiece (..) , Strings -- * Convert to WAI , toWaiApp - , basicHandler - , basicHandler' #if TEST - , testSuite + , dispatchTestSuite #endif ) where -#if TEST -import Yesod.Core hiding (testSuite) -import Yesod.Handler hiding (testSuite) -#else import Yesod.Core import Yesod.Handler -#endif import Yesod.Request import Yesod.Internal @@ -47,10 +40,6 @@ import Network.Wai.Middleware.CleanPath (cleanPath) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip -import qualified Network.Wai.Handler.SimpleServer as SS -import qualified Network.Wai.Handler.CGI as CGI -import System.Environment (getEnvironment) - import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -87,13 +76,10 @@ import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import System.IO.Unsafe -import Yesod.Content hiding (testSuite) -import Data.Serialize.Get -import Data.Serialize.Put -#else -import Yesod.Content #endif +import Yesod.Content + -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. @@ -359,34 +345,6 @@ httpAccept = map B.unpack . lookup "Accept" . W.requestHeaders --- | Runs an application with CGI if CGI variables are present (namely --- PATH_INFO); otherwise uses SimpleServer. -basicHandler :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> y - -> IO () -basicHandler port y = basicHandler' port (Just "localhost") y - - --- | Same as 'basicHandler', but allows you to specify the hostname to display --- to the user. If 'Nothing' is provided, then no output is produced. -basicHandler' :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> Maybe String -- ^ host name, 'Nothing' to show nothing - -> y - -> IO () -basicHandler' port mhost y = do - app <- toWaiApp y - vars <- getEnvironment - case lookup "PATH_INFO" vars of - Nothing -> do - case mhost of - Nothing -> return () - Just h -> putStrLn $ concat - ["http://", h, ":", show port, "/"] - SS.run port app - Just _ -> CGI.run app - parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request @@ -518,8 +476,8 @@ getTime = do #if TEST -testSuite :: Test -testSuite = testGroup "Yesod.Dispatch" +dispatchTestSuite :: Test +dispatchTestSuite = testGroup "Yesod.Dispatch" [ testProperty "encode/decode session" propEncDecSession , testProperty "get/put time" propGetPutTime ] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1420a8f4..a3be72af 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -88,7 +88,7 @@ module Yesod.Handler , ErrorResponse (..) , YesodAppResult (..) #if TEST - , testSuite + , handlerTestSuite #endif ) where @@ -120,14 +120,10 @@ import qualified Data.ByteString.Char8 as S8 #if TEST import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit hiding (Test) -import Yesod.Content hiding (testSuite) -import Data.IORef -#else -import Yesod.Content #endif +import Yesod.Content + -- | The type-safe URLs associated with a site argument. type family Route a @@ -580,8 +576,8 @@ getSession = GHandler $ lift $ lift $ lift get #if TEST -testSuite :: Test -testSuite = testGroup "Yesod.Handler" +handlerTestSuite :: Test +handlerTestSuite = testGroup "Yesod.Handler" [ ] diff --git a/runtests.hs b/runtests.hs index e3fe7bc8..8498ef14 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,18 +1,12 @@ import Test.Framework (defaultMain) -import qualified Yesod.Content -import qualified Yesod.Json -import qualified Yesod.Dispatch -import qualified Yesod.Helpers.Static -import qualified Yesod.Yesod -import qualified Yesod.Handler +import Yesod.Content +import Yesod.Dispatch +import Yesod.Handler main :: IO () main = defaultMain - [ Yesod.Content.testSuite - , Yesod.Json.testSuite - , Yesod.Dispatch.testSuite - , Yesod.Helpers.Static.testSuite - , Yesod.Yesod.testSuite - , Yesod.Handler.testSuite + [ contentTestSuite + , dispatchTestSuite + , handlerTestSuite ] From aa8a4e9c25b68a23c4e252b1b345e1e9291f9810 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 22:44:17 +0200 Subject: [PATCH 021/126] Removed tests from Setup.lhs --- Setup.lhs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/Setup.lhs b/Setup.lhs index 1125d1d3..06e2708f 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -2,10 +2,6 @@ > module Main where > import Distribution.Simple -> import System.Cmd (system) > main :: IO () -> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) - -> runTests' :: a -> b -> c -> d -> IO () -> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return () +> main = defaultMain From 0c946de7562744a7d353a94c6b5b379340b44fb7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 22:49:12 +0200 Subject: [PATCH 022/126] Removed enableClientSessions --- Yesod/Core.hs | 12 +++--------- Yesod/Dispatch.hs | 16 ++++++++-------- 2 files changed, 11 insertions(+), 17 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index ee31f54e..df300c03 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -96,15 +96,9 @@ class Eq (Route a) => Yesod a where approot :: a -> String -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO CS.Key - encryptKey _ = getKey defaultKeyFile - - -- | Whether or not to use client sessions. - -- - -- FIXME: A better API would be to have 'encryptKey' return a Maybe, but - -- that would be a breaking change. Please include in Yesod 0.7. - enableClientSessions :: a -> Bool - enableClientSessions _ = True + -- Returning 'Nothing' disables sessions. + encryptKey :: a -> IO (Maybe CS.Key) + encryptKey _ = fmap Just $ getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to -- 120 (2 hours). diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 35dae927..d36c0905 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -242,9 +242,7 @@ toWaiApp y = do -- middleware. toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiAppPlain a = do - key' <- if enableClientSessions a - then Just `fmap` encryptKey a - else return Nothing + key' <- encryptKey a return $ cleanPath (splitPath a) (B.pack $ approot a) $ toWaiApp' a key' @@ -277,7 +275,7 @@ toWaiApp' y key' segments env = do (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler - rr <- parseWaiRequest env session' + rr <- parseWaiRequest env session' key' let h = do onRequest case eurl of @@ -347,8 +345,9 @@ httpAccept = map B.unpack parseWaiRequest :: W.Request -> [(String, String)] -- ^ session + -> Maybe a -> IO Request -parseWaiRequest env session' = do +parseWaiRequest env session' key' = do let gets' = map (bsToChars *** bsToChars) $ parseQueryString $ W.queryString env let reqCookie = fromMaybe B.empty $ lookup "Cookie" @@ -366,9 +365,10 @@ parseWaiRequest env session' = do Nothing -> langs'' Just x -> x : langs'' rbthunk <- iothunk $ rbHelper env - nonce <- case lookup nonceKey session' of - Just x -> return x - Nothing -> do + nonce <- case (key', lookup nonceKey session') of + (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? + (_, Just x) -> return x + (_, Nothing) -> do g <- newStdGen return $ fst $ randomString 10 g return $ Request gets' cookies' rbthunk env langs''' nonce From 3a5969b8e831f052b287dcad2470fcf631eebfd9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Dec 2010 20:13:08 +0200 Subject: [PATCH 023/126] Exposing toWaiAppPlain --- Yesod/Content.hs | 2 +- Yesod/Dispatch.hs | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index aaf57d60..639b8db3 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -225,7 +225,7 @@ simpleContentType :: String -> String simpleContentType = fst . span (/= ';') -- | A default extension to mime-type dictionary. -typeByExt :: [(String, ContentType)] +typeByExt :: [(String, ContentType)] -- FIXME move to yesod-static typeByExt = [ ("jpg", typeJpeg) , ("jpeg", typeJpeg) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index d36c0905..c0eb4491 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -19,6 +19,7 @@ module Yesod.Dispatch , Strings -- * Convert to WAI , toWaiApp + , toWaiAppPlain #if TEST , dispatchTestSuite #endif From 5c730104c898c25b36ce275c6d91b527420632a8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 30 Dec 2010 06:13:46 +0200 Subject: [PATCH 024/126] MEitherT -> ErrorT --- Yesod/Handler.hs | 27 +++++++++++++++------------ yesod-core.cabal | 1 - 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a3be72af..174acf48 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -95,7 +95,6 @@ module Yesod.Handler import Prelude hiding (catch) import Yesod.Request import Yesod.Internal -import Data.Neither import Data.Time (UTCTime) import Control.Exception hiding (Handler, catch, finally) @@ -107,6 +106,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader import Control.Monad.Trans.State +import Control.Monad.Trans.Error (throwError, ErrorT (runErrorT), Error (..)) import System.IO import qualified Network.Wai as W @@ -211,7 +211,7 @@ newtype GHandler sub master a = type GHInner s m = ReaderT (HandlerData s m) ( - MEitherT HandlerContents ( + ErrorT HandlerContents ( WriterT (Endo [Header]) ( StateT SessionMap ( -- session IO @@ -245,8 +245,11 @@ data HandlerContents = | HCCreated String | HCEnum (forall a. W.ResponseEnumerator a) +instance Error HandlerContents where + strMsg = HCError . InternalError + instance Failure ErrorResponse (GHandler sub master) where - failure = GHandler . lift . throwMEither . HCError + failure = GHandler . lift . throwError . HCError instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> GHandler ask @@ -304,11 +307,11 @@ runHandler handler mrender sroute tomr ma tosa = ((contents', headers), finalSession) <- E.catch ( flip runStateT initSession $ runWriterT - $ runMEitherT + $ runErrorT $ flip runReaderT hd $ unGHandler handler - ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) - let contents = meither id (HCContent W.status200 . chooseRep) contents' + ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) + let contents = either id (HCContent W.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession case yar of @@ -364,7 +367,7 @@ redirectParams rt url params = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt = GHandler . lift . throwMEither . HCRedirect rt +redirectString rt = GHandler . lift . throwError . HCRedirect rt ultDestKey :: String ultDestKey = "_ULT" @@ -433,18 +436,18 @@ 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 :: ContentType -> FilePath -> GHandler sub master a -sendFile ct = GHandler . lift . throwMEither . HCSendFile ct +sendFile ct = GHandler . lift . throwError . HCSendFile ct -- | Bypass remaining handler code and output the given content with a 200 -- status code. sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = GHandler . lift . throwMEither . HCContent W.status200 +sendResponse = GHandler . lift . throwError . HCContent W.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code. sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a -sendResponseStatus s = GHandler . lift . throwMEither . HCContent s +sendResponseStatus s = GHandler . lift . throwError . HCContent s . chooseRep -- | Send a 201 "Created" response with the given route as the Location @@ -452,7 +455,7 @@ sendResponseStatus s = GHandler . lift . throwMEither . HCContent s sendResponseCreated :: Route m -> GHandler s m a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwMEither $ HCCreated $ r url + GHandler $ lift $ throwError $ HCCreated $ r url -- | Send a 'W.ResponseEnumerator'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session @@ -460,7 +463,7 @@ sendResponseCreated url = do -- considered only for they specific needs. If you are not sure if you need it, -- you don't. sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b -sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum +sendResponseEnumerator = GHandler . lift . throwError . HCEnum -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a diff --git a/yesod-core.cabal b/yesod-core.cabal index 03836cbb..9734f4f8 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -41,7 +41,6 @@ library , random >= 1.0.0.2 && < 1.1 , cereal >= 0.2 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1 - , neither >= 0.2 && < 0.3 , web-routes >= 0.23 && < 0.24 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 From db5e987797768e19cb6c0e6b7f8df1f836634c3b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 31 Dec 2010 00:56:40 +0200 Subject: [PATCH 025/126] Remove requestBody, live in Iteratee --- Yesod/Dispatch.hs | 33 +++++++++++++++----------- Yesod/Handler.hs | 59 ++++++++++++++++++++++++++++++----------------- Yesod/Request.hs | 19 +++++++-------- Yesod/Widget.hs | 59 +++++++++++++++++++++++++---------------------- 4 files changed, 99 insertions(+), 71 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c0eb4491..f277ef37 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -43,6 +43,7 @@ import Network.Wai.Middleware.Gzip import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (toLazyByteString) @@ -70,7 +71,8 @@ import System.Random (randomR, newStdGen) import qualified Data.Map as Map import Control.Applicative ((<$>)) -import Data.Enumerator (($$), run_) +import Data.Enumerator (($$), run_, Iteratee) +import Control.Monad.IO.Class (liftIO) #if TEST import Test.Framework (testGroup, Test) @@ -251,10 +253,9 @@ toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key -> [String] - -> W.Request - -> IO W.Response + -> W.Application toWaiApp' y key' segments env = do - now <- getCurrentTime + now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y let host = if sessionIpAddress y then W.remoteHost env else "" @@ -276,7 +277,7 @@ toWaiApp' y key' segments env = do (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler - rr <- parseWaiRequest env session' key' + rr <- liftIO $ parseWaiRequest env session' key' let h = do onRequest case eurl of @@ -389,11 +390,10 @@ parseWaiRequest env session' key' = do nonceKey :: String nonceKey = "_NONCE" -rbHelper :: W.Request -> IO RequestBodyContents +rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents rbHelper req = - (map fix1 *** map fix2) <$> run_ (enum $$ iter) + (map fix1 *** map fix2) <$> iter where - enum = W.requestBody req iter = parseRequestBody lbsSink req fix1 = bsToChars *** bsToChars fix2 (x, NWP.FileInfo a b c) = @@ -402,11 +402,18 @@ rbHelper req = -- | Produces a \"compute on demand\" value. The computation will be run once -- it is requested, and then the result will be stored. This will happen only -- once. -iothunk :: IO a -> IO (IO a) -iothunk = fmap go . newMVar . Left where - go :: MVar (Either (IO a) a) -> IO a - go mvar = modifyMVar mvar go' - go' :: Either (IO a) a -> IO (Either (IO a) a, a) +iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) +iothunk = + fmap go . liftIO . newMVar . Left + where + go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a + go mvar = do + x <- liftIO $ takeMVar mvar + (x', a) <- go' x + liftIO $ putMVar mvar x' + return a + go' :: Either (Iteratee ByteString IO a) a + -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a) go' (Right val) = return (Right val, val) go' (Left comp) = do val <- comp diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 174acf48..85354d50 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -101,6 +101,8 @@ import Control.Exception hiding (Handler, catch, finally) import qualified Control.Exception as E import Control.Applicative +import Control.Monad (liftM) + import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer @@ -117,6 +119,8 @@ import Text.Hamlet import Control.Monad.IO.Peel (MonadPeelIO) import qualified Data.Map as Map import qualified Data.ByteString.Char8 as S8 +import Data.ByteString (ByteString) +import Data.Enumerator (Iteratee (..)) #if TEST import Test.Framework (testGroup, Test) @@ -203,18 +207,20 @@ toMasterHandlerMaybe tm ts route (GHandler h) = -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling -- special responses. It is declared as a newtype to make compiler errors more -- readable. -newtype GHandler sub master a = +newtype GGHandler sub master m a = GHandler - { unGHandler :: GHInner sub master a + { unGHandler :: GHInner sub master m a } deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) -type GHInner s m = +type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) + +type GHInner s m monad = ReaderT (HandlerData s m) ( ErrorT HandlerContents ( WriterT (Endo [Header]) ( StateT SessionMap ( -- session - IO + monad )))) type SessionMap = Map.Map String String @@ -230,7 +236,7 @@ newtype YesodApp = YesodApp -> Request -> [ContentType] -> SessionMap - -> IO YesodAppResult + -> Iteratee ByteString IO YesodAppResult } data YesodAppResult @@ -248,38 +254,43 @@ data HandlerContents = instance Error HandlerContents where strMsg = HCError . InternalError -instance Failure ErrorResponse (GHandler sub master) where +instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where failure = GHandler . lift . throwError . HCError instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> GHandler ask + runRequestBody = do + rr <- getRequest + GHandler $ lift $ lift $ lift $ lift $ reqRequestBody rr -- | Get the sub application argument. -getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub <$> GHandler ask +getYesodSub :: Monad m => GGHandler sub master m sub +getYesodSub = handlerSub `liftM` GHandler ask -- | Get the master site appliation argument. -getYesod :: GHandler sub master master -getYesod = handlerMaster <$> GHandler ask +getYesod :: Monad m => GGHandler sub master m master +getYesod = handlerMaster `liftM` GHandler ask -- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Route master -> String) +getUrlRender :: Monad m => GGHandler sub master m (Route master -> String) getUrlRender = do - x <- handlerRender <$> GHandler ask + x <- handlerRender `liftM` GHandler ask return $ flip x [] -- | The URL rendering function with query-string parameters. -getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String) -getUrlRenderParams = handlerRender <$> GHandler ask +getUrlRenderParams + :: Monad m + => GGHandler sub master m (Route master -> [(String, String)] -> String) +getUrlRenderParams = handlerRender `liftM` GHandler 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 :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = handlerRoute <$> GHandler ask +getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub)) +getCurrentRoute = handlerRoute `liftM` GHandler ask -- | Get the function to promote a route for a subsite to a route for the -- master site. -getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = handlerToMaster <$> GHandler ask +getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master) +getRouteToMaster = handlerToMaster `liftM` GHandler ask -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. @@ -304,7 +315,7 @@ runHandler handler mrender sroute tomr ma tosa = , handlerRender = mrender , handlerToMaster = tomr } - ((contents', headers), finalSession) <- E.catch ( + ((contents', headers), finalSession) <- catchIter ( flip runStateT initSession $ runWriterT $ runErrorT @@ -323,7 +334,7 @@ runHandler handler mrender sroute tomr ma tosa = return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession case contents of HCContent status a -> do - (ct, c) <- chooseRep a cts + (ct, c) <- liftIO $ chooseRep a cts return $ YARPlain status (headers []) ct c finalSession HCError e -> handleError e HCRedirect rt loc -> do @@ -331,7 +342,7 @@ runHandler handler mrender sroute tomr ma tosa = return $ YARPlain (getRedirectStatus rt) hs typePlain emptyContent finalSession - HCSendFile ct fp -> E.catch + HCSendFile ct fp -> catchIter (sendFile' ct fp) (handleError . toErrorHandler) HCCreated loc -> do -- FIXME add status201 to WAI @@ -344,6 +355,12 @@ runHandler handler mrender sroute tomr ma tosa = finalSession HCEnum e -> return $ YAREnum e +catchIter :: Exception e + => Iteratee ByteString IO a + -> (e -> Iteratee ByteString IO a) + -> Iteratee ByteString IO a +catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f) + safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 48cc4236..d0c1573c 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -41,6 +41,8 @@ module Yesod.Request ) where import qualified Network.Wai as W +import Data.ByteString (ByteString) +import Data.Enumerator (Iteratee) import qualified Data.ByteString.Lazy as BL import "transformers" Control.Monad.IO.Class import Control.Monad (liftM) @@ -51,11 +53,12 @@ type ParamName = String type ParamValue = String type ParamError = String +-- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler + -- | The reader monad specialized for 'Request'. class Monad m => RequestReader m where getRequest :: m Request -instance RequestReader ((->) Request) where - getRequest = id + runRequestBody :: m RequestBodyContents -- | Get the list of supported languages supplied by the user. -- @@ -107,7 +110,7 @@ data Request = Request -- service, you may want to accept JSON-encoded data. Just be aware that -- if you do such parsing, the standard POST form parsing functions will -- no longer work. - , reqRequestBody :: IO RequestBodyContents + , reqRequestBody :: Iteratee ByteString IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [String] @@ -129,12 +132,11 @@ lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. -lookupPostParams :: (MonadIO m, RequestReader m) +lookupPostParams :: RequestReader m => ParamName -> m [ParamValue] lookupPostParams pn = do - rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr + (pp, _) <- runRequestBody return $ lookup' pn pp lookupPostParam :: (MonadIO m, RequestReader m) @@ -149,12 +151,11 @@ lookupFile :: (MonadIO m, RequestReader m) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: (MonadIO m, RequestReader m) +lookupFiles :: RequestReader m => ParamName -> m [FileInfo] lookupFiles pn = do - rr <- getRequest - (_, files) <- liftIO $ reqRequestBody rr + (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index e1c20b9a..62a7cd07 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -7,7 +7,8 @@ -- generator, allowing you to create truly modular HTML components. module Yesod.Widget ( -- * Datatype - GWidget (..) + GWidget + , GGWidget (..) , liftHandler , PageContent (..) -- * Creating @@ -54,15 +55,17 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Yesod.Internal import Yesod.Content (RepHtml (RepHtml), Content, toContent) +import Control.Monad (liftM) import Control.Monad.IO.Peel (MonadPeelIO) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. -newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a } +newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a } deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) -type GWInner sub master = +type GWidget s m = GGWidget s m (GHandler s m) +type GWInner sub master monad = WriterT (Body (Route master)) ( WriterT (Last Title) ( WriterT (UniqueList (Script (Route master))) ( @@ -71,28 +74,28 @@ type GWInner sub master = WriterT (Maybe (Julius (Route master))) ( WriterT (Head (Route master)) ( StateT Int ( - GHandler sub master + monad )))))))) -instance Monoid (GWidget sub master ()) where +instance Monad monad => Monoid (GGWidget sub master monad ()) where mempty = return () mappend x y = x >> y -instance HamletValue (GWidget s m ()) where - newtype HamletMonad (GWidget s m ()) a = - GWidget' { runGWidget' :: GWidget s m a } - type HamletUrl (GWidget s m ()) = Route m +instance Monad monad => HamletValue (GGWidget s m monad ()) where + newtype HamletMonad (GGWidget s m monad ()) a = + GWidget' { runGWidget' :: GGWidget s m monad a } + type HamletUrl (GGWidget s m monad ()) = Route m toHamletValue = runGWidget' htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $ addHamlet $ \r -> preEscapedString (r url params) fromHamletValue = GWidget' -instance Monad (HamletMonad (GWidget s m ())) where +instance Monad monad => Monad (HamletMonad (GGWidget s m monad ())) where return = GWidget' . return x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y -- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' -- monad. -liftHandler :: GHandler sub master a -> GWidget sub master a +liftHandler :: Monad monad => monad a -> GGWidget sub master monad a liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a @@ -125,32 +128,32 @@ addSubWidget sub w = do master <- liftHandler getYesod -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. -setTitle :: Html -> GWidget sub master () +setTitle :: Monad m => Html -> GGWidget sub master m () setTitle = GWidget . lift . tell . Last . Just . Title -- | Add a 'Hamlet' to the head tag. -addHamletHead :: Hamlet (Route master) -> GWidget sub master () +addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m () addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head -- | Add a 'Html' to the head tag. -addHtmlHead :: Html -> GWidget sub master () +addHtmlHead :: Monad m => Html -> GGWidget sub master m () addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const -- | Add a 'Hamlet' to the body tag. -addHamlet :: Hamlet (Route master) -> GWidget sub master () +addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m () addHamlet = GWidget . tell . Body -- | Add a 'Html' to the body tag. -addHtml :: Html -> GWidget sub master () +addHtml :: Monad m => Html -> GGWidget sub master m () addHtml = GWidget . tell . Body . const -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent. -addWidget :: GWidget s m () -> GWidget s m () +addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo () addWidget = id -- | Get a unique identifier. -newIdent :: GWidget sub master String +newIdent :: Monad mo => GGWidget sub master mo String newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do i <- get let i' = i + 1 @@ -158,42 +161,42 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do return $ "w" ++ show i' -- | Add some raw CSS to the style tag. -addCassius :: Cassius (Route master) -> GWidget sub master () +addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m () addCassius = GWidget . lift . lift . lift . lift . tell . Just -- | Link to the specified local stylesheet. -addStylesheet :: Route master -> GWidget sub master () +addStylesheet :: Monad m => Route master -> GGWidget sub master m () addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local -- | Link to the specified remote stylesheet. -addStylesheetRemote :: String -> GWidget sub master () +addStylesheetRemote :: Monad m => String -> GGWidget sub master m () addStylesheetRemote = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote -addStylesheetEither :: Either (Route master) String -> GWidget sub master () +addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Either (Route master) String -> GWidget sub master () +addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. -addScript :: Route master -> GWidget sub master () +addScript :: Monad m => Route master -> GGWidget sub master m () addScript = GWidget . lift . lift . tell . toUnique . Script . Local -- | Link to the specified remote script. -addScriptRemote :: String -> GWidget sub master () +addScriptRemote :: Monad m => String -> GGWidget sub master m () addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag. -addJulius :: Julius (Route master) -> GWidget sub master () +addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m () addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. -extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m)) +extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m)) extractBody (GWidget w) = - GWidget $ mapWriterT (fmap go) w + GWidget $ mapWriterT (liftM go) w where go ((), Body h) = (h, Body mempty) From 055da0febe0e6c29d29975004b666d64f30eca9e Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 5 Jan 2011 16:48:09 +0200 Subject: [PATCH 026/126] web-routes-quasi bump --- yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core.cabal b/yesod-core.cabal index 9734f4f8..f63e720a 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -33,7 +33,7 @@ library , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.5 && < 0.12 , template-haskell - , web-routes-quasi >= 0.6.2 && < 0.7 + , web-routes-quasi >= 0.6.3 && < 0.7 , hamlet >= 0.7 && < 0.8 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 From 06db8b950851a93eb6caa34a819e07e850aa48ee Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 5 Jan 2011 23:47:59 +0200 Subject: [PATCH 027/126] Changes to Css and Javascript datatypes --- Yesod/Core.hs | 14 +++++++------- yesod-core.cabal | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index df300c03..78a1f40e 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -50,7 +50,9 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Web.Routes -import Blaze.ByteString.Builder (toLazyByteString) +import Text.Blaze (preEscapedLazyText) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Encoding (encodeUtf8) #if TEST import Test.Framework (testGroup, Test) @@ -382,12 +384,10 @@ widgetToPageContent (GWidget w) = do let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' let stylesheets = map (locationToHamlet . unStylesheet) $ runUniqueList stylesheets' - -- FIXME change hamlet: cassius and julius should be structured datatypes so we don't need to do this - let unsafeLazyByteString = mconcat . map unsafeByteString . L.toChunks - let cssToHtml (Css b) = unsafeLazyByteString $ toLazyByteString b + let cssToHtml = preEscapedLazyText . renderCss celper :: Cassius url -> Hamlet url celper = fmap cssToHtml - jsToHtml (Javascript b) = unsafeLazyByteString $ toLazyByteString b + jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b jelper :: Julius url -> Hamlet url jelper = fmap jsToHtml @@ -402,14 +402,14 @@ widgetToPageContent (GWidget w) = do Nothing -> return Nothing Just s -> do x <- addStaticContent "css" "text/css; charset=utf-8" - $ renderCassius render s + $ encodeUtf8 $ renderCassius render s return $ renderLoc x jsLoc <- case jscript of Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJulius render s + $ encodeUtf8 $ renderJulius render s return $ renderLoc x let head'' = diff --git a/yesod-core.cabal b/yesod-core.cabal index f63e720a..3038df4d 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -47,7 +47,7 @@ library , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 , cookie >= 0.0 && < 0.1 - , blaze-html >= 0.3.0.4 && < 0.4 + , blaze-html >= 0.3.2.1 && < 0.4 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch From 6c3c312a4846ba795fe43947d75054a9b61b08b7 Mon Sep 17 00:00:00 2001 From: Michael Date: Wed, 5 Jan 2011 23:48:12 +0200 Subject: [PATCH 028/126] Compile with new remoteHost --- Yesod/Dispatch.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f277ef37..40034246 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -258,7 +258,9 @@ toWaiApp' y key' segments env = do now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y - let host = if sessionIpAddress y then W.remoteHost env else "" + -- FIXME will show remoteHost give the answer I need? will it include port + -- information that changes on each request? + let host = if sessionIpAddress y then B.pack (show (W.remoteHost env)) else "" let session' = case key' of Nothing -> [] From bf324ded19fd69e3a8e9e73ac91b9ce5380b3b5f Mon Sep 17 00:00:00 2001 From: Michael Date: Thu, 6 Jan 2011 08:15:50 +0200 Subject: [PATCH 029/126] ResponseBuilder constructor --- Yesod/Dispatch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 40034246..695abe99 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -334,7 +334,7 @@ toWaiApp' y key' segments env = do Just len -> ("Content-Length", B.pack $ show len) : hs''' - in W.responseBuilder s hs'''' b + in W.ResponseBuilder s hs'''' b ContentFile fp -> W.ResponseFile s hs''' fp ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s hs''' From 06193634c427b0490a80c1076bf767b67cb0bf37 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 13 Jan 2011 22:08:22 +0200 Subject: [PATCH 030/126] Added ToContent Builder instance --- Yesod/Content.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 639b8db3..f65a0458 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -95,6 +95,8 @@ emptyContent = ContentBuilder mempty $ Just 0 class ToContent a where toContent :: a -> Content +instance ToContent Builder where + toContent = flip ContentBuilder Nothing instance ToContent B.ByteString where toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs instance ToContent L.ByteString where From 62cdd6ba633a4bcef4ee707d944f2025ebec5435 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 13 Jan 2011 22:30:23 +0200 Subject: [PATCH 031/126] MonadTrans instances for GGHandler and GGWidget --- Yesod/Handler.hs | 3 +++ Yesod/Widget.hs | 6 +++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 85354d50..3847bbda 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -213,6 +213,9 @@ newtype GGHandler sub master m a = } deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) +instance MonadTrans (GGHandler s m) where + lift = GHandler . lift . lift . lift . lift + type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) type GHInner s m monad = diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 62a7cd07..df33ea1b 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -52,7 +52,7 @@ import Yesod.Handler ) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Class (MonadTrans (lift)) import Yesod.Internal import Yesod.Content (RepHtml (RepHtml), Content, toContent) import Control.Monad (liftM) @@ -64,6 +64,10 @@ import Control.Monad.IO.Peel (MonadPeelIO) -- dependencies along with a 'StateT' to track unique identifiers. newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a } deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) + +instance MonadTrans (GGWidget s m) where + lift = GWidget . lift . lift . lift . lift . lift . lift . lift . lift + type GWidget s m = GGWidget s m (GHandler s m) type GWInner sub master monad = WriterT (Body (Route master)) ( From 5c3670c8481abf50e78e0bd3b96eb6aa8488190f Mon Sep 17 00:00:00 2001 From: Matt Brown Date: Sun, 16 Jan 2011 17:15:55 -0800 Subject: [PATCH 032/126] relax instance matching for GGWidget hamlet instances --- Yesod/Widget.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index df33ea1b..e1f5a009 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -80,20 +80,20 @@ type GWInner sub master monad = StateT Int ( monad )))))))) -instance Monad monad => Monoid (GGWidget sub master monad ()) where +instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where mempty = return () mappend x y = x >> y -instance Monad monad => HamletValue (GGWidget s m monad ()) where - newtype HamletMonad (GGWidget s m monad ()) a = - GWidget' { runGWidget' :: GGWidget s m monad a } - type HamletUrl (GGWidget s m monad ()) = Route m +instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where + newtype HamletMonad (GGWidget s m monad a) b = + GWidget' { runGWidget' :: GGWidget s m monad b } + type HamletUrl (GGWidget s m monad a) = Route m toHamletValue = runGWidget' htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $ addHamlet $ \r -> preEscapedString (r url params) fromHamletValue = GWidget' -instance Monad monad => Monad (HamletMonad (GGWidget s m monad ())) where +instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where return = GWidget' . return x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y From 085bb88bb17af10f79aa3f2fbcef82166646d14c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 17 Jan 2011 08:14:50 +0200 Subject: [PATCH 033/126] Include some RSS-specific definitions --- Yesod/Content.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index f65a0458..9b026de7 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -19,6 +19,7 @@ module Yesod.Content , typeJson , typeXml , typeAtom + , typeRss , typeJpeg , typePng , typeGif @@ -45,6 +46,7 @@ module Yesod.Content -- * Utilities , formatW3 , formatRFC1123 + , formatRFC822 #if TEST , contentTestSuite #endif @@ -194,6 +196,9 @@ typeXml = "text/xml" typeAtom :: ContentType typeAtom = "application/atom+xml" +typeRss :: ContentType +typeRss = "application/rss+xml" + typeJpeg :: ContentType typeJpeg = "image/jpeg" @@ -271,3 +276,7 @@ formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> String formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" + +-- | Format as per RFC 822. +formatRFC822 :: UTCTime -> String +formatRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" From 0874b61763bba1fc27adf1b7dc1221e507989511 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 19 Jan 2011 21:53:39 +0200 Subject: [PATCH 034/126] Recent Hamlet changes --- Yesod/Core.hs | 90 ++++++++++++++++++++++++----------------------- Yesod/Internal.hs | 6 ++-- yesod-core.cabal | 2 +- 3 files changed, 51 insertions(+), 47 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 78a1f40e..2dc122e8 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -116,16 +116,17 @@ class Eq (Route a) => Yesod a where defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage - hamletToRepHtml [HAMLET| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %body - $maybe mmsg msg - %p.message $msg$ - ^pageBody.p^ + hamletToRepHtml [HAMLET|\ +\ + + + + #{pageTitle p} + \^{pageHead p} + <body> + $maybe msg <- mmsg + <p .message>#{msg} + \^{pageBody p} |] -- | Gets called at the beginning of each request. Useful for logging. @@ -306,8 +307,8 @@ defaultErrorHandler NotFound = do #else [$hamlet| #endif -%h1 Not Found -%p $path'$ +<h1>Not Found +<p>#{path'} |] defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" @@ -316,8 +317,8 @@ defaultErrorHandler (PermissionDenied msg) = #else [$hamlet| #endif -%h1 Permission denied -%p $msg$ +<h1>Permission denied +<p>#{msg} |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" @@ -326,10 +327,10 @@ defaultErrorHandler (InvalidArgs ia) = #else [$hamlet| #endif -%h1 Invalid Arguments -%ul - $forall ia msg - %li $msg$ +<h1>Invalid Arguments +<ul> + $forall msg <- ia + <li>#{msg} |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" @@ -338,8 +339,8 @@ defaultErrorHandler (InternalError e) = #else [$hamlet| #endif -%h1 Internal Server Error -%p $e$ +<h1>Internal Server Error +<p>#{e} |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" @@ -348,8 +349,8 @@ defaultErrorHandler (BadMethod m) = #else [$hamlet| #endif -%h1 Method Not Supported -%p Method "$m$" not supported +<h1>Method Not Supported +<p>Method "#{m}" not supported |] -- | Return the same URL if the user is authorized to see it. @@ -418,21 +419,21 @@ widgetToPageContent (GWidget w) = do #else [$hamlet| #endif -$forall scripts s - %script!src=^s^ -$forall stylesheets s - %link!rel=stylesheet!href=^s^ -$maybe style s - $maybe cssLoc s - %link!rel=stylesheet!href=$s$ +$forall s <- scripts + <script src="^{s}"> +$forall s <- stylesheets + <link rel="stylesheet" href="^{s}"> +$maybe s <- style + $maybe s <- cssLoc + <link rel="stylesheet" href="#{s}"> $nothing - %style ^celper.s^ -$maybe jscript j - $maybe jsLoc s - %script!src=$s$ + <style>^{celper s} +$maybe j <- jscript + $maybe s <- jsLoc + <script src="#{s}"> $nothing - %script ^jelper.j^ -^head'^ + <script>^{jelper j} +\^{head'} |] return $ PageContent title head'' body @@ -500,15 +501,16 @@ redirectToPost dest = hamletToRepHtml #else [$hamlet| #endif -!!! -%html - %head - %title Redirecting... - %body!onload="document.getElementById('form').submit()" - %form#form!method=post!action=@dest@ - %noscript - %p Javascript has been disabled; please click on the button below to be redirected. - %input!type=submit!value=Continue +\<!DOCTYPE html> + +<html> + <head> + <title>Redirecting... + <body onload="document.getElementById('form').submit()"> + <form id="form" method="post" action="@{dest}"> + <noscript> + <p>Javascript has been disabled; please click on the button below to be redirected. + <input type="submit" value="Continue"> |] >>= sendResponse yesodVersion :: String diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 20a1cc28..1880260c 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -70,8 +70,10 @@ langKey = "_LANG" data Location url = Local url | Remote String deriving (Show, Eq) locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [HAMLET|@url@|] -locationToHamlet (Remote s) = [HAMLET|$s$|] +locationToHamlet (Local url) = [HAMLET|\@{url} +|] +locationToHamlet (Remote s) = [HAMLET|\#{s} +|] newtype UniqueList x = UniqueList ([x] -> [x]) instance Monoid (UniqueList x) where diff --git a/yesod-core.cabal b/yesod-core.cabal index 3038df4d..2979f520 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -47,7 +47,7 @@ library , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 , cookie >= 0.0 && < 0.1 - , blaze-html >= 0.3.2.1 && < 0.4 + , blaze-html >= 0.4 && < 0.5 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch From 61c236b8c9e8470458160a047bcd32527381df28 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 19 Jan 2011 23:50:06 +0200 Subject: [PATCH 035/126] Exporting GGHandler --- Yesod/Handler.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3847bbda..b05a2a4a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -28,6 +28,7 @@ module Yesod.Handler , YesodSubRoute (..) -- * Handler monad , GHandler + , GGHandler -- ** Read information from handler , getYesod , getYesodSub From 27d62db253df70112f064eafe621e3a9780277dd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 20 Jan 2011 23:56:09 +0200 Subject: [PATCH 036/126] sendWaiResponse, changes to accomodate wai-app-static --- Yesod/Content.hs | 52 ----------------------------------------------- Yesod/Core.hs | 9 +++++++- Yesod/Dispatch.hs | 2 +- Yesod/Handler.hs | 18 ++++++++-------- 4 files changed, 18 insertions(+), 63 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 9b026de7..cd28f5ca 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} module Yesod.Content ( -- * Content @@ -28,9 +27,6 @@ module Yesod.Content , typeFlv , typeOgv , typeOctet - -- ** File extensions - , typeByExt - , ext -- * Utilities , simpleContentType -- * Representations @@ -47,9 +43,6 @@ module Yesod.Content , formatW3 , formatRFC1123 , formatRFC822 -#if TEST - , contentTestSuite -#endif ) where import Data.Maybe (mapMaybe) @@ -64,13 +57,6 @@ import System.Locale import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - import Data.Enumerator (Enumerator) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) @@ -231,44 +217,6 @@ typeOctet = "application/octet-stream" simpleContentType :: String -> String simpleContentType = fst . span (/= ';') --- | A default extension to mime-type dictionary. -typeByExt :: [(String, ContentType)] -- FIXME move to yesod-static -typeByExt = - [ ("jpg", typeJpeg) - , ("jpeg", typeJpeg) - , ("js", typeJavascript) - , ("css", typeCss) - , ("html", typeHtml) - , ("png", typePng) - , ("gif", typeGif) - , ("txt", typePlain) - , ("flv", typeFlv) - , ("ogv", typeOgv) - ] - --- | Get a file extension (everything after last period). -ext :: String -> String -ext = reverse . fst . break (== '.') . reverse - -#if TEST ----- Testing -contentTestSuite :: Test -contentTestSuite = testGroup "Yesod.Resource" - [ testProperty "ext" propExt - , testCase "typeByExt" caseTypeByExt - ] - -propExt :: String -> Bool -propExt s = - let s' = filter (/= '.') s - in s' == ext ("foobarbaz." ++ s') - -caseTypeByExt :: Assertion -caseTypeByExt = do - Just typeJavascript @=? lookup (ext "foo.js") typeByExt - Just typeHtml @=? lookup (ext "foo.html") typeByExt -#endif - -- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 2dc122e8..da4f2d20 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -180,6 +180,11 @@ class Eq (Route a) => Yesod a where -- * If the last path segment has a period, there is no trailing slash. -- -- * Otherwise, ensures there /is/ a trailing slash. + -- + -- Note: As a special rule, any paths beginning with static are left alone + -- so that the static subsite, if available, can deal with proper + -- directory/folder naming. If you do not wish this behavior, you will need + -- to override this method. splitPath :: a -> S.ByteString -> Either S.ByteString [String] splitPath _ s = if corrected == s @@ -188,7 +193,9 @@ class Eq (Route a) => Yesod a where $ S8.unpack s else Left corrected where - corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s + corrected + | s == "/static" || "/static/" `S.isPrefixOf` s = s + | otherwise = S8.pack $ rts $ ats $ rds $ S8.unpack s -- | Remove double slashes rds :: String -> String diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 695abe99..f1e47ff7 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -338,7 +338,7 @@ toWaiApp' y key' segments env = do ContentFile fp -> W.ResponseFile s hs''' fp ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s hs''' - YAREnum e -> return $ W.ResponseEnumerator e + YARWai r -> return r httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b05a2a4a..6581c614 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -52,7 +52,7 @@ module Yesod.Handler , sendResponse , sendResponseStatus , sendResponseCreated - , sendResponseEnumerator + , sendWaiResponse -- * Setting headers , setCookie , deleteCookie @@ -244,7 +244,7 @@ newtype YesodApp = YesodApp } data YesodAppResult - = YAREnum (forall a. W.ResponseEnumerator a) + = YARWai W.Response | YARPlain W.Status [Header] ContentType Content SessionMap data HandlerContents = @@ -253,7 +253,7 @@ data HandlerContents = | HCSendFile ContentType FilePath | HCRedirect RedirectType String | HCCreated String - | HCEnum (forall a. W.ResponseEnumerator a) + | HCWai W.Response instance Error HandlerContents where strMsg = HCError . InternalError @@ -333,7 +333,7 @@ runHandler handler mrender sroute tomr ma tosa = YARPlain _ hs ct c sess -> let hs' = headers hs in return $ YARPlain (getStatus e) hs' ct c sess - YAREnum _ -> return yar + YARWai _ -> return yar let sendFile' ct fp = return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession case contents of @@ -357,7 +357,7 @@ runHandler handler mrender sroute tomr ma tosa = typePlain emptyContent finalSession - HCEnum e -> return $ YAREnum e + HCWai r -> return $ YARWai r catchIter :: Exception e => Iteratee ByteString IO a @@ -478,13 +478,13 @@ sendResponseCreated url = do r <- getUrlRender GHandler $ lift $ throwError $ HCCreated $ r url --- | Send a 'W.ResponseEnumerator'. Please note: this function is rarely +-- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session -- that you have already specified. This function short-circuits. It should be --- considered only for they specific needs. If you are not sure if you need it, +-- considered only for very specific needs. If you are not sure if you need it, -- you don't. -sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b -sendResponseEnumerator = GHandler . lift . throwError . HCEnum +sendWaiResponse :: W.Response -> GHandler s m b +sendWaiResponse = GHandler . lift . throwError . HCWai -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a From 04df11e41ca4b891219bb65b2abc3ba025f8f8e6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 21 Jan 2011 12:06:45 +0200 Subject: [PATCH 037/126] Stop the unicorns from crying --- Yesod/Core.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index da4f2d20..2dc122e8 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -180,11 +180,6 @@ class Eq (Route a) => Yesod a where -- * If the last path segment has a period, there is no trailing slash. -- -- * Otherwise, ensures there /is/ a trailing slash. - -- - -- Note: As a special rule, any paths beginning with static are left alone - -- so that the static subsite, if available, can deal with proper - -- directory/folder naming. If you do not wish this behavior, you will need - -- to override this method. splitPath :: a -> S.ByteString -> Either S.ByteString [String] splitPath _ s = if corrected == s @@ -193,9 +188,7 @@ class Eq (Route a) => Yesod a where $ S8.unpack s else Left corrected where - corrected - | s == "/static" || "/static/" `S.isPrefixOf` s = s - | otherwise = S8.pack $ rts $ ats $ rds $ S8.unpack s + corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s -- | Remove double slashes rds :: String -> String From 1013e20067e3ea91893648a4dde849a6c21241e9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 22 Jan 2011 20:02:14 +0200 Subject: [PATCH 038/126] Fix some Yesod typeclass type signatures --- Yesod/Core.hs | 94 ++++++++++++++++------------------------------- Yesod/Dispatch.hs | 14 +++---- 2 files changed, 37 insertions(+), 71 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 2dc122e8..d16e10e2 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -95,7 +95,7 @@ class Eq (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> String + approot :: a -> S.ByteString -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -116,27 +116,29 @@ class Eq (Route a) => Yesod a where defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage - hamletToRepHtml [HAMLET|\ -\<!DOCTYPE html> + hamletToRepHtml [HAMLET| +!!! <html> <head> <title>#{pageTitle p} - \^{pageHead p} + ^{pageHead p} <body> $maybe msg <- mmsg <p .message>#{msg} - \^{pageBody p} + ^{pageBody p} |] -- | Gets called at the beginning of each request. Useful for logging. + -- + -- FIXME make this a part of the Yesod middlewares onRequest :: GHandler sub a () onRequest = return () -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe String + urlRenderOverride :: a -> Route a -> Maybe S.ByteString urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -144,6 +146,8 @@ class Eq (Route a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. + -- + -- FIXME make this a part of the Yesod middlewares isAuthorized :: Route a -> Bool -- ^ is this a write request? -> GHandler s a AuthResult @@ -169,73 +173,37 @@ class Eq (Route a) => Yesod a where authRoute :: a -> Maybe (Route a) authRoute _ = Nothing - -- | A function used to split a raw PATH_INFO value into path pieces. It - -- returns a 'Left' value when you should redirect to the given path, and a - -- 'Right' value on successful parse. - -- - -- By default, it splits paths on slashes, and ensures the following are true: + -- | A function used to clean up path segments. It returns 'Nothing' when + -- the given path is already clean, and a 'Just' when Yesod should redirect + -- to the given path pieces. -- -- * No double slashes -- - -- * If the last path segment has a period, there is no trailing slash. + -- * There is no trailing slash. -- - -- * Otherwise, ensures there /is/ a trailing slash. - splitPath :: a -> S.ByteString -> Either S.ByteString [String] - splitPath _ s = + -- Note that versions of Yesod prior to 0.7 used a different set of rules + -- involing trailing slashes. + cleanPath :: a -> [String] -> Maybe [String] + cleanPath _ s = if corrected == s - then Right $ filter (not . null) - $ decodePathInfo - $ S8.unpack s - else Left corrected + then Nothing + else Just corrected where - corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s - - -- | Remove double slashes - rds :: String -> String - rds [] = [] - rds [x] = [x] - rds (a:b:c) - | a == '/' && b == '/' = rds (b:c) - | otherwise = a : rds (b:c) - - -- | Add a trailing slash if it is missing. Empty string is left alone. - ats :: String -> String - ats [] = [] - ats t = - if last t == '/' || dbs (reverse t) - then t - else t ++ "/" - - -- | Remove a trailing slash if the last piece has a period. - rts :: String -> String - rts [] = [] - rts t = - if last t == '/' && dbs (tail $ reverse t) - then init t - else t - - -- | Is there a period before a slash here? - dbs :: String -> Bool - dbs ('/':_) = False - dbs (_:'.':_) = True - dbs (_:x) = dbs x - dbs [] = False - + corrected = filter (not . null) s -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> [(String, String)] -> String + joinPath :: a + -> S.ByteString -- ^ application root + -> [String] -- ^ path pieces + -> [(String, String)] -- ^ query string + -> S.ByteString joinPath _ ar pieces qs = - ar ++ '/' : encodePathInfo (fixSegs pieces) qs - where - fixSegs [] = [] - fixSegs [x] - | anyButLast (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash - fixSegs (x:xs) = x : fixSegs xs - anyButLast _ [] = False - anyButLast _ [_] = False - anyButLast p (x:xs) = p x || anyButLast p xs + S.concat + [ ar + , S8.singleton '/' + , S8.pack $ encodePathInfo pieces qs + ] -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f1e47ff7..08851dfb 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -37,7 +37,6 @@ import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPath) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -241,20 +240,19 @@ toWaiApp y = do a -- | Convert the given argument into a WAI application, executable with any WAI --- handler. This differs from 'toWaiApp' in that it only uses the cleanpath --- middleware. +-- handler. This differs from 'toWaiApp' in that it uses no middlewares. toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiAppPlain a = do key' <- encryptKey a - return $ cleanPath (splitPath a) (B.pack $ approot a) - $ toWaiApp' a key' + return $ toWaiApp' a key' toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key - -> [String] -> W.Application -toWaiApp' y key' segments env = do +toWaiApp' y key' env = do + let segments = decodePathInfo $ B.unpack $ W.pathInfo env + -- FIXME call cleanPath now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y @@ -275,7 +273,7 @@ toWaiApp' y key' segments env = do eurl = parsePathSegments site pathSegments render u qs = let (ps, qs') = formatPathSegments site u - in fromMaybe + in B.unpack $ fromMaybe (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler From 2f7ac581899282cded1082d329de0edcec4e8016 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 23 Jan 2011 21:35:52 +0200 Subject: [PATCH 039/126] Beginning of Yesod middlewares, massive refactor, more to come --- Yesod/Content.hs | 14 ++- Yesod/Core.hs | 236 ++++++++++++++++++++++++++++++++++++++-- Yesod/Dispatch.hs | 271 +++++++--------------------------------------- Yesod/Handler.hs | 118 +++++++++++++++++--- Yesod/Internal.hs | 9 +- 5 files changed, 388 insertions(+), 260 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index cd28f5ca..a65acee5 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Content ( -- * Content @@ -47,6 +48,7 @@ module Yesod.Content import Data.Maybe (mapMaybe) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T @@ -63,6 +65,7 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) +import Data.String (IsString (fromString)) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentEnum (forall a. Enumerator Builder IO a) @@ -72,6 +75,9 @@ data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional emptyContent :: Content emptyContent = ContentBuilder mempty $ Just 0 +instance IsString Content where + fromString = toContent + -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentBuilder' constructor. An easier approach will be to use -- a pre-defined 'toContent' function, such as converting your data into a lazy @@ -131,7 +137,7 @@ instance HasReps ChooseRep where chooseRep = id instance HasReps () where - chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] + chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)] instance HasReps (ContentType, Content) where chooseRep = const . return @@ -165,7 +171,7 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = String +type ContentType = B.ByteString typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -214,8 +220,8 @@ typeOctet = "application/octet-stream" -- -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: String -> String -simpleContentType = fst . span (/= ';') +simpleContentType :: B.ByteString -> B.ByteString +simpleContentType = S8.takeWhile (/= ';') -- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> String diff --git a/Yesod/Core.hs b/Yesod/Core.hs index d16e10e2..72cf9a25 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -24,6 +24,7 @@ module Yesod.Core , AuthResult (..) -- * Misc , yesodVersion + , yesodRender #if TEST , coreTestSuite #endif @@ -45,7 +46,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid import Control.Monad.Trans.Writer -import Control.Monad.Trans.State hiding (get) +import Control.Monad.Trans.State hiding (get, put) import Text.Hamlet import Text.Cassius import Text.Julius @@ -53,6 +54,20 @@ import Web.Routes import Text.Blaze (preEscapedLazyText) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Maybe (fromMaybe) +import System.Random (randomR, newStdGen) +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP +import Data.ByteString (ByteString) +import Data.Enumerator (Iteratee, ($$), run_) +import Control.Concurrent.MVar (MVar, takeMVar, putMVar, newMVar) +import Control.Monad.IO.Class (liftIO) +import Control.Applicative ((<$>)) +import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) +import qualified Data.Map as Map +import Control.Monad (guard) +import Data.Serialize +import Data.Time #if TEST import Test.Framework (testGroup, Test) @@ -69,18 +84,24 @@ import qualified Data.Text.Encoding #define HAMLET $hamlet #endif +{- FIXME +class YesodDispatcher y where + dispatchSubsite :: y -> Key -> [String] -> Maybe Application +-} + -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) + getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) + getSite' _ = getSite + type Method = String -- | Same as 'YesodSite', but for subsites. Once again, users should not need --- to deal with it directly, as the mkYesodSub creates instances appropriately. +-- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite _ = getSubSite -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. @@ -95,6 +116,8 @@ class Eq (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. + -- + -- FIXME: is this the right typesig? approot :: a -> S.ByteString -- | The encryption key to be used for encrypting client sessions. @@ -129,12 +152,6 @@ class Eq (Route a) => Yesod a where ^{pageBody p} |] - -- | Gets called at the beginning of each request. Useful for logging. - -- - -- FIXME make this a part of the Yesod middlewares - onRequest :: GHandler sub a () - onRequest = return () - -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. @@ -193,6 +210,8 @@ class Eq (Route a) => Yesod a where -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. + -- + -- FIXME is this the right type sig? joinPath :: a -> S.ByteString -- ^ application root -> [String] -- ^ path pieces @@ -226,6 +245,68 @@ class Eq (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True + yesodRunner :: YesodSite a => a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application + yesodRunner = defaultYesodRunner + +defaultYesodRunner y mkey murl handler req = do + now <- liftIO getCurrentTime + let getExpires m = fromIntegral (m * 60) `addUTCTime` now + let exp' = getExpires $ clientSessionDuration y + -- FIXME will show remoteHost give the answer I need? will it include port + -- information that changes on each request? + let host = if sessionIpAddress y then S8.pack (show (W.remoteHost req)) else "" + let session' = + case mkey of + Nothing -> [] + Just key -> fromMaybe [] $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + decodeSession key now host val + rr <- liftIO $ parseWaiRequest req session' mkey + let h = do + case murl of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest url + ar <- isAuthorized url isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> + case authRoute y of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDest' + redirect RedirectTemporary url' + Unauthorized s -> permissionDenied s + handler + let sessionMap = Map.fromList + $ filter (\(x, _) -> x /= nonceKey) session' + yar <- handlerToYAR y (yesodRender y) errorHandler rr murl sessionMap h + let mnonce = Just $ reqNonce rr -- FIXME + return $ yarToResponse (hr mnonce getExpires host exp') yar + where + hr mnonce getExpires host exp' hs ct sm = + hs''' + where + sessionVal = + case (mkey, mnonce) of + (Just key, Just nonce) + -> encodeSession key exp' host + $ Map.toList + $ Map.insert nonceKey nonce sm + _ -> S.empty + hs' = + case mkey of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + sessionVal + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", ct) : hs'' + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) @@ -483,3 +564,138 @@ redirectToPost dest = hamletToRepHtml yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version + +yesodRender :: (Yesod y, YesodSite y) + => y + -> Route y + -> [(String, String)] + -> String +yesodRender y u qs = + S8.unpack $ fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') + (urlRenderOverride y u) + where + (ps, qs') = formatPathSegments (getSite' y) u + +parseWaiRequest :: W.Request + -> [(String, String)] -- ^ session + -> Maybe a + -> IO Request +parseWaiRequest env session' key' = do + let gets' = map (bsToChars *** bsToChars) + $ NWP.parseQueryString $ W.queryString env + let reqCookie = fromMaybe S.empty $ lookup "Cookie" + $ W.requestHeaders env + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie + acceptLang = lookup "Accept-Language" $ W.requestHeaders env + langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup langKey session' of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey cookies' of + Nothing -> langs' + Just x -> x : langs' + langs''' = case lookup langKey gets' of + Nothing -> langs'' + Just x -> x : langs'' + rbthunk <- iothunk $ rbHelper env + nonce <- case (key', lookup nonceKey session') of + (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? + (_, Just x) -> return x + (_, Nothing) -> do + g <- newStdGen + return $ fst $ randomString 10 g + return $ Request gets' cookies' rbthunk env langs''' nonce + where + randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +nonceKey :: String +nonceKey = "_NONCE" + +rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents +rbHelper req = + (map fix1 *** map fix2) <$> iter + where + iter = NWP.parseRequestBody NWP.lbsSink req + fix1 = bsToChars *** bsToChars + fix2 (x, NWP.FileInfo a b c) = + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) + +-- | Produces a \"compute on demand\" value. The computation will be run once +-- it is requested, and then the result will be stored. This will happen only +-- once. +-- +-- FIXME: remove this function and use a StateT in Handler +iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) +iothunk = + fmap go . liftIO . newMVar . Left + where + go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a + go mvar = do + x <- liftIO $ takeMVar mvar + (x', a) <- go' x + liftIO $ putMVar mvar x' + return a + go' :: Either (Iteratee ByteString IO a) a + -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a) + go' (Right val) = return (Right val, val) + go' (Left comp) = do + val <- comp + return (Right val, val) + +-- FIXME don't duplicate +sessionName :: ByteString +sessionName = "_SESSION" + +encodeSession :: CS.Key + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(String, String)] -- ^ session + -> ByteString -- ^ cookie value +encodeSession key expire rhost session' = + CS.encrypt key $ encode $ SessionCookie expire rhost session' + +decodeSession :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> Maybe [(String, String)] +decodeSession key now rhost encrypted = do + decrypted <- CS.decrypt key encrypted + SessionCookie expire rhost' session' <- + either (const Nothing) Just $ decode decrypted + guard $ expire > now + guard $ rhost' == rhost + return session' + +data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] + deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = putTime a >> put b >> put c + get = do + a <- getTime + b <- get + c <- get + return $ SessionCookie a b c + +putTime :: Putter UTCTime +putTime t@(UTCTime d _) = do + put $ toModifiedJulianDay d + let ndt = diffUTCTime t $ UTCTime d 0 + put $ toRational ndt + +getTime :: Get UTCTime +getTime = do + d <- get + ndt <- get + return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 08851dfb..5cdb4768 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -44,6 +44,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8 () import Blaze.ByteString.Builder (toLazyByteString) import Control.Concurrent.MVar @@ -225,7 +226,7 @@ mkToMasterArg ps fname = do e = rsg `AppE` e' return $ LamE xps e -sessionName :: String +sessionName :: B.ByteString sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI @@ -246,241 +247,53 @@ toWaiAppPlain a = do key' <- encryptKey a return $ toWaiApp' a key' +dispatchPieces _ _ _ = Nothing -- FIXME + toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key -> W.Application toWaiApp' y key' env = do - let segments = decodePathInfo $ B.unpack $ W.pathInfo env - -- FIXME call cleanPath - now <- liftIO getCurrentTime - let getExpires m = fromIntegral (m * 60) `addUTCTime` now - let exp' = getExpires $ clientSessionDuration y - -- FIXME will show remoteHost give the answer I need? will it include port - -- information that changes on each request? - let host = if sessionIpAddress y then B.pack (show (W.remoteHost env)) else "" - let session' = - case key' of - Nothing -> [] - Just key'' -> fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders env - val <- lookup (B.pack sessionName) $ parseCookies raw - decodeSession key'' now host val - let site = getSite - method = B.unpack $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) segments - eurl = parsePathSegments site pathSegments - render u qs = - let (ps, qs') = formatPathSegments site u - in B.unpack $ fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - let errorHandler' = localNoCurrent . errorHandler - rr <- liftIO $ parseWaiRequest env session' key' - let h = do - onRequest - case eurl of - Left _ -> errorHandler' NotFound - Right url -> do - isWrite <- isWriteRequest url - ar <- isAuthorized url isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute y of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDest' - redirect RedirectTemporary url' - Unauthorized s -> permissionDenied s - case handleSite site render url method of - Nothing -> errorHandler' $ BadMethod method - Just h' -> h' - let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler' er) render eurl' id y id - let ya = runHandler h render eurl' id y id - let sessionMap = Map.fromList - $ filter (\(x, _) -> x /= nonceKey) session' - yar <- unYesodApp ya eh rr types sessionMap - case yar of - YARPlain s hs ct c sessionFinal -> do - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = - case key' of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration y) - sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ - case c of - ContentBuilder b mlen -> - let hs'''' = - case mlen of - Nothing -> hs''' - Just len -> - ("Content-Length", B.pack $ show len) - : hs''' - in W.ResponseBuilder s hs'''' b - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' - YARWai r -> return r + let segments = + case decodePathInfo $ B.unpack $ W.pathInfo env of + "":x -> x + x -> x + liftIO $ print (W.pathInfo env, segments) + case dispatchPieces y key' segments of + Nothing -> + case cleanPath y segments of + Nothing -> normalDispatch y key' segments env + Just segments' -> + let dest = joinPath y (approot y) segments' [] + dest' = + if S.null (W.queryString env) + then dest + else S.concat + [ dest + , B.singleton '?' + , W.queryString env + ] + in return $ W.responseLBS W.status301 + [ ("Content-Type", "text/plain") + , ("Location", dest') + ] "Redirecting" + Just app -> app env -httpAccept :: W.Request -> [ContentType] -httpAccept = map B.unpack - . parseHttpAccept - . fromMaybe B.empty - . lookup "Accept" - . W.requestHeaders - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> Maybe a - -> IO Request -parseWaiRequest env session' key' = do - let gets' = map (bsToChars *** bsToChars) - $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey session' of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey cookies' of - Nothing -> langs' - Just x -> x : langs' - langs''' = case lookup langKey gets' of - Nothing -> langs'' - Just x -> x : langs'' - rbthunk <- iothunk $ rbHelper env - nonce <- case (key', lookup nonceKey session') of - (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? - (_, Just x) -> return x - (_, Nothing) -> do - g <- newStdGen - return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk env langs''' nonce +normalDispatch :: (Yesod m, YesodSite m) + => m -> Maybe Key -> [String] + -> W.Application +normalDispatch y key' segments env = + yesodRunner y key' murl handler env where - randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - -nonceKey :: String -nonceKey = "_NONCE" - -rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents -rbHelper req = - (map fix1 *** map fix2) <$> iter - where - iter = parseRequestBody lbsSink req - fix1 = bsToChars *** bsToChars - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | Produces a \"compute on demand\" value. The computation will be run once --- it is requested, and then the result will be stored. This will happen only --- once. -iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) -iothunk = - fmap go . liftIO . newMVar . Left - where - go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a - go mvar = do - x <- liftIO $ takeMVar mvar - (x', a) <- go' x - liftIO $ putMVar mvar x' - return a - go' :: Either (Iteratee ByteString IO a) a - -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a) - go' (Right val) = return (Right val, val) - go' (Left comp) = do - val <- comp - return (Right val, val) - --- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time - -> Header - -> (W.ResponseHeader, B.ByteString) -headerToPair getExpires (AddCookie minutes key value) = - ("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie - { setCookieName = B.pack key -- FIXME check for non-ASCII - , setCookieValue = B.pack value -- FIXME check for non-ASCII - , setCookiePath = Just "/" -- FIXME make a config option, or use approot? - , setCookieExpires = Just $ getExpires minutes - , setCookieDomain = Nothing - }) - where - builderToBS = S.concat . L.toChunks . toLazyByteString -headerToPair _ (DeleteCookie key) = - ("Set-Cookie", charsToBs $ - key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair _ (Header key value) = - (fromString key, charsToBs value) - -encodeSession :: CS.Key - -> UTCTime -- ^ expire time - -> B.ByteString -- ^ remote host - -> [(String, String)] -- ^ session - -> B.ByteString -- ^ cookie value -encodeSession key expire rhost session' = - encrypt key $ encode $ SessionCookie expire rhost session' - -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> B.ByteString -- ^ remote host field - -> B.ByteString -- ^ cookie value - -> Maybe [(String, String)] -decodeSession key now rhost encrypted = do - decrypted <- decrypt key encrypted - SessionCookie expire rhost' session' <- - either (const Nothing) Just $ decode decrypted - guard $ expire > now - guard $ rhost' == rhost - return session' - -data SessionCookie = SessionCookie UTCTime B.ByteString [(String, String)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put c - get = do - a <- getTime - b <- Ser.get - c <- Ser.get - return $ SessionCookie a b c - -putTime :: Putter UTCTime -putTime t@(UTCTime d _) = do - put $ toModifiedJulianDay d - let ndt = diffUTCTime t $ UTCTime d 0 - put $ toRational ndt - -getTime :: Get UTCTime -getTime = do - d <- Ser.get - ndt <- Ser.get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 + method = B.unpack $ W.requestMethod env + murl = either (const Nothing) Just $ parsePathSegments (getSite' y) segments + handler = + case murl of + Nothing -> notFound + Just url -> + case handleSite (getSite' y) (yesodRender y) url method of + Nothing -> badMethod + Just h -> h #if TEST diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6581c614..847a6737 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -9,6 +9,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -88,6 +89,9 @@ module Yesod.Handler , HandlerData , ErrorResponse (..) , YesodAppResult (..) + , handlerToYAR + , yarToResponse + , headerToPair #if TEST , handlerTestSuite #endif @@ -119,15 +123,21 @@ import Text.Hamlet import Control.Monad.IO.Peel (MonadPeelIO) import qualified Data.Map as Map +import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteString (ByteString) import Data.Enumerator (Iteratee (..)) +import Network.Wai.Parse (parseHttpAccept) #if TEST import Test.Framework (testGroup, Test) #endif import Yesod.Content +import Data.Maybe (fromMaybe) +import Web.Cookie (SetCookie (..), renderSetCookie) +import Blaze.ByteString.Builder (toByteString) +import Data.Enumerator (run_, ($$)) -- | The type-safe URLs associated with a site argument. type family Route a @@ -251,8 +261,8 @@ data HandlerContents = HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath - | HCRedirect RedirectType String - | HCCreated String + | HCRedirect RedirectType ByteString + | HCCreated ByteString | HCWai W.Response instance Error HandlerContents where @@ -349,7 +359,7 @@ runHandler handler mrender sroute tomr ma tosa = HCSendFile ct fp -> catchIter (sendFile' ct fp) (handleError . toErrorHandler) - HCCreated loc -> do -- FIXME add status201 to WAI + HCCreated loc -> do let hs = Header "Location" loc : headers [] return $ YARPlain (W.Status 201 (S8.pack "Created")) @@ -372,7 +382,7 @@ safeEh er = YesodApp $ \_ _ _ session -> do W.status500 [] typePlain - (toContent "Internal Server Error") + (toContent ("Internal Server Error" :: S.ByteString)) session -- | Redirect to the given route. @@ -384,10 +394,10 @@ redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do r <- getUrlRenderParams - redirectString rt $ r url params + redirectString rt $ S8.pack $ r url params -- | Redirect to the given URL. -redirectString :: RedirectType -> String -> GHandler sub master a +redirectString :: RedirectType -> ByteString -> GHandler sub master a redirectString rt = GHandler . lift . throwError . HCRedirect rt ultDestKey :: String @@ -431,7 +441,7 @@ redirectUltDest :: RedirectType redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt) mdest + maybe (redirect rt def) (redirectString rt . S8.pack) mdest msgKey :: String msgKey = "_MSG" @@ -476,7 +486,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s sendResponseCreated :: Route m -> GHandler s m a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwError $ HCCreated $ r url + GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session @@ -507,13 +517,13 @@ invalidArgs = failure . InvalidArgs ------- Headers -- | Set the cookie on the client. setCookie :: Int -- ^ minutes to timeout - -> String -- ^ key - -> String -- ^ value + -> ByteString -- ^ key + -> ByteString -- ^ value -> GHandler sub master () setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: String -> GHandler sub master () +deleteCookie :: ByteString -> GHandler sub master () deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the @@ -522,13 +532,13 @@ setLanguage :: String -> GHandler sub master () setLanguage = setSession langKey -- | Set an arbitrary response header. -setHeader :: String -> String -> GHandler sub master () +setHeader :: W.ResponseHeader -> ByteString -> GHandler sub master () setHeader a = addHeader . Header a -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: Int -> GHandler s m () -cacheSeconds i = setHeader "Cache-Control" $ concat +cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat [ "max-age=" , show i , ", public" @@ -546,7 +556,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. expiresAt :: UTCTime -> GHandler s m () -expiresAt = setHeader "Expires" . formatRFC1123 +expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 -- | Set a variable in the user's session. -- @@ -606,3 +616,83 @@ handlerTestSuite = testGroup "Yesod.Handler" ] #endif + +handlerToYAR :: (HasReps a, HasReps b) + => m -- ^ master site foundation + -> (Route m -> [(String, String)] -> String) -- ^ url render + -> (ErrorResponse -> GHandler m m a) + -> Request + -> Maybe (Route m) + -> SessionMap + -> GHandler m m b + -> Iteratee ByteString IO YesodAppResult +handlerToYAR y render errorHandler rr murl sessionMap h = + unYesodApp ya eh' rr types sessionMap + where + ya = runHandler h render murl id y id + eh' er = runHandler (errorHandler' er) render murl id y id + types = httpAccept $ reqWaiRequest rr + errorHandler' = localNoCurrent . errorHandler + +type HeaderRenderer = [Header] + -> ContentType + -> SessionMap + -> [(W.ResponseHeader, ByteString)] + +yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response +yarToResponse _ (YARWai a) = a +yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = + case c of + ContentBuilder b mlen -> + let hs' = maybe finalHeaders finalHeaders' mlen + in W.ResponseBuilder s hs' b + ContentFile fp -> W.ResponseFile s finalHeaders fp + ContentEnum e -> + W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders + where + finalHeaders = renderHeaders hs ct sessionFinal + finalHeaders' len = ("Content-Length", S8.pack $ show len) + : finalHeaders + {- + getExpires m = fromIntegral (m * 60) `addUTCTime` now + sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> encodeSession key'' exp' host + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal + hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", charsToBs ct) : hs'' + -} + +httpAccept :: W.Request -> [ContentType] +httpAccept = parseHttpAccept + . fromMaybe S.empty + . lookup "Accept" + . W.requestHeaders + +-- | Convert Header to a key/value pair. +headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time + -> Header + -> (W.ResponseHeader, ByteString) +headerToPair getExpires (AddCookie minutes key value) = + ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie + { setCookieName = key + , setCookieValue = value + , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookieExpires = Just $ getExpires minutes + , setCookieDomain = Nothing + }) +headerToPair _ (DeleteCookie key) = + ( "Set-Cookie" + , key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" + ) +headerToPair _ (Header key value) = (key, value) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 1880260c..0082be82 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -30,6 +30,7 @@ import Text.Hamlet (Hamlet, hamlet, Html) import Data.Monoid (Monoid (..)) import Data.List (nub) +import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -40,6 +41,8 @@ import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +import qualified Network.Wai as W + #if GHC7 #define HAMLET hamlet #else @@ -59,9 +62,9 @@ data ErrorResponse = ----- header stuff -- | Headers to be added to a 'Result'. data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String + AddCookie Int ByteString ByteString + | DeleteCookie ByteString + | Header W.ResponseHeader ByteString deriving (Eq, Show) langKey :: String From e802df12dce7d69bfd1a7dc2daa33bc42163da0a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 Jan 2011 05:58:58 +0200 Subject: [PATCH 040/126] Removed iothunk --- Yesod/Core.hs | 34 +--------------------------------- Yesod/Handler.hs | 38 ++++++++++++++++++++++++++++---------- Yesod/Request.hs | 14 -------------- 3 files changed, 29 insertions(+), 57 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 72cf9a25..f702a2a3 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -598,14 +598,13 @@ parseWaiRequest env session' key' = do langs''' = case lookup langKey gets' of Nothing -> langs'' Just x -> x : langs'' - rbthunk <- iothunk $ rbHelper env nonce <- case (key', lookup nonceKey session') of (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? (_, Just x) -> return x (_, Nothing) -> do g <- newStdGen return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk env langs''' nonce + return $ Request gets' cookies' env langs''' nonce where randomString len = first (map toChar) . sequence' (replicate len (randomR (0, 61))) @@ -622,37 +621,6 @@ parseWaiRequest env session' key' = do nonceKey :: String nonceKey = "_NONCE" -rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents -rbHelper req = - (map fix1 *** map fix2) <$> iter - where - iter = NWP.parseRequestBody NWP.lbsSink req - fix1 = bsToChars *** bsToChars - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | Produces a \"compute on demand\" value. The computation will be run once --- it is requested, and then the result will be stored. This will happen only --- once. --- --- FIXME: remove this function and use a StateT in Handler -iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) -iothunk = - fmap go . liftIO . newMVar . Left - where - go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a - go mvar = do - x <- liftIO $ takeMVar mvar - (x', a) <- go' x - liftIO $ putMVar mvar x' - return a - go' :: Either (Iteratee ByteString IO a) a - -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a) - go' (Right val) = return (Right val, val) - go' (Left comp) = do - val <- comp - return (Right val, val) - -- FIXME don't duplicate sessionName :: ByteString sessionName = "_SESSION" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 847a6737..710547ec 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -138,6 +138,8 @@ import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) import Blaze.ByteString.Builder (toByteString) import Data.Enumerator (run_, ($$)) +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP -- | The type-safe URLs associated with a site argument. type family Route a @@ -233,7 +235,7 @@ type GHInner s m monad = ReaderT (HandlerData s m) ( ErrorT HandlerContents ( WriterT (Endo [Header]) ( - StateT SessionMap ( -- session + StateT (SessionMap, Maybe RequestBodyContents) ( monad )))) @@ -273,8 +275,23 @@ instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> GHandler ask runRequestBody = do - rr <- getRequest - GHandler $ lift $ lift $ lift $ lift $ reqRequestBody rr + (sm, mrbc) <- GHandler $ lift $ lift $ lift get + case mrbc of + Just rbc -> return rbc + Nothing -> do + rr <- waiRequest + rbc <- lift $ rbHelper rr + GHandler $ lift $ lift $ lift $ put (sm, Just rbc) + return rbc + +rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents +rbHelper req = + (map fix1 *** map fix2) <$> iter + where + iter = NWP.parseRequestBody NWP.lbsSink req + fix1 = bsToChars *** bsToChars + fix2 (x, NWP.FileInfo a b c) = + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) -- | Get the sub application argument. getYesodSub :: Monad m => GGHandler sub master m sub @@ -329,13 +346,14 @@ runHandler handler mrender sroute tomr ma tosa = , handlerRender = mrender , handlerToMaster = tomr } - ((contents', headers), finalSession) <- catchIter ( - flip runStateT initSession + let initSession' = (initSession, Nothing) + ((contents', headers), (finalSession, _)) <- catchIter ( + flip runStateT initSession' $ runWriterT $ runErrorT $ flip runReaderT hd $ unGHandler handler - ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) + ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession')) let contents = either id (HCContent W.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession @@ -566,11 +584,11 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k = GHandler . lift . lift . lift . modify . Map.insert k +setSession k = GHandler . lift . lift . lift . modify . first . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: String -> GHandler sub master () -deleteSession = GHandler . lift . lift . lift . modify . Map.delete +deleteSession = GHandler . lift . lift . lift . modify . first . Map.delete -- | Internal use only, not to be confused with 'setHeader'. addHeader :: Header -> GHandler sub master () @@ -601,12 +619,12 @@ localNoCurrent = -- | Lookup for session data. lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) lookupSession n = GHandler $ do - m <- lift $ lift $ lift get + m <- fmap fst $ lift $ lift $ lift get return $ Map.lookup n m -- | Get all session variables. getSession :: GHandler s m SessionMap -getSession = GHandler $ lift $ lift $ lift get +getSession = fmap fst $ GHandler $ lift $ lift $ lift get #if TEST diff --git a/Yesod/Request.hs b/Yesod/Request.hs index d0c1573c..17b2f8d0 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -41,8 +41,6 @@ module Yesod.Request ) where import qualified Network.Wai as W -import Data.ByteString (ByteString) -import Data.Enumerator (Iteratee) import qualified Data.ByteString.Lazy as BL import "transformers" Control.Monad.IO.Class import Control.Monad (liftM) @@ -99,18 +97,6 @@ data FileInfo = FileInfo data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)] - -- | The POST parameters and submitted files. This is stored in an IO - -- thunk, which essentially means it will be computed once at most, but - -- only if requested. This allows avoidance of the potentially costly - -- parsing of POST bodies for pages which do not use them. - -- - -- Additionally, since the request body is not read until needed, you can - -- directly access the 'W.requestBody' record in 'reqWaiRequest' and - -- perform other forms of parsing. For example, when designing a web - -- service, you may want to accept JSON-encoded data. Just be aware that - -- if you do such parsing, the standard POST form parsing functions will - -- no longer work. - , reqRequestBody :: Iteratee ByteString IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [String] From 8596bbc10e7ef82cac60f0d2e7de76453cd62396 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 Jan 2011 06:01:38 +0200 Subject: [PATCH 041/126] nonce is a Maybe --- Yesod/Core.hs | 8 ++++---- Yesod/Request.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index f702a2a3..3771a54e 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -283,7 +283,7 @@ defaultYesodRunner y mkey murl handler req = do let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' yar <- handlerToYAR y (yesodRender y) errorHandler rr murl sessionMap h - let mnonce = Just $ reqNonce rr -- FIXME + let mnonce = reqNonce rr return $ yarToResponse (hr mnonce getExpires host exp') yar where hr mnonce getExpires host exp' hs ct sm = @@ -599,11 +599,11 @@ parseWaiRequest env session' key' = do Nothing -> langs'' Just x -> x : langs'' nonce <- case (key', lookup nonceKey session') of - (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? - (_, Just x) -> return x + (Nothing, _) -> return Nothing + (_, Just x) -> return $ Just x (_, Nothing) -> do g <- newStdGen - return $ fst $ randomString 10 g + return $ Just $ fst $ randomString 10 g return $ Request gets' cookies' env langs''' nonce where randomString len = diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 17b2f8d0..9856d2fe 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -101,7 +101,7 @@ data Request = Request -- | Languages which the client supports. , reqLangs :: [String] -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: String + , reqNonce :: Maybe String } lookup' :: Eq a => a -> [(a, b)] -> [b] From 75687a6b7c5e0545527ae5d8aa511acaf57a62c5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 Jan 2011 06:11:52 +0200 Subject: [PATCH 042/126] Moved newIdent from Widget to Handler --- Yesod/Handler.hs | 46 +++++++++++++++++++++++++++++++++------------- Yesod/Widget.hs | 9 --------- 2 files changed, 33 insertions(+), 22 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 710547ec..cdfd8b02 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -78,6 +78,8 @@ module Yesod.Handler -- ** Messages , setMessage , getMessage + -- ** Misc + , newIdent -- * Internal Yesod , runHandler , YesodApp (..) @@ -138,7 +140,7 @@ import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) import Blaze.ByteString.Builder (toByteString) import Data.Enumerator (run_, ($$)) -import Control.Arrow (first, (***)) +import Control.Arrow (second, (***)) import qualified Network.Wai.Parse as NWP -- | The type-safe URLs associated with a site argument. @@ -231,11 +233,17 @@ instance MonadTrans (GGHandler s m) where type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) +data GHState = GHState + { ghsSession :: SessionMap + , ghsRBC :: Maybe RequestBodyContents + , ghsIdent :: Int + } + type GHInner s m monad = ReaderT (HandlerData s m) ( ErrorT HandlerContents ( WriterT (Endo [Header]) ( - StateT (SessionMap, Maybe RequestBodyContents) ( + StateT GHState ( monad )))) @@ -275,13 +283,13 @@ instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> GHandler ask runRequestBody = do - (sm, mrbc) <- GHandler $ lift $ lift $ lift get - case mrbc of + x <- GHandler $ lift $ lift $ lift get + case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest rbc <- lift $ rbHelper rr - GHandler $ lift $ lift $ lift $ put (sm, Just rbc) + GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } return rbc rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents @@ -346,14 +354,15 @@ runHandler handler mrender sroute tomr ma tosa = , handlerRender = mrender , handlerToMaster = tomr } - let initSession' = (initSession, Nothing) - ((contents', headers), (finalSession, _)) <- catchIter ( - flip runStateT initSession' + let initSession' = GHState initSession Nothing 1 + ((contents', headers), finalSession) <- catchIter ( + fmap (second ghsSession) + $ flip runStateT initSession' $ runWriterT $ runErrorT $ flip runReaderT hd $ unGHandler handler - ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession')) + ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) let contents = either id (HCContent W.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession @@ -584,11 +593,14 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k = GHandler . lift . lift . lift . modify . first . Map.insert k +setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: String -> GHandler sub master () -deleteSession = GHandler . lift . lift . lift . modify . first . Map.delete +deleteSession = GHandler . lift . lift . lift . 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 :: Header -> GHandler sub master () @@ -619,12 +631,12 @@ localNoCurrent = -- | Lookup for session data. lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) lookupSession n = GHandler $ do - m <- fmap fst $ lift $ lift $ lift get + m <- fmap ghsSession $ lift $ lift $ lift get return $ Map.lookup n m -- | Get all session variables. getSession :: GHandler s m SessionMap -getSession = fmap fst $ GHandler $ lift $ lift $ lift get +getSession = fmap ghsSession $ GHandler $ lift $ lift $ lift get #if TEST @@ -714,3 +726,11 @@ headerToPair _ (DeleteCookie key) = , key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" ) headerToPair _ (Header key value) = (key, value) + +-- | Get a unique identifier. +newIdent :: Monad mo => GGHandler sub master mo String +newIdent = GHandler $ lift $ lift $ lift $ do + x <- get + let i' = ghsIdent x + 1 + put x { ghsIdent = i' } + return $ "h" ++ show i' diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index e1f5a009..ac217178 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -33,7 +33,6 @@ module Yesod.Widget , addScriptEither -- * Utilities , extractBody - , newIdent -- FIXME this should be a function on Handler, not Widget -- * Helpers for specific content -- ** Hamlet , hamletToContent @@ -156,14 +155,6 @@ addHtml = GWidget . tell . Body . const addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo () addWidget = id --- | Get a unique identifier. -newIdent :: Monad mo => GGWidget sub master mo String -newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do - i <- get - let i' = i + 1 - put i' - return $ "w" ++ show i' - -- | Add some raw CSS to the style tag. addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m () addCassius = GWidget . lift . lift . lift . lift . tell . Just From e41134a1834a933bd6e3e402fbb5694b5932a12d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 Jan 2011 06:17:22 +0200 Subject: [PATCH 043/126] Yesod.Internal.Session --- Yesod/Core.hs | 65 +++++---------------------------------- Yesod/Dispatch.hs | 3 -- Yesod/Internal.hs | 10 ++++++ Yesod/Internal/Session.hs | 53 +++++++++++++++++++++++++++++++ yesod-core.cabal | 1 + 5 files changed, 72 insertions(+), 60 deletions(-) create mode 100644 Yesod/Internal/Session.hs diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 3771a54e..8ddfad1a 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -39,6 +39,7 @@ import Yesod.Widget import Yesod.Request import qualified Network.Wai as W import Yesod.Internal +import Yesod.Internal.Session import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import qualified Data.ByteString as S @@ -58,15 +59,9 @@ import Data.Maybe (fromMaybe) import System.Random (randomR, newStdGen) import Control.Arrow (first, (***)) import qualified Network.Wai.Parse as NWP -import Data.ByteString (ByteString) -import Data.Enumerator (Iteratee, ($$), run_) -import Control.Concurrent.MVar (MVar, takeMVar, putMVar, newMVar) import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) -import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) +import Web.Cookie (parseCookies) import qualified Data.Map as Map -import Control.Monad (guard) -import Data.Serialize import Data.Time #if TEST @@ -248,6 +243,12 @@ class Eq (Route a) => Yesod a where yesodRunner :: YesodSite a => a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application yesodRunner = defaultYesodRunner +defaultYesodRunner :: (Yesod a, YesodSite a) + => a + -> Maybe CS.Key + -> Maybe (Route a) + -> GHandler a a ChooseRep + -> W.Application defaultYesodRunner y mkey murl handler req = do now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -617,53 +618,3 @@ parseWaiRequest env session' key' = do | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52 - -nonceKey :: String -nonceKey = "_NONCE" - --- FIXME don't duplicate -sessionName :: ByteString -sessionName = "_SESSION" - -encodeSession :: CS.Key - -> UTCTime -- ^ expire time - -> ByteString -- ^ remote host - -> [(String, String)] -- ^ session - -> ByteString -- ^ cookie value -encodeSession key expire rhost session' = - CS.encrypt key $ encode $ SessionCookie expire rhost session' - -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> ByteString -- ^ remote host field - -> ByteString -- ^ cookie value - -> Maybe [(String, String)] -decodeSession key now rhost encrypted = do - decrypted <- CS.decrypt key encrypted - SessionCookie expire rhost' session' <- - either (const Nothing) Just $ decode decrypted - guard $ expire > now - guard $ rhost' == rhost - return session' - -data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put c - get = do - a <- getTime - b <- get - c <- get - return $ SessionCookie a b c - -putTime :: Putter UTCTime -putTime t@(UTCTime d _) = do - put $ toModifiedJulianDay d - let ndt = diffUTCTime t $ UTCTime d 0 - put $ toRational ndt - -getTime :: Get UTCTime -getTime = do - d <- get - ndt <- get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5cdb4768..c397f8e3 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -226,9 +226,6 @@ mkToMasterArg ps fname = do e = rsg `AppE` e' return $ LamE xps e -sessionName :: B.ByteString -sessionName = "_SESSION" - -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes three -- middlewares: GZIP compression, JSON-P and path cleaning. This is the diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 0082be82..f3e6ee30 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses @@ -24,6 +25,9 @@ module Yesod.Internal , bsToChars , lbsToChars , charsToBs + -- * Names + , sessionName + , nonceKey ) where import Text.Hamlet (Hamlet, hamlet, Html) @@ -106,3 +110,9 @@ bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode charsToBs :: String -> S.ByteString charsToBs = T.encodeUtf8 . T.pack + +nonceKey :: String +nonceKey = "_NONCE" + +sessionName :: ByteString +sessionName = "_SESSION" diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs new file mode 100644 index 00000000..cb87d96c --- /dev/null +++ b/Yesod/Internal/Session.hs @@ -0,0 +1,53 @@ +module Yesod.Internal.Session + ( encodeSession + , decodeSession + ) where + +import qualified Web.ClientSession as CS +import Data.Serialize +import Data.Time +import Data.ByteString (ByteString) +import Control.Monad (guard) + +encodeSession :: CS.Key + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(String, String)] -- ^ session + -> ByteString -- ^ cookie value +encodeSession key expire rhost session' = + CS.encrypt key $ encode $ SessionCookie expire rhost session' + +decodeSession :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> Maybe [(String, String)] +decodeSession key now rhost encrypted = do + decrypted <- CS.decrypt key encrypted + SessionCookie expire rhost' session' <- + either (const Nothing) Just $ decode decrypted + guard $ expire > now + guard $ rhost' == rhost + return session' + +data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] + deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = putTime a >> put b >> put c + get = do + a <- getTime + b <- get + c <- get + return $ SessionCookie a b c + +putTime :: Putter UTCTime +putTime t@(UTCTime d _) = do + put $ toModifiedJulianDay d + let ndt = diffUTCTime t $ UTCTime d 0 + put $ toRational ndt + +getTime :: Get UTCTime +getTime = do + d <- get + ndt <- get + return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 diff --git a/yesod-core.cabal b/yesod-core.cabal index 2979f520..db06e436 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -55,6 +55,7 @@ library Yesod.Request Yesod.Widget other-modules: Yesod.Internal + Yesod.Internal.Session Paths_yesod_core ghc-options: -Wall From fddfd9bcf1a3b77cd7e92023efb67fd7dcfab683 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 Jan 2011 06:22:45 +0200 Subject: [PATCH 044/126] Yesod.Internal.Request --- Yesod/Core.hs | 45 +------------------------------- Yesod/Internal/Request.hs | 55 +++++++++++++++++++++++++++++++++++++++ Yesod/Request.hs | 3 +-- yesod-core.cabal | 1 + 4 files changed, 58 insertions(+), 46 deletions(-) create mode 100644 Yesod/Internal/Request.hs diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 8ddfad1a..e098aadf 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -40,6 +40,7 @@ import Yesod.Request import qualified Network.Wai as W import Yesod.Internal import Yesod.Internal.Session +import Yesod.Internal.Request import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import qualified Data.ByteString as S @@ -56,9 +57,6 @@ import Text.Blaze (preEscapedLazyText) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Maybe (fromMaybe) -import System.Random (randomR, newStdGen) -import Control.Arrow (first, (***)) -import qualified Network.Wai.Parse as NWP import Control.Monad.IO.Class (liftIO) import Web.Cookie (parseCookies) import qualified Data.Map as Map @@ -577,44 +575,3 @@ yesodRender y u qs = (urlRenderOverride y u) where (ps, qs') = formatPathSegments (getSite' y) u - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> Maybe a - -> IO Request -parseWaiRequest env session' key' = do - let gets' = map (bsToChars *** bsToChars) - $ NWP.parseQueryString $ W.queryString env - let reqCookie = fromMaybe S.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang - langs' = case lookup langKey session' of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey cookies' of - Nothing -> langs' - Just x -> x : langs' - langs''' = case lookup langKey gets' of - Nothing -> langs'' - Just x -> x : langs'' - nonce <- case (key', lookup nonceKey session') of - (Nothing, _) -> return Nothing - (_, Just x) -> return $ Just x - (_, Nothing) -> do - g <- newStdGen - return $ Just $ fst $ randomString 10 g - return $ Request gets' cookies' env langs''' nonce - where - randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs new file mode 100644 index 00000000..08a4a4e0 --- /dev/null +++ b/Yesod/Internal/Request.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Internal.Request + ( parseWaiRequest + ) where + +import Yesod.Request +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP +import Data.Maybe (fromMaybe) +import Yesod.Internal +import qualified Network.Wai as W +import qualified Data.ByteString as S +import System.Random (randomR, newStdGen) +import Web.Cookie (parseCookies) + +parseWaiRequest :: W.Request + -> [(String, String)] -- ^ session + -> Maybe a + -> IO Request +parseWaiRequest env session' key' = do + let gets' = map (bsToChars *** bsToChars) + $ NWP.parseQueryString $ W.queryString env + let reqCookie = fromMaybe S.empty $ lookup "Cookie" + $ W.requestHeaders env + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie + acceptLang = lookup "Accept-Language" $ W.requestHeaders env + langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup langKey session' of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey cookies' of + Nothing -> langs' + Just x -> x : langs' + langs''' = case lookup langKey gets' of + Nothing -> langs'' + Just x -> x : langs'' + nonce <- case (key', lookup nonceKey session') of + (Nothing, _) -> return Nothing + (_, Just x) -> return $ Just x + (_, Nothing) -> do + g <- newStdGen + return $ Just $ fst $ randomString 10 g + return $ Request gets' cookies' env langs''' nonce + where + randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 9856d2fe..cd5717e0 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -71,8 +71,7 @@ class Monad m => RequestReader m where -- -- * Accept-Language HTTP header. -- --- This is handled by the parseWaiRequest function in Yesod.Dispatch (not --- exposed). +-- This is handled by parseWaiRequest (not exposed). languages :: RequestReader m => m [String] languages = reqLangs `liftM` getRequest diff --git a/yesod-core.cabal b/yesod-core.cabal index db06e436..c43720f0 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -56,6 +56,7 @@ library Yesod.Widget other-modules: Yesod.Internal Yesod.Internal.Session + Yesod.Internal.Request Paths_yesod_core ghc-options: -Wall From ee3fc92111459cb05ff6253bbe3c04269ba0f5d7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 26 Jan 2011 00:21:32 +0200 Subject: [PATCH 045/126] Beginning of modifications to dispatch code for more powerful subsites --- Yesod/Core.hs | 67 ++++++++++++++--------------------------------- Yesod/Dispatch.hs | 61 ++++++++++++++++++++++++++++++++++-------- Yesod/Handler.hs | 42 +++++++++++++++++++++++++++++ Yesod/Widget.hs | 22 +--------------- 4 files changed, 113 insertions(+), 79 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index e098aadf..8de5e7e9 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -17,7 +17,6 @@ module Yesod.Core -- * Utitlities , maybeAuthorized , widgetToPageContent - , redirectToPost -- * Defaults , defaultErrorHandler -- * Data types @@ -46,6 +45,7 @@ import qualified Web.ClientSession as CS import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State hiding (get, put) @@ -77,10 +77,7 @@ import qualified Data.Text.Encoding #define HAMLET $hamlet #endif -{- FIXME -class YesodDispatcher y where - dispatchSubsite :: y -> Key -> [String] -> Maybe Application --} +-- FIXME ditch the whole Site thing and just have render and dispatch? -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -88,6 +85,7 @@ class Eq (Route y) => YesodSite y where getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) getSite' _ = getSite + dispatchToSubsite :: y -> Maybe CS.Key -> [String] -> Maybe W.Application type Method = String @@ -95,6 +93,8 @@ type Method = String -- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + dispatchSubsite :: y -> Maybe CS.Key -> [String] -> (y -> s) -> W.Application + dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME" -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. @@ -156,8 +156,6 @@ class Eq (Route a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - -- - -- FIXME make this a part of the Yesod middlewares isAuthorized :: Route a -> Bool -- ^ is this a write request? -> GHandler s a AuthResult @@ -485,6 +483,21 @@ $maybe j <- jscript |] return $ PageContent title head'' body +yesodVersion :: String +yesodVersion = showVersion Paths_yesod_core.version + +yesodRender :: (Yesod y, YesodSite y) + => y + -> Route y + -> [(String, String)] + -> String +yesodRender y u qs = + S8.unpack $ fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') + (urlRenderOverride y u) + where + (ps, qs') = formatPathSegments (getSite' y) u + #if TEST coreTestSuite :: Test coreTestSuite = testGroup "Yesod.Yesod" @@ -535,43 +548,3 @@ caseUtf8JoinPath :: Assertion caseUtf8JoinPath = do "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] #endif - --- | Redirect to a POST resource. --- --- This is not technically a redirect; instead, it returns an HTML page with a --- 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 :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -\<!DOCTYPE html> - -<html> - <head> - <title>Redirecting... - <body onload="document.getElementById('form').submit()"> - <form id="form" method="post" action="@{dest}"> - <noscript> - <p>Javascript has been disabled; please click on the button below to be redirected. - <input type="submit" value="Continue"> -|] >>= sendResponse - -yesodVersion :: String -yesodVersion = showVersion Paths_yesod_core.version - -yesodRender :: (Yesod y, YesodSite y) - => y - -> Route y - -> [(String, String)] - -> String -yesodRender y u qs = - S8.unpack $ fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - where - (ps, qs') = formatPathSegments (getSite' y) u diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c397f8e3..79b4cb5f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -70,7 +70,7 @@ import System.Random (randomR, newStdGen) import qualified Data.Map as Map -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Data.Enumerator (($$), run_, Iteratee) import Control.Monad.IO.Class (liftIO) @@ -144,7 +144,8 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites + th' <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites + let th = map fst th' w' <- createRoutes th let routesName = mkName $ name ++ "Route" let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] @@ -170,18 +171,58 @@ mkYesodGeneral name args clazzes isSub res = do if isSub then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") + subsiteClauses <- catMaybes <$> mapM sc th' + nothing <- [|Nothing|] + let otherMethods = + if isSub + then [] + else [ FunD (mkName "dispatchToSubsite") + (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) + ] let y = InstanceD ctx ytyp - [ FunD (mkName yfunc) [Clause [] (NormalB site') []] - ] + $ FunD (mkName yfunc) [Clause [] (NormalB site') []] + : otherMethods return ([w, x], [y]) + where + sc ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + master <- newName "master" + mkey <- newName "mkey" + just <- [|Just|] + (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE $ mkName toSub) + ds <- [|dispatchSubsite|] + let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest + fmap' <- [|(<$>)|] + let body = InfixE (Just body') fmap' $ Just tma' + return $ Just $ Clause + [ VarP master + , VarP mkey + , pat' + ] (NormalB body) [] + sc _ = return Nothing + mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp) + mkPat' (MultiPiece _:_) _ = error "MultiPiece not allowed as part of a subsite" + mkPat' (StaticPiece s:rest) tma = do + (x, tma, rest') <- mkPat' rest tma + let sp = LitP $ StringL s + return (InfixP sp (mkName ":") x, tma, rest') + mkPat' (SinglePiece s:rest) tma = do + fsp <- [|either (const Nothing) Just . fromSinglePiece|] + v <- newName $ "var" ++ s + be <- [|(<*>)|] + let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v + (x, tma'', rest) <- mkPat' rest tma' + return (InfixP (VarP v) (mkName ":") x, tma'', rest) + mkPat' [] parse = do + rest <- newName "rest" + return (VarP rest, parse, VarE rest) isStatic :: Piece -> Bool isStatic StaticPiece{} = True isStatic _ = False -thResourceFromResource :: Type -> Resource -> Q THResource +thResourceFromResource :: Type -> Resource -> Q (THResource, Maybe String) thResourceFromResource _ (Resource n ps atts) - | all (all isUpper) atts = return (n, Simple ps atts) + | all (all isUpper) atts = return ((n, Simple ps atts), Nothing) thResourceFromResource master (Resource n ps [stype, toSubArg]) -- static route to subsite = do @@ -201,14 +242,14 @@ thResourceFromResource master (Resource n ps [stype, toSubArg]) dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] let dispatch = dispatch' `AppE` gss' tmg <- mkToMasterArg ps toSubArg - return (n, SubSite + return ((n, SubSite { ssType = ConT ''Route `AppT` stype' , ssParse = parse , ssRender = render , ssDispatch = dispatch , ssToMasterArg = tmg , ssPieces = ps - }) + }), Just toSubArg) thResourceFromResource _ (Resource n _ _) = @@ -244,8 +285,6 @@ toWaiAppPlain a = do key' <- encryptKey a return $ toWaiApp' a key' -dispatchPieces _ _ _ = Nothing -- FIXME - toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key @@ -256,7 +295,7 @@ toWaiApp' y key' env = do "":x -> x x -> x liftIO $ print (W.pathInfo env, segments) - case dispatchPieces y key' segments of + case dispatchToSubsite y key' segments of Nothing -> case cleanPath y segments of Nothing -> normalDispatch y key' segments env diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index cdfd8b02..e6d94dbb 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -10,6 +10,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -43,6 +44,7 @@ module Yesod.Handler , redirect , redirectParams , redirectString + , redirectToPost -- ** Errors , notFound , badMethod @@ -78,6 +80,10 @@ module Yesod.Handler -- ** Messages , setMessage , getMessage + -- * Helpers for specific content + -- ** Hamlet + , hamletToContent + , hamletToRepHtml -- ** Misc , newIdent -- * Internal Yesod @@ -734,3 +740,39 @@ newIdent = GHandler $ lift $ lift $ lift $ do let i' = ghsIdent x + 1 put x { ghsIdent = i' } return $ "h" ++ show i' + +-- | Redirect to a POST resource. +-- +-- This is not technically a redirect; instead, it returns an HTML page with a +-- 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 :: Route master -> GHandler sub master a +redirectToPost dest = hamletToRepHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +\<!DOCTYPE html> + +<html> + <head> + <title>Redirecting... + <body onload="document.getElementById('form').submit()"> + <form id="form" method="post" action="@{dest}"> + <noscript> + <p>Javascript has been disabled; please click on the button below to be redirected. + <input type="submit" value="Continue"> +|] >>= sendResponse + +-- | Converts the given Hamlet template into 'Content', which can be used in a +-- Yesod 'Response'. +hamletToContent :: Hamlet (Route master) -> GHandler sub master Content +hamletToContent h = do + render <- getUrlRenderParams + return $ toContent $ h render + +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml +hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ac217178..ae4736c9 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -33,10 +33,6 @@ module Yesod.Widget , addScriptEither -- * Utilities , extractBody - -- * Helpers for specific content - -- ** Hamlet - , hamletToContent - , hamletToRepHtml ) where import Data.Monoid @@ -46,14 +42,11 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Yesod.Handler - ( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod - , getUrlRenderParams - ) + (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans (lift)) import Yesod.Internal -import Yesod.Content (RepHtml (RepHtml), Content, toContent) import Control.Monad (liftM) import Control.Monad.IO.Peel (MonadPeelIO) @@ -204,16 +197,3 @@ data PageContent url = PageContent , pageHead :: Hamlet url , pageBody :: Hamlet url } - --- FIXME these ideally belong somewhere else, I'm just not sure where - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ h render - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent From b3ae5e6149e122b6003049796e4e5652d0420685 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 26 Jan 2011 00:28:27 +0200 Subject: [PATCH 046/126] Works with subsites with arguments --- Yesod/Core.hs | 2 +- Yesod/Dispatch.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 8de5e7e9..53a0bed5 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -93,7 +93,7 @@ type Method = String -- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - dispatchSubsite :: y -> Maybe CS.Key -> [String] -> (y -> s) -> W.Application + dispatchSubsite :: y -> Maybe CS.Key -> [String] -> s -> W.Application dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME" -- | Define settings for a Yesod applications. The only required setting is diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 79b4cb5f..7f8a4a85 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -188,7 +188,7 @@ mkYesodGeneral name args clazzes isSub res = do master <- newName "master" mkey <- newName "mkey" just <- [|Just|] - (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE $ mkName toSub) + (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) ds <- [|dispatchSubsite|] let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest fmap' <- [|(<$>)|] @@ -260,12 +260,12 @@ mkToMasterArg ps fname = do let nargs = length $ filter (not.isStatic) ps f = VarE $ mkName fname args <- sequence $ take nargs $ repeat $ newName "x" - rsg <- [| runSubsiteGetter|] + rsg <- [|error "runSubsiteGetter"|] let xps = map VarP args xes = map VarE args e' = foldl (\x y -> x `AppE` y) f xes e = rsg `AppE` e' - return $ LamE xps e + return $ rsg -- FIXME LamE xps e -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes three From 93c724ba7d56af8f85fa83af61c2fb46ee063f0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 26 Jan 2011 01:03:22 +0200 Subject: [PATCH 047/126] dispatchSubsite is now working --- Yesod/Core.hs | 11 +++++++++-- Yesod/Dispatch.hs | 28 ++++++++++++++++++++++++++-- helloworld.hs | 27 +++++++++++++++++++++++++++ 3 files changed, 62 insertions(+), 4 deletions(-) create mode 100644 helloworld.hs diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 53a0bed5..027a27f7 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -93,8 +93,15 @@ type Method = String -- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - dispatchSubsite :: y -> Maybe CS.Key -> [String] -> s -> W.Application - dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME" + getSubSite' :: s -> y -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSubSite' _ _ = getSubSite + dispatchSubsite :: (Yesod y, YesodSite y) + => y + -> Maybe CS.Key + -> [String] + -> (Route s -> Route y) + -> s + -> W.Application -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 7f8a4a85..cfc3e8a6 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -173,9 +173,10 @@ mkYesodGeneral name args clazzes isSub res = do else ([], ConT ''YesodSite `AppT` arg, "getSite") subsiteClauses <- catMaybes <$> mapM sc th' nothing <- [|Nothing|] + dds <- [|defaultDispatchSubsite|] let otherMethods = if isSub - then [] + then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []]] else [ FunD (mkName "dispatchToSubsite") (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) ] @@ -190,7 +191,9 @@ mkYesodGeneral name args clazzes isSub res = do just <- [|Just|] (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) ds <- [|dispatchSubsite|] - let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest + -- let toMaster = ConE (mkName "SubsiteR") + toMaster <- [|error "FIXME toMaster"|] + let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster fmap' <- [|(<$>)|] let body = InfixE (Just body') fmap' $ Just tma' return $ Just $ Clause @@ -331,6 +334,27 @@ normalDispatch y key' segments env = Nothing -> badMethod Just h -> h +-- FIXME address sub-subsites +defaultDispatchSubsite + :: (Yesod m, YesodSite m, YesodSubSite s m) + => m -> Maybe Key -> [String] + -> (Route s -> Route m) + -> s + -> W.Application +defaultDispatchSubsite y key' segments toMasterRoute s env = + yesodRunner y key' (fmap toMasterRoute murl) handler env + where + method = B.unpack $ W.requestMethod env + murl = either (const Nothing) Just $ parsePathSegments (getSubSite' s y) segments + handler = toMasterHandlerMaybe toMasterRoute (const s) murl handler' + handler' = + case murl of + Nothing -> notFound + Just url -> + case handleSite (getSubSite' s y) (yesodRender y . toMasterRoute) url method of + Nothing -> badMethod + Just h -> h + #if TEST dispatchTestSuite :: Test diff --git a/helloworld.hs b/helloworld.hs new file mode 100644 index 00000000..29d37b6a --- /dev/null +++ b/helloworld.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +import Yesod.Core +import Yesod.Dispatch +import Yesod.Content +import Yesod.Handler +import Network.Wai.Handler.Warp (run) + +data Subsite = Subsite String + +mkYesodSub "Subsite" [] [$parseRoutes| +/ SubRootR GET +|] + +getSubRootR :: GHandler Subsite m RepPlain +getSubRootR = do + Subsite s <- getYesodSub + return $ RepPlain $ toContent $ "Hello Sub World: " ++ s + +data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } +mkYesod "HelloWorld" [$parseRoutes| +/ RootR GET +/subsite/#String SubsiteR Subsite getSubsite +|] +instance Yesod HelloWorld where approot _ = "" +getRootR = return $ RepPlain "Hello World" +main = toWaiApp (HelloWorld Subsite) >>= run 3000 From 7f51c7fd2072604f0b0487af88156549901eee30 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 27 Jan 2011 20:02:51 +0200 Subject: [PATCH 048/126] Fixed some TH code for subsites --- Yesod/Core.hs | 8 ++++++++ Yesod/Dispatch.hs | 43 ++++++++++++++++++++++++++----------------- helloworld.hs | 5 ++++- 3 files changed, 38 insertions(+), 18 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 027a27f7..33ccafdb 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -102,6 +102,14 @@ class Eq (Route s) => YesodSubSite s y where -> (Route s -> Route y) -> s -> W.Application + dispatchToSubSubsite + :: (Yesod y, YesodSite y) + => y + -> Maybe CS.Key + -> [String] + -> (Route s -> Route y) + -> s + -> Maybe W.Application -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index cfc3e8a6..df341353 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -172,11 +172,15 @@ mkYesodGeneral name args clazzes isSub res = do then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") subsiteClauses <- catMaybes <$> mapM sc th' + let subSubsiteClauses = [] -- FIXME subSubsiteClauses nothing <- [|Nothing|] dds <- [|defaultDispatchSubsite|] let otherMethods = if isSub - then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []]] + then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []] + , FunD (mkName "dispatchToSubSubsite") + (subSubsiteClauses ++ [Clause [WildP, WildP, WildP, WildP, WildP] (NormalB nothing) []]) + ] else [ FunD (mkName "dispatchToSubsite") (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) ] @@ -189,10 +193,13 @@ mkYesodGeneral name args clazzes isSub res = do master <- newName "master" mkey <- newName "mkey" just <- [|Just|] - (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) + (pat', tma', rest, toMaster) + <- mkPat' pieces + (ConE $ mkName constr) + $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) ds <- [|dispatchSubsite|] - -- let toMaster = ConE (mkName "SubsiteR") - toMaster <- [|error "FIXME toMaster"|] + goodParse <- (`AppE` tma') <$> [|isJust|] + tma'' <- (`AppE` tma') <$> [|fromJust|] let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster fmap' <- [|(<$>)|] let body = InfixE (Just body') fmap' $ Just tma' @@ -200,24 +207,25 @@ mkYesodGeneral name args clazzes isSub res = do [ VarP master , VarP mkey , pat' - ] (NormalB body) [] + ] (GuardedB [(NormalG goodParse, body)]) [] sc _ = return Nothing - mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp) - mkPat' (MultiPiece _:_) _ = error "MultiPiece not allowed as part of a subsite" - mkPat' (StaticPiece s:rest) tma = do - (x, tma, rest') <- mkPat' rest tma + mkPat' :: [Piece] -> Exp -> Exp -> Q (Pat, Exp, Exp, Exp) + mkPat' (MultiPiece _:_) _ _ = error "MultiPiece not allowed as part of a subsite" + mkPat' (StaticPiece s:rest) toMaster tma = do + (x, tma, rest', toMaster') <- mkPat' rest toMaster tma let sp = LitP $ StringL s - return (InfixP sp (mkName ":") x, tma, rest') - mkPat' (SinglePiece s:rest) tma = do + return (InfixP sp (mkName ":") x, tma, rest', toMaster') + mkPat' (SinglePiece s:rest) toMaster tma = do fsp <- [|either (const Nothing) Just . fromSinglePiece|] v <- newName $ "var" ++ s be <- [|(<*>)|] let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v - (x, tma'', rest) <- mkPat' rest tma' - return (InfixP (VarP v) (mkName ":") x, tma'', rest) - mkPat' [] parse = do + let toMaster' = toMaster `AppE` VarE v + (x, tma'', rest, toMaster'') <- mkPat' rest toMaster' tma' + return (InfixP (VarP v) (mkName ":") x, tma'', rest, toMaster'') + mkPat' [] toMaster parse = do rest <- newName "rest" - return (VarP rest, parse, VarE rest) + return (VarP rest, parse, VarE rest, toMaster) isStatic :: Piece -> Bool isStatic StaticPiece{} = True @@ -334,7 +342,6 @@ normalDispatch y key' segments env = Nothing -> badMethod Just h -> h --- FIXME address sub-subsites defaultDispatchSubsite :: (Yesod m, YesodSite m, YesodSubSite s m) => m -> Maybe Key -> [String] @@ -342,7 +349,9 @@ defaultDispatchSubsite -> s -> W.Application defaultDispatchSubsite y key' segments toMasterRoute s env = - yesodRunner y key' (fmap toMasterRoute murl) handler env + case dispatchToSubSubsite y key' segments toMasterRoute s of + Just app -> app env + Nothing -> yesodRunner y key' (fmap toMasterRoute murl) handler env where method = B.unpack $ W.requestMethod env murl = either (const Nothing) Just $ parsePathSegments (getSubSite' s y) segments diff --git a/helloworld.hs b/helloworld.hs index 29d37b6a..fd4e15da 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} import Yesod.Core import Yesod.Dispatch import Yesod.Content @@ -15,7 +16,9 @@ mkYesodSub "Subsite" [] [$parseRoutes| getSubRootR :: GHandler Subsite m RepPlain getSubRootR = do Subsite s <- getYesodSub - return $ RepPlain $ toContent $ "Hello Sub World: " ++ s + tm <- getRouteToMaster + render <- getUrlRender + return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR) data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } mkYesod "HelloWorld" [$parseRoutes| From 21bdab3602b34daebeb408f199eb72f6a3537fa4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 09:37:14 +0200 Subject: [PATCH 049/126] Lots of cases --- Yesod/Core.hs | 37 +++--- Yesod/Dispatch.hs | 281 ++++++++++++++++++++++++++++++++++------------ helloworld.hs | 5 +- 3 files changed, 228 insertions(+), 95 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 33ccafdb..fbd823a2 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -9,8 +9,9 @@ module Yesod.Core ( -- * Type classes Yesod (..) - , YesodSite (..) + , YesodDispatch (..) , YesodSubSite (..) + , RenderRoute (..) -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -45,7 +46,6 @@ import qualified Web.ClientSession as CS import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State hiding (get, put) @@ -77,25 +77,19 @@ import qualified Data.Text.Encoding #define HAMLET $hamlet #endif --- FIXME ditch the whole Site thing and just have render and dispatch? +class Eq u => RenderRoute u where + renderRoute :: u -> ([String], [(String, String)]) +-- FIXME unify YesodSite and YesodSubSite -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. -class Eq (Route y) => YesodSite y where - getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) - getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) - getSite' _ = getSite - dispatchToSubsite :: y -> Maybe CS.Key -> [String] -> Maybe W.Application - -type Method = String +class RenderRoute (Route y) => YesodDispatch y where + yesodDispatch :: y -> Maybe CS.Key -> [String] -> Maybe W.Application -- | Same as 'YesodSite', but for subsites. Once again, users should not need -- to deal with it directly, as mkYesodSub creates instances appropriately. -class Eq (Route s) => YesodSubSite s y where - getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSubSite' :: s -> y -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSubSite' _ _ = getSubSite - dispatchSubsite :: (Yesod y, YesodSite y) +class (RenderRoute (Route s)) => YesodSubSite s y where + dispatchSubsite :: (Yesod y) => y -> Maybe CS.Key -> [String] @@ -103,17 +97,18 @@ class Eq (Route s) => YesodSubSite s y where -> s -> W.Application dispatchToSubSubsite - :: (Yesod y, YesodSite y) + :: (Yesod y) => y -> Maybe CS.Key -> [String] -> (Route s -> Route y) -> s -> Maybe W.Application + dispatchSubLocal :: y -> Maybe CS.Key -> [String] -> (Route s -> Route y) -> s -> Maybe W.Application -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. -class Eq (Route a) => Yesod a where +class RenderRoute (Route a) => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- @@ -251,10 +246,10 @@ class Eq (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True - yesodRunner :: YesodSite a => a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application + yesodRunner :: a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application yesodRunner = defaultYesodRunner -defaultYesodRunner :: (Yesod a, YesodSite a) +defaultYesodRunner :: Yesod a => a -> Maybe CS.Key -> Maybe (Route a) @@ -501,7 +496,7 @@ $maybe j <- jscript yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version -yesodRender :: (Yesod y, YesodSite y) +yesodRender :: Yesod y => y -> Route y -> [(String, String)] @@ -511,7 +506,7 @@ yesodRender y u qs = (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) where - (ps, qs') = formatPathSegments (getSite' y) u + (ps, qs') = renderRoute u #if TEST coreTestSuite :: Test diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index df341353..2475b436 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -56,7 +56,7 @@ import Control.Monad import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS -import Data.Char (isUpper) +import Data.Char (isUpper, toLower) import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) import Data.Serialize @@ -64,7 +64,7 @@ import qualified Data.Serialize as Ser import Network.Wai.Parse hiding (FileInfo) import qualified Network.Wai.Parse as NWP import Data.String (fromString) -import Web.Routes +import Web.Routes (decodePathInfo) import Control.Arrow (first) import System.Random (randomR, newStdGen) @@ -73,6 +73,7 @@ import qualified Data.Map as Map import Control.Applicative ((<$>), (<*>)) import Data.Enumerator (($$), run_, Iteratee) import Control.Monad.IO.Class (liftIO) +import Data.List (foldl') #if TEST import Test.Framework (testGroup, Test) @@ -134,8 +135,8 @@ mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True where (name':rest) = words name -mkYesodGeneral :: String -- ^ argument name - -> [String] -- ^ parameters for site argument +mkYesodGeneral :: String -- ^ foundation name + -> [String] -- ^ parameters for foundation -> Cxt -- ^ classes -> Bool -- ^ is subsite? -> [Resource] @@ -144,20 +145,19 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - th' <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites + th' <- mapM (thResourceFromResource arg) res let th = map fst th' w' <- createRoutes th let routesName = mkName $ name ++ "Route" let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] let x = TySynInstD ''Route [arg] $ ConT routesName - parse' <- createParse th - parse'' <- newName "parse" - let parse = LetE [FunD parse'' parse'] $ VarE parse'' - render' <- createRender th render'' <- newName "render" let render = LetE [FunD render'' render'] $ VarE render'' + let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName) + [ FunD (mkName "renderRoute") render' + ] tmh <- [|toMasterHandlerDyn|] modMaster <- [|fmap chooseRep|] @@ -165,13 +165,16 @@ mkYesodGeneral name args clazzes isSub res = do dispatch'' <- newName "dispatch" let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' - site <- [|Site|] - let site' = site `AppE` dispatch `AppE` render `AppE` parse + {- FIXME let (ctx, ytyp, yfunc) = if isSub then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") - subsiteClauses <- catMaybes <$> mapM sc th' + -} + let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th' + yd <- mkYesodDispatch' sortedRes + localClauses <- catMaybes <$> mapM mkDispatchLocal th' + subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th' let subSubsiteClauses = [] -- FIXME subSubsiteClauses nothing <- [|Nothing|] dds <- [|defaultDispatchSubsite|] @@ -184,37 +187,186 @@ mkYesodGeneral name args clazzes isSub res = do else [ FunD (mkName "dispatchToSubsite") (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) ] - let y = InstanceD ctx ytyp + let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master")) + [ + ] + mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] + let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp $ FunD (mkName yfunc) [Clause [] (NormalB site') []] - : otherMethods - return ([w, x], [y]) + : otherMethods -} + return ([w, x, x'], [y]) + +isSubSite ((_, SubSite{}), _) = True +isSubSite _ = False + +mkYesodDispatch' sortedRes = do + master <- newName "master" + mkey <- newName "mkey" + segments <- newName "segments" + nothing <- [|Nothing|] + body <- foldM (go master mkey segments) nothing sortedRes + return $ Clause + [VarP master, VarP mkey, VarP segments] + (NormalB body) + [] where - sc ((constr, SubSite { ssPieces = pieces }), Just toSub) = do - master <- newName "master" - mkey <- newName "mkey" + go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = return onFail + go master mkey segments onFail ((constr, Simple pieces methods), Nothing) = do + test <- mkSimpleExp segments pieces id (master, mkey, constr, methods) just <- [|Just|] - (pat', tma', rest, toMaster) - <- mkPat' pieces - (ConE $ mkName constr) - $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) - ds <- [|dispatchSubsite|] - goodParse <- (`AppE` tma') <$> [|isJust|] - tma'' <- (`AppE` tma') <$> [|fromJust|] - let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster - fmap' <- [|(<$>)|] - let body = InfixE (Just body') fmap' $ Just tma' - return $ Just $ Clause - [ VarP master - , VarP mkey - , pat' - ] (GuardedB [(NormalG goodParse, body)]) [] - sc _ = return Nothing + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] + ] + +mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do + just <- [|Just|] + nothing <- [|Nothing|] + onSuccess <- newName "onSuccess" + req <- newName "req" + badMethod' <- [|badMethod|] + rm <- [|W.requestMethod|] + let caseExp = rm `AppE` VarE req + yr <- [|yesodRunner|] + cr <- [|fmap chooseRep|] + let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] + let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] + runHandler h = NormalB $ yr `AppE` VarE master `AppE` VarE mkey `AppE` (just `AppE` url) `AppE` h `AppE` VarE req + let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] + let clauses = + case methods of + [] -> [Clause [] (runHandlerVars $ "handle" ++ constr) []] + _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ + [Match WildP (runHandler badMethod') []]) []] + let exp = CaseE (VarE segments) + [ Match + (ConP (mkName "[]") []) + (NormalB $ just `AppE` VarE onSuccess) + [FunD onSuccess clauses] + , Match + WildP + (NormalB nothing) + [] + ] + return exp +mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSimpleExp srest pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE (VarE segments) + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSimpleExp srest pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE (VarE segments) + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp + +{- + mkPat' (SinglePiece s:rest) url = do + fsp <- [|either (const Nothing) Just . fromSinglePiece|] + v <- newName $ "var" ++ s + be <- [|(<*>)|] + let url' = InfixE (Just url) be $ Just $ fsp `AppE` VarE v + (x, rest, url'') <- mkPat' rest url' + return (InfixP (VarP v) (mkName ":") x, rest, url'') + mkPat' [] url = do + rest <- newName "rest" + return (VarP rest, VarE rest, url) +-} + +mkDispatchLocal ((constr, Simple pieces methods), Nothing) = do + master <- newName "master" + mkey <- newName "mkey" + req <- newName "req" + just <- [|Just|] + (pat', rest, url) <- mkPat' pieces $ just `AppE` (ConE $ mkName constr) + goodParse <- (`AppE` url) <$> [|isJust|] + tma'' <- (`AppE` url) <$> [|fromJust|] + nothing <- [|Nothing|] + let body = if null methods + then VarE $ mkName $ "handle" ++ constr + else CaseE (VarE req) $ map mkMatch methods ++ [Match WildP (NormalB nothing) []] + return $ Just $ Clause + [ VarP master + , VarP mkey + , pat' + ] (GuardedB [(NormalG goodParse, body)]) [] -- FIXME + where + singleToMApp :: GHandler s m c -> Maybe W.Application + singleToMApp = undefined + multiToMApp = undefined + -- FIXME requires OverloadedStrings + mkMatch method = Match (LitP $ StringL method) (NormalB $ VarE $ mkName $ map toLower method ++ constr) [] + mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp) + mkPat' (StaticPiece s:rest) url = do + (x, rest', url') <- mkPat' rest url + let sp = LitP $ StringL s + return (InfixP sp (mkName ":") x, rest', url') + mkPat' (SinglePiece s:rest) url = do + fsp <- [|either (const Nothing) Just . fromSinglePiece|] + v <- newName $ "var" ++ s + be <- [|(<*>)|] + let url' = InfixE (Just url) be $ Just $ fsp `AppE` VarE v + (x, rest, url'') <- mkPat' rest url' + return (InfixP (VarP v) (mkName ":") x, rest, url'') + mkPat' [] url = do + rest <- newName "rest" + return (VarP rest, VarE rest, url) +mkDispatchLocal _ = return Nothing + +mkDispatchToSubsite ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + master <- newName "master" + mkey <- newName "mkey" + just <- [|Just|] + (pat', tma', rest, toMaster) + <- mkPat' pieces + (ConE $ mkName constr) + $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) + ds <- [|dispatchSubsite|] + goodParse <- (`AppE` tma') <$> [|isJust|] + tma'' <- (`AppE` tma') <$> [|fromJust|] + let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster + fmap' <- [|(<$>)|] + let body = InfixE (Just body') fmap' $ Just tma' + return $ Just $ Clause + [ VarP master + , VarP mkey + , pat' + ] (GuardedB [(NormalG goodParse, body)]) [] + where mkPat' :: [Piece] -> Exp -> Exp -> Q (Pat, Exp, Exp, Exp) mkPat' (MultiPiece _:_) _ _ = error "MultiPiece not allowed as part of a subsite" mkPat' (StaticPiece s:rest) toMaster tma = do - (x, tma, rest', toMaster') <- mkPat' rest toMaster tma + (x, tma', rest', toMaster') <- mkPat' rest toMaster tma let sp = LitP $ StringL s - return (InfixP sp (mkName ":") x, tma, rest', toMaster') + return (InfixP sp (mkName ":") x, tma', rest', toMaster') mkPat' (SinglePiece s:rest) toMaster tma = do fsp <- [|either (const Nothing) Just . fromSinglePiece|] v <- newName $ "var" ++ s @@ -226,6 +378,7 @@ mkYesodGeneral name args clazzes isSub res = do mkPat' [] toMaster parse = do rest <- newName "rest" return (VarP rest, parse, VarE rest, toMaster) +mkDispatchToSubsite _ = return Nothing isStatic :: Piece -> Bool isStatic StaticPiece{} = True @@ -238,7 +391,8 @@ thResourceFromResource master (Resource n ps [stype, toSubArg]) -- static route to subsite = do let stype' = ConT $ mkName stype - gss <- [|getSubSite|] + {- + gss <- [|error "FIXME getSubSite"|] let inside = ConT ''Maybe `AppT` (ConT ''GHandler `AppT` stype' `AppT` master `AppT` ConT ''ChooseRep) @@ -252,6 +406,10 @@ thResourceFromResource master (Resource n ps [stype, toSubArg]) let render = render' `AppE` gss' dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] let dispatch = dispatch' `AppE` gss' + -} + parse <- [|error "ssParse"|] + dispatch <- [|error "ssDispatch"|] + render <- [|renderRoute|] tmg <- mkToMasterArg ps toSubArg return ((n, SubSite { ssType = ConT ''Route `AppT` stype' @@ -282,7 +440,7 @@ mkToMasterArg ps fname = do -- handler. This is the same as 'toWaiAppPlain', except it includes three -- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- recommended approach for most users. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application +toWaiApp :: (Yesod y, YesodDispatch y) => y -> IO W.Application toWaiApp y = do a <- toWaiAppPlain y return $ gzip False @@ -291,12 +449,12 @@ toWaiApp y = do -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares. -toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application +toWaiAppPlain :: (Yesod y, YesodDispatch y) => y -> IO W.Application toWaiAppPlain a = do key' <- encryptKey a return $ toWaiApp' a key' -toWaiApp' :: (Yesod y, YesodSite y) +toWaiApp' :: (Yesod y, YesodDispatch y) => y -> Maybe Key -> W.Application @@ -306,10 +464,14 @@ toWaiApp' y key' env = do "":x -> x x -> x liftIO $ print (W.pathInfo env, segments) - case dispatchToSubsite y key' segments of + case yesodDispatch y key' segments of + Just app -> app env Nothing -> case cleanPath y segments of - Nothing -> normalDispatch y key' segments env + Nothing -> + case yesodDispatch y key' segments of + Just app -> app env + Nothing -> yesodRunner y key' Nothing notFound env Just segments' -> let dest = joinPath y (approot y) segments' [] dest' = @@ -324,26 +486,9 @@ toWaiApp' y key' env = do [ ("Content-Type", "text/plain") , ("Location", dest') ] "Redirecting" - Just app -> app env - -normalDispatch :: (Yesod m, YesodSite m) - => m -> Maybe Key -> [String] - -> W.Application -normalDispatch y key' segments env = - yesodRunner y key' murl handler env - where - method = B.unpack $ W.requestMethod env - murl = either (const Nothing) Just $ parsePathSegments (getSite' y) segments - handler = - case murl of - Nothing -> notFound - Just url -> - case handleSite (getSite' y) (yesodRender y) url method of - Nothing -> badMethod - Just h -> h defaultDispatchSubsite - :: (Yesod m, YesodSite m, YesodSubSite s m) + :: (Yesod m, YesodDispatch m, YesodSubSite s m) => m -> Maybe Key -> [String] -> (Route s -> Route m) -> s @@ -351,18 +496,10 @@ defaultDispatchSubsite defaultDispatchSubsite y key' segments toMasterRoute s env = case dispatchToSubSubsite y key' segments toMasterRoute s of Just app -> app env - Nothing -> yesodRunner y key' (fmap toMasterRoute murl) handler env - where - method = B.unpack $ W.requestMethod env - murl = either (const Nothing) Just $ parsePathSegments (getSubSite' s y) segments - handler = toMasterHandlerMaybe toMasterRoute (const s) murl handler' - handler' = - case murl of - Nothing -> notFound - Just url -> - case handleSite (getSubSite' s y) (yesodRender y . toMasterRoute) url method of - Nothing -> badMethod - Just h -> h + Nothing -> + case dispatchSubLocal y key' segments toMasterRoute s of + Just app -> app env + Nothing -> yesodRunner y key' Nothing notFound env #if TEST diff --git a/helloworld.hs b/helloworld.hs index fd4e15da..34d715b4 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -5,7 +5,7 @@ import Yesod.Core import Yesod.Dispatch import Yesod.Content import Yesod.Handler -import Network.Wai.Handler.Warp (run) +import Network.Wai.Handler.Warp (runEx) data Subsite = Subsite String @@ -26,5 +26,6 @@ mkYesod "HelloWorld" [$parseRoutes| /subsite/#String SubsiteR Subsite getSubsite |] instance Yesod HelloWorld where approot _ = "" +getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig getRootR = return $ RepPlain "Hello World" -main = toWaiApp (HelloWorld Subsite) >>= run 3000 +main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000 From c87068b7fb881d5fd14097d2522796ebaa1e87f0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 09:59:30 +0200 Subject: [PATCH 050/126] mkSubsiteExp --- Yesod/Dispatch.hs | 55 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2475b436..5ce988da 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -210,7 +210,14 @@ mkYesodDispatch' sortedRes = do (NormalB body) [] where - go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = return onFail + go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + test <- mkSubsiteExp segments pieces id (master, mkey, constr, toSub) + just <- [|Just|] + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] + ] go master mkey segments onFail ((constr, Simple pieces methods), Nothing) = do test <- mkSimpleExp segments pieces id (master, mkey, constr, methods) just <- [|Just|] @@ -288,6 +295,52 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do ] return exp +mkSubsiteExp segments [] frontVars (master, mkey, constr, toSub) = do + ds <- [|dispatchSubsite|] + let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] + let s' = VarE (mkName toSub) `AppE` VarE master + let s = foldl' AppE s' $ frontVars [] + let app = ds `AppE` VarE master `AppE` VarE mkey `AppE` VarE segments `AppE` con `AppE` s + just <- [|Just|] + return $ just `AppE` app +mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSubsiteExp srest pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE (VarE segments) + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSubsiteExp segments (SinglePiece s:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE (VarE segments) + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp + {- mkPat' (SinglePiece s:rest) url = do fsp <- [|either (const Nothing) Just . fromSinglePiece|] From 09e93e96a1208bb050990ad6c5796ebb94d12b91 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 10:30:02 +0200 Subject: [PATCH 051/126] Steps towards unifying on YesodDispatch --- Yesod/Core.hs | 41 ++++++++++++++++++++++------------ Yesod/Dispatch.hs | 56 +++++++++++++++++++++++------------------------ Yesod/Handler.hs | 20 +++++++++-------- helloworld.hs | 2 +- 4 files changed, 67 insertions(+), 52 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index fbd823a2..58439072 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -80,11 +80,17 @@ import qualified Data.Text.Encoding class Eq u => RenderRoute u where renderRoute :: u -> ([String], [(String, String)]) --- FIXME unify YesodSite and YesodSubSite -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. -class RenderRoute (Route y) => YesodDispatch y where - yesodDispatch :: y -> Maybe CS.Key -> [String] -> Maybe W.Application +class Yesod master => YesodDispatch a master where + yesodDispatch + :: (Yesod master) + => a + -> Maybe CS.Key + -> [String] + -> master + -> (Route a -> Route master) + -> Maybe W.Application -- | Same as 'YesodSite', but for subsites. Once again, users should not need -- to deal with it directly, as mkYesodSub creates instances appropriately. @@ -246,22 +252,29 @@ class RenderRoute (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True - yesodRunner :: a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application + -- FIXME this probably needs to be a part of YesodDispatch + yesodRunner :: Yesod master + => a + -> master + -> (Route a -> Route master) + -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application yesodRunner = defaultYesodRunner -defaultYesodRunner :: Yesod a +defaultYesodRunner :: Yesod master => a + -> master + -> (Route a -> Route master) -> Maybe CS.Key -> Maybe (Route a) - -> GHandler a a ChooseRep + -> GHandler a master ChooseRep -> W.Application -defaultYesodRunner y mkey murl handler req = do +defaultYesodRunner s master toMasterRoute mkey murl handler req = do now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now - let exp' = getExpires $ clientSessionDuration y + let exp' = getExpires $ clientSessionDuration master -- FIXME will show remoteHost give the answer I need? will it include port -- information that changes on each request? - let host = if sessionIpAddress y then S8.pack (show (W.remoteHost req)) else "" + let host = if sessionIpAddress master then S8.pack (show (W.remoteHost req)) else "" let session' = case mkey of Nothing -> [] @@ -274,12 +287,12 @@ defaultYesodRunner y mkey murl handler req = do case murl of Nothing -> handler Just url -> do - isWrite <- isWriteRequest url - ar <- isAuthorized url isWrite + isWrite <- isWriteRequest $ toMasterRoute url + ar <- isAuthorized (toMasterRoute url) isWrite case ar of Authorized -> return () AuthenticationRequired -> - case authRoute y of + case authRoute master of Nothing -> permissionDenied "Authentication required" Just url' -> do @@ -289,7 +302,7 @@ defaultYesodRunner y mkey murl handler req = do handler let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' - yar <- handlerToYAR y (yesodRender y) errorHandler rr murl sessionMap h + yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h let mnonce = reqNonce rr return $ yarToResponse (hr mnonce getExpires host exp') yar where @@ -307,7 +320,7 @@ defaultYesodRunner y mkey murl handler req = do case mkey of Nothing -> hs Just _ -> AddCookie - (clientSessionDuration y) + (clientSessionDuration master) sessionName sessionVal : hs diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5ce988da..84bfeb9c 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -177,20 +177,10 @@ mkYesodGeneral name args clazzes isSub res = do subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th' let subSubsiteClauses = [] -- FIXME subSubsiteClauses nothing <- [|Nothing|] - dds <- [|defaultDispatchSubsite|] - let otherMethods = - if isSub - then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []] - , FunD (mkName "dispatchToSubSubsite") - (subSubsiteClauses ++ [Clause [WildP, WildP, WildP, WildP, WildP] (NormalB nothing) []]) - ] - else [ FunD (mkName "dispatchToSubsite") - (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) - ] let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master")) [ ] - mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] + mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp $ FunD (mkName yfunc) [Clause [] (NormalB site') []] : otherMethods -} @@ -200,26 +190,28 @@ isSubSite ((_, SubSite{}), _) = True isSubSite _ = False mkYesodDispatch' sortedRes = do + sub <- newName "sub" master <- newName "master" mkey <- newName "mkey" segments <- newName "segments" + toMasterRoute <- newName "toMasterRoute" nothing <- [|Nothing|] - body <- foldM (go master mkey segments) nothing sortedRes + body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes return $ Clause - [VarP master, VarP mkey, VarP segments] + [VarP master, VarP mkey, VarP segments, VarP sub, VarP toMasterRoute] (NormalB body) [] where - go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do - test <- mkSubsiteExp segments pieces id (master, mkey, constr, toSub) + go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, toSub) just <- [|Just|] app <- newName "app" return $ CaseE test [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] ] - go master mkey segments onFail ((constr, Simple pieces methods), Nothing) = do - test <- mkSimpleExp segments pieces id (master, mkey, constr, methods) + go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do + test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods) just <- [|Just|] app <- newName "app" return $ CaseE test @@ -227,7 +219,7 @@ mkYesodDispatch' sortedRes = do , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] ] -mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do +mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do just <- [|Just|] nothing <- [|Nothing|] onSuccess <- newName "onSuccess" @@ -239,7 +231,13 @@ mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do cr <- [|fmap chooseRep|] let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] - runHandler h = NormalB $ yr `AppE` VarE master `AppE` VarE mkey `AppE` (just `AppE` url) `AppE` h `AppE` VarE req + runHandler h = NormalB $ yr `AppE` VarE sub + `AppE` VarE master + `AppE` VarE toMasterRoute + `AppE` VarE mkey + `AppE` (just `AppE` url) + `AppE` h + `AppE` VarE req let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] let clauses = case methods of @@ -295,7 +293,7 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do ] return exp -mkSubsiteExp segments [] frontVars (master, mkey, constr, toSub) = do +mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do ds <- [|dispatchSubsite|] let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] let s' = VarE (mkName toSub) `AppE` VarE master @@ -493,7 +491,7 @@ mkToMasterArg ps fname = do -- handler. This is the same as 'toWaiAppPlain', except it includes three -- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- recommended approach for most users. -toWaiApp :: (Yesod y, YesodDispatch y) => y -> IO W.Application +toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application toWaiApp y = do a <- toWaiAppPlain y return $ gzip False @@ -502,12 +500,12 @@ toWaiApp y = do -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares. -toWaiAppPlain :: (Yesod y, YesodDispatch y) => y -> IO W.Application +toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application toWaiAppPlain a = do key' <- encryptKey a return $ toWaiApp' a key' -toWaiApp' :: (Yesod y, YesodDispatch y) +toWaiApp' :: (Yesod y, YesodDispatch y y) => y -> Maybe Key -> W.Application @@ -517,14 +515,14 @@ toWaiApp' y key' env = do "":x -> x x -> x liftIO $ print (W.pathInfo env, segments) - case yesodDispatch y key' segments of + case yesodDispatch y key' segments y id of Just app -> app env Nothing -> case cleanPath y segments of Nothing -> - case yesodDispatch y key' segments of + case yesodDispatch y key' segments y id of Just app -> app env - Nothing -> yesodRunner y key' Nothing notFound env + Nothing -> yesodRunner y y id key' Nothing notFound env Just segments' -> let dest = joinPath y (approot y) segments' [] dest' = @@ -540,19 +538,21 @@ toWaiApp' y key' env = do , ("Location", dest') ] "Redirecting" +{- defaultDispatchSubsite :: (Yesod m, YesodDispatch m, YesodSubSite s m) => m -> Maybe Key -> [String] -> (Route s -> Route m) -> s -> W.Application -defaultDispatchSubsite y key' segments toMasterRoute s env = +defaultDispatchSubsite y key' segments toMasterRoute s env = error "FIXME" {- case dispatchToSubSubsite y key' segments toMasterRoute s of Just app -> app env Nothing -> case dispatchSubLocal y key' segments toMasterRoute s of Just app -> app env - Nothing -> yesodRunner y key' Nothing notFound env + Nothing -> yesodRunner y key' Nothing notFound env-} +-} #if TEST diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index e6d94dbb..80da4471 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -345,16 +345,16 @@ runHandler :: HasReps c -> Maybe (Route sub) -> (Route sub -> Route master) -> master - -> (master -> sub) + -> sub -> YesodApp -runHandler handler mrender sroute tomr ma tosa = +runHandler handler mrender sroute tomr ma sa = YesodApp $ \eh rr cts initSession -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) let hd = HandlerData { handlerRequest = rr - , handlerSub = tosa ma + , handlerSub = sa , handlerMaster = ma , handlerRoute = sroute , handlerRender = mrender @@ -655,18 +655,20 @@ handlerTestSuite = testGroup "Yesod.Handler" handlerToYAR :: (HasReps a, HasReps b) => m -- ^ master site foundation + -> s -- ^ sub site foundation + -> (Route s -> Route m) -> (Route m -> [(String, String)] -> String) -- ^ url render - -> (ErrorResponse -> GHandler m m a) + -> (ErrorResponse -> GHandler s m a) -> Request - -> Maybe (Route m) + -> Maybe (Route s) -> SessionMap - -> GHandler m m b + -> GHandler s m b -> Iteratee ByteString IO YesodAppResult -handlerToYAR y render errorHandler rr murl sessionMap h = +handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where - ya = runHandler h render murl id y id - eh' er = runHandler (errorHandler' er) render murl id y id + ya = runHandler h render murl toMasterRoute y s + eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler diff --git a/helloworld.hs b/helloworld.hs index 34d715b4..af60a009 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -26,6 +26,6 @@ mkYesod "HelloWorld" [$parseRoutes| /subsite/#String SubsiteR Subsite getSubsite |] instance Yesod HelloWorld where approot _ = "" -getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig +-- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig getRootR = return $ RepPlain "Hello World" main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000 From c571aac930061fd32de059ae70682c2b3af4ac97 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 10:45:12 +0200 Subject: [PATCH 052/126] Normal and subsite dispatch code completely unified --- Yesod/Core.hs | 33 +++++---------------------------- Yesod/Dispatch.hs | 23 +++++++++++++---------- 2 files changed, 18 insertions(+), 38 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 58439072..bf23a5c8 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -10,7 +10,6 @@ module Yesod.Core ( -- * Type classes Yesod (..) , YesodDispatch (..) - , YesodSubSite (..) , RenderRoute (..) -- ** Breadcrumbs , YesodBreadcrumbs (..) @@ -92,25 +91,11 @@ class Yesod master => YesodDispatch a master where -> (Route a -> Route master) -> Maybe W.Application --- | Same as 'YesodSite', but for subsites. Once again, users should not need --- to deal with it directly, as mkYesodSub creates instances appropriately. -class (RenderRoute (Route s)) => YesodSubSite s y where - dispatchSubsite :: (Yesod y) - => y - -> Maybe CS.Key - -> [String] - -> (Route s -> Route y) - -> s - -> W.Application - dispatchToSubSubsite - :: (Yesod y) - => y - -> Maybe CS.Key - -> [String] - -> (Route s -> Route y) - -> s - -> Maybe W.Application - dispatchSubLocal :: y -> Maybe CS.Key -> [String] -> (Route s -> Route y) -> s -> Maybe W.Application + yesodRunner :: a + -> master + -> (Route a -> Route master) + -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application + yesodRunner = defaultYesodRunner -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. @@ -252,14 +237,6 @@ class RenderRoute (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True - -- FIXME this probably needs to be a part of YesodDispatch - yesodRunner :: Yesod master - => a - -> master - -> (Route a -> Route master) - -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application - yesodRunner = defaultYesodRunner - defaultYesodRunner :: Yesod master => a -> master diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 84bfeb9c..14a736a0 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -173,12 +173,11 @@ mkYesodGeneral name args clazzes isSub res = do -} let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th' yd <- mkYesodDispatch' sortedRes - localClauses <- catMaybes <$> mapM mkDispatchLocal th' - subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th' - let subSubsiteClauses = [] -- FIXME subSubsiteClauses nothing <- [|Nothing|] - let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master")) - [ + let master = mkName "master" + let ctx = ClassP (mkName "Yesod") [VarT master] : clazzes + let mkYSS = InstanceD ctx (ConT ''YesodDispatch `AppT` arg `AppT` VarT master) + [ FunD (mkName "yesodDispatch") [yd] ] mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp @@ -198,7 +197,7 @@ mkYesodDispatch' sortedRes = do nothing <- [|Nothing|] body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes return $ Clause - [VarP master, VarP mkey, VarP segments, VarP sub, VarP toMasterRoute] + [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] (NormalB body) [] where @@ -208,7 +207,7 @@ mkYesodDispatch' sortedRes = do app <- newName "app" return $ CaseE test [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] - , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] ] go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods) @@ -294,11 +293,15 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do return exp mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do - ds <- [|dispatchSubsite|] + yd <- [|yesodDispatch|] let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] let s' = VarE (mkName toSub) `AppE` VarE master let s = foldl' AppE s' $ frontVars [] - let app = ds `AppE` VarE master `AppE` VarE mkey `AppE` VarE segments `AppE` con `AppE` s + let app = yd `AppE` s + `AppE` VarE mkey + `AppE` VarE segments + `AppE` VarE master + `AppE` con just <- [|Just|] return $ just `AppE` app mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do @@ -400,7 +403,7 @@ mkDispatchToSubsite ((constr, SubSite { ssPieces = pieces }), Just toSub) = do <- mkPat' pieces (ConE $ mkName constr) $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) - ds <- [|dispatchSubsite|] + ds <- error "FIXME" -- [|dispatchSubsite|] goodParse <- (`AppE` tma') <$> [|isJust|] tma'' <- (`AppE` tma') <$> [|fromJust|] let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster From af30b44ef2a77e16d544e4f51ed87726aecaa98e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 11:15:58 +0200 Subject: [PATCH 053/126] Big code cleanup --- Yesod/Core.hs | 5 +- Yesod/Dispatch.hs | 312 +++++++++++++--------------------------------- helloworld.hs | 3 + yesod-core.cabal | 2 +- 4 files changed, 94 insertions(+), 228 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index bf23a5c8..6acfe834 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -91,7 +91,8 @@ class Yesod master => YesodDispatch a master where -> (Route a -> Route master) -> Maybe W.Application - yesodRunner :: a + yesodRunner :: Yesod master + => a -> master -> (Route a -> Route master) -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application @@ -275,7 +276,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do Just url' -> do setUltDest' redirect RedirectTemporary url' - Unauthorized s -> permissionDenied s + Unauthorized s' -> permissionDenied s' handler let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 14a736a0..0c3440fe 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -25,12 +25,10 @@ module Yesod.Dispatch #endif ) where +import Prelude hiding (exp) import Yesod.Core import Yesod.Handler -import Yesod.Request -import Yesod.Internal - import Web.Routes.Quasi import Web.Routes.Quasi.Parse import Web.Routes.Quasi.TH @@ -42,36 +40,14 @@ import Network.Wai.Middleware.Gzip import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () -import Blaze.ByteString.Builder (toLazyByteString) - -import Control.Concurrent.MVar -import Control.Arrow ((***)) - -import Data.Time import Control.Monad -import Data.Maybe import Web.ClientSession -import qualified Web.ClientSession as CS import Data.Char (isUpper, toLower) -import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) -import Data.Serialize -import qualified Data.Serialize as Ser -import Network.Wai.Parse hiding (FileInfo) -import qualified Network.Wai.Parse as NWP -import Data.String (fromString) import Web.Routes (decodePathInfo) -import Control.Arrow (first) -import System.Random (randomR, newStdGen) -import qualified Data.Map as Map - -import Control.Applicative ((<$>), (<*>)) -import Data.Enumerator (($$), run_, Iteratee) import Control.Monad.IO.Class (liftIO) import Data.List (foldl') @@ -145,49 +121,35 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - th' <- mapM (thResourceFromResource arg) res + th' <- mapM thResourceFromResource res let th = map fst th' w' <- createRoutes th let routesName = mkName $ name ++ "Route" let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] let x = TySynInstD ''Route [arg] $ ConT routesName - render' <- createRender th - render'' <- newName "render" - let render = LetE [FunD render'' render'] $ VarE render'' + render <- createRender th let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName) - [ FunD (mkName "renderRoute") render' + [ FunD (mkName "renderRoute") render ] - tmh <- [|toMasterHandlerDyn|] - modMaster <- [|fmap chooseRep|] - dispatch' <- createDispatch modMaster tmh th - dispatch'' <- newName "dispatch" - let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' - - {- FIXME - let (ctx, ytyp, yfunc) = - if isSub - then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") - else ([], ConT ''YesodSite `AppT` arg, "getSite") - -} - let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th' + let sortedRes = filter (not . isSubSite) th ++ filter isSubSite th yd <- mkYesodDispatch' sortedRes - nothing <- [|Nothing|] let master = mkName "master" - let ctx = ClassP (mkName "Yesod") [VarT master] : clazzes - let mkYSS = InstanceD ctx (ConT ''YesodDispatch `AppT` arg `AppT` VarT master) - [ FunD (mkName "yesodDispatch") [yd] - ] - mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] - let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp - $ FunD (mkName yfunc) [Clause [] (NormalB site') []] - : otherMethods -} + let ctx = if isSub + then ClassP (mkName "Yesod") [VarT master] : clazzes + else [] + let ytyp = if isSub + then ConT ''YesodDispatch `AppT` arg `AppT` VarT master + else ConT ''YesodDispatch `AppT` arg `AppT` arg + let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] return ([w, x, x'], [y]) -isSubSite ((_, SubSite{}), _) = True +isSubSite :: (String, Pieces) -> Bool +isSubSite (_, SubSite{}) = True isSubSite _ = False +mkYesodDispatch' :: [(String, Pieces)] -> Q Clause mkYesodDispatch' sortedRes = do sub <- newName "sub" master <- newName "master" @@ -195,22 +157,21 @@ mkYesodDispatch' sortedRes = do segments <- newName "segments" toMasterRoute <- newName "toMasterRoute" nothing <- [|Nothing|] - body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes + body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing sortedRes return $ Clause [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] (NormalB body) [] where - go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do - test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, toSub) - just <- [|Just|] + go master sub toMasterRoute mkey segments onFail (constr, SubSite { ssPieces = pieces }) = do + test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr) app <- newName "app" return $ CaseE test [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] ] - go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do - test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods) + go master sub toMasterRoute mkey segments onFail (constr, Simple pieces methods) = do + test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods) just <- [|Just|] app <- newName "app" return $ CaseE test @@ -218,6 +179,11 @@ mkYesodDispatch' sortedRes = do , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] ] +mkSimpleExp :: Exp -- ^ segments + -> [Piece] + -> ([Exp] -> [Exp]) -- ^ variables already parsed + -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods + -> Q Exp mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do just <- [|Just|] nothing <- [|Nothing|] @@ -229,21 +195,21 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met yr <- [|yesodRunner|] cr <- [|fmap chooseRep|] let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] - let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] - runHandler h = NormalB $ yr `AppE` VarE sub - `AppE` VarE master - `AppE` VarE toMasterRoute - `AppE` VarE mkey - `AppE` (just `AppE` url) - `AppE` h - `AppE` VarE req + let runHandlerVars h = runHandler' $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] + runHandler' h = NormalB $ yr `AppE` sub + `AppE` VarE master + `AppE` toMasterRoute + `AppE` VarE mkey + `AppE` (just `AppE` url) + `AppE` h + `AppE` VarE req let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] let clauses = case methods of - [] -> [Clause [] (runHandlerVars $ "handle" ++ constr) []] + [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []] _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ - [Match WildP (runHandler badMethod') []]) []] - let exp = CaseE (VarE segments) + [Match WildP (runHandler' badMethod') []]) []] + let exp = CaseE segments [ Match (ConP (mkName "[]") []) (NormalB $ just `AppE` VarE onSuccess) @@ -256,9 +222,9 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met return exp mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do srest <- newName "segments" - innerExp <- mkSimpleExp srest pieces frontVars x + innerExp <- mkSimpleExp (VarE srest) pieces frontVars x nothing <- [|Nothing|] - let exp = CaseE (VarE segments) + let exp = CaseE segments [ Match (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) (NormalB innerExp) @@ -266,10 +232,10 @@ mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do , Match WildP (NormalB nothing) [] ] return exp -mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do +mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do srest <- newName "segments" next' <- newName "next'" - innerExp <- mkSimpleExp srest pieces (frontVars . (:) (VarE next')) x + innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x nothing <- [|Nothing|] next <- newName "next" fsp <- [|fromSinglePiece|] @@ -283,7 +249,7 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do (NormalB innerExp) [] ] - let exp = CaseE (VarE segments) + let exp = CaseE segments [ Match (InfixP (VarP next) (mkName ":") (VarP srest)) (NormalB exp') @@ -291,19 +257,42 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do , Match WildP (NormalB nothing) [] ] return exp +mkSimpleExp segments [MultiPiece _] frontVars x = do + next' <- newName "next'" + srest <- [|[]|] + innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + fmp <- [|fromMultiPiece|] + let exp = CaseE (fmp `AppE` segments) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + return exp +mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece" -mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do +mkSubsiteExp :: Name -- ^ segments + -> [Piece] + -> ([Exp] -> [Exp]) -- ^ variables already parsed + -> (Name, Exp, Exp, Name, String) -- ^ master, sub, toMasterRoute, mkey, constructor + -> Q Exp +mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr) = do yd <- [|yesodDispatch|] - let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] - let s' = VarE (mkName toSub) `AppE` VarE master - let s = foldl' AppE s' $ frontVars [] - let app = yd `AppE` s + dot <- [|(.)|] + let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars [] + let app = yd `AppE` sub `AppE` VarE mkey `AppE` VarE segments `AppE` VarE master `AppE` con just <- [|Just|] return $ just `AppE` app +mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece" mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do srest <- newName "segments" innerExp <- mkSubsiteExp srest pieces frontVars x @@ -316,7 +305,7 @@ mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do , Match WildP (NormalB nothing) [] ] return exp -mkSubsiteExp segments (SinglePiece s:pieces) frontVars x = do +mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do srest <- newName "segments" next' <- newName "next'" innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x @@ -342,154 +331,27 @@ mkSubsiteExp segments (SinglePiece s:pieces) frontVars x = do ] return exp -{- - mkPat' (SinglePiece s:rest) url = do - fsp <- [|either (const Nothing) Just . fromSinglePiece|] - v <- newName $ "var" ++ s - be <- [|(<*>)|] - let url' = InfixE (Just url) be $ Just $ fsp `AppE` VarE v - (x, rest, url'') <- mkPat' rest url' - return (InfixP (VarP v) (mkName ":") x, rest, url'') - mkPat' [] url = do - rest <- newName "rest" - return (VarP rest, VarE rest, url) --} - -mkDispatchLocal ((constr, Simple pieces methods), Nothing) = do - master <- newName "master" - mkey <- newName "mkey" - req <- newName "req" - just <- [|Just|] - (pat', rest, url) <- mkPat' pieces $ just `AppE` (ConE $ mkName constr) - goodParse <- (`AppE` url) <$> [|isJust|] - tma'' <- (`AppE` url) <$> [|fromJust|] - nothing <- [|Nothing|] - let body = if null methods - then VarE $ mkName $ "handle" ++ constr - else CaseE (VarE req) $ map mkMatch methods ++ [Match WildP (NormalB nothing) []] - return $ Just $ Clause - [ VarP master - , VarP mkey - , pat' - ] (GuardedB [(NormalG goodParse, body)]) [] -- FIXME - where - singleToMApp :: GHandler s m c -> Maybe W.Application - singleToMApp = undefined - multiToMApp = undefined - -- FIXME requires OverloadedStrings - mkMatch method = Match (LitP $ StringL method) (NormalB $ VarE $ mkName $ map toLower method ++ constr) [] - mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp) - mkPat' (StaticPiece s:rest) url = do - (x, rest', url') <- mkPat' rest url - let sp = LitP $ StringL s - return (InfixP sp (mkName ":") x, rest', url') - mkPat' (SinglePiece s:rest) url = do - fsp <- [|either (const Nothing) Just . fromSinglePiece|] - v <- newName $ "var" ++ s - be <- [|(<*>)|] - let url' = InfixE (Just url) be $ Just $ fsp `AppE` VarE v - (x, rest, url'') <- mkPat' rest url' - return (InfixP (VarP v) (mkName ":") x, rest, url'') - mkPat' [] url = do - rest <- newName "rest" - return (VarP rest, VarE rest, url) -mkDispatchLocal _ = return Nothing - -mkDispatchToSubsite ((constr, SubSite { ssPieces = pieces }), Just toSub) = do - master <- newName "master" - mkey <- newName "mkey" - just <- [|Just|] - (pat', tma', rest, toMaster) - <- mkPat' pieces - (ConE $ mkName constr) - $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) - ds <- error "FIXME" -- [|dispatchSubsite|] - goodParse <- (`AppE` tma') <$> [|isJust|] - tma'' <- (`AppE` tma') <$> [|fromJust|] - let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster - fmap' <- [|(<$>)|] - let body = InfixE (Just body') fmap' $ Just tma' - return $ Just $ Clause - [ VarP master - , VarP mkey - , pat' - ] (GuardedB [(NormalG goodParse, body)]) [] - where - mkPat' :: [Piece] -> Exp -> Exp -> Q (Pat, Exp, Exp, Exp) - mkPat' (MultiPiece _:_) _ _ = error "MultiPiece not allowed as part of a subsite" - mkPat' (StaticPiece s:rest) toMaster tma = do - (x, tma', rest', toMaster') <- mkPat' rest toMaster tma - let sp = LitP $ StringL s - return (InfixP sp (mkName ":") x, tma', rest', toMaster') - mkPat' (SinglePiece s:rest) toMaster tma = do - fsp <- [|either (const Nothing) Just . fromSinglePiece|] - v <- newName $ "var" ++ s - be <- [|(<*>)|] - let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v - let toMaster' = toMaster `AppE` VarE v - (x, tma'', rest, toMaster'') <- mkPat' rest toMaster' tma' - return (InfixP (VarP v) (mkName ":") x, tma'', rest, toMaster'') - mkPat' [] toMaster parse = do - rest <- newName "rest" - return (VarP rest, parse, VarE rest, toMaster) -mkDispatchToSubsite _ = return Nothing - -isStatic :: Piece -> Bool -isStatic StaticPiece{} = True -isStatic _ = False - -thResourceFromResource :: Type -> Resource -> Q (THResource, Maybe String) -thResourceFromResource _ (Resource n ps atts) +thResourceFromResource :: Resource -> Q (THResource, Maybe String) +thResourceFromResource (Resource n ps atts) | all (all isUpper) atts = return ((n, Simple ps atts), Nothing) -thResourceFromResource master (Resource n ps [stype, toSubArg]) - -- static route to subsite - = do - let stype' = ConT $ mkName stype - {- - gss <- [|error "FIXME getSubSite"|] - let inside = ConT ''Maybe `AppT` - (ConT ''GHandler `AppT` stype' `AppT` master `AppT` - ConT ''ChooseRep) - let typ = ConT ''Site `AppT` - (ConT ''Route `AppT` stype') `AppT` - (ArrowT `AppT` ConT ''String `AppT` inside) - let gss' = gss `SigE` typ - parse' <- [|parsePathSegments|] - let parse = parse' `AppE` gss' - render' <- [|formatPathSegments|] - let render = render' `AppE` gss' - dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] - let dispatch = dispatch' `AppE` gss' - -} - parse <- [|error "ssParse"|] - dispatch <- [|error "ssDispatch"|] - render <- [|renderRoute|] - tmg <- mkToMasterArg ps toSubArg - return ((n, SubSite - { ssType = ConT ''Route `AppT` stype' - , ssParse = parse - , ssRender = render - , ssDispatch = dispatch - , ssToMasterArg = tmg - , ssPieces = ps - }), Just toSubArg) +thResourceFromResource (Resource n ps [stype, toSubArg]) = do + let stype' = ConT $ mkName stype + parse <- [|error "ssParse"|] + dispatch <- [|error "ssDispatch"|] + render <- [|renderRoute|] + tmg <- [|error "ssToMasterArg"|] + return ((n, SubSite + { ssType = ConT ''Route `AppT` stype' + , ssParse = parse + , ssRender = render + , ssDispatch = dispatch + , ssToMasterArg = tmg + , ssPieces = ps + }), Just toSubArg) - -thResourceFromResource _ (Resource n _ _) = +thResourceFromResource (Resource n _ _) = error $ "Invalid attributes for resource: " ++ n -mkToMasterArg :: [Piece] -> String -> Q Exp -mkToMasterArg ps fname = do - let nargs = length $ filter (not.isStatic) ps - f = VarE $ mkName fname - args <- sequence $ take nargs $ repeat $ newName "x" - rsg <- [|error "runSubsiteGetter"|] - let xps = map VarP args - xes = map VarE args - e' = foldl (\x y -> x `AppE` y) f xes - e = rsg `AppE` e' - return $ rsg -- FIXME LamE xps e - -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes three -- middlewares: GZIP compression, JSON-P and path cleaning. This is the diff --git a/helloworld.hs b/helloworld.hs index af60a009..63cd9a27 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -11,6 +11,7 @@ data Subsite = Subsite String mkYesodSub "Subsite" [] [$parseRoutes| / SubRootR GET +/multi/*Strings SubMultiR |] getSubRootR :: GHandler Subsite m RepPlain @@ -20,6 +21,8 @@ getSubRootR = do render <- getUrlRender return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR) +handleSubMultiR = return . RepPlain . toContent . show + data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } mkYesod "HelloWorld" [$parseRoutes| / RootR GET diff --git a/yesod-core.cabal b/yesod-core.cabal index c43720f0..8cc2e95e 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -58,7 +58,7 @@ library Yesod.Internal.Session Yesod.Internal.Request Paths_yesod_core - ghc-options: -Wall + ghc-options: -Wall -Werror executable runtests if flag(ghc7) From 24b519ffa4b0d8f0db761cc84e551ee265238f55 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 11:26:13 +0200 Subject: [PATCH 054/126] Fixed some dispatch bugs --- Yesod/Dispatch.hs | 25 ++++++++++++++----------- helloworld.hs | 5 ++++- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0c3440fe..ac410bc5 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -133,7 +133,7 @@ mkYesodGeneral name args clazzes isSub res = do [ FunD (mkName "renderRoute") render ] - let sortedRes = filter (not . isSubSite) th ++ filter isSubSite th + let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th' yd <- mkYesodDispatch' sortedRes let master = mkName "master" let ctx = if isSub @@ -145,11 +145,11 @@ mkYesodGeneral name args clazzes isSub res = do let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] return ([w, x, x'], [y]) -isSubSite :: (String, Pieces) -> Bool -isSubSite (_, SubSite{}) = True +isSubSite :: ((String, Pieces), a) -> Bool +isSubSite ((_, SubSite{}), _) = True isSubSite _ = False -mkYesodDispatch' :: [(String, Pieces)] -> Q Clause +mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause mkYesodDispatch' sortedRes = do sub <- newName "sub" master <- newName "master" @@ -163,14 +163,14 @@ mkYesodDispatch' sortedRes = do (NormalB body) [] where - go master sub toMasterRoute mkey segments onFail (constr, SubSite { ssPieces = pieces }) = do - test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr) + go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub) app <- newName "app" return $ CaseE test [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] ] - go master sub toMasterRoute mkey segments onFail (constr, Simple pieces methods) = do + go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods) just <- [|Just|] app <- newName "app" @@ -178,6 +178,7 @@ mkYesodDispatch' sortedRes = do [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] ] + go _ _ _ _ _ _ _ = error "Invalid combination" mkSimpleExp :: Exp -- ^ segments -> [Piece] @@ -195,7 +196,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met yr <- [|yesodRunner|] cr <- [|fmap chooseRep|] let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] - let runHandlerVars h = runHandler' $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] + let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars []) runHandler' h = NormalB $ yr `AppE` sub `AppE` VarE master `AppE` toMasterRoute @@ -279,13 +280,15 @@ mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece" mkSubsiteExp :: Name -- ^ segments -> [Piece] -> ([Exp] -> [Exp]) -- ^ variables already parsed - -> (Name, Exp, Exp, Name, String) -- ^ master, sub, toMasterRoute, mkey, constructor + -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub -> Q Exp -mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr) = do +mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do yd <- [|yesodDispatch|] dot <- [|(.)|] let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars [] - let app = yd `AppE` sub + -- proper handling for sub-subsites + let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars [] + let app = yd `AppE` sub' `AppE` VarE mkey `AppE` VarE segments `AppE` VarE master diff --git a/helloworld.hs b/helloworld.hs index 63cd9a27..9a2b70f1 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -21,7 +21,10 @@ getSubRootR = do render <- getUrlRender return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR) -handleSubMultiR = return . RepPlain . toContent . show +handleSubMultiR :: Strings -> GHandler Subsite m RepPlain +handleSubMultiR x = do + Subsite y <- getYesodSub + return . RepPlain . toContent . show $ (x, y) data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } mkYesod "HelloWorld" [$parseRoutes| From b9b94bbf8ecb3142c5ab2079ab539dee2d250f17 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 28 Jan 2011 11:53:32 +0200 Subject: [PATCH 055/126] Yesod.Internal.Dispatch --- Yesod/Dispatch.hs | 215 +------------------------------ Yesod/Internal/Dispatch.hs | 250 +++++++++++++++++++++++++++++++++++++ yesod-core.cabal | 1 + 3 files changed, 254 insertions(+), 212 deletions(-) create mode 100644 Yesod/Internal/Dispatch.hs diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index ac410bc5..85c52a83 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -28,6 +28,7 @@ module Yesod.Dispatch import Prelude hiding (exp) import Yesod.Core import Yesod.Handler +import Yesod.Internal.Dispatch import Web.Routes.Quasi import Web.Routes.Quasi.Parse @@ -42,14 +43,12 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S import Data.ByteString.Lazy.Char8 () -import Control.Monad import Web.ClientSession -import Data.Char (isUpper, toLower) +import Data.Char (isUpper) import Web.Routes (decodePathInfo) import Control.Monad.IO.Class (liftIO) -import Data.List (foldl') #if TEST import Test.Framework (testGroup, Test) @@ -58,8 +57,6 @@ import Test.QuickCheck import System.IO.Unsafe #endif -import Yesod.Content - -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. @@ -133,8 +130,7 @@ mkYesodGeneral name args clazzes isSub res = do [ FunD (mkName "renderRoute") render ] - let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th' - yd <- mkYesodDispatch' sortedRes + yd <- mkYesodDispatch' th' let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes @@ -145,195 +141,6 @@ mkYesodGeneral name args clazzes isSub res = do let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] return ([w, x, x'], [y]) -isSubSite :: ((String, Pieces), a) -> Bool -isSubSite ((_, SubSite{}), _) = True -isSubSite _ = False - -mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause -mkYesodDispatch' sortedRes = do - sub <- newName "sub" - master <- newName "master" - mkey <- newName "mkey" - segments <- newName "segments" - toMasterRoute <- newName "toMasterRoute" - nothing <- [|Nothing|] - body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing sortedRes - return $ Clause - [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] - (NormalB body) - [] - where - go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do - test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub) - app <- newName "app" - return $ CaseE test - [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] - , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] - ] - go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do - test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods) - just <- [|Just|] - app <- newName "app" - return $ CaseE test - [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] - , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] - ] - go _ _ _ _ _ _ _ = error "Invalid combination" - -mkSimpleExp :: Exp -- ^ segments - -> [Piece] - -> ([Exp] -> [Exp]) -- ^ variables already parsed - -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods - -> Q Exp -mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do - just <- [|Just|] - nothing <- [|Nothing|] - onSuccess <- newName "onSuccess" - req <- newName "req" - badMethod' <- [|badMethod|] - rm <- [|W.requestMethod|] - let caseExp = rm `AppE` VarE req - yr <- [|yesodRunner|] - cr <- [|fmap chooseRep|] - let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] - let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars []) - runHandler' h = NormalB $ yr `AppE` sub - `AppE` VarE master - `AppE` toMasterRoute - `AppE` VarE mkey - `AppE` (just `AppE` url) - `AppE` h - `AppE` VarE req - let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] - let clauses = - case methods of - [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []] - _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ - [Match WildP (runHandler' badMethod') []]) []] - let exp = CaseE segments - [ Match - (ConP (mkName "[]") []) - (NormalB $ just `AppE` VarE onSuccess) - [FunD onSuccess clauses] - , Match - WildP - (NormalB nothing) - [] - ] - return exp -mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do - srest <- newName "segments" - innerExp <- mkSimpleExp (VarE srest) pieces frontVars x - nothing <- [|Nothing|] - let exp = CaseE segments - [ Match - (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) - (NormalB innerExp) - [] - , Match WildP (NormalB nothing) [] - ] - return exp -mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do - srest <- newName "segments" - next' <- newName "next'" - innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x - nothing <- [|Nothing|] - next <- newName "next" - fsp <- [|fromSinglePiece|] - let exp' = CaseE (fsp `AppE` VarE next) - [ Match - (ConP (mkName "Left") [WildP]) - (NormalB nothing) - [] - , Match - (ConP (mkName "Right") [VarP next']) - (NormalB innerExp) - [] - ] - let exp = CaseE segments - [ Match - (InfixP (VarP next) (mkName ":") (VarP srest)) - (NormalB exp') - [] - , Match WildP (NormalB nothing) [] - ] - return exp -mkSimpleExp segments [MultiPiece _] frontVars x = do - next' <- newName "next'" - srest <- [|[]|] - innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x - nothing <- [|Nothing|] - fmp <- [|fromMultiPiece|] - let exp = CaseE (fmp `AppE` segments) - [ Match - (ConP (mkName "Left") [WildP]) - (NormalB nothing) - [] - , Match - (ConP (mkName "Right") [VarP next']) - (NormalB innerExp) - [] - ] - return exp -mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece" - -mkSubsiteExp :: Name -- ^ segments - -> [Piece] - -> ([Exp] -> [Exp]) -- ^ variables already parsed - -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub - -> Q Exp -mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do - yd <- [|yesodDispatch|] - dot <- [|(.)|] - let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars [] - -- proper handling for sub-subsites - let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars [] - let app = yd `AppE` sub' - `AppE` VarE mkey - `AppE` VarE segments - `AppE` VarE master - `AppE` con - just <- [|Just|] - return $ just `AppE` app -mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece" -mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do - srest <- newName "segments" - innerExp <- mkSubsiteExp srest pieces frontVars x - nothing <- [|Nothing|] - let exp = CaseE (VarE segments) - [ Match - (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) - (NormalB innerExp) - [] - , Match WildP (NormalB nothing) [] - ] - return exp -mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do - srest <- newName "segments" - next' <- newName "next'" - innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x - nothing <- [|Nothing|] - next <- newName "next" - fsp <- [|fromSinglePiece|] - let exp' = CaseE (fsp `AppE` VarE next) - [ Match - (ConP (mkName "Left") [WildP]) - (NormalB nothing) - [] - , Match - (ConP (mkName "Right") [VarP next']) - (NormalB innerExp) - [] - ] - let exp = CaseE (VarE segments) - [ Match - (InfixP (VarP next) (mkName ":") (VarP srest)) - (NormalB exp') - [] - , Match WildP (NormalB nothing) [] - ] - return exp - thResourceFromResource :: Resource -> Q (THResource, Maybe String) thResourceFromResource (Resource n ps atts) | all (all isUpper) atts = return ((n, Simple ps atts), Nothing) @@ -406,22 +213,6 @@ toWaiApp' y key' env = do , ("Location", dest') ] "Redirecting" -{- -defaultDispatchSubsite - :: (Yesod m, YesodDispatch m, YesodSubSite s m) - => m -> Maybe Key -> [String] - -> (Route s -> Route m) - -> s - -> W.Application -defaultDispatchSubsite y key' segments toMasterRoute s env = error "FIXME" {- - case dispatchToSubSubsite y key' segments toMasterRoute s of - Just app -> app env - Nothing -> - case dispatchSubLocal y key' segments toMasterRoute s of - Just app -> app env - Nothing -> yesodRunner y key' Nothing notFound env-} --} - #if TEST dispatchTestSuite :: Test diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs new file mode 100644 index 00000000..3b52352e --- /dev/null +++ b/Yesod/Internal/Dispatch.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | A bunch of Template Haskell used in the Yesod.Dispatch module. +module Yesod.Internal.Dispatch + ( mkYesodDispatch' + ) where + +import Prelude hiding (exp) +import Language.Haskell.TH.Syntax +import Web.Routes.Quasi +import Web.Routes.Quasi.Parse +import Web.Routes.Quasi.TH +import Control.Monad (foldM) +import Yesod.Handler (badMethod) +import Yesod.Content (chooseRep) +import qualified Network.Wai as W +import Yesod.Core (yesodRunner, yesodDispatch) +import Data.List (foldl') +import Data.Char (toLower) + +{-| + +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. + +We want to create a tree of case statements basically resembling: + +case testRoute1 of + Just app -> Just app + Nothing -> + case testRoute2 of + Just app -> Just app + Nothing -> + case testRoute3 of + Just app -> Just app + Nothing -> Nothing + +Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int): + +case segments of + "name" : as -> + case as of + [] -> Nothing + b:bs -> + case fromSinglePiece b of + Left _ -> Nothing + Right name -> + case bs of + "age":cs -> + case cs of + [] -> Nothing + d:ds -> + case fromSinglePiece d of + Left _ -> Nothing + Right age -> + case ds of + [] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)... + _ -> Nothing + _ -> Nothing + _ -> Nothing + +Obviously we would never want to write code by hand like this, but generating it is not too bad. + +This function generates a clause for the yesodDispatch function based on a set of routes. +-} +mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause +mkYesodDispatch' res = do + sub <- newName "sub" + master <- newName "master" + mkey <- newName "mkey" + segments <- newName "segments" + toMasterRoute <- newName "toMasterRoute" + nothing <- [|Nothing|] + body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res + return $ Clause + [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] + (NormalB body) + [] + where + go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub) + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] + ] + go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do + test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods) + just <- [|Just|] + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] + ] + go _ _ _ _ _ _ _ = error "Invalid combination" + +mkSimpleExp :: Exp -- ^ segments + -> [Piece] + -> ([Exp] -> [Exp]) -- ^ variables already parsed + -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods + -> Q Exp +mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do + just <- [|Just|] + nothing <- [|Nothing|] + onSuccess <- newName "onSuccess" + req <- newName "req" + badMethod' <- [|badMethod|] + rm <- [|W.requestMethod|] + let caseExp = rm `AppE` VarE req + yr <- [|yesodRunner|] + cr <- [|fmap chooseRep|] + let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] + let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars []) + runHandler' h = NormalB $ yr `AppE` sub + `AppE` VarE master + `AppE` toMasterRoute + `AppE` VarE mkey + `AppE` (just `AppE` url) + `AppE` h + `AppE` VarE req + let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] + let clauses = + case methods of + [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []] + _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ + [Match WildP (runHandler' badMethod') []]) []] + let exp = CaseE segments + [ Match + (ConP (mkName "[]") []) + (NormalB $ just `AppE` VarE onSuccess) + [FunD onSuccess clauses] + , Match + WildP + (NormalB nothing) + [] + ] + return exp +mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSimpleExp (VarE srest) pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE segments + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE segments + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSimpleExp segments [MultiPiece _] frontVars x = do + next' <- newName "next'" + srest <- [|[]|] + innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + fmp <- [|fromMultiPiece|] + let exp = CaseE (fmp `AppE` segments) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + return exp +mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece" + +mkSubsiteExp :: Name -- ^ segments + -> [Piece] + -> ([Exp] -> [Exp]) -- ^ variables already parsed + -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub + -> Q Exp +mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do + yd <- [|yesodDispatch|] + dot <- [|(.)|] + let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars [] + -- proper handling for sub-subsites + let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars [] + let app = yd `AppE` sub' + `AppE` VarE mkey + `AppE` VarE segments + `AppE` VarE master + `AppE` con + just <- [|Just|] + return $ just `AppE` app +mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece" +mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSubsiteExp srest pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE (VarE segments) + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE (VarE segments) + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp diff --git a/yesod-core.cabal b/yesod-core.cabal index 8cc2e95e..776f190e 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -57,6 +57,7 @@ library other-modules: Yesod.Internal Yesod.Internal.Session Yesod.Internal.Request + Yesod.Internal.Dispatch Paths_yesod_core ghc-options: -Wall -Werror From 327401eee4c866730087822c4c4fd46d5742bba2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 30 Jan 2011 21:52:42 +0200 Subject: [PATCH 056/126] Fixed a ByteString/String mismatch --- Yesod/Internal/Dispatch.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 3b52352e..faf687f8 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -16,6 +16,7 @@ import qualified Network.Wai as W import Yesod.Core (yesodRunner, yesodDispatch) import Data.List (foldl') import Data.Char (toLower) +import qualified Data.ByteString.Char8 as S8 {-| @@ -106,7 +107,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met onSuccess <- newName "onSuccess" req <- newName "req" badMethod' <- [|badMethod|] - rm <- [|W.requestMethod|] + rm <- [|S8.unpack . W.requestMethod|] let caseExp = rm `AppE` VarE req yr <- [|yesodRunner|] cr <- [|fmap chooseRep|] From 02cf6f84d3a225220df6d52182834cebd02a3c8a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 31 Jan 2011 07:11:05 +0200 Subject: [PATCH 057/126] Change some ByteString to String --- Yesod/Core.hs | 29 ++++++++++------------------- Yesod/Dispatch.hs | 8 ++------ 2 files changed, 12 insertions(+), 25 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 6acfe834..b1c9093d 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -81,9 +81,9 @@ class Eq u => RenderRoute u where -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. -class Yesod master => YesodDispatch a master where +class YesodDispatch a master where yesodDispatch - :: (Yesod master) + :: Yesod master => a -> Maybe CS.Key -> [String] @@ -111,9 +111,7 @@ class RenderRoute (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - -- - -- FIXME: is this the right typesig? - approot :: a -> S.ByteString + approot :: a -> String -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -150,7 +148,7 @@ class RenderRoute (Route a) => Yesod a where -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe S.ByteString + urlRenderOverride :: a -> Route a -> Maybe String urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -203,19 +201,12 @@ class RenderRoute (Route a) => Yesod a where -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. - -- - -- FIXME is this the right type sig? joinPath :: a - -> S.ByteString -- ^ application root + -> String -- ^ application root -> [String] -- ^ path pieces -> [(String, String)] -- ^ query string - -> S.ByteString - joinPath _ ar pieces qs = - S.concat - [ ar - , S8.singleton '/' - , S8.pack $ encodePathInfo pieces qs - ] + -> String + joinPath _ ar pieces qs = ar ++ '/' : encodePathInfo pieces qs -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and @@ -493,9 +484,9 @@ yesodRender :: Yesod y -> [(String, String)] -> String yesodRender y u qs = - S8.unpack $ fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) + fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') + (urlRenderOverride y u) where (ps, qs') = renderRoute u diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 85c52a83..cbc447ef 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -203,14 +203,10 @@ toWaiApp' y key' env = do dest' = if S.null (W.queryString env) then dest - else S.concat - [ dest - , B.singleton '?' - , W.queryString env - ] + else dest ++ '?' : B.unpack (W.queryString env) in return $ W.responseLBS W.status301 [ ("Content-Type", "text/plain") - , ("Location", dest') + , ("Location", B.pack $ dest') ] "Redirecting" #if TEST From 5b06e66382aacbda613c7a4cdcca8afbebf1f543 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 31 Jan 2011 07:21:59 +0200 Subject: [PATCH 058/126] Cleaned up extension lists --- Yesod/Content.hs | 4 ---- Yesod/Core.hs | 2 -- Yesod/Dispatch.hs | 2 -- Yesod/Handler.hs | 3 --- Yesod/Request.hs | 5 +---- Yesod/Widget.hs | 2 -- 6 files changed, 1 insertion(+), 17 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index a65acee5..1a238c93 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -1,11 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} - module Yesod.Content ( -- * Content Content (..) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index b1c9093d..00d0b0b6 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -1,6 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index cbc447ef..31ea35b3 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 80da4471..d099f37c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} diff --git a/Yesod/Request.hs b/Yesod/Request.hs index cd5717e0..37a02960 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -42,7 +39,7 @@ module Yesod.Request import qualified Network.Wai as W import qualified Data.ByteString.Lazy as BL -import "transformers" Control.Monad.IO.Class +import Control.Monad.IO.Class import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ae4736c9..7367704d 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -1,6 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier From 9de5c48c19e3a4952154675cae1e89e300231c0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 31 Jan 2011 07:31:21 +0200 Subject: [PATCH 059/126] Removed liftHandler- just use lift --- Yesod/Widget.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 7367704d..ff9378a8 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -7,7 +7,6 @@ module Yesod.Widget ( -- * Datatype GWidget , GGWidget (..) - , liftHandler , PageContent (..) -- * Creating -- ** Head of page @@ -87,16 +86,11 @@ instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) whe return = GWidget' . return x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y --- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' --- monad. -liftHandler :: Monad monad => monad a -> GGWidget sub master monad a -liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift - addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub w = do master <- liftHandler getYesod +addSubWidget sub w = do master <- lift getYesod let sr = fromSubRoute sub master i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get - w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i + w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ unGWidget w From f96b71e6f1e3b1e32f2d35b8b3b6708f4b7da2ed Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 31 Jan 2011 13:26:31 +0200 Subject: [PATCH 060/126] liftIOHandler --- Yesod/Dispatch.hs | 3 --- Yesod/Handler.hs | 18 ++++++++++++++++-- yesod-core.cabal | 2 +- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 31ea35b3..096ebf02 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -46,8 +46,6 @@ import Data.Char (isUpper) import Web.Routes (decodePathInfo) -import Control.Monad.IO.Class (liftIO) - #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -187,7 +185,6 @@ toWaiApp' y key' env = do case decodePathInfo $ B.unpack $ W.pathInfo env of "":x -> x x -> x - liftIO $ print (W.pathInfo env, segments) case yesodDispatch y key' segments y id of Just app -> app env Nothing -> diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d099f37c..0490c92b 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -83,6 +83,7 @@ module Yesod.Handler , hamletToRepHtml -- ** Misc , newIdent + , liftIOHandler -- * Internal Yesod , runHandler , YesodApp (..) @@ -111,14 +112,14 @@ import Control.Exception hiding (Handler, catch, finally) import qualified Control.Exception as E import Control.Applicative -import Control.Monad (liftM) +import Control.Monad (liftM, join) import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader import Control.Monad.Trans.State -import Control.Monad.Trans.Error (throwError, ErrorT (runErrorT), Error (..)) +import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..)) import System.IO import qualified Network.Wai as W @@ -127,6 +128,7 @@ import Control.Failure (Failure (failure)) import Text.Hamlet import Control.Monad.IO.Peel (MonadPeelIO) +import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) import qualified Data.Map as Map import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -740,6 +742,18 @@ newIdent = GHandler $ lift $ lift $ lift $ do put x { ghsIdent = i' } return $ "h" ++ show i' +liftIOHandler :: MonadIO mo + => GGHandler sub master IO a + -> GGHandler sub master mo a +liftIOHandler x = do + k <- peel + join $ liftIO $ k x + +instance MonadTransPeel (GGHandler s m) where + peel = GHandler $ do + k <- liftPeel $ liftPeel $ liftPeel peel + return $ liftM GHandler . k . unGHandler + -- | Redirect to a POST resource. -- -- This is not technically a redirect; instead, it returns an HTML page with a diff --git a/yesod-core.cabal b/yesod-core.cabal index 776f190e..6b4001a4 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -59,7 +59,7 @@ library Yesod.Internal.Request Yesod.Internal.Dispatch Paths_yesod_core - ghc-options: -Wall -Werror + ghc-options: -Wall executable runtests if flag(ghc7) From 753477518f87860dcc4981762e3799d6ffc44f30 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 3 Feb 2011 06:57:37 +0200 Subject: [PATCH 061/126] Exception instance for ErrorHandler --- Yesod/Handler.hs | 7 ++++--- Yesod/Internal.hs | 6 +++++- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0490c92b..ac3330ae 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -348,9 +348,10 @@ runHandler :: HasReps c -> YesodApp runHandler handler mrender sroute tomr ma sa = YesodApp $ \eh rr cts initSession -> do - let toErrorHandler = - InternalError - . (show :: Control.Exception.SomeException -> String) + let toErrorHandler e = + case fromException e of + Just x -> x + Nothing -> InternalError $ show e let hd = HandlerData { handlerRequest = rr , handlerSub = sa diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index f3e6ee30..6d9eb8fc 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses @@ -46,6 +47,8 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import qualified Network.Wai as W +import Data.Typeable (Typeable) +import Control.Exception (Exception) #if GHC7 #define HAMLET hamlet @@ -61,7 +64,8 @@ data ErrorResponse = | InvalidArgs [String] | PermissionDenied String | BadMethod String - deriving (Show, Eq) + deriving (Show, Eq, Typeable) +instance Exception ErrorResponse ----- header stuff -- | Headers to be added to a 'Result'. From fecdd6e7445c83dc3c230d13e5bc3d314be16fad Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 4 Feb 2011 07:04:39 +0200 Subject: [PATCH 062/126] All possible Handler functions live in GGHandler, not just GHandler --- Yesod/Handler.hs | 106 +++++++++++++++++++++++++---------------------- 1 file changed, 57 insertions(+), 49 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ac3330ae..1bed488b 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -186,16 +186,17 @@ handlerSubDataMaybe tm ts route hd = hd toMasterHandler :: (Route sub -> Route master) -> (master -> sub) -> Route sub - -> GHandler sub master a - -> GHandler sub' master a + -> GGHandler sub master mo a + -> GGHandler sub' master mo a toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h -toMasterHandlerDyn :: (Route sub -> Route master) - -> GHandler sub' master sub +toMasterHandlerDyn :: Monad mo + => (Route sub -> Route master) + -> GGHandler sub' master mo sub -> Route sub - -> GHandler sub master a - -> GHandler sub' master a + -> GGHandler sub master mo a + -> GGHandler sub' master mo a toMasterHandlerDyn tm getSub route (GHandler h) = do sub <- getSub GHandler $ withReaderT (handlerSubData tm (const sub) route) h @@ -217,8 +218,8 @@ instance (anySub ~ anySub' toMasterHandlerMaybe :: (Route sub -> Route master) -> (master -> sub) -> Maybe (Route sub) - -> GHandler sub master a - -> GHandler sub' master a + -> GGHandler sub master mo a + -> GGHandler sub' master mo a toMasterHandlerMaybe tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h @@ -285,7 +286,7 @@ instance Error HandlerContents where instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where failure = GHandler . lift . throwError . HCError -instance RequestReader (GHandler sub master) where +instance RequestReader (GHandler sub master) where -- FIXME kill this typeclass, does not work for GGHandler getRequest = handlerRequest <$> GHandler ask runRequestBody = do x <- GHandler $ lift $ lift $ lift get @@ -419,18 +420,19 @@ safeEh er = YesodApp $ \_ _ _ session -> do session -- | Redirect to the given route. -redirect :: RedirectType -> Route master -> GHandler sub master a +redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a redirect rt url = redirectParams rt url [] -- | Redirects to the given route with the associated query-string parameters. -redirectParams :: RedirectType -> Route master -> [(String, String)] - -> GHandler sub master a +redirectParams :: Monad mo + => RedirectType -> Route master -> [(String, String)] + -> GGHandler sub master mo a redirectParams rt url params = do r <- getUrlRenderParams redirectString rt $ S8.pack $ r url params -- | Redirect to the given URL. -redirectString :: RedirectType -> ByteString -> GHandler sub master a +redirectString :: Monad mo => RedirectType -> ByteString -> GGHandler sub master mo a redirectString rt = GHandler . lift . throwError . HCRedirect rt ultDestKey :: String @@ -440,27 +442,27 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: Route master -> GHandler sub master () +setUltDest :: Monad mo => Route master -> GGHandler sub master mo () setUltDest dest = do render <- getUrlRender setUltDestString $ render dest -- | Same as 'setUltDest', but use the given string. -setUltDestString :: String -> GHandler sub master () +setUltDestString :: Monad mo => String -> GGHandler sub master mo () setUltDestString = setSession ultDestKey -- | Same as 'setUltDest', but uses the current page. -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing. -setUltDest' :: GHandler sub master () +setUltDest' :: Monad mo => GGHandler sub master mo () setUltDest' = do route <- getCurrentRoute case route of Nothing -> return () Just r -> do tm <- getRouteToMaster - gets' <- reqGetParams <$> getRequest + gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask render <- getUrlRenderParams setUltDestString $ render (tm r) gets' @@ -468,9 +470,10 @@ setUltDest' = do -- value from the session. -- -- The ultimate destination is set with 'setUltDest'. -redirectUltDest :: RedirectType +redirectUltDest :: Monad mo + => RedirectType -> Route master -- ^ default destination if nothing in session - -> GHandler sub master () + -> GGHandler sub master mo () redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey @@ -482,16 +485,16 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessage :: Html -> GHandler sub master () +setMessage :: Monad mo => Html -> GGHandler sub master mo () setMessage = setSession msgKey . lbsToChars . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. -- -- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) +getMessage :: Monad mo => GGHandler sub master mo (Maybe Html) getMessage = do - mmsg <- fmap (fmap preEscapedString) $ lookupSession msgKey + mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey deleteSession msgKey return mmsg @@ -499,24 +502,24 @@ 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 :: ContentType -> FilePath -> GHandler sub master a +sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a sendFile ct = GHandler . lift . throwError . HCSendFile ct -- | Bypass remaining handler code and output the given content with a 200 -- status code. -sendResponse :: HasReps c => c -> GHandler sub master a +sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a sendResponse = GHandler . lift . throwError . HCContent W.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a +sendResponseStatus :: (Monad mo, HasReps c) => W.Status -> c -> GGHandler s m mo a sendResponseStatus s = GHandler . lift . throwError . HCContent s . chooseRep -- | Send a 201 "Created" response with the given route as the Location -- response header. -sendResponseCreated :: Route m -> GHandler s m a +sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated url = do r <- getUrlRender GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url @@ -526,7 +529,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 :: W.Response -> GHandler s m b +sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b sendWaiResponse = GHandler . lift . throwError . HCWai -- | Return a 404 not found page. Also denotes no handler available. @@ -549,28 +552,30 @@ invalidArgs = failure . InvalidArgs ------- Headers -- | Set the cookie on the client. -setCookie :: Int -- ^ minutes to timeout +setCookie :: Monad mo + => Int -- ^ minutes to timeout -> ByteString -- ^ key -> ByteString -- ^ value - -> GHandler sub master () + -> GGHandler sub master mo () setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: ByteString -> GHandler sub master () +deleteCookie :: Monad mo => ByteString -> GGHandler sub master mo () deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the -- next request. -setLanguage :: String -> GHandler sub master () +setLanguage :: Monad mo => String -> GGHandler sub master mo () setLanguage = setSession langKey -- | Set an arbitrary response header. -setHeader :: W.ResponseHeader -> ByteString -> GHandler sub master () +setHeader :: Monad mo + => W.ResponseHeader -> ByteString -> GGHandler sub master mo () setHeader a = addHeader . Header a -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. -cacheSeconds :: Int -> GHandler s m () +cacheSeconds :: Monad mo => Int -> GGHandler s m mo () cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat [ "max-age=" , show i @@ -579,16 +584,16 @@ cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired. -neverExpires :: GHandler s m () +neverExpires :: Monad mo => GGHandler s m mo () neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" -- | Set an Expires header in the past, meaning this content should not be -- cached. -alreadyExpired :: GHandler s m () +alreadyExpired :: Monad mo => GGHandler s m mo () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. -expiresAt :: UTCTime -> GHandler s m () +expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 -- | Set a variable in the user's session. @@ -596,20 +601,21 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. -setSession :: String -- ^ key +setSession :: Monad mo + => String -- ^ key -> String -- ^ value - -> GHandler sub master () + -> GGHandler sub master mo () setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. -deleteSession :: String -> GHandler sub master () +deleteSession :: Monad mo => String -> GGHandler sub master mo () deleteSession = GHandler . lift . lift . lift . 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 :: Header -> GHandler sub master () +addHeader :: Monad mo => Header -> GGHandler sub master mo () addHeader = GHandler . lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status @@ -630,19 +636,19 @@ data RedirectType = RedirectPermanent | RedirectSeeOther deriving (Show, Eq) -localNoCurrent :: GHandler s m a -> GHandler s m a +localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a localNoCurrent = GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler -- | Lookup for session data. -lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) +lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue) lookupSession n = GHandler $ do - m <- fmap ghsSession $ lift $ lift $ lift get + m <- liftM ghsSession $ lift $ lift $ lift get return $ Map.lookup n m -- | Get all session variables. -getSession :: GHandler s m SessionMap -getSession = fmap ghsSession $ GHandler $ lift $ lift $ lift get +getSession :: Monad mo => GGHandler s m mo SessionMap +getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get #if TEST @@ -761,7 +767,7 @@ instance MonadTransPeel (GGHandler s m) where -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. -redirectToPost :: Route master -> GHandler sub master a +redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a redirectToPost dest = hamletToRepHtml #if GHC7 [hamlet| @@ -782,11 +788,13 @@ redirectToPost dest = hamletToRepHtml -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content +hamletToContent :: Monad mo + => Hamlet (Route master) -> GGHandler sub master mo Content hamletToContent h = do render <- getUrlRenderParams return $ toContent $ h render -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent +hamletToRepHtml :: Monad mo + => Hamlet (Route master) -> GGHandler sub master mo RepHtml +hamletToRepHtml = liftM RepHtml . hamletToContent From 37c261fa1eda163334d4045e7098eecde3b72495 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 5 Feb 2011 19:57:48 +0200 Subject: [PATCH 063/126] More intelligent cleanPath --- Yesod/Core.hs | 12 ++++++------ Yesod/Dispatch.hs | 6 +++--- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 00d0b0b6..82ef97df 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -179,9 +179,9 @@ class RenderRoute (Route a) => Yesod a where authRoute :: a -> Maybe (Route a) authRoute _ = Nothing - -- | A function used to clean up path segments. It returns 'Nothing' when - -- the given path is already clean, and a 'Just' when Yesod should redirect - -- to the given path pieces. + -- | A function used to clean up path segments. It returns 'Right' with a + -- clean path or 'Left' with a new set of pieces the user should be + -- redirected to. The default implementation enforces: -- -- * No double slashes -- @@ -189,11 +189,11 @@ class RenderRoute (Route a) => Yesod a where -- -- Note that versions of Yesod prior to 0.7 used a different set of rules -- involing trailing slashes. - cleanPath :: a -> [String] -> Maybe [String] + cleanPath :: a -> [String] -> Either [String] [String] cleanPath _ s = if corrected == s - then Nothing - else Just corrected + then Right s + else Left corrected where corrected = filter (not . null) s diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 096ebf02..43c30b21 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -189,11 +189,11 @@ toWaiApp' y key' env = do Just app -> app env Nothing -> case cleanPath y segments of - Nothing -> - case yesodDispatch y key' segments y id of + Right segments' -> + case yesodDispatch y key' segments' y id of Just app -> app env Nothing -> yesodRunner y y id key' Nothing notFound env - Just segments' -> + Left segments' -> let dest = joinPath y (approot y) segments' [] dest' = if S.null (W.queryString env) From 7b7cbc950b42083ffbffcd7d68c53b202681e8c3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 5 Feb 2011 19:58:14 +0200 Subject: [PATCH 064/126] Fix remoteHost session issue --- Yesod/Core.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 82ef97df..81611667 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -239,9 +239,8 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration master - -- FIXME will show remoteHost give the answer I need? will it include port - -- information that changes on each request? - let host = if sessionIpAddress master then S8.pack (show (W.remoteHost req)) else "" + let rh = takeWhile (/= ':') $ show $ W.remoteHost req + let host = if sessionIpAddress master then S8.pack rh else "" let session' = case mkey of Nothing -> [] From 3003c9b3cdd54490a2e1c4bce11ef41aaa1eb28c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Feb 2011 15:44:53 +0200 Subject: [PATCH 065/126] Beginning of new test suite --- Test/CleanPath.hs | 79 +++++++++++++++++++++++++++++++++++++++++++++++ Yesod/Core.hs | 63 ------------------------------------- Yesod/Dispatch.hs | 47 +++------------------------- Yesod/Handler.hs | 16 ---------- runtests.hs | 9 ++---- test/.ignored | 0 test/bar/baz | 0 test/foo | 0 test/tmp/ignored | 0 9 files changed, 85 insertions(+), 129 deletions(-) create mode 100644 Test/CleanPath.hs delete mode 100644 test/.ignored delete mode 100644 test/bar/baz delete mode 100644 test/foo delete mode 100644 test/tmp/ignored diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs new file mode 100644 index 00000000..35fcc333 --- /dev/null +++ b/Test/CleanPath.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.CleanPath (cleanPathTest) where + +import Yesod.Core +import Yesod.Content +import Yesod.Dispatch + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Network.Wai +import Network.Wai.Test + +data Y = Y +mkYesod "Y" [$parseRoutes| +/foo FooR GET +/bar BarR GET +|] + +instance Yesod Y where + approot _ = "http://test" + cleanPath _ ["bar", ""] = Right ["bar"] + cleanPath _ ["bar"] = Left ["bar", ""] + cleanPath _ s = + if corrected == s + then Right s + else Left corrected + where + corrected = filter (not . null) s + +getFooR = return $ RepPlain "foo" +getBarR = return $ RepPlain "bar" + +cleanPathTest :: Test +cleanPathTest = testGroup "Test.CleanPath" + [ testCase "remove trailing slash" removeTrailingSlash + , testCase "noTrailingSlash" noTrailingSlash + , testCase "add trailing slash" addTrailingSlash + , testCase "has trailing slash" hasTrailingSlash + ] + +runner f = toWaiApp Y >>= runSession f +defaultRequest = Request + { pathInfo = "" + , requestHeaders = [] + , queryString = "" + , requestMethod = "GET" + } + +removeTrailingSlash = runner $ do + res <- request defaultRequest + { pathInfo = "/foo/" + } + assertStatus 301 res + assertHeader "Location" "http://test/foo" res + +noTrailingSlash = runner $ do + res <- request defaultRequest + { pathInfo = "/foo" + } + assertStatus 200 res + assertContentType "text/plain; charset=utf-8" res + assertBody "foo" res + +addTrailingSlash = runner $ do + res <- request defaultRequest + { pathInfo = "/bar" + } + assertStatus 301 res + assertHeader "Location" "http://test/bar/" res + +hasTrailingSlash = runner $ do + res <- request defaultRequest + { pathInfo = "/bar/" + } + assertStatus 200 res + assertContentType "text/plain; charset=utf-8" res + assertBody "bar" res diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 81611667..5c58e931 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -22,9 +22,6 @@ module Yesod.Core -- * Misc , yesodVersion , yesodRender -#if TEST - , coreTestSuite -#endif ) where import Yesod.Content @@ -59,15 +56,6 @@ import Web.Cookie (parseCookies) import qualified Data.Map as Map import Data.Time -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -import qualified Data.Text -import qualified Data.Text.Encoding -#endif - #if GHC7 #define HAMLET hamlet #else @@ -486,54 +474,3 @@ yesodRender y u qs = (urlRenderOverride y u) where (ps, qs') = renderRoute u - -#if TEST -coreTestSuite :: Test -coreTestSuite = testGroup "Yesod.Yesod" - [ testProperty "join/split path" propJoinSplitPath - , testCase "join/split path [\".\"]" caseJoinSplitPathDquote - , testCase "utf8 split path" caseUtf8SplitPath - , testCase "utf8 join path" caseUtf8JoinPath - ] - -data TmpYesod = TmpYesod -data TmpRoute = TmpRoute deriving Eq -type instance Route TmpYesod = TmpRoute -instance Yesod TmpYesod where approot _ = "" - -fromString :: String -> S8.ByteString -fromString = Data.Text.Encoding.encodeUtf8 . Data.Text.pack - -propJoinSplitPath :: [String] -> Bool -propJoinSplitPath ss = - splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' []) - == Right ss' - where - ss' = filter (not . null) ss - -caseJoinSplitPathDquote :: Assertion -caseJoinSplitPathDquote = do - splitPath TmpYesod (fromString "/x%2E/") @?= Right ["x."] - splitPath TmpYesod (fromString "/y./") @?= Right ["y."] - joinPath TmpYesod "" ["z."] [] @?= "/z./" - x @?= Right ss - where - x = splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' []) - ss' = filter (not . null) ss - ss = ["a."] - -caseUtf8SplitPath :: Assertion -caseUtf8SplitPath = do - Right ["שלום"] @=? - splitPath TmpYesod (fromString "/שלום/") - Right ["page", "Fooé"] @=? - splitPath TmpYesod (fromString "/page/Fooé/") - Right ["\156"] @=? - splitPath TmpYesod (fromString "/\156/") - Right ["ð"] @=? - splitPath TmpYesod (fromString "/%C3%B0/") - -caseUtf8JoinPath :: Assertion -caseUtf8JoinPath = do - "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] -#endif diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 43c30b21..61410011 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -18,9 +18,6 @@ module Yesod.Dispatch -- * Convert to WAI , toWaiApp , toWaiAppPlain -#if TEST - , dispatchTestSuite -#endif ) where import Prelude hiding (exp) @@ -46,13 +43,6 @@ import Data.Char (isUpper) import Web.Routes (decodePathInfo) -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck -import System.IO.Unsafe -#endif - -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. @@ -181,10 +171,10 @@ toWaiApp' :: (Yesod y, YesodDispatch y y) -> Maybe Key -> W.Application toWaiApp' y key' env = do - let segments = - case decodePathInfo $ B.unpack $ W.pathInfo env of - "":x -> x - x -> x + let dropSlash ('/':x) = x + dropSlash x = x + let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env + -- FIXME cleanPath will not force redirect if yesodDispatch likes its arguments case yesodDispatch y key' segments y id of Just app -> app env Nothing -> @@ -203,32 +193,3 @@ toWaiApp' y key' env = do [ ("Content-Type", "text/plain") , ("Location", B.pack $ dest') ] "Redirecting" - -#if TEST - -dispatchTestSuite :: Test -dispatchTestSuite = testGroup "Yesod.Dispatch" - [ testProperty "encode/decode session" propEncDecSession - , testProperty "get/put time" propGetPutTime - ] - -propEncDecSession :: [(String, String)] -> Bool -propEncDecSession session' = unsafePerformIO $ do - key <- getDefaultKey - now <- getCurrentTime - let expire = addUTCTime 1 now - let rhost = B.pack "some host" - let val = encodeSession key expire rhost session' - return $ Just session' == decodeSession key now rhost val - -propGetPutTime :: UTCTime -> Bool -propGetPutTime t = Right t == runGet getTime (runPut $ putTime t) - -instance Arbitrary UTCTime where - arbitrary = do - a <- arbitrary - b <- arbitrary - return $ addUTCTime (fromRational b) - $ UTCTime (ModifiedJulianDay a) 0 - -#endif diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1bed488b..66127f76 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -98,9 +98,6 @@ module Yesod.Handler , handlerToYAR , yarToResponse , headerToPair -#if TEST - , handlerTestSuite -#endif ) where import Prelude hiding (catch) @@ -136,10 +133,6 @@ import Data.ByteString (ByteString) import Data.Enumerator (Iteratee (..)) import Network.Wai.Parse (parseHttpAccept) -#if TEST -import Test.Framework (testGroup, Test) -#endif - import Yesod.Content import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) @@ -650,15 +643,6 @@ lookupSession n = GHandler $ do getSession :: Monad mo => GGHandler s m mo SessionMap getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get -#if TEST - -handlerTestSuite :: Test -handlerTestSuite = testGroup "Yesod.Handler" - [ - ] - -#endif - handlerToYAR :: (HasReps a, HasReps b) => m -- ^ master site foundation -> s -- ^ sub site foundation diff --git a/runtests.hs b/runtests.hs index 8498ef14..c2fc7d9d 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,12 +1,7 @@ import Test.Framework (defaultMain) - -import Yesod.Content -import Yesod.Dispatch -import Yesod.Handler +import Test.CleanPath main :: IO () main = defaultMain - [ contentTestSuite - , dispatchTestSuite - , handlerTestSuite + [ cleanPathTest ] diff --git a/test/.ignored b/test/.ignored deleted file mode 100644 index e69de29b..00000000 diff --git a/test/bar/baz b/test/bar/baz deleted file mode 100644 index e69de29b..00000000 diff --git a/test/foo b/test/foo deleted file mode 100644 index e69de29b..00000000 diff --git a/test/tmp/ignored b/test/tmp/ignored deleted file mode 100644 index e69de29b..00000000 From 8684ce5b276b4544e4800614b45045670d40bac3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Feb 2011 19:36:49 +0200 Subject: [PATCH 066/126] Proper cleanPath behavior --- Test/CleanPath.hs | 11 +++++++++ Yesod/Dispatch.hs | 29 +++++++++--------------- Yesod/Internal/Dispatch.hs | 46 +++++++++++++++++++++++++++++++++++--- yesod-core.cabal | 3 ++- 4 files changed, 66 insertions(+), 23 deletions(-) diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs index 35fcc333..a3161321 100644 --- a/Test/CleanPath.hs +++ b/Test/CleanPath.hs @@ -15,6 +15,7 @@ import Network.Wai.Test data Y = Y mkYesod "Y" [$parseRoutes| /foo FooR GET +/foo/#String FooStringR GET /bar BarR GET |] @@ -30,6 +31,7 @@ instance Yesod Y where corrected = filter (not . null) s getFooR = return $ RepPlain "foo" +getFooStringR = return . RepPlain . toContent getBarR = return $ RepPlain "bar" cleanPathTest :: Test @@ -38,6 +40,7 @@ cleanPathTest = testGroup "Test.CleanPath" , testCase "noTrailingSlash" noTrailingSlash , testCase "add trailing slash" addTrailingSlash , testCase "has trailing slash" hasTrailingSlash + , testCase "/foo/something" fooSomething ] runner f = toWaiApp Y >>= runSession f @@ -77,3 +80,11 @@ hasTrailingSlash = runner $ do assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "bar" res + +fooSomething = runner $ do + res <- request defaultRequest + { pathInfo = "/foo/something" + } + assertStatus 200 res + assertContentType "text/plain; charset=utf-8" res + assertBody "something" res diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 61410011..2530924b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -20,6 +20,7 @@ module Yesod.Dispatch , toWaiAppPlain ) where +import Data.Either (partitionEithers) import Prelude hiding (exp) import Yesod.Core import Yesod.Handler @@ -35,7 +36,6 @@ import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString as S import Data.ByteString.Lazy.Char8 () import Web.ClientSession @@ -116,7 +116,14 @@ mkYesodGeneral name args clazzes isSub res = do [ FunD (mkName "renderRoute") render ] - yd <- mkYesodDispatch' th' + let splitter :: (THResource, Maybe String) + -> Either + (THResource, Maybe String) + (THResource, Maybe String) + splitter a@((_, SubSite{}), _) = Left a + splitter a = Right a + let (resSub, resLoc) = partitionEithers $ map splitter th' + yd <- mkYesodDispatch' resSub resLoc let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes @@ -174,22 +181,6 @@ toWaiApp' y key' env = do let dropSlash ('/':x) = x dropSlash x = x let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env - -- FIXME cleanPath will not force redirect if yesodDispatch likes its arguments case yesodDispatch y key' segments y id of Just app -> app env - Nothing -> - case cleanPath y segments of - Right segments' -> - case yesodDispatch y key' segments' y id of - Just app -> app env - Nothing -> yesodRunner y y id key' Nothing notFound env - Left segments' -> - let dest = joinPath y (approot y) segments' [] - dest' = - if S.null (W.queryString env) - then dest - else dest ++ '?' : B.unpack (W.queryString env) - in return $ W.responseLBS W.status301 - [ ("Content-Type", "text/plain") - , ("Location", B.pack $ dest') - ] "Redirecting" + Nothing -> yesodRunner y y id key' Nothing notFound env diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index faf687f8..5fd1b434 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} -- | A bunch of Template Haskell used in the Yesod.Dispatch module. module Yesod.Internal.Dispatch ( mkYesodDispatch' @@ -17,6 +18,9 @@ import Yesod.Core (yesodRunner, yesodDispatch) import Data.List (foldl') import Data.Char (toLower) import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Lazy.Char8 () +import qualified Data.ByteString as S +import Yesod.Core (Yesod (joinPath, approot, cleanPath)) {-| @@ -64,16 +68,52 @@ case segments of Obviously we would never want to write code by hand like this, but generating it is not too bad. This function generates a clause for the yesodDispatch function based on a set of routes. + +NOTE: We deal with subsites first; if none of those match, we try to apply +cleanPath. If that indicates a redirect, we perform it. Otherwise, we match +local routes. + -} -mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause -mkYesodDispatch' res = do + +sendRedirect :: Yesod master => master -> [String] -> W.Application +sendRedirect y segments' env = + return $ W.responseLBS W.status301 + [ ("Content-Type", "text/plain") + , ("Location", S8.pack $ dest') + ] "Redirecting" + where + dest = joinPath y (approot y) segments' [] + dest' = + if S.null (W.queryString env) + then dest + else dest ++ '?' : S8.unpack (W.queryString env) + +mkYesodDispatch' :: [((String, Pieces), Maybe String)] + -> [((String, Pieces), Maybe String)] + -> Q Clause +mkYesodDispatch' resSub resLoc = do sub <- newName "sub" master <- newName "master" mkey <- newName "mkey" segments <- newName "segments" + segments' <- newName "segmentsClean" toMasterRoute <- newName "toMasterRoute" nothing <- [|Nothing|] - body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res + bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc + cp <- [|cleanPath|] + sr <- [|sendRedirect|] + just <- [|Just|] + let bodyLoc' = + CaseE (cp `AppE` VarE master `AppE` VarE segments) + [ Match (ConP (mkName "Left") [VarP segments']) + (NormalB $ just `AppE` + (sr `AppE` VarE master `AppE` VarE segments')) + [] + , Match (ConP (mkName "Right") [VarP segments']) + (NormalB bodyLoc) + [] + ] + body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub return $ Clause [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] (NormalB body) diff --git a/yesod-core.cabal b/yesod-core.cabal index 6b4001a4..b91542a1 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -33,7 +33,7 @@ library , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.5 && < 0.12 , template-haskell - , web-routes-quasi >= 0.6.3 && < 0.7 + , web-routes-quasi >= 0.6.3.1 && < 0.7 , hamlet >= 0.7 && < 0.8 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 @@ -74,6 +74,7 @@ executable runtests test-framework-quickcheck2, test-framework-hunit, HUnit, + wai-test, QuickCheck >= 2 && < 3 else Buildable: False From cb3765dfe9eee6e35dc073461425d89915ad1b45 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Feb 2011 19:43:04 +0200 Subject: [PATCH 067/126] Test for correct subsite dispatch --- Test/CleanPath.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs index a3161321..85e87931 100644 --- a/Test/CleanPath.hs +++ b/Test/CleanPath.hs @@ -1,10 +1,12 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} module Test.CleanPath (cleanPathTest) where import Yesod.Core import Yesod.Content import Yesod.Dispatch +import Yesod.Handler (Route) import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit @@ -12,11 +14,28 @@ import Test.HUnit hiding (Test) import Network.Wai import Network.Wai.Test +import qualified Data.ByteString.Lazy.Char8 as L8 + +data Subsite = Subsite +getSubsite = const Subsite +data SubsiteRoute = SubsiteRoute [String] + deriving (Eq, Show, Read) +type instance Route Subsite = SubsiteRoute +instance RenderRoute SubsiteRoute where + renderRoute (SubsiteRoute x) = (x, []) + +instance YesodDispatch Subsite master where + yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS + status200 + [ ("Content-Type", "SUBSITE") + ] $ L8.pack $ show pieces + data Y = Y mkYesod "Y" [$parseRoutes| /foo FooR GET /foo/#String FooStringR GET /bar BarR GET +/subsite SubsiteR Subsite getSubsite |] instance Yesod Y where @@ -41,6 +60,7 @@ cleanPathTest = testGroup "Test.CleanPath" , testCase "add trailing slash" addTrailingSlash , testCase "has trailing slash" hasTrailingSlash , testCase "/foo/something" fooSomething + , testCase "subsite dispatch" subsiteDispatch ] runner f = toWaiApp Y >>= runSession f @@ -88,3 +108,11 @@ fooSomething = runner $ do assertStatus 200 res assertContentType "text/plain; charset=utf-8" res assertBody "something" res + +subsiteDispatch = runner $ do + res <- request defaultRequest + { pathInfo = "/subsite/1/2/3/" + } + assertStatus 200 res + assertContentType "SUBSITE" res + assertBody "[\"1\",\"2\",\"3\",\"\"]" res From 2b70aeb2b3ba43637595c07c2615e53f06cb5303 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Feb 2011 19:54:20 +0200 Subject: [PATCH 068/126] Version bump --- yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core.cabal b/yesod-core.cabal index b91542a1..1e47b9ec 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.7.0 +version: 0.7.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From c556a19febfcd105238ee44c8124312ad9af718c Mon Sep 17 00:00:00 2001 From: Michael <michael@snoyman.com> Date: Fri, 4 Mar 2011 15:56:36 +0200 Subject: [PATCH 069/126] Test.Exceptions --- Test/Exceptions.hs | 47 ++++++++++++++++++++++++++++++++++++++++++++++ runtests.hs | 2 ++ 2 files changed, 49 insertions(+) create mode 100644 Test/Exceptions.hs diff --git a/Test/Exceptions.hs b/Test/Exceptions.hs new file mode 100644 index 00000000..fb869f10 --- /dev/null +++ b/Test/Exceptions.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Exceptions (exceptionsTest) where + +import Yesod.Core +import Yesod.Content +import Yesod.Dispatch +import Yesod.Handler (Route, ErrorResponse (InternalError)) + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Network.Wai +import Network.Wai.Test + +import qualified Data.ByteString.Lazy.Char8 as L8 + +data Y = Y +mkYesod "Y" [$parseRoutes| +/ RootR GET +|] + +instance Yesod Y where + approot _ = "http://test" + errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e + errorHandler x = defaultErrorHandler x + +getRootR = error "FOOBAR" >> return () + +exceptionsTest :: Test +exceptionsTest = testGroup "Test.Exceptions" + [ testCase "500" case500 + ] + +runner f = toWaiApp Y >>= runSession f +defaultRequest = Request + { pathInfo = "" + , requestHeaders = [] + , queryString = "" + , requestMethod = "GET" + } + +case500 = runner $ do + res <- request defaultRequest + assertStatus 500 res + assertBody "FOOBAR" res diff --git a/runtests.hs b/runtests.hs index c2fc7d9d..d4d2c34b 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,7 +1,9 @@ import Test.Framework (defaultMain) import Test.CleanPath +import Test.Exceptions main :: IO () main = defaultMain [ cleanPathTest + , exceptionsTest ] From b899498bd2530576701c65a303e5ea4d2c506b5a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 23 Mar 2011 08:26:11 +0200 Subject: [PATCH 070/126] Added a widget benchmark --- widget-benchmark.hs | 79 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 79 insertions(+) create mode 100644 widget-benchmark.hs diff --git a/widget-benchmark.hs b/widget-benchmark.hs new file mode 100644 index 00000000..f3114462 --- /dev/null +++ b/widget-benchmark.hs @@ -0,0 +1,79 @@ +-- | BigTable benchmark implemented using Hamlet. +-- +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import Criterion.Main +import Text.Hamlet +import Numeric (showInt) +import qualified Data.ByteString.Lazy as L +import qualified Text.Blaze.Renderer.Utf8 as Utf8 +import Data.Monoid (mconcat) +import Text.Blaze.Html5 (table, tr, td) +import Yesod.Widget +import Control.Monad.Trans.Writer +import Control.Monad.Trans.RWS +import Data.Functor.Identity +import Yesod.Internal + +main = defaultMain + [ bench "bigTable html" $ nf bigTableHtml bigTableData + , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData + , bench "bigTable widget" $ nf bigTableWidget bigTableData + , bench "bigTable blaze" $ nf bigTableBlaze bigTableData + ] + where + rows :: Int + rows = 10 + + bigTableData :: [[Int]] + bigTableData = replicate rows [1..10] + {-# NOINLINE bigTableData #-} + +bigTableHtml rows = L.length $ renderHtml [$hamlet| +<table + $forall row <- rows + <tr + $forall cell <- row + <td>#{show cell} +|] + +bigTableHamlet rows = L.length $ renderHamlet id [$hamlet| +<table + $forall row <- rows + <tr + $forall cell <- row + <td>#{show cell} +|] + +bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet| +<table + $forall row <- rows + <tr + $forall cell <- row + <td>#{show cell} +|]) (\_ _ -> "foo") + where + run (GWidget w) = + let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0 + in x + {- + run (GWidget w) = runIdentity $ do + w' <- flip evalStateT 0 + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT w + let ((((((((), + Body body), + _), + _), + _), + _), + _), + _) = w' + + return body + -} + +bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t + where + row r = tr $ mconcat $ map (td . string . show) r From 70eba502de2ae0e36c66cad45e0cbbd5750c7774 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 23 Mar 2011 08:41:30 +0200 Subject: [PATCH 071/126] Migrated Widget to RWS transformer --- Yesod/Core.hs | 15 ++------- Yesod/Internal.hs | 25 ++++++++++++++- Yesod/Widget.hs | 82 +++++++++++++++-------------------------------- yesod-core.cabal | 2 +- 4 files changed, 53 insertions(+), 71 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 5c58e931..c52bdc0d 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -41,8 +41,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid -import Control.Monad.Trans.Writer -import Control.Monad.Trans.State hiding (get, put) +import Control.Monad.Trans.RWS import Text.Hamlet import Text.Cassius import Text.Julius @@ -393,17 +392,7 @@ widgetToPageContent :: (Eq (Route master), Yesod master) => GWidget sub master () -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - Last mTitle), - scripts'), - stylesheets'), - style), - jscript), - Head head') = w' + ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 let title = maybe mempty unTitle mTitle let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' let stylesheets = map (locationToHamlet . unStylesheet) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 6d9eb8fc..34cf642b 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -12,6 +12,7 @@ module Yesod.Internal -- * Cookie names , langKey -- * Widgets + , GWData (..) , Location (..) , UniqueList (..) , Script (..) @@ -32,7 +33,9 @@ module Yesod.Internal ) where import Text.Hamlet (Hamlet, hamlet, Html) -import Data.Monoid (Monoid (..)) +import Text.Cassius (Cassius) +import Text.Julius (Julius) +import Data.Monoid (Monoid (..), Last) import Data.List (nub) import Data.ByteString (ByteString) @@ -120,3 +123,23 @@ nonceKey = "_NONCE" sessionName :: ByteString sessionName = "_SESSION" + +data GWData a = GWData + (Body a) + (Last Title) + (UniqueList (Script a)) + (UniqueList (Stylesheet a)) + (Maybe (Cassius a)) + (Maybe (Julius a)) + (Head a) +instance Monoid (GWData a) where + mempty = GWData mempty mempty mempty mempty mempty mempty mempty + mappend (GWData a1 a2 a3 a4 a5 a6 a7) + (GWData b1 b2 b3 b4 b5 b6 b7) = GWData + (a1 `mappend` b1) + (a2 `mappend` b2) + (a3 `mappend` b3) + (a4 `mappend` b4) + (a5 `mappend` b5) + (a6 `mappend` b6) + (a7 `mappend` b7) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ff9378a8..a7f40f6e 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -33,8 +33,7 @@ module Yesod.Widget ) where import Data.Monoid -import Control.Monad.Trans.Writer -import Control.Monad.Trans.State +import Control.Monad.Trans.RWS import Text.Hamlet import Text.Cassius import Text.Julius @@ -51,24 +50,15 @@ import Control.Monad.IO.Peel (MonadPeelIO) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. -newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a } +newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner m monad a } -- FIXME remove s deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) instance MonadTrans (GGWidget s m) where - lift = GWidget . lift . lift . lift . lift . lift . lift . lift . lift + lift = GWidget . lift type GWidget s m = GGWidget s m (GHandler s m) -type GWInner sub master monad = - WriterT (Body (Route master)) ( - WriterT (Last Title) ( - WriterT (UniqueList (Script (Route master))) ( - WriterT (UniqueList (Stylesheet (Route master))) ( - WriterT (Maybe (Cassius (Route master))) ( - WriterT (Maybe (Julius (Route master))) ( - WriterT (Head (Route master)) ( - StateT Int ( - monad - )))))))) +type GWInner master = RWST () (GWData (Route master)) Int + instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where mempty = return () mappend x y = x >> y @@ -87,53 +77,35 @@ instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) whe x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub w = do master <- lift getYesod - let sr = fromSubRoute sub master - i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get - w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT - $ unGWidget w - let ((((((((a, - body), - title), - scripts), - stylesheets), - style), - jscript), - h), - i') = w' - GWidget $ do - tell body - lift $ tell title - lift $ lift $ tell scripts - lift $ lift $ lift $ tell stylesheets - lift $ lift $ lift $ lift $ tell style - lift $ lift $ lift $ lift $ lift $ tell jscript - lift $ lift $ lift $ lift $ lift $ lift $ tell h - lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' - return a +addSubWidget sub (GWidget w) = do + master <- lift getYesod + let sr = fromSubRoute sub master + s <- GWidget get + (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s + GWidget $ put s' + GWidget $ tell w' + return a -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: Monad m => Html -> GGWidget sub master m () -setTitle = GWidget . lift . tell . Last . Just . Title +setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty -- | Add a 'Hamlet' to the head tag. addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m () -addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head +addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head -- | Add a 'Html' to the head tag. addHtmlHead :: Monad m => Html -> GGWidget sub master m () -addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const +addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag. addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m () -addHamlet = GWidget . tell . Body +addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -- | Add a 'Html' to the body tag. addHtml :: Monad m => Html -> GGWidget sub master m () -addHtml = GWidget . tell . Body . const +addHtml = addHamlet . const -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent. @@ -142,16 +114,15 @@ addWidget = id -- | Add some raw CSS to the style tag. addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m () -addCassius = GWidget . lift . lift . lift . lift . tell . Just +addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty -- | Link to the specified local stylesheet. addStylesheet :: Monad m => Route master -> GGWidget sub master m () -addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local +addStylesheet x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Local x) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: Monad m => String -> GGWidget sub master m () -addStylesheetRemote = - GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote +addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addStylesheetEither = either addStylesheet addStylesheetRemote @@ -161,24 +132,23 @@ addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. addScript :: Monad m => Route master -> GGWidget sub master m () -addScript = GWidget . lift . lift . tell . toUnique . Script . Local +addScript x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Local x) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: Monad m => String -> GGWidget sub master m () -addScriptRemote = - GWidget . lift . lift . tell . toUnique . Script . Remote +addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag. addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m () -addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just +addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m)) extractBody (GWidget w) = - GWidget $ mapWriterT (liftM go) w + GWidget $ mapRWST (liftM go) w where - go ((), Body h) = (h, Body mempty) + go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/yesod-core.cabal b/yesod-core.cabal index 1e47b9ec..38ab6a5a 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.7.0.1 +version: 0.7.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 77fee84f5d9de1146601d6b09350510b2e97a98b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 23 Mar 2011 23:28:11 +0200 Subject: [PATCH 072/126] Strict fields in GWData --- Yesod/Internal.hs | 14 +++++++------- widget-benchmark.hs | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 34cf642b..0d7ce029 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -125,13 +125,13 @@ sessionName :: ByteString sessionName = "_SESSION" data GWData a = GWData - (Body a) - (Last Title) - (UniqueList (Script a)) - (UniqueList (Stylesheet a)) - (Maybe (Cassius a)) - (Maybe (Julius a)) - (Head a) + !(Body a) + !(Last Title) + !(UniqueList (Script a)) + !(UniqueList (Stylesheet a)) + !(Maybe (Cassius a)) + !(Maybe (Julius a)) + !(Head a) instance Monoid (GWData a) where mempty = GWData mempty mempty mempty mempty mempty mempty mempty mappend (GWData a1 a2 a3 a4 a5 a6 a7) diff --git a/widget-benchmark.hs b/widget-benchmark.hs index f3114462..9be4acd8 100644 --- a/widget-benchmark.hs +++ b/widget-benchmark.hs @@ -24,7 +24,7 @@ main = defaultMain ] where rows :: Int - rows = 10 + rows = 1000 bigTableData :: [[Int]] bigTableData = replicate rows [1..10] From 4bbbc78f2b98e28dc024c98d6170cac2a12bff6b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 10 Mar 2011 11:32:43 +0200 Subject: [PATCH 073/126] WAI 0.4 --- Test/CleanPath.hs | 18 +++++---- Yesod/Content.hs | 8 ++-- Yesod/Core.hs | 21 ++++++---- Yesod/Dispatch.hs | 8 +--- Yesod/Handler.hs | 83 +++++++++++++++++++------------------- Yesod/Internal.hs | 16 ++++---- Yesod/Internal/Dispatch.hs | 12 +++--- Yesod/Internal/Request.hs | 20 ++++----- Yesod/Internal/Session.hs | 5 ++- Yesod/Request.hs | 7 ++-- yesod-core.cabal | 13 +++--- 11 files changed, 112 insertions(+), 99 deletions(-) diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs index 85e87931..fe9da96f 100644 --- a/Test/CleanPath.hs +++ b/Test/CleanPath.hs @@ -13,6 +13,7 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import Network.Wai import Network.Wai.Test +import Network.HTTP.Types (status200, decodePathSegments) import qualified Data.ByteString.Lazy.Char8 as L8 @@ -65,22 +66,23 @@ cleanPathTest = testGroup "Test.CleanPath" runner f = toWaiApp Y >>= runSession f defaultRequest = Request - { pathInfo = "" + { pathInfo = [] , requestHeaders = [] - , queryString = "" + , queryString = [] + , rawQueryString = "" , requestMethod = "GET" } removeTrailingSlash = runner $ do res <- request defaultRequest - { pathInfo = "/foo/" + { pathInfo = decodePathSegments "/foo/" } assertStatus 301 res assertHeader "Location" "http://test/foo" res noTrailingSlash = runner $ do res <- request defaultRequest - { pathInfo = "/foo" + { pathInfo = decodePathSegments "/foo" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res @@ -88,14 +90,14 @@ noTrailingSlash = runner $ do addTrailingSlash = runner $ do res <- request defaultRequest - { pathInfo = "/bar" + { pathInfo = decodePathSegments "/bar" } assertStatus 301 res assertHeader "Location" "http://test/bar/" res hasTrailingSlash = runner $ do res <- request defaultRequest - { pathInfo = "/bar/" + { pathInfo = decodePathSegments "/bar/" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res @@ -103,7 +105,7 @@ hasTrailingSlash = runner $ do fooSomething = runner $ do res <- request defaultRequest - { pathInfo = "/foo/something" + { pathInfo = decodePathSegments "/foo/something" } assertStatus 200 res assertContentType "text/plain; charset=utf-8" res @@ -111,7 +113,7 @@ fooSomething = runner $ do subsiteDispatch = runner $ do res <- request defaultRequest - { pathInfo = "/subsite/1/2/3/" + { pathInfo = decodePathSegments "/subsite/1/2/3/" } assertStatus 200 res assertContentType "SUBSITE" res diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 1a238c93..21bdc4c4 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -44,7 +44,6 @@ module Yesod.Content import Data.Maybe (mapMaybe) import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T @@ -62,6 +61,7 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Data.String (IsString (fromString)) +import qualified Data.Ascii as A data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentEnum (forall a. Enumerator Builder IO a) @@ -167,7 +167,7 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = B.ByteString +type ContentType = A.Ascii typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -216,8 +216,8 @@ typeOctet = "application/octet-stream" -- -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: B.ByteString -> B.ByteString -simpleContentType = S8.takeWhile (/= ';') +simpleContentType :: A.Ascii -> A.Ascii +simpleContentType = A.unsafeFromByteString . fst . B.breakByte 59 . A.toByteString -- 59 == ; -- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> String diff --git a/Yesod/Core.hs b/Yesod/Core.hs index c52bdc0d..c1c06369 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -27,6 +27,7 @@ module Yesod.Core import Yesod.Content import Yesod.Handler +import Control.Arrow ((***)) import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Widget @@ -37,7 +38,6 @@ import Yesod.Internal.Session import Yesod.Internal.Request import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid @@ -45,7 +45,6 @@ import Control.Monad.Trans.RWS import Text.Hamlet import Text.Cassius import Text.Julius -import Web.Routes import Text.Blaze (preEscapedLazyText) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) @@ -54,6 +53,9 @@ import Control.Monad.IO.Class (liftIO) import Web.Cookie (parseCookies) import qualified Data.Map as Map import Data.Time +import Network.HTTP.Types (encodePath) +import qualified Data.Text as TS +import qualified Data.Ascii as A #if GHC7 #define HAMLET hamlet @@ -188,10 +190,15 @@ class RenderRoute (Route a) => Yesod a where -- be the inverse of 'splitPath'. joinPath :: a -> String -- ^ application root - -> [String] -- ^ path pieces + -> [String] -- ^ path pieces FIXME Text -> [(String, String)] -- ^ query string -> String - joinPath _ ar pieces qs = ar ++ '/' : encodePathInfo pieces qs + joinPath _ ar pieces qs' = + ar ++ A.toString (A.fromAsciiBuilder $ encodePath (map TS.pack pieces) qs) + where + qs = map (charsToBs *** go) qs' + go "" = Nothing + go x = Just $ charsToBs x -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and @@ -268,7 +275,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do -> encodeSession key exp' host $ Map.toList $ Map.insert nonceKey nonce sm - _ -> S.empty + _ -> mempty hs' = case mkey of Nothing -> hs @@ -322,7 +329,7 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let path' = bsToChars $ W.pathInfo r + let path' = bsToChars $ W.rawPathInfo r applyLayout' "Not Found" #if GHC7 [hamlet| @@ -372,7 +379,7 @@ defaultErrorHandler (BadMethod m) = [$hamlet| #endif <h1>Method Not Supported -<p>Method "#{m}" not supported +<p>Method "#{A.toText m}" not supported |] -- | Return the same URL if the user is authorized to see it. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2530924b..1f328a14 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -35,13 +35,11 @@ import qualified Network.Wai as W import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip -import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 () import Web.ClientSession import Data.Char (isUpper) - -import Web.Routes (decodePathInfo) +import qualified Data.Text as TS -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. @@ -178,9 +176,7 @@ toWaiApp' :: (Yesod y, YesodDispatch y y) -> Maybe Key -> W.Application toWaiApp' y key' env = do - let dropSlash ('/':x) = x - dropSlash x = x - let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env + let segments = map TS.unpack $ W.pathInfo env case yesodDispatch y key' segments y id of Just app -> app env Nothing -> yesodRunner y y id key' Nothing notFound env diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 66127f76..5da98291 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -120,6 +120,7 @@ import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..)) import System.IO import qualified Network.Wai as W +import qualified Network.HTTP.Types as H import Control.Failure (Failure (failure)) import Text.Hamlet @@ -128,7 +129,6 @@ import Control.Monad.IO.Peel (MonadPeelIO) import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) import qualified Data.Map as Map import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 import Data.ByteString (ByteString) import Data.Enumerator (Iteratee (..)) import Network.Wai.Parse (parseHttpAccept) @@ -136,10 +136,11 @@ import Network.Wai.Parse (parseHttpAccept) import Yesod.Content import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) -import Blaze.ByteString.Builder (toByteString) import Data.Enumerator (run_, ($$)) import Control.Arrow (second, (***)) import qualified Network.Wai.Parse as NWP +import qualified Data.Ascii as A +import Data.Monoid (mappend, mempty) -- | The type-safe URLs associated with a site argument. type family Route a @@ -152,7 +153,7 @@ data HandlerData sub master = HandlerData , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> [(String, String)] -> String) + , handlerRender :: (Route master -> [(String, String)] -> String) -- FIXME replace output String with Ascii , handlerToMaster :: Route sub -> Route master } @@ -264,14 +265,14 @@ newtype YesodApp = YesodApp data YesodAppResult = YARWai W.Response - | YARPlain W.Status [Header] ContentType Content SessionMap + | YARPlain H.Status [Header] ContentType Content SessionMap data HandlerContents = - HCContent W.Status ChooseRep + HCContent H.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath - | HCRedirect RedirectType ByteString - | HCCreated ByteString + | HCRedirect RedirectType A.Ascii + | HCCreated A.Ascii | HCWai W.Response instance Error HandlerContents where @@ -363,7 +364,7 @@ runHandler handler mrender sroute tomr ma sa = $ flip runReaderT hd $ unGHandler handler ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) - let contents = either id (HCContent W.status200 . chooseRep) contents' + let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession case yar of @@ -372,7 +373,7 @@ runHandler handler mrender sroute tomr ma sa = in return $ YARPlain (getStatus e) hs' ct c sess YARWai _ -> return yar let sendFile' ct fp = - return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession + return $ YARPlain H.status200 (headers []) ct (ContentFile fp) finalSession case contents of HCContent status a -> do (ct, c) <- liftIO $ chooseRep a cts @@ -389,7 +390,7 @@ runHandler handler mrender sroute tomr ma sa = HCCreated loc -> do let hs = Header "Location" loc : headers [] return $ YARPlain - (W.Status 201 (S8.pack "Created")) + H.status201 hs typePlain emptyContent @@ -406,7 +407,7 @@ safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ YARPlain - W.status500 + H.status500 [] typePlain (toContent ("Internal Server Error" :: S.ByteString)) @@ -422,10 +423,10 @@ redirectParams :: Monad mo -> GGHandler sub master mo a redirectParams rt url params = do r <- getUrlRenderParams - redirectString rt $ S8.pack $ r url params + redirectString rt $ A.unsafeFromString $ r url params -- | Redirect to the given URL. -redirectString :: Monad mo => RedirectType -> ByteString -> GGHandler sub master mo a +redirectString :: Monad mo => RedirectType -> A.Ascii -> GGHandler sub master mo a redirectString rt = GHandler . lift . throwError . HCRedirect rt ultDestKey :: String @@ -470,7 +471,7 @@ redirectUltDest :: Monad mo redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt . S8.pack) mdest + maybe (redirect rt def) (redirectString rt . A.unsafeFromString) mdest msgKey :: String msgKey = "_MSG" @@ -501,12 +502,12 @@ sendFile ct = GHandler . lift . throwError . HCSendFile ct -- | Bypass remaining handler code and output the given content with a 200 -- status code. sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a -sendResponse = GHandler . lift . throwError . HCContent W.status200 +sendResponse = GHandler . lift . throwError . HCContent H.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: (Monad mo, HasReps c) => W.Status -> c -> GGHandler s m mo a +sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a sendResponseStatus s = GHandler . lift . throwError . HCContent s . chooseRep @@ -515,7 +516,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url + GHandler $ lift $ throwError $ HCCreated $ A.unsafeFromString $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session @@ -533,7 +534,7 @@ notFound = failure NotFound badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest - failure $ BadMethod $ bsToChars $ W.requestMethod w + failure $ BadMethod $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => String -> m a @@ -547,29 +548,29 @@ invalidArgs = failure . InvalidArgs -- | Set the cookie on the client. setCookie :: Monad mo => Int -- ^ minutes to timeout - -> ByteString -- ^ key - -> ByteString -- ^ value + -> A.Ascii -- ^ key + -> A.Ascii -- ^ value -> GGHandler sub master mo () setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: Monad mo => ByteString -> GGHandler sub master mo () +deleteCookie :: Monad mo => A.Ascii -> GGHandler sub master mo () deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the -- next request. setLanguage :: Monad mo => String -> GGHandler sub master mo () -setLanguage = setSession langKey +setLanguage = setSession (A.toString langKey) -- | Set an arbitrary response header. setHeader :: Monad mo - => W.ResponseHeader -> ByteString -> GGHandler sub master mo () + => A.CIAscii -> A.Ascii -> GGHandler sub master mo () setHeader a = addHeader . Header a -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: Monad mo => Int -> GGHandler s m mo () -cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat +cacheSeconds i = setHeader "Cache-Control" $ A.unsafeFromString $ concat [ "max-age=" , show i , ", public" @@ -587,7 +588,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () -expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 +expiresAt = setHeader "Expires" . A.unsafeFromString . formatRFC1123 -- | Set a variable in the user's session. -- @@ -611,17 +612,17 @@ modSession f x = x { ghsSession = f $ ghsSession x } addHeader :: Monad mo => Header -> GGHandler sub master mo () addHeader = GHandler . lift . lift . tell . (:) -getStatus :: ErrorResponse -> W.Status -getStatus NotFound = W.status404 -getStatus (InternalError _) = W.status500 -getStatus (InvalidArgs _) = W.status400 -getStatus (PermissionDenied _) = W.status403 -getStatus (BadMethod _) = W.status405 +getStatus :: ErrorResponse -> H.Status +getStatus NotFound = H.status404 +getStatus (InternalError _) = H.status500 +getStatus (InvalidArgs _) = H.status400 +getStatus (PermissionDenied _) = H.status403 +getStatus (BadMethod _) = H.status405 -getRedirectStatus :: RedirectType -> W.Status -getRedirectStatus RedirectPermanent = W.status301 -getRedirectStatus RedirectTemporary = W.status302 -getRedirectStatus RedirectSeeOther = W.status303 +getRedirectStatus :: RedirectType -> H.Status +getRedirectStatus RedirectPermanent = H.status301 +getRedirectStatus RedirectTemporary = H.status302 +getRedirectStatus RedirectSeeOther = H.status303 -- | Different types of redirects. data RedirectType = RedirectPermanent @@ -665,7 +666,7 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = type HeaderRenderer = [Header] -> ContentType -> SessionMap - -> [(W.ResponseHeader, ByteString)] + -> [(A.CIAscii, A.Ascii)] yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response yarToResponse _ (YARWai a) = a @@ -679,7 +680,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders where finalHeaders = renderHeaders hs ct sessionFinal - finalHeaders' len = ("Content-Length", S8.pack $ show len) + finalHeaders' len = ("Content-Length", A.unsafeFromString $ show len) : finalHeaders {- getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -703,16 +704,16 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept - . fromMaybe S.empty + . fromMaybe mempty . lookup "Accept" . W.requestHeaders -- | Convert Header to a key/value pair. headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> Header - -> (W.ResponseHeader, ByteString) + -> (A.CIAscii, A.Ascii) headerToPair getExpires (AddCookie minutes key value) = - ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie + ("Set-Cookie", A.fromAsciiBuilder $ renderSetCookie $ SetCookie { setCookieName = key , setCookieValue = value , setCookiePath = Just "/" -- FIXME make a config option, or use approot? @@ -721,7 +722,7 @@ headerToPair getExpires (AddCookie minutes key value) = }) headerToPair _ (DeleteCookie key) = ( "Set-Cookie" - , key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" + , key `mappend` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" ) headerToPair _ (Header key value) = (key, value) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 0d7ce029..82205bce 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -49,10 +49,12 @@ import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT -import qualified Network.Wai as W import Data.Typeable (Typeable) import Control.Exception (Exception) +import qualified Data.Ascii as A +import qualified Network.HTTP.Types as H + #if GHC7 #define HAMLET hamlet #else @@ -66,19 +68,19 @@ data ErrorResponse = | InternalError String | InvalidArgs [String] | PermissionDenied String - | BadMethod String + | BadMethod H.Method deriving (Show, Eq, Typeable) instance Exception ErrorResponse ----- header stuff -- | Headers to be added to a 'Result'. data Header = - AddCookie Int ByteString ByteString - | DeleteCookie ByteString - | Header W.ResponseHeader ByteString + AddCookie Int A.Ascii A.Ascii + | DeleteCookie A.Ascii + | Header A.CIAscii A.Ascii deriving (Eq, Show) -langKey :: String +langKey :: A.Ascii langKey = "_LANG" data Location url = Local url | Remote String @@ -121,7 +123,7 @@ charsToBs = T.encodeUtf8 . T.pack nonceKey :: String nonceKey = "_NONCE" -sessionName :: ByteString +sessionName :: A.Ascii sessionName = "_SESSION" data GWData a = GWData diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 5fd1b434..2f29c199 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -21,6 +21,8 @@ import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy.Char8 () import qualified Data.ByteString as S import Yesod.Core (Yesod (joinPath, approot, cleanPath)) +import Network.HTTP.Types (status301) +import qualified Data.Ascii as A {-| @@ -77,16 +79,16 @@ local routes. sendRedirect :: Yesod master => master -> [String] -> W.Application sendRedirect y segments' env = - return $ W.responseLBS W.status301 + return $ W.responseLBS status301 [ ("Content-Type", "text/plain") - , ("Location", S8.pack $ dest') + , ("Location", A.unsafeFromString $ dest') ] "Redirecting" where dest = joinPath y (approot y) segments' [] dest' = - if S.null (W.queryString env) + if S.null (W.rawQueryString env) then dest - else dest ++ '?' : S8.unpack (W.queryString env) + else dest ++ '?' : S8.unpack (W.rawQueryString env) mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> [((String, Pieces), Maybe String)] @@ -147,7 +149,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met onSuccess <- newName "onSuccess" req <- newName "req" badMethod' <- [|badMethod|] - rm <- [|S8.unpack . W.requestMethod|] + rm <- [|A.toString . W.requestMethod|] let caseExp = rm `AppE` VarE req yr <- [|yesodRunner|] cr <- [|fmap chooseRep|] diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs index 08a4a4e0..d4f1045e 100644 --- a/Yesod/Internal/Request.hs +++ b/Yesod/Internal/Request.hs @@ -6,32 +6,32 @@ module Yesod.Internal.Request import Yesod.Request import Control.Arrow (first, (***)) import qualified Network.Wai.Parse as NWP -import Data.Maybe (fromMaybe) import Yesod.Internal import qualified Network.Wai as W -import qualified Data.ByteString as S import System.Random (randomR, newStdGen) import Web.Cookie (parseCookies) +import qualified Data.Ascii as A +import Data.Monoid (mempty) parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> Maybe a -> IO Request parseWaiRequest env session' key' = do - let gets' = map (bsToChars *** bsToChars) - $ NWP.parseQueryString $ W.queryString env - let reqCookie = fromMaybe S.empty $ lookup "Cookie" + let gets' = map (bsToChars *** maybe "" bsToChars) + $ W.queryString env + let reqCookie = maybe mempty id $ lookup "Cookie" $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie + cookies' = parseCookies reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang - langs' = case lookup langKey session' of + langs = map A.toString $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup (A.toString langKey) session' of Nothing -> langs Just x -> x : langs langs'' = case lookup langKey cookies' of Nothing -> langs' - Just x -> x : langs' - langs''' = case lookup langKey gets' of + Just x -> A.toString x : langs' + langs''' = case lookup (A.toString langKey) gets' of Nothing -> langs'' Just x -> x : langs'' nonce <- case (key', lookup nonceKey session') of diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs index cb87d96c..e97e55a5 100644 --- a/Yesod/Internal/Session.hs +++ b/Yesod/Internal/Session.hs @@ -8,19 +8,20 @@ import Data.Serialize import Data.Time import Data.ByteString (ByteString) import Control.Monad (guard) +import qualified Data.Ascii as A encodeSession :: CS.Key -> UTCTime -- ^ expire time -> ByteString -- ^ remote host -> [(String, String)] -- ^ session - -> ByteString -- ^ cookie value + -> A.Ascii -- ^ cookie value encodeSession key expire rhost session' = CS.encrypt key $ encode $ SessionCookie expire rhost session' decodeSession :: CS.Key -> UTCTime -- ^ current time -> ByteString -- ^ remote host field - -> ByteString -- ^ cookie value + -> A.Ascii -- ^ cookie value -> Maybe [(String, String)] decodeSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 37a02960..22efe036 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -43,6 +43,7 @@ import Control.Monad.IO.Class import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) +import qualified Data.Ascii as A type ParamName = String type ParamValue = String @@ -92,7 +93,7 @@ data FileInfo = FileInfo -- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)] - , reqCookies :: [(ParamName, ParamValue)] + , reqCookies :: [(A.Ascii, A.Ascii)] , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [String] @@ -141,11 +142,11 @@ lookupFiles pn = do return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupCookie :: RequestReader m => A.Ascii -> m (Maybe A.Ascii) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: RequestReader m => ParamName -> m [ParamValue] +lookupCookies :: RequestReader m => A.Ascii -> m [A.Ascii] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr diff --git a/yesod-core.cabal b/yesod-core.cabal index 38ab6a5a..ab052ce8 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.7.0.2 +version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -28,8 +28,8 @@ library else build-depends: base >= 4 && < 4.3 build-depends: time >= 1.1.4 && < 1.3 - , wai >= 0.3 && < 0.4 - , wai-extra >= 0.3 && < 0.4 + , wai >= 0.4 && < 0.5 + , wai-extra >= 0.4 && < 0.5 , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.5 && < 0.12 , template-haskell @@ -37,17 +37,18 @@ library , hamlet >= 0.7 && < 0.8 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 - , clientsession >= 0.4.0 && < 0.5 + , clientsession >= 0.5 && < 0.6 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.2 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1 - , web-routes >= 0.23 && < 0.24 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 - , cookie >= 0.0 && < 0.1 + , cookie >= 0.1 && < 0.2 , blaze-html >= 0.4 && < 0.5 + , ascii >= 0.0.2 && < 0.1 + , http-types >= 0.5 && < 0.6 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch From a221c1c8320ea078ff27478a84bedea4bfa14f79 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Mar 2011 23:16:36 +0200 Subject: [PATCH 074/126] approot, joinPath, a few others are Ascii --- Yesod/Core.hs | 26 ++++++++++++++------------ Yesod/Internal.hs | 1 - Yesod/Internal/Dispatch.hs | 17 +++++++++++------ 3 files changed, 25 insertions(+), 19 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index c1c06369..498bfc27 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -55,6 +55,7 @@ import qualified Data.Map as Map import Data.Time import Network.HTTP.Types (encodePath) import qualified Data.Text as TS +import qualified Data.Text.Encoding as TE import qualified Data.Ascii as A #if GHC7 @@ -64,7 +65,7 @@ import qualified Data.Ascii as A #endif class Eq u => RenderRoute u where - renderRoute :: u -> ([String], [(String, String)]) + renderRoute :: u -> ([String], [(String, String)]) -- FIXME switch to Text? -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -98,7 +99,7 @@ class RenderRoute (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> String + approot :: a -> A.Ascii -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -135,7 +136,7 @@ class RenderRoute (Route a) => Yesod a where -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe String + urlRenderOverride :: a -> Route a -> Maybe A.AsciiBuilder urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -189,16 +190,15 @@ class RenderRoute (Route a) => Yesod a where -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. joinPath :: a - -> String -- ^ application root - -> [String] -- ^ path pieces FIXME Text - -> [(String, String)] -- ^ query string - -> String - joinPath _ ar pieces qs' = - ar ++ A.toString (A.fromAsciiBuilder $ encodePath (map TS.pack pieces) qs) + -> A.AsciiBuilder -- ^ application root + -> [TS.Text] -- ^ path pieces FIXME Text + -> [(TS.Text, TS.Text)] -- ^ query string + -> A.AsciiBuilder + joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs where - qs = map (charsToBs *** go) qs' + qs = map (TE.encodeUtf8 *** go) qs' go "" = Nothing - go x = Just $ charsToBs x + go x = Just $ TE.encodeUtf8 x -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and @@ -465,8 +465,10 @@ yesodRender :: Yesod y -> [(String, String)] -> String yesodRender y u qs = + A.toString $ A.fromAsciiBuilder $ fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') + ( joinPath y (A.toAsciiBuilder $ approot y) (map TS.pack ps) + $ map (TS.pack *** TS.pack) $ qs ++ qs') (urlRenderOverride y u) where (ps, qs') = renderRoute u diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 82205bce..b9a3e64d 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -38,7 +38,6 @@ import Text.Julius (Julius) import Data.Monoid (Monoid (..), Last) import Data.List (nub) -import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 2f29c199..2da55d1b 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -17,12 +17,14 @@ import qualified Network.Wai as W import Yesod.Core (yesodRunner, yesodDispatch) import Data.List (foldl') import Data.Char (toLower) -import qualified Data.ByteString.Char8 as S8 -import Data.ByteString.Lazy.Char8 () import qualified Data.ByteString as S import Yesod.Core (Yesod (joinPath, approot, cleanPath)) import Network.HTTP.Types (status301) import qualified Data.Ascii as A +import Data.Text (Text) +import Data.Monoid (mappend) +import qualified Blaze.ByteString.Builder +import qualified Blaze.ByteString.Builder.Char8 {-| @@ -77,18 +79,21 @@ local routes. -} -sendRedirect :: Yesod master => master -> [String] -> W.Application +sendRedirect :: Yesod master => master -> [Text] -> W.Application sendRedirect y segments' env = return $ W.responseLBS status301 [ ("Content-Type", "text/plain") - , ("Location", A.unsafeFromString $ dest') + , ("Location", A.fromAsciiBuilder dest') ] "Redirecting" where - dest = joinPath y (approot y) segments' [] + dest = joinPath y (A.toAsciiBuilder $ approot y) segments' [] dest' = if S.null (W.rawQueryString env) then dest - else dest ++ '?' : S8.unpack (W.rawQueryString env) + else A.unsafeFromBuilder + (A.toBuilder dest `mappend` + Blaze.ByteString.Builder.Char8.fromChar '?' `mappend` + Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> [((String, Pieces), Maybe String)] From 33db6ced91578d71b9134b92ecf2384a3b7c27ab Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 24 Mar 2011 16:32:44 +0200 Subject: [PATCH 075/126] Major modification of data types --- Test/CleanPath.hs | 5 ++-- Test/Exceptions.hs | 4 +-- Yesod/Content.hs | 7 ++--- Yesod/Core.hs | 35 ++++++++++++---------- Yesod/Dispatch.hs | 6 ++-- Yesod/Handler.hs | 60 +++++++++++++++++++++----------------- Yesod/Internal.hs | 5 ++-- Yesod/Internal/Dispatch.hs | 15 +++++----- Yesod/Internal/Request.hs | 10 +++---- Yesod/Internal/Session.hs | 5 ++-- Yesod/Request.hs | 2 +- yesod-core.cabal | 16 +++++----- 12 files changed, 88 insertions(+), 82 deletions(-) diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs index fe9da96f..f00c7c93 100644 --- a/Test/CleanPath.hs +++ b/Test/CleanPath.hs @@ -16,10 +16,11 @@ import Network.Wai.Test import Network.HTTP.Types (status200, decodePathSegments) import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Text as TS data Subsite = Subsite getSubsite = const Subsite -data SubsiteRoute = SubsiteRoute [String] +data SubsiteRoute = SubsiteRoute [TS.Text] deriving (Eq, Show, Read) type instance Route Subsite = SubsiteRoute instance RenderRoute SubsiteRoute where @@ -48,7 +49,7 @@ instance Yesod Y where then Right s else Left corrected where - corrected = filter (not . null) s + corrected = filter (not . TS.null) s getFooR = return $ RepPlain "foo" getFooStringR = return . RepPlain . toContent diff --git a/Test/Exceptions.hs b/Test/Exceptions.hs index fb869f10..01a7c7c1 100644 --- a/Test/Exceptions.hs +++ b/Test/Exceptions.hs @@ -35,9 +35,9 @@ exceptionsTest = testGroup "Test.Exceptions" runner f = toWaiApp Y >>= runSession f defaultRequest = Request - { pathInfo = "" + { pathInfo = [] , requestHeaders = [] - , queryString = "" + , queryString = [] , requestMethod = "GET" } diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 21bdc4c4..46c9ac65 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -61,7 +61,6 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Data.String (IsString (fromString)) -import qualified Data.Ascii as A data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentEnum (forall a. Enumerator Builder IO a) @@ -167,7 +166,7 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = A.Ascii +type ContentType = B.ByteString typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -216,8 +215,8 @@ typeOctet = "application/octet-stream" -- -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: A.Ascii -> A.Ascii -simpleContentType = A.unsafeFromByteString . fst . B.breakByte 59 . A.toByteString -- 59 == ; +simpleContentType :: ContentType -> ContentType +simpleContentType = fst . B.breakByte 59 -- 59 == ; -- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> String diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 498bfc27..7bb97a76 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -54,9 +54,11 @@ import Web.Cookie (parseCookies) import qualified Data.Map as Map import Data.Time import Network.HTTP.Types (encodePath) +import qualified Network.HTTP.Types as H import qualified Data.Text as TS +import Data.Text (Text) import qualified Data.Text.Encoding as TE -import qualified Data.Ascii as A +import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) #if GHC7 #define HAMLET hamlet @@ -65,7 +67,7 @@ import qualified Data.Ascii as A #endif class Eq u => RenderRoute u where - renderRoute :: u -> ([String], [(String, String)]) -- FIXME switch to Text? + renderRoute :: u -> ([Text], [(Text, Text)]) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -74,7 +76,7 @@ class YesodDispatch a master where :: Yesod master => a -> Maybe CS.Key - -> [String] + -> [Text] -> master -> (Route a -> Route master) -> Maybe W.Application @@ -99,7 +101,7 @@ class RenderRoute (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> A.Ascii + approot :: a -> H.Ascii -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -136,7 +138,7 @@ class RenderRoute (Route a) => Yesod a where -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe A.AsciiBuilder + urlRenderOverride :: a -> Route a -> Maybe Builder urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -179,21 +181,21 @@ class RenderRoute (Route a) => Yesod a where -- -- Note that versions of Yesod prior to 0.7 used a different set of rules -- involing trailing slashes. - cleanPath :: a -> [String] -> Either [String] [String] + cleanPath :: a -> [Text] -> Either [Text] [Text] cleanPath _ s = if corrected == s then Right s else Left corrected where - corrected = filter (not . null) s + corrected = filter (not . TS.null) s -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. joinPath :: a - -> A.AsciiBuilder -- ^ application root + -> Builder -- ^ application root -> [TS.Text] -- ^ path pieces FIXME Text -> [(TS.Text, TS.Text)] -- ^ query string - -> A.AsciiBuilder + -> Builder joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs where qs = map (TE.encodeUtf8 *** go) qs' @@ -379,7 +381,7 @@ defaultErrorHandler (BadMethod m) = [$hamlet| #endif <h1>Method Not Supported -<p>Method "#{A.toText m}" not supported +<p>Method "#{S8.unpack m}" not supported |] -- | Return the same URL if the user is authorized to see it. @@ -411,7 +413,8 @@ widgetToPageContent (GWidget w) = do jelper :: Julius url -> Hamlet url jelper = fmap jsToHtml - render <- getUrlRenderParams + renderFIXME <- getUrlRenderParams + let render a b = renderFIXME a $ map (TS.pack *** TS.pack) b let renderLoc x = case x of Nothing -> Nothing @@ -462,13 +465,13 @@ yesodVersion = showVersion Paths_yesod_core.version yesodRender :: Yesod y => y -> Route y - -> [(String, String)] - -> String + -> [(Text, Text)] + -> String -- FIXME yesodRender y u qs = - A.toString $ A.fromAsciiBuilder $ + S8.unpack $ toByteString $ fromMaybe - ( joinPath y (A.toAsciiBuilder $ approot y) (map TS.pack ps) - $ map (TS.pack *** TS.pack) $ qs ++ qs') + (joinPath y (fromByteString $ approot y) ps + $ qs ++ qs') (urlRenderOverride y u) where (ps, qs') = renderRoute u diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 1f328a14..d868498d 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -39,7 +39,6 @@ import Data.ByteString.Lazy.Char8 () import Web.ClientSession import Data.Char (isUpper) -import qualified Data.Text as TS -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. @@ -175,8 +174,7 @@ toWaiApp' :: (Yesod y, YesodDispatch y y) => y -> Maybe Key -> W.Application -toWaiApp' y key' env = do - let segments = map TS.unpack $ W.pathInfo env - case yesodDispatch y key' segments y id of +toWaiApp' y key' env = + case yesodDispatch y key' (W.pathInfo env) y id of Just app -> app env Nothing -> yesodRunner y y id key' Nothing notFound env diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 5da98291..ab576cf6 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -125,7 +125,7 @@ import Control.Failure (Failure (failure)) import Text.Hamlet -import Control.Monad.IO.Peel (MonadPeelIO) +import Control.Monad.IO.Peel (MonadPeelIO) -- FIXME monad-control import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) import qualified Data.Map as Map import qualified Data.ByteString as S @@ -139,8 +139,12 @@ import Web.Cookie (SetCookie (..), renderSetCookie) import Data.Enumerator (run_, ($$)) import Control.Arrow (second, (***)) import qualified Network.Wai.Parse as NWP -import qualified Data.Ascii as A import Data.Monoid (mappend, mempty) +import qualified Data.ByteString.Char8 as S8 +import Data.CaseInsensitive (CI) +import Blaze.ByteString.Builder (toByteString) +import Data.Text (Text) +import qualified Data.Text as TS -- | The type-safe URLs associated with a site argument. type family Route a @@ -153,7 +157,7 @@ data HandlerData sub master = HandlerData , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> [(String, String)] -> String) -- FIXME replace output String with Ascii + , handlerRender :: (Route master -> [(Text, Text)] -> String) -- FIXME replace output String with Ascii , handlerToMaster :: Route sub -> Route master } @@ -271,8 +275,8 @@ data HandlerContents = HCContent H.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath - | HCRedirect RedirectType A.Ascii - | HCCreated A.Ascii + | HCRedirect RedirectType H.Ascii + | HCCreated H.Ascii | HCWai W.Response instance Error HandlerContents where @@ -318,7 +322,7 @@ getUrlRender = do -- | The URL rendering function with query-string parameters. getUrlRenderParams :: Monad m - => GGHandler sub master m (Route master -> [(String, String)] -> String) + => GGHandler sub master m (Route master -> [(Text, Text)] -> String) getUrlRenderParams = handlerRender `liftM` GHandler ask -- | Get the route requested by the user. If this is a 404 response- where the @@ -335,7 +339,7 @@ getRouteToMaster = handlerToMaster `liftM` GHandler ask -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c - -> (Route master -> [(String, String)] -> String) + -> (Route master -> [(Text, Text)] -> String) -> Maybe (Route sub) -> (Route sub -> Route master) -> master @@ -419,14 +423,14 @@ redirect rt url = redirectParams rt url [] -- | Redirects to the given route with the associated query-string parameters. redirectParams :: Monad mo - => RedirectType -> Route master -> [(String, String)] + => RedirectType -> Route master -> [(Text, Text)] -> GGHandler sub master mo a redirectParams rt url params = do r <- getUrlRenderParams - redirectString rt $ A.unsafeFromString $ r url params + redirectString rt $ S8.pack $ r url params -- | Redirect to the given URL. -redirectString :: Monad mo => RedirectType -> A.Ascii -> GGHandler sub master mo a +redirectString :: Monad mo => RedirectType -> H.Ascii -> GGHandler sub master mo a redirectString rt = GHandler . lift . throwError . HCRedirect rt ultDestKey :: String @@ -458,7 +462,8 @@ setUltDest' = do tm <- getRouteToMaster gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask render <- getUrlRenderParams - setUltDestString $ render (tm r) gets' + let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b + setUltDestString $ renderFIXME (tm r) gets' -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. @@ -471,7 +476,7 @@ redirectUltDest :: Monad mo redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt . A.unsafeFromString) mdest + maybe (redirect rt def) (redirectString rt . S8.pack) mdest msgKey :: String msgKey = "_MSG" @@ -516,7 +521,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwError $ HCCreated $ A.unsafeFromString $ r url + GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session @@ -548,29 +553,29 @@ invalidArgs = failure . InvalidArgs -- | Set the cookie on the client. setCookie :: Monad mo => Int -- ^ minutes to timeout - -> A.Ascii -- ^ key - -> A.Ascii -- ^ value + -> H.Ascii -- ^ key + -> H.Ascii -- ^ value -> GGHandler sub master mo () setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: Monad mo => A.Ascii -> GGHandler sub master mo () +deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo () deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the -- next request. setLanguage :: Monad mo => String -> GGHandler sub master mo () -setLanguage = setSession (A.toString langKey) +setLanguage = setSession $ S8.unpack langKey -- | Set an arbitrary response header. setHeader :: Monad mo - => A.CIAscii -> A.Ascii -> GGHandler sub master mo () + => CI H.Ascii -> H.Ascii -> GGHandler sub master mo () setHeader a = addHeader . Header a -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: Monad mo => Int -> GGHandler s m mo () -cacheSeconds i = setHeader "Cache-Control" $ A.unsafeFromString $ concat +cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat [ "max-age=" , show i , ", public" @@ -588,7 +593,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () -expiresAt = setHeader "Expires" . A.unsafeFromString . formatRFC1123 +expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 -- | Set a variable in the user's session. -- @@ -648,7 +653,7 @@ handlerToYAR :: (HasReps a, HasReps b) => m -- ^ master site foundation -> s -- ^ sub site foundation -> (Route s -> Route m) - -> (Route m -> [(String, String)] -> String) -- ^ url render + -> (Route m -> [(Text, Text)] -> String) -- ^ url render FIXME -> (ErrorResponse -> GHandler s m a) -> Request -> Maybe (Route s) @@ -666,7 +671,7 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = type HeaderRenderer = [Header] -> ContentType -> SessionMap - -> [(A.CIAscii, A.Ascii)] + -> [(CI H.Ascii, H.Ascii)] yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response yarToResponse _ (YARWai a) = a @@ -675,12 +680,12 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = ContentBuilder b mlen -> let hs' = maybe finalHeaders finalHeaders' mlen in W.ResponseBuilder s hs' b - ContentFile fp -> W.ResponseFile s finalHeaders fp + ContentFile fp -> W.ResponseFile s finalHeaders fp Nothing -- FIXME handle partial files ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders where finalHeaders = renderHeaders hs ct sessionFinal - finalHeaders' len = ("Content-Length", A.unsafeFromString $ show len) + finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders {- getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -711,9 +716,9 @@ httpAccept = parseHttpAccept -- | Convert Header to a key/value pair. headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> Header - -> (A.CIAscii, A.Ascii) + -> (CI H.Ascii, H.Ascii) headerToPair getExpires (AddCookie minutes key value) = - ("Set-Cookie", A.fromAsciiBuilder $ renderSetCookie $ SetCookie + ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie { setCookieName = key , setCookieValue = value , setCookiePath = Just "/" -- FIXME make a config option, or use approot? @@ -777,7 +782,8 @@ hamletToContent :: Monad mo => Hamlet (Route master) -> GGHandler sub master mo Content hamletToContent h = do render <- getUrlRenderParams - return $ toContent $ h render + let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b + return $ toContent $ h renderFIXME -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: Monad mo diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index b9a3e64d..c58855c4 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -51,8 +51,9 @@ import qualified Data.Text.Lazy.Encoding as LT import Data.Typeable (Typeable) import Control.Exception (Exception) -import qualified Data.Ascii as A import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types as A +import Data.CaseInsensitive (CI) #if GHC7 #define HAMLET hamlet @@ -76,7 +77,7 @@ instance Exception ErrorResponse data Header = AddCookie Int A.Ascii A.Ascii | DeleteCookie A.Ascii - | Header A.CIAscii A.Ascii + | Header (CI A.Ascii) A.Ascii deriving (Eq, Show) langKey :: A.Ascii diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 2da55d1b..4c581ccb 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -20,11 +20,11 @@ import Data.Char (toLower) import qualified Data.ByteString as S import Yesod.Core (Yesod (joinPath, approot, cleanPath)) import Network.HTTP.Types (status301) -import qualified Data.Ascii as A import Data.Text (Text) import Data.Monoid (mappend) import qualified Blaze.ByteString.Builder import qualified Blaze.ByteString.Builder.Char8 +import qualified Data.ByteString.Char8 as S8 {-| @@ -83,15 +83,14 @@ sendRedirect :: Yesod master => master -> [Text] -> W.Application sendRedirect y segments' env = return $ W.responseLBS status301 [ ("Content-Type", "text/plain") - , ("Location", A.fromAsciiBuilder dest') + , ("Location", Blaze.ByteString.Builder.toByteString dest') ] "Redirecting" where - dest = joinPath y (A.toAsciiBuilder $ approot y) segments' [] + dest = joinPath y (Blaze.ByteString.Builder.fromByteString $ approot y) segments' [] dest' = if S.null (W.rawQueryString env) then dest - else A.unsafeFromBuilder - (A.toBuilder dest `mappend` + else (dest `mappend` Blaze.ByteString.Builder.Char8.fromChar '?' `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) @@ -154,7 +153,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met onSuccess <- newName "onSuccess" req <- newName "req" badMethod' <- [|badMethod|] - rm <- [|A.toString . W.requestMethod|] + rm <- [|S8.unpack . W.requestMethod|] let caseExp = rm `AppE` VarE req yr <- [|yesodRunner|] cr <- [|fmap chooseRep|] @@ -205,11 +204,11 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do fsp <- [|fromSinglePiece|] let exp' = CaseE (fsp `AppE` VarE next) [ Match - (ConP (mkName "Left") [WildP]) + (ConP (mkName "Nothing") []) (NormalB nothing) [] , Match - (ConP (mkName "Right") [VarP next']) + (ConP (mkName "Just") [VarP next']) (NormalB innerExp) [] ] diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs index d4f1045e..62a14490 100644 --- a/Yesod/Internal/Request.hs +++ b/Yesod/Internal/Request.hs @@ -10,8 +10,8 @@ import Yesod.Internal import qualified Network.Wai as W import System.Random (randomR, newStdGen) import Web.Cookie (parseCookies) -import qualified Data.Ascii as A import Data.Monoid (mempty) +import qualified Data.ByteString.Char8 as S8 parseWaiRequest :: W.Request -> [(String, String)] -- ^ session @@ -24,14 +24,14 @@ parseWaiRequest env session' key' = do $ W.requestHeaders env cookies' = parseCookies reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map A.toString $ maybe [] NWP.parseHttpAccept acceptLang - langs' = case lookup (A.toString langKey) session' of + langs = map S8.unpack $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup (S8.unpack langKey) session' of Nothing -> langs Just x -> x : langs langs'' = case lookup langKey cookies' of Nothing -> langs' - Just x -> A.toString x : langs' - langs''' = case lookup (A.toString langKey) gets' of + Just x -> S8.unpack x : langs' + langs''' = case lookup (S8.unpack langKey) gets' of Nothing -> langs'' Just x -> x : langs'' nonce <- case (key', lookup nonceKey session') of diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs index e97e55a5..cb87d96c 100644 --- a/Yesod/Internal/Session.hs +++ b/Yesod/Internal/Session.hs @@ -8,20 +8,19 @@ import Data.Serialize import Data.Time import Data.ByteString (ByteString) import Control.Monad (guard) -import qualified Data.Ascii as A encodeSession :: CS.Key -> UTCTime -- ^ expire time -> ByteString -- ^ remote host -> [(String, String)] -- ^ session - -> A.Ascii -- ^ cookie value + -> ByteString -- ^ cookie value encodeSession key expire rhost session' = CS.encrypt key $ encode $ SessionCookie expire rhost session' decodeSession :: CS.Key -> UTCTime -- ^ current time -> ByteString -- ^ remote host field - -> A.Ascii -- ^ cookie value + -> ByteString -- ^ cookie value -> Maybe [(String, String)] decodeSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 22efe036..33b4c768 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -43,7 +43,7 @@ import Control.Monad.IO.Class import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) -import qualified Data.Ascii as A +import qualified Network.HTTP.Types as A type ParamName = String type ParamValue = String diff --git a/yesod-core.cabal b/yesod-core.cabal index ab052ce8..e5b15f8e 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -33,22 +33,22 @@ library , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.5 && < 0.12 , template-haskell - , web-routes-quasi >= 0.6.3.1 && < 0.7 - , hamlet >= 0.7 && < 0.8 - , blaze-builder >= 0.2.1 && < 0.3 + , web-routes-quasi >= 0.7 && < 0.8 + , hamlet >= 0.7.3 && < 0.8 + , blaze-builder >= 0.2.1 && < 0.4 , transformers >= 0.2 && < 0.3 - , clientsession >= 0.5 && < 0.6 + , clientsession >= 0.6 && < 0.7 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.2 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 - , enumerator >= 0.4 && < 0.5 - , cookie >= 0.1 && < 0.2 + , enumerator >= 0.4.7 && < 0.5 + , cookie >= 0.2 && < 0.3 , blaze-html >= 0.4 && < 0.5 - , ascii >= 0.0.2 && < 0.1 - , http-types >= 0.5 && < 0.6 + , http-types >= 0.6 && < 0.7 + , case-insensitive >= 0.2 && < 0.3 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch From b9e0a0d532e8d70f3b81d714a956af08aec56aed Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 31 Mar 2011 18:06:47 +0200 Subject: [PATCH 076/126] getCurrentTime only called when using sessions --- Yesod/Core.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 7bb97a76..36dd747e 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -232,15 +232,16 @@ defaultYesodRunner :: Yesod master -> GHandler a master ChooseRep -> W.Application defaultYesodRunner s master toMasterRoute mkey murl handler req = do - now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration master let rh = takeWhile (/= ':') $ show $ W.remoteHost req let host = if sessionIpAddress master then S8.pack rh else "" - let session' = - case mkey of - Nothing -> [] - Just key -> fromMaybe [] $ do + session' <- + case mkey of + Nothing -> return [] + Just key -> do + now <- liftIO getCurrentTime + return $ fromMaybe [] $ do raw <- lookup "Cookie" $ W.requestHeaders req val <- lookup sessionName $ parseCookies raw decodeSession key now host val From 4ff6ba77263ae3fe8595afe41458b95ba68d7687 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 31 Mar 2011 22:04:01 +0200 Subject: [PATCH 077/126] Allow attributes on <script> and <link> tags --- Yesod/Core.hs | 34 +++++++++++++++++++++------------- Yesod/Internal.hs | 6 +++--- Yesod/Widget.hs | 29 +++++++++++++++++++++++++---- 3 files changed, 49 insertions(+), 20 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 36dd747e..a231d784 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -45,7 +45,9 @@ import Control.Monad.Trans.RWS import Text.Hamlet import Text.Cassius import Text.Julius -import Text.Blaze (preEscapedLazyText) +import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue) +import qualified Data.Text as T +import qualified Text.Blaze.Html5 as TBH import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Maybe (fromMaybe) @@ -59,6 +61,7 @@ import qualified Data.Text as TS import Data.Text (Text) import qualified Data.Text.Encoding as TE import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) +import Data.List (foldl') #if GHC7 #define HAMLET hamlet @@ -232,16 +235,15 @@ defaultYesodRunner :: Yesod master -> GHandler a master ChooseRep -> W.Application defaultYesodRunner s master toMasterRoute mkey murl handler req = do + now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration master let rh = takeWhile (/= ':') $ show $ W.remoteHost req let host = if sessionIpAddress master then S8.pack rh else "" - session' <- - case mkey of - Nothing -> return [] - Just key -> do - now <- liftIO getCurrentTime - return $ fromMaybe [] $ do + let session' = + case mkey of + Nothing -> [] + Just key -> fromMaybe [] $ do raw <- lookup "Cookie" $ W.requestHeaders req val <- lookup sessionName $ parseCookies raw decodeSession key now host val @@ -404,9 +406,8 @@ widgetToPageContent :: (Eq (Route master), Yesod master) widgetToPageContent (GWidget w) = do ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 let title = maybe mempty unTitle mTitle - let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' - let stylesheets = map (locationToHamlet . unStylesheet) - $ runUniqueList stylesheets' + let scripts = runUniqueList scripts' + let stylesheets = runUniqueList stylesheets' let cssToHtml = preEscapedLazyText . renderCss celper :: Cassius url -> Hamlet url celper = fmap cssToHtml @@ -436,6 +437,13 @@ widgetToPageContent (GWidget w) = do $ encodeUtf8 $ renderJulius render s return $ renderLoc x + let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) + let renderLoc' render' (Local url) = render' url [] + renderLoc' _ (Remote s) = s + let mkScriptTag (Script loc attrs) render' = + foldl' addAttr TBH.script (("src", T.pack $ renderLoc' render' loc) : attrs) $ return () + let mkLinkTag (Stylesheet loc attrs) render' = + foldl' addAttr TBH.link (("rel", "stylesheet") : ("href", T.pack $ renderLoc' render' loc) : attrs) let head'' = #if GHC7 [hamlet| @@ -443,12 +451,12 @@ widgetToPageContent (GWidget w) = do [$hamlet| #endif $forall s <- scripts - <script src="^{s}"> + ^{mkScriptTag s} $forall s <- stylesheets - <link rel="stylesheet" href="^{s}"> + ^{mkLinkTag s} $maybe s <- style $maybe s <- cssLoc - <link rel="stylesheet" href="#{s}"> + <link rel=stylesheet href=#{s} $nothing <style>^{celper s} $maybe j <- jscript diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index c58855c4..dd04b4a2 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -83,7 +83,7 @@ data Header = langKey :: A.Ascii langKey = "_LANG" -data Location url = Local url | Remote String +data Location url = Local url | Remote String -- FIXME Text deriving (Show, Eq) locationToHamlet :: Location url -> Hamlet url locationToHamlet (Local url) = [HAMLET|\@{url} @@ -100,9 +100,9 @@ runUniqueList (UniqueList x) = nub $ x [] toUnique :: x -> UniqueList x toUnique = UniqueList . (:) -newtype Script url = Script { unScript :: Location url } +data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(T.Text, T.Text)] } deriving (Show, Eq) -newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } +data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(T.Text, T.Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index a7f40f6e..67fd439c 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -21,12 +21,16 @@ module Yesod.Widget -- ** CSS , addCassius , addStylesheet + , addStylesheetAttrs , addStylesheetRemote + , addStylesheetRemoteAttrs , addStylesheetEither -- ** Javascript , addJulius , addScript + , addScriptAttrs , addScriptRemote + , addScriptRemoteAttrs , addScriptEither -- * Utilities , extractBody @@ -44,6 +48,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans (lift)) import Yesod.Internal import Control.Monad (liftM) +import Data.Text (Text) import Control.Monad.IO.Peel (MonadPeelIO) @@ -118,11 +123,19 @@ addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) memp -- | Link to the specified local stylesheet. addStylesheet :: Monad m => Route master -> GGWidget sub master m () -addStylesheet x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Local x) mempty mempty mempty +addStylesheet = flip addStylesheetAttrs [] + +-- | Link to the specified local stylesheet. +addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: Monad m => String -> GGWidget sub master m () -addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty +addStylesheetRemote = flip addStylesheetRemoteAttrs [] + +-- | Link to the specified remote stylesheet. +addStylesheetRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addStylesheetEither = either addStylesheet addStylesheetRemote @@ -132,11 +145,19 @@ addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. addScript :: Monad m => Route master -> GGWidget sub master m () -addScript x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Local x) mempty mempty mempty mempty +addScript = flip addScriptAttrs [] + +-- | Link to the specified local script. +addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m () +addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: Monad m => String -> GGWidget sub master m () -addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty +addScriptRemote = flip addScriptRemoteAttrs [] + +-- | Link to the specified remote script. +addScriptRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m () +addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag. addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m () From 571ec80d164503b248f1428c0e2644ef909acaf6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 11:32:57 +0300 Subject: [PATCH 078/126] Fake conversion to monad-control --- Yesod/Handler.hs | 22 +++++++++++----------- Yesod/Widget.hs | 4 ++-- yesod-core.cabal | 2 +- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ab576cf6..0d547cde 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -125,8 +125,8 @@ import Control.Failure (Failure (failure)) import Text.Hamlet -import Control.Monad.IO.Peel (MonadPeelIO) -- FIXME monad-control -import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) +import Control.Monad.IO.Control (MonadControlIO) +import Control.Monad.Trans.Control (MonadTransControl, liftControl, control) import qualified Data.Map as Map import qualified Data.ByteString as S import Data.ByteString (ByteString) @@ -230,7 +230,7 @@ newtype GGHandler sub master m a = GHandler { unGHandler :: GHInner sub master m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) instance MonadTrans (GGHandler s m) where lift = GHandler . lift . lift . lift . lift @@ -243,7 +243,7 @@ data GHState = GHState , ghsIdent :: Int } -type GHInner s m monad = +type GHInner s m monad = -- FIXME collapse the stack ReaderT (HandlerData s m) ( ErrorT HandlerContents ( WriterT (Endo [Header]) ( @@ -742,14 +742,14 @@ newIdent = GHandler $ lift $ lift $ lift $ do liftIOHandler :: MonadIO mo => GGHandler sub master IO a -> GGHandler sub master mo a -liftIOHandler x = do - k <- peel - join $ liftIO $ k x +liftIOHandler x = error "FIXME liftIOHandler" {- do + k <- control + join $ liftIO $ k x -} -instance MonadTransPeel (GGHandler s m) where - peel = GHandler $ do - k <- liftPeel $ liftPeel $ liftPeel peel - return $ liftM GHandler . k . unGHandler +instance MonadTransControl (GGHandler s m) where + liftControl = error "FIXME liftControl for GGHandler" {-GHandler $ do + k <- liftControl $ liftControl $ liftControl control + return $ liftM GHandler . k . unGHandler -} -- | Redirect to a POST resource. -- diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 67fd439c..41cddc8e 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -50,13 +50,13 @@ import Yesod.Internal import Control.Monad (liftM) import Data.Text (Text) -import Control.Monad.IO.Peel (MonadPeelIO) +import Control.Monad.IO.Control (MonadControlIO) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner m monad a } -- FIXME remove s - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) instance MonadTrans (GGWidget s m) where lift = GWidget . lift diff --git a/yesod-core.cabal b/yesod-core.cabal index e5b15f8e..50258068 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -43,7 +43,7 @@ library , old-locale >= 1.0.0.2 && < 1.1 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 - , monad-peel >= 0.1 && < 0.2 + , monad-control >= 0.2 && < 0.3 , enumerator >= 0.4.7 && < 0.5 , cookie >= 0.2 && < 0.3 , blaze-html >= 0.4 && < 0.5 From b1abfd1a6abe497bd3ca8dab06ef7d14b4edcbed Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 12:43:13 +0300 Subject: [PATCH 079/126] Large-scale switch from String and Ascii to Text --- Yesod/Core.hs | 33 ++++++++------- Yesod/Handler.hs | 83 +++++++++++++++++++++----------------- Yesod/Internal.hs | 17 ++++---- Yesod/Internal/Dispatch.hs | 3 +- Yesod/Internal/Request.hs | 28 +++++++------ Yesod/Internal/Session.hs | 12 +++--- Yesod/Request.hs | 48 +++++++++------------- Yesod/Widget.hs | 15 +++---- yesod-core.cabal | 8 ++-- 9 files changed, 130 insertions(+), 117 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index a231d784..a81f01c8 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -46,7 +46,6 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue) -import qualified Data.Text as T import qualified Text.Blaze.Html5 as TBH import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) @@ -56,11 +55,11 @@ import Web.Cookie (parseCookies) import qualified Data.Map as Map import Data.Time import Network.HTTP.Types (encodePath) -import qualified Network.HTTP.Types as H import qualified Data.Text as TS import Data.Text (Text) import qualified Data.Text.Encoding as TE -import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) +import Blaze.ByteString.Builder (Builder, toByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') #if GHC7 @@ -104,7 +103,7 @@ class RenderRoute (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> H.Ascii + approot :: a -> Text -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -215,10 +214,10 @@ class RenderRoute (Route a) => Yesod a where -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is -- necessary when you are serving the content outside the context of a -- Yesod application, such as via memcached. - addStaticContent :: String -- ^ filename extension - -> String -- ^ mime-type + addStaticContent :: Text -- ^ filename extension + -> Text -- ^ mime-type -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) + -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing -- | Whether or not to tie a session to a specific IP address. Defaults to @@ -292,7 +291,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do hs'' = map (headerToPair getExpires) hs' hs''' = ("Content-Type", ct) : hs'' -data AuthResult = Authorized | AuthenticationRequired | Unauthorized String +data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text deriving (Eq, Show, Read) -- | A type-safe, concise method of creating breadcrumbs for pages. For each @@ -408,6 +407,7 @@ widgetToPageContent (GWidget w) = do let title = maybe mempty unTitle mTitle let scripts = runUniqueList scripts' let stylesheets = runUniqueList stylesheets' + -- FIXME check size of cassius/julius template let cssToHtml = preEscapedLazyText . renderCss celper :: Cassius url -> Hamlet url celper = fmap cssToHtml @@ -415,8 +415,7 @@ widgetToPageContent (GWidget w) = do jelper :: Julius url -> Hamlet url jelper = fmap jsToHtml - renderFIXME <- getUrlRenderParams - let render a b = renderFIXME a $ map (TS.pack *** TS.pack) b + render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing @@ -441,9 +440,13 @@ widgetToPageContent (GWidget w) = do let renderLoc' render' (Local url) = render' url [] renderLoc' _ (Remote s) = s let mkScriptTag (Script loc attrs) render' = - foldl' addAttr TBH.script (("src", T.pack $ renderLoc' render' loc) : attrs) $ return () + foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () let mkLinkTag (Stylesheet loc attrs) render' = - foldl' addAttr TBH.link (("rel", "stylesheet") : ("href", T.pack $ renderLoc' render' loc) : attrs) + foldl' addAttr TBH.link + ( ("rel", "stylesheet") + : ("href", renderLoc' render' loc) + : attrs + ) let head'' = #if GHC7 [hamlet| @@ -475,11 +478,11 @@ yesodRender :: Yesod y => y -> Route y -> [(Text, Text)] - -> String -- FIXME + -> Text yesodRender y u qs = - S8.unpack $ toByteString $ + TE.decodeUtf8 $ toByteString $ fromMaybe - (joinPath y (fromByteString $ approot y) ps + (joinPath y (fromText $ approot y) ps $ qs ++ qs') (urlRenderOverride y u) where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0d547cde..e62acf1f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -41,6 +41,7 @@ module Yesod.Handler , redirect , redirectParams , redirectString + , redirectText , redirectToPost -- ** Errors , notFound @@ -124,6 +125,12 @@ import qualified Network.HTTP.Types as H import Control.Failure (Failure (failure)) import Text.Hamlet +import Text.Blaze (preEscapedText) +import qualified Text.Blaze.Renderer.Text +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL import Control.Monad.IO.Control (MonadControlIO) import Control.Monad.Trans.Control (MonadTransControl, liftControl, control) @@ -144,7 +151,6 @@ import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (CI) import Blaze.ByteString.Builder (toByteString) import Data.Text (Text) -import qualified Data.Text as TS -- | The type-safe URLs associated with a site argument. type family Route a @@ -157,7 +163,7 @@ data HandlerData sub master = HandlerData , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> [(Text, Text)] -> String) -- FIXME replace output String with Ascii + , handlerRender :: (Route master -> [(Text, Text)] -> Text) , handlerToMaster :: Route sub -> Route master } @@ -251,7 +257,7 @@ type GHInner s m monad = -- FIXME collapse the stack monad )))) -type SessionMap = Map.Map String String +type SessionMap = Map.Map Text Text type Endo a = a -> a @@ -274,13 +280,13 @@ data YesodAppResult data HandlerContents = HCContent H.Status ChooseRep | HCError ErrorResponse - | HCSendFile ContentType FilePath - | HCRedirect RedirectType H.Ascii - | HCCreated H.Ascii + | HCSendFile ContentType FilePath -- FIXME replace FilePath with opaque type from system-filepath? + | HCRedirect RedirectType Text + | HCCreated Text | HCWai W.Response instance Error HandlerContents where - strMsg = HCError . InternalError + strMsg = HCError . InternalError . T.pack instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where failure = GHandler . lift . throwError . HCError @@ -301,9 +307,10 @@ rbHelper req = (map fix1 *** map fix2) <$> iter where iter = NWP.parseRequestBody NWP.lbsSink req - fix1 = bsToChars *** bsToChars + fix1 = go *** go fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) + (go x, FileInfo (go a) (go b) c) + go = decodeUtf8With lenientDecode -- | Get the sub application argument. getYesodSub :: Monad m => GGHandler sub master m sub @@ -314,7 +321,7 @@ getYesod :: Monad m => GGHandler sub master m master getYesod = handlerMaster `liftM` GHandler ask -- | Get the URL rendering function. -getUrlRender :: Monad m => GGHandler sub master m (Route master -> String) +getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text) getUrlRender = do x <- handlerRender `liftM` GHandler ask return $ flip x [] @@ -322,7 +329,7 @@ getUrlRender = do -- | The URL rendering function with query-string parameters. getUrlRenderParams :: Monad m - => GGHandler sub master m (Route master -> [(Text, Text)] -> String) + => GGHandler sub master m (Route master -> [(Text, Text)] -> Text) getUrlRenderParams = handlerRender `liftM` GHandler ask -- | Get the route requested by the user. If this is a 404 response- where the @@ -339,7 +346,7 @@ getRouteToMaster = handlerToMaster `liftM` GHandler ask -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c - -> (Route master -> [(Text, Text)] -> String) + -> (Route master -> [(Text, Text)] -> Text) -> Maybe (Route sub) -> (Route sub -> Route master) -> master @@ -350,7 +357,7 @@ runHandler handler mrender sroute tomr ma sa = let toErrorHandler e = case fromException e of Just x -> x - Nothing -> InternalError $ show e + Nothing -> InternalError $ T.pack $ show e let hd = HandlerData { handlerRequest = rr , handlerSub = sa @@ -384,7 +391,7 @@ runHandler handler mrender sroute tomr ma sa = return $ YARPlain status (headers []) ct c finalSession HCError e -> handleError e HCRedirect rt loc -> do - let hs = Header "Location" loc : headers [] + let hs = Header "Location" (encodeUtf8 loc) : headers [] return $ YARPlain (getRedirectStatus rt) hs typePlain emptyContent finalSession @@ -392,7 +399,7 @@ runHandler handler mrender sroute tomr ma sa = (sendFile' ct fp) (handleError . toErrorHandler) HCCreated loc -> do - let hs = Header "Location" loc : headers [] + let hs = Header "Location" (encodeUtf8 loc) : headers [] return $ YARPlain H.status201 hs @@ -427,13 +434,15 @@ redirectParams :: Monad mo -> GGHandler sub master mo a redirectParams rt url params = do r <- getUrlRenderParams - redirectString rt $ S8.pack $ r url params + redirectString rt $ r url params -- | Redirect to the given URL. -redirectString :: Monad mo => RedirectType -> H.Ascii -> GGHandler sub master mo a -redirectString rt = GHandler . lift . throwError . HCRedirect rt +redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a +redirectText rt = GHandler . lift . throwError . HCRedirect rt +redirectString = redirectText +{-# DEPRECATED redirectString "Use redirectText instead" #-} -ultDestKey :: String +ultDestKey :: Text ultDestKey = "_ULT" -- | Sets the ultimate destination variable to the given route. @@ -446,7 +455,7 @@ setUltDest dest = do setUltDestString $ render dest -- | Same as 'setUltDest', but use the given string. -setUltDestString :: Monad mo => String -> GGHandler sub master mo () +setUltDestString :: Monad mo => Text -> GGHandler sub master mo () setUltDestString = setSession ultDestKey -- | Same as 'setUltDest', but uses the current page. @@ -462,8 +471,7 @@ setUltDest' = do tm <- getRouteToMaster gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask render <- getUrlRenderParams - let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b - setUltDestString $ renderFIXME (tm r) gets' + setUltDestString $ render (tm r) gets' -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. @@ -476,16 +484,16 @@ redirectUltDest :: Monad mo redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt . S8.pack) mdest + maybe (redirect rt def) (redirectText rt) mdest -msgKey :: String +msgKey :: Text msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. setMessage :: Monad mo => Html -> GGHandler sub master mo () -setMessage = setSession msgKey . lbsToChars . renderHtml +setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. @@ -493,7 +501,7 @@ setMessage = setSession msgKey . lbsToChars . renderHtml -- See 'setMessage'. getMessage :: Monad mo => GGHandler sub master mo (Maybe Html) getMessage = do - mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey + mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey deleteSession msgKey return mmsg @@ -521,7 +529,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated url = do r <- getUrlRender - GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url + GHandler $ lift $ throwError $ HCCreated $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session @@ -542,11 +550,11 @@ badMethod = do failure $ BadMethod $ W.requestMethod w -- | Return a 403 permission denied page. -permissionDenied :: Failure ErrorResponse m => String -> m a +permissionDenied :: Failure ErrorResponse m => Text -> m a permissionDenied = failure . PermissionDenied -- | Return a 400 invalid arguments page. -invalidArgs :: Failure ErrorResponse m => [String] -> m a +invalidArgs :: Failure ErrorResponse m => [Text] -> m a invalidArgs = failure . InvalidArgs ------- Headers @@ -564,8 +572,8 @@ deleteCookie = addHeader . DeleteCookie -- | Set the language in the user session. Will show up in 'languages' on the -- next request. -setLanguage :: Monad mo => String -> GGHandler sub master mo () -setLanguage = setSession $ S8.unpack langKey +setLanguage :: Monad mo => Text -> GGHandler sub master mo () +setLanguage = setSession langKey -- | Set an arbitrary response header. setHeader :: Monad mo @@ -601,13 +609,13 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. setSession :: Monad mo - => String -- ^ key - -> String -- ^ value + => Text -- ^ key + -> Text -- ^ value -> GGHandler sub master mo () setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. -deleteSession :: Monad mo => String -> GGHandler sub master mo () +deleteSession :: Monad mo => Text -> GGHandler sub master mo () deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete modSession :: (SessionMap -> SessionMap) -> GHState -> GHState @@ -640,7 +648,7 @@ localNoCurrent = GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler -- | Lookup for session data. -lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue) +lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupSession n = GHandler $ do m <- liftM ghsSession $ lift $ lift $ lift get return $ Map.lookup n m @@ -653,7 +661,7 @@ handlerToYAR :: (HasReps a, HasReps b) => m -- ^ master site foundation -> s -- ^ sub site foundation -> (Route s -> Route m) - -> (Route m -> [(Text, Text)] -> String) -- ^ url render FIXME + -> (Route m -> [(Text, Text)] -> Text) -> (ErrorResponse -> GHandler s m a) -> Request -> Maybe (Route s) @@ -782,8 +790,7 @@ hamletToContent :: Monad mo => Hamlet (Route master) -> GGHandler sub master mo Content hamletToContent h = do render <- getUrlRenderParams - let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b - return $ toContent $ h renderFIXME + return $ toContent $ h render -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: Monad mo diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index dd04b4a2..ab43a17f 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -41,6 +41,7 @@ import Data.List (nub) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T @@ -54,6 +55,7 @@ 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) #if GHC7 #define HAMLET hamlet @@ -65,9 +67,9 @@ import Data.CaseInsensitive (CI) -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = NotFound - | InternalError String - | InvalidArgs [String] - | PermissionDenied String + | InternalError Text + | InvalidArgs [Text] + | PermissionDenied Text | BadMethod H.Method deriving (Show, Eq, Typeable) instance Exception ErrorResponse @@ -80,10 +82,10 @@ data Header = | Header (CI A.Ascii) A.Ascii deriving (Eq, Show) -langKey :: A.Ascii +langKey :: IsString a => a langKey = "_LANG" -data Location url = Local url | Remote String -- FIXME Text +data Location url = Local url | Remote Text deriving (Show, Eq) locationToHamlet :: Location url -> Hamlet url locationToHamlet (Local url) = [HAMLET|\@{url} @@ -111,6 +113,7 @@ newtype Head url = Head (Hamlet url) newtype Body url = Body (Hamlet url) deriving Monoid +-- FIXME remove these functions lbsToChars :: L.ByteString -> String lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode @@ -120,10 +123,10 @@ bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode charsToBs :: String -> S.ByteString charsToBs = T.encodeUtf8 . T.pack -nonceKey :: String +nonceKey :: IsString a => a nonceKey = "_NONCE" -sessionName :: A.Ascii +sessionName :: IsString a => a sessionName = "_SESSION" data GWData a = GWData diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 4c581ccb..f8f073e8 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -24,6 +24,7 @@ import Data.Text (Text) import Data.Monoid (mappend) import qualified Blaze.ByteString.Builder import qualified Blaze.ByteString.Builder.Char8 +import Blaze.ByteString.Builder.Char.Utf8 (fromText) import qualified Data.ByteString.Char8 as S8 {-| @@ -86,7 +87,7 @@ sendRedirect y segments' env = , ("Location", Blaze.ByteString.Builder.toByteString dest') ] "Redirecting" where - dest = joinPath y (Blaze.ByteString.Builder.fromByteString $ approot y) segments' [] + dest = joinPath y (fromText $ approot y) segments' [] dest' = if S.null (W.rawQueryString env) then dest diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs index 62a14490..183b5cb3 100644 --- a/Yesod/Internal/Request.hs +++ b/Yesod/Internal/Request.hs @@ -4,34 +4,37 @@ module Yesod.Internal.Request ) where import Yesod.Request -import Control.Arrow (first, (***)) +import Control.Arrow (first, second) import qualified Network.Wai.Parse as NWP import Yesod.Internal import qualified Network.Wai as W import System.Random (randomR, newStdGen) -import Web.Cookie (parseCookies) +import Web.Cookie (parseCookiesText) import Data.Monoid (mempty) import qualified Data.ByteString.Char8 as S8 +import Data.Text (Text, pack) +import Network.HTTP.Types (queryToQueryText) +import Control.Monad (join) +import Data.Maybe (fromMaybe) parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session + -> [(Text, Text)] -- ^ session -> Maybe a -> IO Request parseWaiRequest env session' key' = do - let gets' = map (bsToChars *** maybe "" bsToChars) - $ W.queryString env + let gets' = queryToQueryText $ W.queryString env let reqCookie = maybe mempty id $ lookup "Cookie" $ W.requestHeaders env - cookies' = parseCookies reqCookie + cookies' = parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map S8.unpack $ maybe [] NWP.parseHttpAccept acceptLang - langs' = case lookup (S8.unpack langKey) session' of + langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup langKey session' of Nothing -> langs Just x -> x : langs langs'' = case lookup langKey cookies' of Nothing -> langs' - Just x -> S8.unpack x : langs' - langs''' = case lookup (S8.unpack langKey) gets' of + Just x -> x : langs' + langs''' = case join $ lookup langKey gets' of Nothing -> langs'' Just x -> x : langs'' nonce <- case (key', lookup nonceKey session') of @@ -39,8 +42,9 @@ parseWaiRequest env session' key' = do (_, Just x) -> return $ Just x (_, Nothing) -> do g <- newStdGen - return $ Just $ fst $ randomString 10 g - return $ Request gets' cookies' env langs''' nonce + return $ Just $ pack $ fst $ randomString 10 g + let gets'' = map (second $ fromMaybe "") gets' + return $ Request gets'' cookies' env langs''' nonce where randomString len = first (map toChar) . sequence' (replicate len (randomR (0, 61))) diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs index cb87d96c..7e840136 100644 --- a/Yesod/Internal/Session.hs +++ b/Yesod/Internal/Session.hs @@ -8,11 +8,13 @@ import Data.Serialize import Data.Time import Data.ByteString (ByteString) import Control.Monad (guard) +import Data.Text (Text, pack, unpack) +import Control.Arrow ((***)) encodeSession :: CS.Key -> UTCTime -- ^ expire time -> ByteString -- ^ remote host - -> [(String, String)] -- ^ session + -> [(Text, Text)] -- ^ session -> ByteString -- ^ cookie value encodeSession key expire rhost session' = CS.encrypt key $ encode $ SessionCookie expire rhost session' @@ -21,7 +23,7 @@ decodeSession :: CS.Key -> UTCTime -- ^ current time -> ByteString -- ^ remote host field -> ByteString -- ^ cookie value - -> Maybe [(String, String)] + -> Maybe [(Text, Text)] decodeSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie expire rhost' session' <- @@ -30,14 +32,14 @@ decodeSession key now rhost encrypted = do guard $ rhost' == rhost return session' -data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] +data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)] deriving (Show, Read) instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put c + put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c) get = do a <- getTime b <- get - c <- get + c <- map (pack *** pack) `fmap` get return $ SessionCookie a b c putTime :: Putter UTCTime diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 33b4c768..ce257946 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -31,10 +31,6 @@ module Yesod.Request , lookupPostParams , lookupCookies , lookupFiles - -- * Parameter type synonyms - , ParamName - , ParamValue - , ParamError ) where import qualified Network.Wai as W @@ -43,11 +39,7 @@ import Control.Monad.IO.Class import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) -import qualified Network.HTTP.Types as A - -type ParamName = String -type ParamValue = String -type ParamError = String +import Data.Text (Text) -- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler @@ -70,7 +62,7 @@ class Monad m => RequestReader m where -- * Accept-Language HTTP header. -- -- This is handled by parseWaiRequest (not exposed). -languages :: RequestReader m => m [String] +languages :: RequestReader m => m [Text] languages = reqLangs `liftM` getRequest -- | Get the request\'s 'W.Request' value. @@ -79,74 +71,74 @@ waiRequest = reqWaiRequest `liftM` getRequest -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = - ( [(ParamName, ParamValue)] - , [(ParamName, FileInfo)] + ( [(Text, Text)] + , [(Text, FileInfo)] ) data FileInfo = FileInfo - { fileName :: String - , fileContentType :: String + { fileName :: Text + , fileContentType :: Text , fileContent :: BL.ByteString } deriving (Eq, Show) -- | The parsed request information. data Request = Request - { reqGetParams :: [(ParamName, ParamValue)] - , reqCookies :: [(A.Ascii, A.Ascii)] + { reqGetParams :: [(Text, Text)] + , reqCookies :: [(Text, Text)] , reqWaiRequest :: W.Request -- | Languages which the client supports. - , reqLangs :: [String] + , reqLangs :: [Text] -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: Maybe String + , reqNonce :: Maybe Text } lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup for GET parameters. -lookupGetParams :: RequestReader m => ParamName -> m [ParamValue] +lookupGetParams :: RequestReader m => Text -> m [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. -lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupGetParam :: RequestReader m => Text -> m (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. lookupPostParams :: RequestReader m - => ParamName - -> m [ParamValue] + => Text + -> m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp lookupPostParam :: (MonadIO m, RequestReader m) - => ParamName - -> m (Maybe ParamValue) + => Text + -> m (Maybe Text) lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. lookupFile :: (MonadIO m, RequestReader m) - => ParamName + => Text -> m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. lookupFiles :: RequestReader m - => ParamName + => Text -> m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: RequestReader m => A.Ascii -> m (Maybe A.Ascii) +lookupCookie :: RequestReader m => Text -> m (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: RequestReader m => A.Ascii -> m [A.Ascii] +lookupCookies :: RequestReader m => Text -> m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 41cddc8e..5d863972 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -38,6 +38,7 @@ module Yesod.Widget import Data.Monoid import Control.Monad.Trans.RWS +import Text.Blaze (preEscapedText) import Text.Hamlet import Text.Cassius import Text.Julius @@ -75,7 +76,7 @@ instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where toHamletValue = runGWidget' htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $ - addHamlet $ \r -> preEscapedString (r url params) + addHamlet $ \r -> preEscapedText (r url params) fromHamletValue = GWidget' instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where return = GWidget' . return @@ -130,17 +131,17 @@ addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. -addStylesheetRemote :: Monad m => String -> GGWidget sub master m () +addStylesheetRemote :: Monad m => Text -> GGWidget sub master m () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. -addStylesheetRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m () addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty -addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () +addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget sub master m () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m () +addScriptEither :: Monad m => Either (Route master) Text -> GGWidget sub master m () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. @@ -152,11 +153,11 @@ addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub mast addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. -addScriptRemote :: Monad m => String -> GGWidget sub master m () +addScriptRemote :: Monad m => Text -> GGWidget sub master m () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. -addScriptRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m () +addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m () addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag. diff --git a/yesod-core.cabal b/yesod-core.cabal index 50258068..761d95d3 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -8,12 +8,12 @@ synopsis: Creation of type-safe, RESTful web applications. description: Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. . - The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. + The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. category: Web, Yesod stability: Stable cabal-version: >= 1.6 build-type: Simple -homepage: http://docs.yesodweb.com/ +homepage: http://www.yesodweb.com/ flag test description: Build the executable to run unit tests @@ -34,7 +34,7 @@ library , text >= 0.5 && < 0.12 , template-haskell , web-routes-quasi >= 0.7 && < 0.8 - , hamlet >= 0.7.3 && < 0.8 + , hamlet >= 0.8 && < 0.9 , blaze-builder >= 0.2.1 && < 0.4 , transformers >= 0.2 && < 0.3 , clientsession >= 0.6 && < 0.7 @@ -45,7 +45,7 @@ library , containers >= 0.2 && < 0.5 , monad-control >= 0.2 && < 0.3 , enumerator >= 0.4.7 && < 0.5 - , cookie >= 0.2 && < 0.3 + , cookie >= 0.2.1 && < 0.3 , blaze-html >= 0.4 && < 0.5 , http-types >= 0.6 && < 0.7 , case-insensitive >= 0.2 && < 0.3 From 35e424f241b030a07c1a4d742a3f388c42c94685 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 12:49:59 +0300 Subject: [PATCH 080/126] sendFilePart --- Yesod/Content.hs | 3 ++- Yesod/Core.hs | 3 +-- Yesod/Handler.hs | 25 ++++++++++++++++++------- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 46c9ac65..adc440ec 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -61,10 +61,11 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Data.String (IsString (fromString)) +import Network.Wai (FilePart) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentEnum (forall a. Enumerator Builder IO a) - | ContentFile FilePath + | ContentFile FilePath (Maybe FilePart) -- | Zero-length enumerator. emptyContent :: Content diff --git a/Yesod/Core.hs b/Yesod/Core.hs index a81f01c8..0d3e5143 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -195,7 +195,7 @@ class RenderRoute (Route a) => Yesod a where -- be the inverse of 'splitPath'. joinPath :: a -> Builder -- ^ application root - -> [TS.Text] -- ^ path pieces FIXME Text + -> [TS.Text] -- ^ path pieces -> [(TS.Text, TS.Text)] -- ^ query string -> Builder joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs @@ -407,7 +407,6 @@ widgetToPageContent (GWidget w) = do let title = maybe mempty unTitle mTitle let scripts = runUniqueList scripts' let stylesheets = runUniqueList stylesheets' - -- FIXME check size of cassius/julius template let cssToHtml = preEscapedLazyText . renderCss celper :: Cassius url -> Hamlet url celper = fmap cssToHtml diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index e62acf1f..0a9c3dc2 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,7 @@ module Yesod.Handler , invalidArgs -- ** Short-circuit responses. , sendFile + , sendFilePart , sendResponse , sendResponseStatus , sendResponseCreated @@ -280,7 +281,7 @@ data YesodAppResult data HandlerContents = HCContent H.Status ChooseRep | HCError ErrorResponse - | HCSendFile ContentType FilePath -- FIXME replace FilePath with opaque type from system-filepath? + | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath? | HCRedirect RedirectType Text | HCCreated Text | HCWai W.Response @@ -383,8 +384,8 @@ runHandler handler mrender sroute tomr ma sa = let hs' = headers hs in return $ YARPlain (getStatus e) hs' ct c sess YARWai _ -> return yar - let sendFile' ct fp = - return $ YARPlain H.status200 (headers []) ct (ContentFile fp) finalSession + let sendFile' ct fp p = + return $ YARPlain H.status200 (headers []) ct (ContentFile fp p) finalSession case contents of HCContent status a -> do (ct, c) <- liftIO $ chooseRep a cts @@ -395,8 +396,8 @@ runHandler handler mrender sroute tomr ma sa = return $ YARPlain (getRedirectStatus rt) hs typePlain emptyContent finalSession - HCSendFile ct fp -> catchIter - (sendFile' ct fp) + HCSendFile ct fp p -> catchIter + (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do let hs = Header "Location" (encodeUtf8 loc) : headers [] @@ -510,7 +511,17 @@ getMessage = do -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a -sendFile ct = GHandler . lift . throwError . HCSendFile ct +sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing + +-- | Same as 'sendFile', but only sends part of a file. +sendFilePart :: Monad mo + => ContentType + -> FilePath + -> Integer -- ^ offset + -> Integer -- ^ count + -> GGHandler sub master mo a +sendFilePart ct fp off count = + GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count -- | Bypass remaining handler code and output the given content with a 200 -- status code. @@ -688,7 +699,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = ContentBuilder b mlen -> let hs' = maybe finalHeaders finalHeaders' mlen in W.ResponseBuilder s hs' b - ContentFile fp -> W.ResponseFile s finalHeaders fp Nothing -- FIXME handle partial files + ContentFile fp p -> W.ResponseFile s finalHeaders fp p ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders where From d9fb87b63441b32b21233b06f62cf21f050b0ffe Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 12:52:35 +0300 Subject: [PATCH 081/126] More String -> Text --- Yesod/Content.hs | 14 +++++++------- Yesod/Handler.hs | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index adc440ec..6244474c 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -167,7 +167,7 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = B.ByteString +type ContentType = B.ByteString -- FIXME Text? typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -220,13 +220,13 @@ simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.breakByte 59 -- 59 == ; -- | Format a 'UTCTime' in W3 format. -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" +formatW3 :: UTCTime -> T.Text +formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123. -formatRFC1123 :: UTCTime -> String -formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" +formatRFC1123 :: UTCTime -> T.Text +formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" -- | Format as per RFC 822. -formatRFC822 :: UTCTime -> String -formatRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" +formatRFC822 :: UTCTime -> T.Text +formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0a9c3dc2..1c70923f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -612,7 +612,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () -expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 +expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123 -- | Set a variable in the user's session. -- From 0ee09c2ac5f52cce74fc32c1ff91ec980f2bbc85 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 12:54:41 +0300 Subject: [PATCH 082/126] Remove bsToChars... helper functions --- Yesod/Core.hs | 3 ++- Yesod/Internal.hs | 27 ++------------------------- 2 files changed, 4 insertions(+), 26 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 0d3e5143..92c5d53a 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -58,6 +58,7 @@ import Network.HTTP.Types (encodePath) import qualified Data.Text as TS import Data.Text (Text) import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE import Blaze.ByteString.Builder (Builder, toByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') @@ -333,7 +334,7 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let path' = bsToChars $ W.rawPathInfo r + let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r applyLayout' "Not Found" #if GHC7 [hamlet| diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index ab43a17f..3778143d 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -23,10 +23,6 @@ module Yesod.Internal , locationToHamlet , runUniqueList , toUnique - -- * UTF8 helpers - , bsToChars - , lbsToChars - , charsToBs -- * Names , sessionName , nonceKey @@ -38,16 +34,7 @@ import Text.Julius (Julius) import Data.Monoid (Monoid (..), Last) import Data.List (nub) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T - -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -102,9 +89,9 @@ runUniqueList (UniqueList x) = nub $ x [] toUnique :: x -> UniqueList x toUnique = UniqueList . (:) -data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(T.Text, T.Text)] } +data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } deriving (Show, Eq) -data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(T.Text, T.Text)] } +data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } @@ -113,16 +100,6 @@ newtype Head url = Head (Hamlet url) newtype Body url = Body (Hamlet url) deriving Monoid --- FIXME remove these functions -lbsToChars :: L.ByteString -> String -lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode - -bsToChars :: S.ByteString -> String -bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode - -charsToBs :: String -> S.ByteString -charsToBs = T.encodeUtf8 . T.pack - nonceKey :: IsString a => a nonceKey = "_NONCE" From 49f81f0f870ce881416715ea2319de749e2468f7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 13:06:29 +0300 Subject: [PATCH 083/126] Finally removed RequestReader --- Yesod/Handler.hs | 36 +++++++++++++------- Yesod/Internal/Request.hs | 29 +++++++++++++++- Yesod/Request.hs | 71 ++++++++------------------------------- 3 files changed, 65 insertions(+), 71 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1c70923f..9b3e6268 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -35,6 +35,9 @@ module Yesod.Handler , getUrlRenderParams , getCurrentRoute , getRouteToMaster + , getRequest + , waiRequest + , runRequestBody -- * Special responses -- ** Redirecting , RedirectType (..) @@ -103,7 +106,7 @@ module Yesod.Handler ) where import Prelude hiding (catch) -import Yesod.Request +import Yesod.Internal.Request import Yesod.Internal import Data.Time (UTCTime) @@ -289,19 +292,22 @@ data HandlerContents = instance Error HandlerContents where strMsg = HCError . InternalError . T.pack +getRequest :: Monad mo => GGHandler s m mo Request +getRequest = handlerRequest `liftM` GHandler ask + instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where failure = GHandler . lift . throwError . HCError -instance RequestReader (GHandler sub master) where -- FIXME kill this typeclass, does not work for GGHandler - getRequest = handlerRequest <$> GHandler ask - runRequestBody = do - x <- GHandler $ lift $ lift $ lift get - case ghsRBC x of - Just rbc -> return rbc - Nothing -> do - rr <- waiRequest - rbc <- lift $ rbHelper rr - GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } - return rbc + +runRequestBody :: GHandler s m RequestBodyContents +runRequestBody = do + x <- GHandler $ lift $ lift $ lift get + case ghsRBC x of + Just rbc -> return rbc + Nothing -> do + rr <- waiRequest + rbc <- lift $ rbHelper rr + GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } + return rbc rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents rbHelper req = @@ -555,7 +561,7 @@ notFound :: Failure ErrorResponse m => m a notFound = failure NotFound -- | Return a 405 method not supported page. -badMethod :: (RequestReader m, Failure ErrorResponse m) => m a +badMethod :: Monad mo => GGHandler s m mo a badMethod = do w <- waiRequest failure $ BadMethod $ W.requestMethod w @@ -807,3 +813,7 @@ hamletToContent h = do hamletToRepHtml :: Monad mo => Hamlet (Route master) -> GGHandler 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 = reqWaiRequest `liftM` getRequest diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs index 183b5cb3..f668f6a4 100644 --- a/Yesod/Internal/Request.hs +++ b/Yesod/Internal/Request.hs @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Yesod.Internal.Request ( parseWaiRequest + , Request (..) + , RequestBodyContents + , FileInfo (..) ) where -import Yesod.Request import Control.Arrow (first, second) import qualified Network.Wai.Parse as NWP import Yesod.Internal @@ -16,6 +18,18 @@ import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText) import Control.Monad (join) import Data.Maybe (fromMaybe) +import qualified Data.ByteString.Lazy as L + +-- | The parsed request information. +data Request = Request + { reqGetParams :: [(Text, Text)] + , reqCookies :: [(Text, Text)] + , reqWaiRequest :: W.Request + -- | Languages which the client supports. + , reqLangs :: [Text] + -- | A random, session-specific nonce used to prevent CSRF attacks. + , reqNonce :: Maybe Text + } parseWaiRequest :: W.Request -> [(Text, Text)] -- ^ session @@ -57,3 +71,16 @@ parseWaiRequest env session' key' = do | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | A tuple containing both the POST parameters and submitted files. +type RequestBodyContents = + ( [(Text, Text)] + , [(Text, FileInfo)] + ) + +data FileInfo = FileInfo + { fileName :: Text + , fileContentType :: Text + , fileContent :: L.ByteString + } + deriving (Eq, Show) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index ce257946..3d42e3cb 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -16,10 +16,8 @@ module Yesod.Request -- * Request datatype RequestBodyContents , Request (..) - , RequestReader (..) , FileInfo (..) -- * Convenience functions - , waiRequest , languages -- * Lookup parameters , lookupGetParam @@ -33,21 +31,13 @@ module Yesod.Request , lookupFiles ) where -import qualified Network.Wai as W -import qualified Data.ByteString.Lazy as BL -import Control.Monad.IO.Class +import Yesod.Internal.Request +import Yesod.Handler import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) import Data.Text (Text) --- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler - --- | The reader monad specialized for 'Request'. -class Monad m => RequestReader m where - getRequest :: m Request - runRequestBody :: m RequestBodyContents - -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order @@ -62,83 +52,50 @@ class Monad m => RequestReader m where -- * Accept-Language HTTP header. -- -- This is handled by parseWaiRequest (not exposed). -languages :: RequestReader m => m [Text] +languages :: Monad mo => GGHandler s m mo [Text] languages = reqLangs `liftM` getRequest --- | Get the request\'s 'W.Request' value. -waiRequest :: RequestReader m => m W.Request -waiRequest = reqWaiRequest `liftM` getRequest - --- | A tuple containing both the POST parameters and submitted files. -type RequestBodyContents = - ( [(Text, Text)] - , [(Text, FileInfo)] - ) - -data FileInfo = FileInfo - { fileName :: Text - , fileContentType :: Text - , fileContent :: BL.ByteString - } - deriving (Eq, Show) - --- | The parsed request information. -data Request = Request - { reqGetParams :: [(Text, Text)] - , reqCookies :: [(Text, Text)] - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [Text] - -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: Maybe Text - } - lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup for GET parameters. -lookupGetParams :: RequestReader m => Text -> m [Text] +lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. -lookupGetParam :: RequestReader m => Text -> m (Maybe Text) +lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. -lookupPostParams :: RequestReader m - => Text - -> m [Text] +lookupPostParams :: Text -> GHandler s m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp -lookupPostParam :: (MonadIO m, RequestReader m) - => Text - -> m (Maybe Text) +lookupPostParam :: Text + -> GHandler s m (Maybe Text) lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. -lookupFile :: (MonadIO m, RequestReader m) - => Text - -> m (Maybe FileInfo) +lookupFile :: Text + -> GHandler s m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: RequestReader m - => Text - -> m [FileInfo] +lookupFiles :: Text + -> GHandler s m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: RequestReader m => Text -> m (Maybe Text) +lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: RequestReader m => Text -> m [Text] +lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr From 0a8c8e7f9c3970c12a432ba4f36f65238c165ff0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 13:08:25 +0300 Subject: [PATCH 084/126] Removed extra type argument on GGWidget --- Yesod/Widget.hs | 56 ++++++++++++++++++++++++------------------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 5d863972..ade2f79a 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -56,29 +56,29 @@ import Control.Monad.IO.Control (MonadControlIO) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. -newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner m monad a } -- FIXME remove s +newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a } deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) -instance MonadTrans (GGWidget s m) where +instance MonadTrans (GGWidget m) where lift = GWidget . lift -type GWidget s m = GGWidget s m (GHandler s m) +type GWidget s m = GGWidget m (GHandler s m) type GWInner master = RWST () (GWData (Route master)) Int -instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where +instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where mempty = return () mappend x y = x >> y -instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where - newtype HamletMonad (GGWidget s m monad a) b = - GWidget' { runGWidget' :: GGWidget s m monad b } - type HamletUrl (GGWidget s m monad a) = Route m +instance (Monad monad, a ~ ()) => HamletValue (GGWidget m monad a) where + newtype HamletMonad (GGWidget m monad a) b = + GWidget' { runGWidget' :: GGWidget m monad b } + type HamletUrl (GGWidget m monad a) = Route m toHamletValue = runGWidget' htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $ addHamlet $ \r -> preEscapedText (r url params) fromHamletValue = GWidget' -instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where +instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget m monad a)) where return = GWidget' . return x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y @@ -94,79 +94,79 @@ addSubWidget sub (GWidget w) = do -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. -setTitle :: Monad m => Html -> GGWidget sub master m () +setTitle :: Monad m => Html -> GGWidget master m () setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty -- | Add a 'Hamlet' to the head tag. -addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m () +addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m () addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head -- | Add a 'Html' to the head tag. -addHtmlHead :: Monad m => Html -> GGWidget sub master m () +addHtmlHead :: Monad m => Html -> GGWidget master m () addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag. -addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m () +addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m () addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -- | Add a 'Html' to the body tag. -addHtml :: Monad m => Html -> GGWidget sub master m () +addHtml :: Monad m => Html -> GGWidget master m () addHtml = addHamlet . const -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent. -addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo () +addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo () addWidget = id -- | Add some raw CSS to the style tag. -addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m () +addCassius :: Monad m => Cassius (Route master) -> GGWidget master m () addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty -- | Link to the specified local stylesheet. -addStylesheet :: Monad m => Route master -> GGWidget sub master m () +addStylesheet :: Monad m => Route master -> GGWidget master m () addStylesheet = flip addStylesheetAttrs [] -- | Link to the specified local stylesheet. -addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m () addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. -addStylesheetRemote :: Monad m => Text -> GGWidget sub master m () +addStylesheetRemote :: Monad m => Text -> GGWidget master m () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. -addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m () addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty -addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget sub master m () +addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Monad m => Either (Route master) Text -> GGWidget sub master m () +addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. -addScript :: Monad m => Route master -> GGWidget sub master m () +addScript :: Monad m => Route master -> GGWidget master m () addScript = flip addScriptAttrs [] -- | Link to the specified local script. -addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m () +addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m () addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. -addScriptRemote :: Monad m => Text -> GGWidget sub master m () +addScriptRemote :: Monad m => Text -> GGWidget master m () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. -addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m () +addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m () addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag. -addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m () +addJulius :: Monad m => Julius (Route master) -> GGWidget master m () addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. -extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m)) +extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m)) extractBody (GWidget w) = GWidget $ mapRWST (liftM go) w where From b1ecaeee086702481fd06fbe82db7661c90c1e44 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 13:13:57 +0300 Subject: [PATCH 085/126] cookiePath --- Yesod/Core.hs | 7 ++++++- Yesod/Handler.hs | 13 +++++++------ 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 92c5d53a..72a7b779 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -226,6 +226,11 @@ class RenderRoute (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True + -- | The path value to set for cookies. By default, uses \"\/\", meaning + -- cookies will be sent to every page on the current domain. + cookiePath :: a -> S8.ByteString + cookiePath _ = "/" + defaultYesodRunner :: Yesod master => a -> master @@ -289,7 +294,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do sessionName sessionVal : hs - hs'' = map (headerToPair getExpires) hs' + hs'' = map (headerToPair (cookiePath master) getExpires) hs' hs''' = ("Content-Type", ct) : hs'' data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 9b3e6268..8b1e820d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -739,22 +739,23 @@ httpAccept = parseHttpAccept . W.requestHeaders -- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time +headerToPair :: S.ByteString -- ^ cookie path + -> (Int -> UTCTime) -- ^ minutes -> expiration time -> Header -> (CI H.Ascii, H.Ascii) -headerToPair getExpires (AddCookie minutes key value) = +headerToPair cp getExpires (AddCookie minutes key value) = ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie { setCookieName = key , setCookieValue = value - , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookiePath = Just cp , setCookieExpires = Just $ getExpires minutes , setCookieDomain = Nothing }) -headerToPair _ (DeleteCookie key) = +headerToPair cp _ (DeleteCookie key) = ( "Set-Cookie" - , key `mappend` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" + , key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ) -headerToPair _ (Header key value) = (key, value) +headerToPair _ _ (Header key value) = (key, value) -- | Get a unique identifier. newIdent :: Monad mo => GGHandler sub master mo String From 2e7e24f2a267398c8b1f091600f57eae925a4735 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 1 Apr 2011 14:24:21 +0300 Subject: [PATCH 086/126] addJuliusBody --- Test/Widget.hs | 45 +++++++++++++++++++++++++++++++++++++++++++++ Yesod/Widget.hs | 9 ++++++++- runtests.hs | 2 ++ 3 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 Test/Widget.hs diff --git a/Test/Widget.hs b/Test/Widget.hs new file mode 100644 index 00000000..b3edabff --- /dev/null +++ b/Test/Widget.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Widget (widgetTest) where + +import Yesod.Core +import Yesod.Content +import Yesod.Dispatch +import Yesod.Widget +import Text.Julius + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Network.Wai +import Network.Wai.Test + +import qualified Data.ByteString.Lazy.Char8 as L8 + +data Y = Y +mkYesod "Y" [$parseRoutes| +/ RootR GET +|] + +instance Yesod Y where + approot _ = "http://test" + +getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|] + +widgetTest :: Test +widgetTest = testGroup "Test.Exceptions" + [ testCase "addJuliusBody" case_addJuliusBody + ] + +runner f = toWaiApp Y >>= runSession f +defaultRequest = Request + { pathInfo = [] + , requestHeaders = [] + , queryString = [] + , requestMethod = "GET" + } + +case_addJuliusBody = runner $ do + res <- request defaultRequest + assertBody "<!DOCTYPE html>\n<html><head><title>" res diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ade2f79a..b32d8665 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -27,6 +27,7 @@ module Yesod.Widget , addStylesheetEither -- ** Javascript , addJulius + , addJuliusBody , addScript , addScriptAttrs , addScriptRemote @@ -38,7 +39,8 @@ module Yesod.Widget import Data.Monoid import Control.Monad.Trans.RWS -import Text.Blaze (preEscapedText) +import Text.Blaze (preEscapedText, preEscapedLazyText) +import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius import Text.Julius @@ -164,6 +166,11 @@ addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Scr addJulius :: Monad m => Julius (Route master) -> GGWidget master m () addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty +-- | Add a new script tag to the body with the contents of this 'Julius' +-- template. +addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m () +addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j + -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m)) diff --git a/runtests.hs b/runtests.hs index d4d2c34b..ac283084 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,9 +1,11 @@ import Test.Framework (defaultMain) import Test.CleanPath import Test.Exceptions +import Test.Widget main :: IO () main = defaultMain [ cleanPathTest , exceptionsTest + , widgetTest ] From 423f693bc32608049dc0b2902d731bd57e931643 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 3 Apr 2011 22:07:40 +0300 Subject: [PATCH 087/126] Fix query string redirect bug --- Test/CleanPath.hs | 11 +++++++++++ Yesod/Internal/Dispatch.hs | 1 - 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs index f00c7c93..d6248ff2 100644 --- a/Test/CleanPath.hs +++ b/Test/CleanPath.hs @@ -38,6 +38,7 @@ mkYesod "Y" [$parseRoutes| /foo/#String FooStringR GET /bar BarR GET /subsite SubsiteR Subsite getSubsite +/plain PlainR GET |] instance Yesod Y where @@ -54,6 +55,7 @@ instance Yesod Y where getFooR = return $ RepPlain "foo" getFooStringR = return . RepPlain . toContent getBarR = return $ RepPlain "bar" +getPlainR = return $ RepPlain "plain" cleanPathTest :: Test cleanPathTest = testGroup "Test.CleanPath" @@ -63,6 +65,7 @@ cleanPathTest = testGroup "Test.CleanPath" , testCase "has trailing slash" hasTrailingSlash , testCase "/foo/something" fooSomething , testCase "subsite dispatch" subsiteDispatch + , testCase "redirect with query string" redQueryString ] runner f = toWaiApp Y >>= runSession f @@ -119,3 +122,11 @@ subsiteDispatch = runner $ do assertStatus 200 res assertContentType "SUBSITE" res assertBody "[\"1\",\"2\",\"3\",\"\"]" res + +redQueryString = runner $ do + res <- request defaultRequest + { pathInfo = decodePathSegments "/plain/" + , rawQueryString = "?foo=bar" + } + assertStatus 301 res + assertHeader "Location" "http://test/plain?foo=bar" res diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index f8f073e8..9594b652 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -92,7 +92,6 @@ sendRedirect y segments' env = if S.null (W.rawQueryString env) then dest else (dest `mappend` - Blaze.ByteString.Builder.Char8.fromChar '?' `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) mkYesodDispatch' :: [((String, Pieces), Maybe String)] From 300fe9031ff9f173b5bec0180d9553a6c6ca54a3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 3 Apr 2011 22:16:11 +0300 Subject: [PATCH 088/126] maximumContentLength --- Yesod/Core.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 72a7b779..15a4a984 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -62,6 +62,7 @@ import qualified Data.Text.Encoding.Error as TEE import Blaze.ByteString.Builder (Builder, toByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') +import qualified Network.HTTP.Types as H #if GHC7 #define HAMLET hamlet @@ -231,6 +232,10 @@ class RenderRoute (Route a) => Yesod a where cookiePath :: a -> S8.ByteString cookiePath _ = "/" + -- | Maximum allowed length of the request body, in bytes. + maximumContentLength :: a -> Maybe (Route a) -> Int + maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes + defaultYesodRunner :: Yesod master => a -> master @@ -239,6 +244,18 @@ defaultYesodRunner :: Yesod master -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application +defaultYesodRunner _ m toMaster _ murl _ req + | maximumContentLength m (fmap toMaster murl) < len = + return $ W.responseLBS + (H.Status 413 "Too Large") + [("Content-Type", "text/plain")] + "Request body too large to be processed." + where + len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay + readMay s = + case reads $ S8.unpack s of + [] -> Nothing + (x, _):_ -> Just x defaultYesodRunner s master toMasterRoute mkey murl handler req = do now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now From 06ad6c254b1088119d2242600915854483dbad76 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 3 Apr 2011 22:24:13 +0300 Subject: [PATCH 089/126] messageLogger --- Yesod/Core.hs | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 15a4a984..26759eba 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -19,6 +19,9 @@ module Yesod.Core , defaultErrorHandler -- * Data types , AuthResult (..) + -- * Logging + , LogLevel (..) + , formatLogMessage -- * Misc , yesodVersion , yesodRender @@ -63,6 +66,10 @@ import Blaze.ByteString.Builder (Builder, toByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') import qualified Network.HTTP.Types as H +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO +import qualified System.IO +import qualified Data.Text.Lazy.Builder as TB #if GHC7 #define HAMLET hamlet @@ -236,6 +243,34 @@ class RenderRoute (Route a) => Yesod a where maximumContentLength :: a -> Maybe (Route a) -> Int maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes + -- | Send a message to the log. By default, prints to stderr. + messageLogger :: a + -> LogLevel + -> Text -- ^ source + -> Text -- ^ message + -> IO () + messageLogger _ level src msg = + formatLogMessage level src msg >>= + Data.Text.Lazy.IO.hPutStrLn System.IO.stderr + +data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text + deriving (Eq, Show, Read, Ord) + +formatLogMessage :: LogLevel + -> Text -- ^ source + -> Text -- ^ message + -> IO TL.Text +formatLogMessage level src msg = do + now <- getCurrentTime + return $ TB.toLazyText $ + TB.fromText (TS.pack $ show now) + `mappend` TB.fromText ": " + `mappend` TB.fromText (TS.pack $ show level) + `mappend` TB.fromText "@(" + `mappend` TB.fromText src + `mappend` TB.fromText ") " + `mappend` TB.fromText msg + defaultYesodRunner :: Yesod master => a -> master From aa20916e948bccabd1a29271ab891aff76423456 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Apr 2011 20:54:50 +0300 Subject: [PATCH 090/126] Some implementations from Bas --- Yesod/Handler.hs | 42 +++++++++++++++++++++++++++++++++++------- 1 file changed, 35 insertions(+), 7 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 8b1e820d..19d4941d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -137,7 +137,7 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import Control.Monad.IO.Control (MonadControlIO) -import Control.Monad.Trans.Control (MonadTransControl, liftControl, control) +import Control.Monad.Trans.Control (MonadTransControl, liftControl) import qualified Data.Map as Map import qualified Data.ByteString as S import Data.ByteString (ByteString) @@ -768,14 +768,42 @@ newIdent = GHandler $ lift $ lift $ lift $ do liftIOHandler :: MonadIO mo => GGHandler sub master IO a -> GGHandler sub master mo a -liftIOHandler x = error "FIXME liftIOHandler" {- do - k <- control - join $ liftIO $ k x -} +liftIOHandler m = GHandler $ + ReaderT $ \r -> + ErrorT $ + WriterT $ + StateT $ \s -> + liftIO $ runGGHandler m r s + +runGGHandler :: GGHandler sub master m a + -> HandlerData sub master + -> GHState + -> m ( ( Either HandlerContents a + , Endo [Header] + ) + , GHState + ) +runGGHandler m r s = runStateT + (runWriterT + (runErrorT + (runReaderT + (unGHandler m) r))) s instance MonadTransControl (GGHandler s m) where - liftControl = error "FIXME liftControl for GGHandler" {-GHandler $ do - k <- liftControl $ liftControl $ liftControl control - return $ liftM GHandler . k . unGHandler -} + liftControl f = + GHandler $ + liftControl $ \runRdr -> + liftControl $ \runErr -> + liftControl $ \runWrt -> + liftControl $ \runSt -> + f ( liftM ( GHandler + . join . lift + . join . lift + . join . lift + ) + . runSt . runWrt . runErr . runRdr + . unGHandler + ) -- | Redirect to a POST resource. -- From 372bcf52d81f1b92a5d8b986ba45dca59f0bdb39 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Apr 2011 21:46:08 +0300 Subject: [PATCH 091/126] Yesod.Core exports everything --- Yesod/Core.hs | 529 +---------------------------------- Yesod/Dispatch.hs | 2 +- Yesod/Internal/Core.hs | 546 +++++++++++++++++++++++++++++++++++++ Yesod/Internal/Dispatch.hs | 4 +- yesod-core.cabal | 3 +- 5 files changed, 560 insertions(+), 524 deletions(-) create mode 100644 Yesod/Internal/Core.hs diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 26759eba..3fe6b4f4 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | The basic typeclass for a Yesod application. module Yesod.Core ( -- * Type classes Yesod (..) @@ -25,522 +19,17 @@ module Yesod.Core -- * Misc , yesodVersion , yesodRender + -- * Re-exports + , module Yesod.Content + , module Yesod.Dispatch + , module Yesod.Handler + , module Yesod.Request + , module Yesod.Widget ) where +import Yesod.Internal.Core import Yesod.Content +import Yesod.Dispatch import Yesod.Handler - -import Control.Arrow ((***)) -import qualified Paths_yesod_core -import Data.Version (showVersion) -import Yesod.Widget import Yesod.Request -import qualified Network.Wai as W -import Yesod.Internal -import Yesod.Internal.Session -import Yesod.Internal.Request -import Web.ClientSession (getKey, defaultKeyFile) -import qualified Web.ClientSession as CS -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.Monoid -import Control.Monad.Trans.RWS -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue) -import qualified Text.Blaze.Html5 as TBH -import Data.Text.Lazy.Builder (toLazyText) -import Data.Text.Lazy.Encoding (encodeUtf8) -import Data.Maybe (fromMaybe) -import Control.Monad.IO.Class (liftIO) -import Web.Cookie (parseCookies) -import qualified Data.Map as Map -import Data.Time -import Network.HTTP.Types (encodePath) -import qualified Data.Text as TS -import Data.Text (Text) -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TEE -import Blaze.ByteString.Builder (Builder, toByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromText) -import Data.List (foldl') -import qualified Network.HTTP.Types as H -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO -import qualified System.IO -import qualified Data.Text.Lazy.Builder as TB - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - -class Eq u => RenderRoute u where - renderRoute :: u -> ([Text], [(Text, Text)]) - --- | This class is automatically instantiated when you use the template haskell --- mkYesod function. You should never need to deal with it directly. -class YesodDispatch a master where - yesodDispatch - :: Yesod master - => a - -> Maybe CS.Key - -> [Text] - -> master - -> (Route a -> Route master) - -> Maybe W.Application - - yesodRunner :: Yesod master - => a - -> master - -> (Route a -> Route master) - -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application - yesodRunner = defaultYesodRunner - --- | Define settings for a Yesod applications. The only required setting is --- 'approot'; other than that, there are intelligent defaults. -class RenderRoute (Route a) => Yesod a where - -- | An absolute URL to the root of the application. Do not include - -- trailing slash. - -- - -- If you want to be lazy, you can supply an empty string under the - -- following conditions: - -- - -- * Your application is served from the root of the domain. - -- - -- * You do not use any features that require absolute URLs, such as Atom - -- feeds and XML sitemaps. - approot :: a -> Text - - -- | The encryption key to be used for encrypting client sessions. - -- Returning 'Nothing' disables sessions. - encryptKey :: a -> IO (Maybe CS.Key) - encryptKey _ = fmap Just $ getKey defaultKeyFile - - -- | Number of minutes before a client session times out. Defaults to - -- 120 (2 hours). - clientSessionDuration :: a -> Int - clientSessionDuration = const 120 - - -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler sub a ChooseRep - errorHandler = defaultErrorHandler - - -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml - defaultLayout w = do - p <- widgetToPageContent w - mmsg <- getMessage - hamletToRepHtml [HAMLET| -!!! - - - - #{pageTitle p} - ^{pageHead p} - <body> - $maybe msg <- mmsg - <p .message>#{msg} - ^{pageBody p} -|] - - -- | Override the rendering function for a particular URL. One use case for - -- this is to offload static hosting to a different domain name to avoid - -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe Builder - urlRenderOverride _ _ = Nothing - - -- | Determine if a request is authorized or not. - -- - -- Return 'Nothing' is the request is authorized, 'Just' a message if - -- unauthorized. If authentication is required, you should use a redirect; - -- the Auth helper provides this functionality automatically. - isAuthorized :: Route a - -> Bool -- ^ is this a write request? - -> GHandler s a AuthResult - isAuthorized _ _ = return Authorized - - -- | Determines whether the current request is a write request. By default, - -- this assumes you are following RESTful principles, and determines this - -- from request method. In particular, all except the following request - -- methods are considered write: GET HEAD OPTIONS TRACE. - -- - -- This function is used to determine if a request is authorized; see - -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler s a Bool - isWriteRequest _ = do - wai <- waiRequest - return $ not $ W.requestMethod wai `elem` - ["GET", "HEAD", "OPTIONS", "TRACE"] - - -- | The default route for authentication. - -- - -- Used in particular by 'isAuthorized', but library users can do whatever - -- they want with it. - authRoute :: a -> Maybe (Route a) - authRoute _ = Nothing - - -- | A function used to clean up path segments. It returns 'Right' with a - -- clean path or 'Left' with a new set of pieces the user should be - -- redirected to. The default implementation enforces: - -- - -- * No double slashes - -- - -- * There is no trailing slash. - -- - -- Note that versions of Yesod prior to 0.7 used a different set of rules - -- involing trailing slashes. - cleanPath :: a -> [Text] -> Either [Text] [Text] - cleanPath _ s = - if corrected == s - then Right s - else Left corrected - where - corrected = filter (not . TS.null) s - - -- | Join the pieces of a path together into an absolute URL. This should - -- be the inverse of 'splitPath'. - joinPath :: a - -> Builder -- ^ application root - -> [TS.Text] -- ^ path pieces - -> [(TS.Text, TS.Text)] -- ^ query string - -> Builder - joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs - where - qs = map (TE.encodeUtf8 *** go) qs' - go "" = Nothing - go x = Just $ TE.encodeUtf8 x - - -- | This function is used to store some static content to be served as an - -- external file. The most common case of this is stashing CSS and - -- JavaScript content in an external file; the "Yesod.Widget" module uses - -- this feature. - -- - -- The return value is 'Nothing' if no storing was performed; this is the - -- default implementation. A 'Just' 'Left' gives the absolute URL of the - -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is - -- necessary when you are serving the content outside the context of a - -- Yesod application, such as via memcached. - addStaticContent :: Text -- ^ filename extension - -> Text -- ^ mime-type - -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) - addStaticContent _ _ _ = return Nothing - - -- | Whether or not to tie a session to a specific IP address. Defaults to - -- 'True'. - sessionIpAddress :: a -> Bool - sessionIpAddress _ = True - - -- | The path value to set for cookies. By default, uses \"\/\", meaning - -- cookies will be sent to every page on the current domain. - cookiePath :: a -> S8.ByteString - cookiePath _ = "/" - - -- | Maximum allowed length of the request body, in bytes. - maximumContentLength :: a -> Maybe (Route a) -> Int - maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes - - -- | Send a message to the log. By default, prints to stderr. - messageLogger :: a - -> LogLevel - -> Text -- ^ source - -> Text -- ^ message - -> IO () - messageLogger _ level src msg = - formatLogMessage level src msg >>= - Data.Text.Lazy.IO.hPutStrLn System.IO.stderr - -data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text - deriving (Eq, Show, Read, Ord) - -formatLogMessage :: LogLevel - -> Text -- ^ source - -> Text -- ^ message - -> IO TL.Text -formatLogMessage level src msg = do - now <- getCurrentTime - return $ TB.toLazyText $ - TB.fromText (TS.pack $ show now) - `mappend` TB.fromText ": " - `mappend` TB.fromText (TS.pack $ show level) - `mappend` TB.fromText "@(" - `mappend` TB.fromText src - `mappend` TB.fromText ") " - `mappend` TB.fromText msg - -defaultYesodRunner :: Yesod master - => a - -> master - -> (Route a -> Route master) - -> Maybe CS.Key - -> Maybe (Route a) - -> GHandler a master ChooseRep - -> W.Application -defaultYesodRunner _ m toMaster _ murl _ req - | maximumContentLength m (fmap toMaster murl) < len = - return $ W.responseLBS - (H.Status 413 "Too Large") - [("Content-Type", "text/plain")] - "Request body too large to be processed." - where - len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay - readMay s = - case reads $ S8.unpack s of - [] -> Nothing - (x, _):_ -> Just x -defaultYesodRunner s master toMasterRoute mkey murl handler req = do - now <- liftIO getCurrentTime - let getExpires m = fromIntegral (m * 60) `addUTCTime` now - let exp' = getExpires $ clientSessionDuration master - let rh = takeWhile (/= ':') $ show $ W.remoteHost req - let host = if sessionIpAddress master then S8.pack rh else "" - let session' = - case mkey of - Nothing -> [] - Just key -> fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders req - val <- lookup sessionName $ parseCookies raw - decodeSession key now host val - rr <- liftIO $ parseWaiRequest req session' mkey - let h = do - case murl of - Nothing -> handler - Just url -> do - isWrite <- isWriteRequest $ toMasterRoute url - ar <- isAuthorized (toMasterRoute url) isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute master of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDest' - redirect RedirectTemporary url' - Unauthorized s' -> permissionDenied s' - handler - let sessionMap = Map.fromList - $ filter (\(x, _) -> x /= nonceKey) session' - yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h - let mnonce = reqNonce rr - return $ yarToResponse (hr mnonce getExpires host exp') yar - where - hr mnonce getExpires host exp' hs ct sm = - hs''' - where - sessionVal = - case (mkey, mnonce) of - (Just key, Just nonce) - -> encodeSession key exp' host - $ Map.toList - $ Map.insert nonceKey nonce sm - _ -> mempty - hs' = - case mkey of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration master) - sessionName - sessionVal - : hs - hs'' = map (headerToPair (cookiePath master) getExpires) hs' - hs''' = ("Content-Type", ct) : hs'' - -data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text - deriving (Eq, Show, Read) - --- | A type-safe, concise method of creating breadcrumbs for pages. For each --- resource, you declare the title of the page and the parent resource (if --- present). -class YesodBreadcrumbs y where - -- | Returns the title and the parent resource, if available. If you return - -- a 'Nothing', then this is considered a top-level page. - breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) - --- | Gets the title of the current page and the hierarchy of parent pages, --- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) -breadcrumbs = do - x' <- getCurrentRoute - tm <- getRouteToMaster - let x = fmap tm x' - case x of - Nothing -> return ("Not found", []) - Just y -> do - (title, next) <- breadcrumb y - z <- go [] next - return (title, z) - where - go back Nothing = return back - go back (Just this) = do - (title, next) <- breadcrumb this - go ((this, title) : back) next - -applyLayout' :: Yesod master - => Html -- ^ title - -> Hamlet (Route master) -- ^ body - -> GHandler sub master ChooseRep -applyLayout' title body = fmap chooseRep $ defaultLayout $ do - setTitle title - addHamlet body - --- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r - applyLayout' "Not Found" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h1>Not Found -<p>#{path'} -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h1>Permission denied -<p>#{msg} -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h1>Invalid Arguments -<ul> - $forall msg <- ia - <li>#{msg} -|] -defaultErrorHandler (InternalError e) = - applyLayout' "Internal Server Error" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h1>Internal Server Error -<p>#{e} -|] -defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h1>Method Not Supported -<p>Method "#{S8.unpack m}" not supported -|] - --- | Return the same URL if the user is authorized to see it. --- --- Built on top of 'isAuthorized'. This is useful for building page that only --- contain links to pages the user is allowed to see. -maybeAuthorized :: Yesod a - => Route a - -> Bool -- ^ is this a write request? - -> GHandler s a (Maybe (Route a)) -maybeAuthorized r isWrite = do - x <- isAuthorized r isWrite - return $ if x == Authorized then Just r else Nothing - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent (GWidget w) = do - ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 - let title = maybe mempty unTitle mTitle - let scripts = runUniqueList scripts' - let stylesheets = runUniqueList stylesheets' - let cssToHtml = preEscapedLazyText . renderCss - celper :: Cassius url -> Hamlet url - celper = fmap cssToHtml - jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b - jelper :: Julius url -> Hamlet url - jelper = fmap jsToHtml - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - cssLoc <- - case style of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "css" "text/css; charset=utf-8" - $ encodeUtf8 $ renderCassius render s - return $ renderLoc x - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ encodeUtf8 $ renderJulius render s - return $ renderLoc x - - let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) - let renderLoc' render' (Local url) = render' url [] - renderLoc' _ (Remote s) = s - let mkScriptTag (Script loc attrs) render' = - foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () - let mkLinkTag (Stylesheet loc attrs) render' = - foldl' addAttr TBH.link - ( ("rel", "stylesheet") - : ("href", renderLoc' render' loc) - : attrs - ) - let head'' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -$forall s <- scripts - ^{mkScriptTag s} -$forall s <- stylesheets - ^{mkLinkTag s} -$maybe s <- style - $maybe s <- cssLoc - <link rel=stylesheet href=#{s} - $nothing - <style>^{celper s} -$maybe j <- jscript - $maybe s <- jsLoc - <script src="#{s}"> - $nothing - <script>^{jelper j} -\^{head'} -|] - return $ PageContent title head'' body - -yesodVersion :: String -yesodVersion = showVersion Paths_yesod_core.version - -yesodRender :: Yesod y - => y - -> Route y - -> [(Text, Text)] - -> Text -yesodRender y u qs = - TE.decodeUtf8 $ toByteString $ - fromMaybe - (joinPath y (fromText $ approot y) ps - $ qs ++ qs') - (urlRenderOverride y u) - where - (ps, qs') = renderRoute u +import Yesod.Widget diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index d868498d..4f3778bf 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -22,7 +22,7 @@ module Yesod.Dispatch import Data.Either (partitionEithers) import Prelude hiding (exp) -import Yesod.Core +import Yesod.Internal.Core import Yesod.Handler import Yesod.Internal.Dispatch diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs new file mode 100644 index 00000000..1c1b2ac0 --- /dev/null +++ b/Yesod/Internal/Core.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +-- | The basic typeclass for a Yesod application. +module Yesod.Internal.Core + ( -- * Type classes + Yesod (..) + , YesodDispatch (..) + , RenderRoute (..) + -- ** Breadcrumbs + , YesodBreadcrumbs (..) + , breadcrumbs + -- * Utitlities + , maybeAuthorized + , widgetToPageContent + -- * Defaults + , defaultErrorHandler + -- * Data types + , AuthResult (..) + -- * Logging + , LogLevel (..) + , formatLogMessage + -- * Misc + , yesodVersion + , yesodRender + ) where + +import Yesod.Content +import Yesod.Handler + +import Control.Arrow ((***)) +import qualified Paths_yesod_core +import Data.Version (showVersion) +import Yesod.Widget +import Yesod.Request +import qualified Network.Wai as W +import Yesod.Internal +import Yesod.Internal.Session +import Yesod.Internal.Request +import Web.ClientSession (getKey, defaultKeyFile) +import qualified Web.ClientSession as CS +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Control.Monad.Trans.RWS +import Text.Hamlet +import Text.Cassius +import Text.Julius +import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue) +import qualified Text.Blaze.Html5 as TBH +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Maybe (fromMaybe) +import Control.Monad.IO.Class (liftIO) +import Web.Cookie (parseCookies) +import qualified Data.Map as Map +import Data.Time +import Network.HTTP.Types (encodePath) +import qualified Data.Text as TS +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE +import Blaze.ByteString.Builder (Builder, toByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromText) +import Data.List (foldl') +import qualified Network.HTTP.Types as H +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO +import qualified System.IO +import qualified Data.Text.Lazy.Builder as TB + +#if GHC7 +#define HAMLET hamlet +#else +#define HAMLET $hamlet +#endif + +class Eq u => RenderRoute u where + renderRoute :: u -> ([Text], [(Text, Text)]) + +-- | This class is automatically instantiated when you use the template haskell +-- mkYesod function. You should never need to deal with it directly. +class YesodDispatch a master where + yesodDispatch + :: Yesod master + => a + -> Maybe CS.Key + -> [Text] + -> master + -> (Route a -> Route master) + -> Maybe W.Application + + yesodRunner :: Yesod master + => a + -> master + -> (Route a -> Route master) + -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application + yesodRunner = defaultYesodRunner + +-- | Define settings for a Yesod applications. The only required setting is +-- 'approot'; other than that, there are intelligent defaults. +class RenderRoute (Route a) => Yesod a where + -- | An absolute URL to the root of the application. Do not include + -- trailing slash. + -- + -- If you want to be lazy, you can supply an empty string under the + -- following conditions: + -- + -- * Your application is served from the root of the domain. + -- + -- * You do not use any features that require absolute URLs, such as Atom + -- feeds and XML sitemaps. + approot :: a -> Text + + -- | The encryption key to be used for encrypting client sessions. + -- Returning 'Nothing' disables sessions. + encryptKey :: a -> IO (Maybe CS.Key) + encryptKey _ = fmap Just $ getKey defaultKeyFile + + -- | Number of minutes before a client session times out. Defaults to + -- 120 (2 hours). + clientSessionDuration :: a -> Int + clientSessionDuration = const 120 + + -- | Output error response pages. + errorHandler :: ErrorResponse -> GHandler sub a ChooseRep + errorHandler = defaultErrorHandler + + -- | Applies some form of layout to the contents of a page. + defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout w = do + p <- widgetToPageContent w + mmsg <- getMessage + hamletToRepHtml [HAMLET| +!!! + +<html> + <head> + <title>#{pageTitle p} + ^{pageHead p} + <body> + $maybe msg <- mmsg + <p .message>#{msg} + ^{pageBody p} +|] + + -- | Override the rendering function for a particular URL. One use case for + -- this is to offload static hosting to a different domain name to avoid + -- sending cookies. + urlRenderOverride :: a -> Route a -> Maybe Builder + urlRenderOverride _ _ = Nothing + + -- | Determine if a request is authorized or not. + -- + -- Return 'Nothing' is the request is authorized, 'Just' a message if + -- unauthorized. If authentication is required, you should use a redirect; + -- the Auth helper provides this functionality automatically. + isAuthorized :: Route a + -> Bool -- ^ is this a write request? + -> GHandler s a AuthResult + isAuthorized _ _ = return Authorized + + -- | Determines whether the current request is a write request. By default, + -- this assumes you are following RESTful principles, and determines this + -- from request method. In particular, all except the following request + -- methods are considered write: GET HEAD OPTIONS TRACE. + -- + -- This function is used to determine if a request is authorized; see + -- 'isAuthorized'. + isWriteRequest :: Route a -> GHandler s a Bool + isWriteRequest _ = do + wai <- waiRequest + return $ not $ W.requestMethod wai `elem` + ["GET", "HEAD", "OPTIONS", "TRACE"] + + -- | The default route for authentication. + -- + -- Used in particular by 'isAuthorized', but library users can do whatever + -- they want with it. + authRoute :: a -> Maybe (Route a) + authRoute _ = Nothing + + -- | A function used to clean up path segments. It returns 'Right' with a + -- clean path or 'Left' with a new set of pieces the user should be + -- redirected to. The default implementation enforces: + -- + -- * No double slashes + -- + -- * There is no trailing slash. + -- + -- Note that versions of Yesod prior to 0.7 used a different set of rules + -- involing trailing slashes. + cleanPath :: a -> [Text] -> Either [Text] [Text] + cleanPath _ s = + if corrected == s + then Right s + else Left corrected + where + corrected = filter (not . TS.null) s + + -- | Join the pieces of a path together into an absolute URL. This should + -- be the inverse of 'splitPath'. + joinPath :: a + -> Builder -- ^ application root + -> [TS.Text] -- ^ path pieces + -> [(TS.Text, TS.Text)] -- ^ query string + -> Builder + joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs + where + qs = map (TE.encodeUtf8 *** go) qs' + go "" = Nothing + go x = Just $ TE.encodeUtf8 x + + -- | This function is used to store some static content to be served as an + -- external file. The most common case of this is stashing CSS and + -- JavaScript content in an external file; the "Yesod.Widget" module uses + -- this feature. + -- + -- The return value is 'Nothing' if no storing was performed; this is the + -- default implementation. A 'Just' 'Left' gives the absolute URL of the + -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is + -- necessary when you are serving the content outside the context of a + -- Yesod application, such as via memcached. + addStaticContent :: Text -- ^ filename extension + -> Text -- ^ mime-type + -> L.ByteString -- ^ content + -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) + addStaticContent _ _ _ = return Nothing + + -- | Whether or not to tie a session to a specific IP address. Defaults to + -- 'True'. + sessionIpAddress :: a -> Bool + sessionIpAddress _ = True + + -- | The path value to set for cookies. By default, uses \"\/\", meaning + -- cookies will be sent to every page on the current domain. + cookiePath :: a -> S8.ByteString + cookiePath _ = "/" + + -- | Maximum allowed length of the request body, in bytes. + maximumContentLength :: a -> Maybe (Route a) -> Int + maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes + + -- | Send a message to the log. By default, prints to stderr. + messageLogger :: a + -> LogLevel + -> Text -- ^ source + -> Text -- ^ message + -> IO () + messageLogger _ level src msg = + formatLogMessage level src msg >>= + Data.Text.Lazy.IO.hPutStrLn System.IO.stderr + +data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text + deriving (Eq, Show, Read, Ord) + +formatLogMessage :: LogLevel + -> Text -- ^ source + -> Text -- ^ message + -> IO TL.Text +formatLogMessage level src msg = do + now <- getCurrentTime + return $ TB.toLazyText $ + TB.fromText (TS.pack $ show now) + `mappend` TB.fromText ": " + `mappend` TB.fromText (TS.pack $ show level) + `mappend` TB.fromText "@(" + `mappend` TB.fromText src + `mappend` TB.fromText ") " + `mappend` TB.fromText msg + +defaultYesodRunner :: Yesod master + => a + -> master + -> (Route a -> Route master) + -> Maybe CS.Key + -> Maybe (Route a) + -> GHandler a master ChooseRep + -> W.Application +defaultYesodRunner _ m toMaster _ murl _ req + | maximumContentLength m (fmap toMaster murl) < len = + return $ W.responseLBS + (H.Status 413 "Too Large") + [("Content-Type", "text/plain")] + "Request body too large to be processed." + where + len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay + readMay s = + case reads $ S8.unpack s of + [] -> Nothing + (x, _):_ -> Just x +defaultYesodRunner s master toMasterRoute mkey murl handler req = do + now <- liftIO getCurrentTime + let getExpires m = fromIntegral (m * 60) `addUTCTime` now + let exp' = getExpires $ clientSessionDuration master + let rh = takeWhile (/= ':') $ show $ W.remoteHost req + let host = if sessionIpAddress master then S8.pack rh else "" + let session' = + case mkey of + Nothing -> [] + Just key -> fromMaybe [] $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + decodeSession key now host val + rr <- liftIO $ parseWaiRequest req session' mkey + let h = do + case murl of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest $ toMasterRoute url + ar <- isAuthorized (toMasterRoute url) isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> + case authRoute master of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDest' + redirect RedirectTemporary url' + Unauthorized s' -> permissionDenied s' + handler + let sessionMap = Map.fromList + $ filter (\(x, _) -> x /= nonceKey) session' + yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h + let mnonce = reqNonce rr + return $ yarToResponse (hr mnonce getExpires host exp') yar + where + hr mnonce getExpires host exp' hs ct sm = + hs''' + where + sessionVal = + case (mkey, mnonce) of + (Just key, Just nonce) + -> encodeSession key exp' host + $ Map.toList + $ Map.insert nonceKey nonce sm + _ -> mempty + hs' = + case mkey of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration master) + sessionName + sessionVal + : hs + hs'' = map (headerToPair (cookiePath master) getExpires) hs' + hs''' = ("Content-Type", ct) : hs'' + +data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text + deriving (Eq, Show, Read) + +-- | A type-safe, concise method of creating breadcrumbs for pages. For each +-- resource, you declare the title of the page and the parent resource (if +-- present). +class YesodBreadcrumbs y where + -- | Returns the title and the parent resource, if available. If you return + -- a 'Nothing', then this is considered a top-level page. + breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) + +-- | Gets the title of the current page and the hierarchy of parent pages, +-- along with their respective titles. +breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) +breadcrumbs = do + x' <- getCurrentRoute + tm <- getRouteToMaster + let x = fmap tm x' + case x of + Nothing -> return ("Not found", []) + Just y -> do + (title, next) <- breadcrumb y + z <- go [] next + return (title, z) + where + go back Nothing = return back + go back (Just this) = do + (title, next) <- breadcrumb this + go ((this, title) : back) next + +applyLayout' :: Yesod master + => Html -- ^ title + -> Hamlet (Route master) -- ^ body + -> GHandler sub master ChooseRep +applyLayout' title body = fmap chooseRep $ defaultLayout $ do + setTitle title + addHamlet body + +-- | The default error handler for 'errorHandler'. +defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep +defaultErrorHandler NotFound = do + r <- waiRequest + let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r + applyLayout' "Not Found" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Not Found +<p>#{path'} +|] +defaultErrorHandler (PermissionDenied msg) = + applyLayout' "Permission Denied" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Permission denied +<p>#{msg} +|] +defaultErrorHandler (InvalidArgs ia) = + applyLayout' "Invalid Arguments" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Invalid Arguments +<ul> + $forall msg <- ia + <li>#{msg} +|] +defaultErrorHandler (InternalError e) = + applyLayout' "Internal Server Error" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Internal Server Error +<p>#{e} +|] +defaultErrorHandler (BadMethod m) = + applyLayout' "Bad Method" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Method Not Supported +<p>Method "#{S8.unpack m}" not supported +|] + +-- | Return the same URL if the user is authorized to see it. +-- +-- Built on top of 'isAuthorized'. This is useful for building page that only +-- contain links to pages the user is allowed to see. +maybeAuthorized :: Yesod a + => Route a + -> Bool -- ^ is this a write request? + -> GHandler s a (Maybe (Route a)) +maybeAuthorized r isWrite = do + x <- isAuthorized r isWrite + return $ if x == Authorized then Just r else Nothing + +-- | Convert a widget to a 'PageContent'. +widgetToPageContent :: (Eq (Route master), Yesod master) + => GWidget sub master () + -> GHandler sub master (PageContent (Route master)) +widgetToPageContent (GWidget w) = do + ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 + let title = maybe mempty unTitle mTitle + let scripts = runUniqueList scripts' + let stylesheets = runUniqueList stylesheets' + let cssToHtml = preEscapedLazyText . renderCss + celper :: Cassius url -> Hamlet url + celper = fmap cssToHtml + jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b + jelper :: Julius url -> Hamlet url + jelper = fmap jsToHtml + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + cssLoc <- + case style of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "css" "text/css; charset=utf-8" + $ encodeUtf8 $ renderCassius render s + return $ renderLoc x + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ encodeUtf8 $ renderJulius render s + return $ renderLoc x + + let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) + let renderLoc' render' (Local url) = render' url [] + renderLoc' _ (Remote s) = s + let mkScriptTag (Script loc attrs) render' = + foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () + let mkLinkTag (Stylesheet loc attrs) render' = + foldl' addAttr TBH.link + ( ("rel", "stylesheet") + : ("href", renderLoc' render' loc) + : attrs + ) + let head'' = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +$forall s <- scripts + ^{mkScriptTag s} +$forall s <- stylesheets + ^{mkLinkTag s} +$maybe s <- style + $maybe s <- cssLoc + <link rel=stylesheet href=#{s} + $nothing + <style>^{celper s} +$maybe j <- jscript + $maybe s <- jsLoc + <script src="#{s}"> + $nothing + <script>^{jelper j} +\^{head'} +|] + return $ PageContent title head'' body + +yesodVersion :: String +yesodVersion = showVersion Paths_yesod_core.version + +yesodRender :: Yesod y + => y + -> Route y + -> [(Text, Text)] + -> Text +yesodRender y u qs = + TE.decodeUtf8 $ toByteString $ + fromMaybe + (joinPath y (fromText $ approot y) ps + $ qs ++ qs') + (urlRenderOverride y u) + where + (ps, qs') = renderRoute u diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 9594b652..e70d49ad 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -14,11 +14,11 @@ import Control.Monad (foldM) import Yesod.Handler (badMethod) import Yesod.Content (chooseRep) import qualified Network.Wai as W -import Yesod.Core (yesodRunner, yesodDispatch) +import Yesod.Internal.Core (yesodRunner, yesodDispatch) import Data.List (foldl') import Data.Char (toLower) import qualified Data.ByteString as S -import Yesod.Core (Yesod (joinPath, approot, cleanPath)) +import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath)) import Network.HTTP.Types (status301) import Data.Text (Text) import Data.Monoid (mappend) diff --git a/yesod-core.cabal b/yesod-core.cabal index 761d95d3..851ff103 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -8,7 +8,7 @@ synopsis: Creation of type-safe, RESTful web applications. description: Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. . - The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. + The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and Persistent. category: Web, Yesod stability: Stable cabal-version: >= 1.6 @@ -56,6 +56,7 @@ library Yesod.Request Yesod.Widget other-modules: Yesod.Internal + Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request Yesod.Internal.Dispatch From 5e5125a5ac6e58a6a0d56f656160b0139de3baeb Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 5 Apr 2011 00:52:25 +0300 Subject: [PATCH 092/126] Fix fromMultiPiece call --- Test/CleanPath.hs | 2 +- Test/Exceptions.hs | 2 +- Test/Widget.hs | 4 +++- Yesod/Internal/Dispatch.hs | 4 ++-- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/Test/CleanPath.hs b/Test/CleanPath.hs index d6248ff2..9c7306cf 100644 --- a/Test/CleanPath.hs +++ b/Test/CleanPath.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} module Test.CleanPath (cleanPathTest) where -import Yesod.Core +import Yesod.Core hiding (Request) import Yesod.Content import Yesod.Dispatch import Yesod.Handler (Route) diff --git a/Test/Exceptions.hs b/Test/Exceptions.hs index 01a7c7c1..e64900a8 100644 --- a/Test/Exceptions.hs +++ b/Test/Exceptions.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} module Test.Exceptions (exceptionsTest) where -import Yesod.Core +import Yesod.Core hiding (Request) import Yesod.Content import Yesod.Dispatch import Yesod.Handler (Route, ErrorResponse (InternalError)) diff --git a/Test/Widget.hs b/Test/Widget.hs index b3edabff..d9497378 100644 --- a/Test/Widget.hs +++ b/Test/Widget.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} module Test.Widget (widgetTest) where -import Yesod.Core +import Yesod.Core hiding (Request) import Yesod.Content import Yesod.Dispatch import Yesod.Widget @@ -20,12 +20,14 @@ import qualified Data.ByteString.Lazy.Char8 as L8 data Y = Y mkYesod "Y" [$parseRoutes| / RootR GET +/foo/*Strings MultiR GET |] instance Yesod Y where approot _ = "http://test" getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|] +getMultiR _ = return () widgetTest :: Test widgetTest = testGroup "Test.Exceptions" diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index e70d49ad..45e3e178 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -228,11 +228,11 @@ mkSimpleExp segments [MultiPiece _] frontVars x = do fmp <- [|fromMultiPiece|] let exp = CaseE (fmp `AppE` segments) [ Match - (ConP (mkName "Left") [WildP]) + (ConP (mkName "Nothing") []) (NormalB nothing) [] , Match - (ConP (mkName "Right") [VarP next']) + (ConP (mkName "Just") [VarP next']) (NormalB innerExp) [] ] From b778372e2fc6da0724eaeafefaf88c767a757b9a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 8 Apr 2011 00:40:51 +0300 Subject: [PATCH 093/126] Exporting parseRoutesFile --- Yesod/Dispatch.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4f3778bf..e11cd817 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -4,6 +4,7 @@ module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes + , parseRoutesFile , mkYesod , mkYesodSub -- ** More fine-grained From e114a057fbecf4bc32128dddffba15c1d0698a8a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 8 Apr 2011 11:53:54 +0300 Subject: [PATCH 094/126] addCassiusMedia --- Test/Media.hs | 64 ++++++++++++++++++++++++++++++++++++++++++ Yesod/Internal.hs | 5 ++-- Yesod/Internal/Core.hs | 35 +++++++++++++++-------- Yesod/Widget.hs | 10 +++++-- runtests.hs | 2 ++ yesod-core.cabal | 2 ++ 6 files changed, 102 insertions(+), 16 deletions(-) create mode 100644 Test/Media.hs diff --git a/Test/Media.hs b/Test/Media.hs new file mode 100644 index 00000000..75d8c447 --- /dev/null +++ b/Test/Media.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Media (mediaTest) where + +import Yesod.Core hiding (Request) + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Network.Wai +import Network.Wai.Test +import Network.HTTP.Types (status200, decodePathSegments) + +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Text as TS +import Text.Lucius + +data Y = Y +mkYesod "Y" [$parseRoutes| +/ RootR GET +/static StaticR GET +|] + +instance Yesod Y where + approot _ = "" + addStaticContent _ _ content = do + tm <- getRouteToMaster + route <- getCurrentRoute + case fmap tm route of + Just StaticR -> return $ Just $ Left $ + if content == "foo2{bar:baz}" + then "screen.css" + else "all.css" + _ -> return Nothing + +getRootR = defaultLayout $ do + addCassius [$lucius|foo1{bar:baz}|] + addCassiusMedia "screen" [$lucius|foo2{bar:baz}|] + addCassius [$lucius|foo3{bar:baz}|] +getStaticR = getRootR + +runner f = toWaiApp Y >>= runSession f +defaultRequest = Request + { pathInfo = [] + , requestHeaders = [] + , queryString = [] + , requestMethod = "GET" + } + +caseMedia = runner $ do + res <- request defaultRequest + assertStatus 200 res + flip assertBody res "<!DOCTYPE html>\n<html><head><title>" + +caseMediaLink = runner $ do + res <- request defaultRequest { pathInfo = ["static"] } + assertStatus 200 res + flip assertBody res "\n" + +mediaTest = testGroup "Test.Media" + [ testCase "media" caseMedia + , testCase "media link" caseMediaLink + ] diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 3778143d..5fba8c79 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -43,6 +43,7 @@ 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 #if GHC7 #define HAMLET hamlet @@ -111,7 +112,7 @@ data GWData a = GWData !(Last Title) !(UniqueList (Script a)) !(UniqueList (Stylesheet a)) - !(Maybe (Cassius a)) + !(Map.Map (Maybe Text) (Cassius a)) -- media type !(Maybe (Julius a)) !(Head a) instance Monoid (GWData a) where @@ -122,6 +123,6 @@ instance Monoid (GWData a) where (a2 `mappend` b2) (a3 `mappend` b3) (a4 `mappend` b4) - (a5 `mappend` b5) + (Map.unionWith mappend a5 b5) (a6 `mappend` b6) (a7 `mappend` b7) diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs index 1c1b2ac0..298f25d2 100644 --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -478,13 +478,14 @@ widgetToPageContent (GWidget w) = do Nothing -> Nothing Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p - cssLoc <- - case style of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "css" "text/css; charset=utf-8" - $ encodeUtf8 $ renderCassius render s - return $ renderLoc x + css <- flip mapM (Map.toList style) $ \(mmedia, content) -> do + let rendered = renderCassius render content + x <- addStaticContent "css" "text/css; charset=utf-8" + $ encodeUtf8 rendered + return (mmedia, + case x of + Nothing -> Left $ preEscapedLazyText rendered + Just y -> Right $ either id (uncurry render) y) jsLoc <- case jscript of Nothing -> return Nothing @@ -504,6 +505,10 @@ widgetToPageContent (GWidget w) = do : ("href", renderLoc' render' loc) : attrs ) + let left (Left x) = Just x + left _ = Nothing + right (Right x) = Just x + right _ = Nothing let head'' = #if GHC7 [hamlet| @@ -514,11 +519,17 @@ $forall s <- scripts ^{mkScriptTag s} $forall s <- stylesheets ^{mkLinkTag s} -$maybe s <- style - $maybe s <- cssLoc - ^{celper s} +$forall s <- css + $maybe t <- right $ snd s + $maybe media <- fst s + #{content} + $nothing +