From 1f9d11eb292f50e9a20cd8e2c19b293855011707 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Jan 2010 00:18:28 +0200 Subject: [PATCH 1/5] Building lists of strict text in HtmlObject --- Data/Object/Html.hs | 79 +++++++++++++++++++++++---------------------- 1 file changed, 41 insertions(+), 38 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 8ed6ff77..c1eaeed8 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -26,6 +26,8 @@ module Data.Object.Html -- * Standard 'Object' functions , toHtmlObject , fromHtmlObject + -- * Re-export + , module Data.Object #if TEST , testSuite #endif @@ -35,11 +37,13 @@ import Data.Generics import Data.Object.Text import Data.Object.Json import qualified Data.Text.Lazy as TL +import qualified Data.Text as TS import Data.ByteString.Lazy (ByteString) import Web.Encodings import Text.StringTemplate.Classes import Control.Arrow (second) import Data.Attempt +import Data.Object #if TEST import Test.Framework (testGroup, Test) @@ -50,8 +54,8 @@ import Text.StringTemplate -- | A single piece of HTML code. data Html = - Html Text -- ^ Already encoded HTML. - | Text Text -- ^ Text which should be HTML escaped. + Html TS.Text -- ^ Already encoded HTML. + | Text TS.Text -- ^ Text which should be HTML escaped. | Tag String [(String, String)] Html -- ^ Tag which needs a closing tag. | EmptyTag String [(String, String)] -- ^ Tag without a closing tag. | HtmlList [Html] @@ -70,57 +74,56 @@ fromHtmlObject = ca instance ConvertSuccess String Html where convertSuccess = Text . cs -instance ConvertSuccess Text Html where +instance ConvertSuccess TS.Text Html where convertSuccess = Text +instance ConvertSuccess Text Html where + convertSuccess = Text . cs $(deriveAttempts [ (''String, ''Html) , (''Text, ''Html) + , (''TS.Text, ''Html) ]) -showAttribs :: [(String, String)] -> Text -showAttribs = TL.concat . map helper where - helper :: (String, String) -> Text - helper (k, v) = TL.concat - [ cs " " - , encodeHtml $ cs k - , cs "=\"" - , encodeHtml $ cs v - , cs "\"" - ] +showAttribs :: [(String, String)] -> String -> String +showAttribs pairs rest = foldr ($) rest $ map helper pairs where + helper :: (String, String) -> String -> String + helper (k, v) rest' = + ' ' : encodeHtml k + ++ '=' : '"' : encodeHtml v + ++ '"' : rest' htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML -> Html - -> Text -htmlToText _ (Html t) = t -htmlToText _ (Text t) = encodeHtml t -htmlToText xml (Tag n as content) = TL.concat - [ cs "<" - , cs n - , showAttribs as - , cs ">" - , htmlToText xml content - , cs "" - ] -htmlToText xml (EmptyTag n as) = TL.concat - [ cs "<" - , cs n - , showAttribs as - , cs $ if xml then "/>" else ">" - ] -htmlToText xml (HtmlList l) = TL.concat $ map (htmlToText xml) l + -> ([TS.Text] -> [TS.Text]) +htmlToText _ (Html t) = (:) t +htmlToText _ (Text t) = (:) $ encodeHtml t +htmlToText xml (Tag n as content) = \rest -> + (cs $ '<' : n) + : (cs $ showAttribs as ">") + : (htmlToText xml content + $ (cs $ '<' : '/' : n) + : cs ">" + : rest) +htmlToText xml (EmptyTag n as) = \rest -> + (cs $ '<' : n ) + : (cs $ showAttribs as (if xml then "/>" else ">")) + : rest +htmlToText xml (HtmlList l) = \rest -> + foldr ($) rest $ map (htmlToText xml) l +newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text } +instance ConvertSuccess Html HtmlFragment where + convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ [] +-- FIXME remove the next instance instance ConvertSuccess Html Text where - convertSuccess = htmlToText False + convertSuccess h = TL.fromChunks . htmlToText False h $ [] -- | Not fully typesafe. You must make sure that when converting to this, the -- 'Html' starts with a tag. newtype XmlDoc = XmlDoc { unXmlDoc :: Text } instance ConvertSuccess Html XmlDoc where - convertSuccess h = XmlDoc $ TL.concat - [ cs "\n" - , htmlToText True h - ] + convertSuccess h = XmlDoc $ TL.fromChunks $ + cs "\n" + : htmlToText True h [] -- | Wrap an 'Html' in CDATA for XML output. cdata :: Html -> Html From a5893f5621ad5edb9f8da21943ac1d79b79dcb40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Jan 2010 00:59:10 +0200 Subject: [PATCH 2/5] Fixed other code to reflect HtmlObject changes --- Data/Object/Html.hs | 44 ++++++++++++++++++++++++-------------------- Yesod.hs | 2 -- Yesod/Rep.hs | 5 ++--- 3 files changed, 26 insertions(+), 25 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index c1eaeed8..3a228cf1 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -19,6 +19,7 @@ module Data.Object.Html ( -- * Data type Html (..) , HtmlDoc (..) + , HtmlFragment (..) , HtmlObject -- * XML helpers , XmlDoc (..) @@ -38,7 +39,6 @@ import Data.Object.Text import Data.Object.Json import qualified Data.Text.Lazy as TL import qualified Data.Text as TS -import Data.ByteString.Lazy (ByteString) import Web.Encodings import Text.StringTemplate.Classes import Control.Arrow (second) @@ -84,6 +84,19 @@ $(deriveAttempts , (''TS.Text, ''Html) ]) +instance ConvertSuccess String HtmlObject where + convertSuccess = Scalar . cs +instance ConvertSuccess Text HtmlObject where + convertSuccess = Scalar . cs +instance ConvertSuccess TS.Text HtmlObject where + convertSuccess = Scalar . cs +instance ConvertSuccess [(String, String)] HtmlObject where + convertSuccess = omTO +instance ConvertSuccess [(Text, Text)] HtmlObject where + convertSuccess = omTO +instance ConvertSuccess [(TS.Text, TS.Text)] HtmlObject where + convertSuccess = omTO + showAttribs :: [(String, String)] -> String -> String showAttribs pairs rest = foldr ($) rest $ map helper pairs where helper :: (String, String) -> String -> String @@ -114,9 +127,8 @@ htmlToText xml (HtmlList l) = \rest -> newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text } instance ConvertSuccess Html HtmlFragment where convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ [] --- FIXME remove the next instance -instance ConvertSuccess Html Text where - convertSuccess h = TL.fromChunks . htmlToText False h $ [] +instance ConvertSuccess HtmlFragment Html where + convertSuccess = HtmlList . map Html . TL.toChunks . unHtmlFragment -- | Not fully typesafe. You must make sure that when converting to this, the -- 'Html' starts with a tag. newtype XmlDoc = XmlDoc { unXmlDoc :: Text } @@ -133,18 +145,11 @@ cdata h = HtmlList , Html $ cs "]]>" ] -instance ConvertSuccess Html String where - convertSuccess = cs . (cs :: Html -> Text) -instance ConvertSuccess Html ByteString where - convertSuccess = cs . (cs :: Html -> Text) - instance ConvertSuccess Html HtmlDoc where - convertSuccess h = HtmlDoc $ TL.concat - [ cs "HtmlDoc (autogenerated)" - , cs "" - , cs h - , cs "" - ] + convertSuccess h = HtmlDoc $ TL.fromChunks $ + cs "\nHtmlDoc (autogenerated)" + : htmlToText False h + [cs ""] instance ConvertSuccess HtmlObject Html where convertSuccess (Scalar h) = h @@ -162,25 +167,24 @@ instance ConvertSuccess HtmlObject HtmlDoc where convertSuccess = cs . (cs :: HtmlObject -> Html) instance ConvertSuccess Html JsonScalar where - convertSuccess = cs . (cs :: Html -> Text) + convertSuccess = cs . unHtmlFragment . cs instance ConvertSuccess HtmlObject JsonObject where convertSuccess = mapKeysValues convertSuccess convertSuccess instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) $(deriveAttempts - [ (''Html, ''String) - , (''Html, ''Text) + [ (''Html, ''HtmlFragment) , (''Html, ''HtmlDoc) , (''Html, ''JsonScalar) ]) $(deriveSuccessConvs ''String ''Html [''String, ''Text] - [''Html, ''String, ''Text]) + [''Html, ''HtmlFragment]) instance ToSElem HtmlObject where - toSElem (Scalar h) = STR $ TL.unpack $ cs h + toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h toSElem (Sequence hs) = LI $ map toSElem hs toSElem (Mapping pairs) = helper $ map (second toSElem) pairs where helper :: [(String, SElem b)] -> SElem b diff --git a/Yesod.hs b/Yesod.hs index fdc2ce15..8ebda038 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -24,7 +24,6 @@ module Yesod , module Yesod.Parameter , module Yesod.Rep , module Yesod.Template - , module Data.Convertible.Text , Application ) where @@ -48,4 +47,3 @@ import Yesod.Definitions import Yesod.Handler import Hack (Application) import Yesod.Template -import Data.Convertible.Text diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 54bcc786..509a9f32 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -57,7 +57,6 @@ import Data.Object.Html #endif import Data.Object.Json -import Data.Convertible.Text import Text.StringTemplate #if TEST @@ -109,8 +108,8 @@ instance ConvertSuccess ByteString Content where convertSuccess = Content instance ConvertSuccess String Content where convertSuccess = Content . cs -instance ConvertSuccess Html Content where - convertSuccess = Content . cs +instance ConvertSuccess HtmlDoc Content where + convertSuccess = cs . unHtmlDoc instance ConvertSuccess XmlDoc Content where convertSuccess = cs . unXmlDoc From 953d66542a8a5ab5430b1ec1773c18f8c4b7d08f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 21 Jan 2010 20:00:22 +0200 Subject: [PATCH 3/5] Basic upgrade to data-object-yaml 0.2.0 --- Yesod/Resource.hs | 4 +--- yesod.cabal | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 6a77c233..ad28b3cf 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -216,8 +216,6 @@ data RPNode = RPNode RP VerbMap deriving (Show, Eq) data VerbMap = AllVerbs String | Verbs [(Verb, String)] deriving (Show, Eq) -instance ConvertAttempt YamlDoc [RPNode] where - convertAttempt = fromTextObject <=< ca instance ConvertAttempt TextObject [RPNode] where convertAttempt = mapM helper <=< fromMapping where helper :: (Text, TextObject) -> Attempt RPNode @@ -384,7 +382,7 @@ liftVerbMap (Verbs vs) r rp = do strToExp :: Bool -> String -> Q Exp strToExp toCheck s = do - rpnodes <- runIO $ convertAttemptWrap $ YamlDoc $ cs s + rpnodes <- runIO $ decode (cs s) >>= \to -> convertAttemptWrap (to :: TextObject) (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes #if TEST diff --git a/yesod.cabal b/yesod.cabal index a6e4ff0f..57dfd552 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -39,7 +39,7 @@ library bytestring >= 0.9.1.4 && < 0.10, web-encodings >= 0.2.0 && < 0.3, data-object >= 0.2.0 && < 0.3, - data-object-yaml >= 0.0.0 && < 0.1, + data-object-yaml >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, transformers >= 0.1.4.0 && < 0.2, control-monad-attempt >= 0.0.0 && < 0.1, From b460e9d4778614ddbed0827de47f7f4b56b38a92 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jan 2010 00:56:08 +0200 Subject: [PATCH 4/5] Does not reload template dir on each request --- Yesod/Yesod.hs | 35 ++++++++++++++++++++++------------- examples/fact.lhs | 4 ++-- examples/hellotemplate.lhs | 2 +- examples/helloworld.lhs | 2 +- 4 files changed, 26 insertions(+), 17 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6344bf3e..0a5e0d32 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -14,6 +14,7 @@ import Yesod.Constants import Yesod.Definitions import Yesod.Handler import Yesod.Utils +import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) import Data.Convertible.Text @@ -27,7 +28,8 @@ import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride class Yesod a where - -- | Please use the Quasi-Quoter, you\'ll be happier. FIXME more info. + -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, + -- see the examples/fact.lhs sample. handlers :: Resource -> Verb -> Handler a RepChooser -- | The encryption key to be used for encrypting client sessions. @@ -74,26 +76,33 @@ defaultErrorHandler (InternalError e) = [ ("Internal server error", e) ] -toHackApp :: Yesod y => y -> Hack.Application -toHackApp a env = do +toHackApp :: Yesod y => y -> IO Hack.Application +toHackApp a = do key <- encryptKey a - let app' = toHackApp' a + app' <- toHackApp' a let mins = clientSessionDuration a - (gzip $ cleanPath $ jsonp $ methodOverride - $ clientsession encryptedCookies key mins $ app') env + return $ gzip + $ cleanPath + $ jsonp + $ methodOverride + $ clientsession encryptedCookies key mins + $ app' -toHackApp' :: Yesod y => y -> Hack.Application -toHackApp' y env = do +toHackApp' :: Yesod y => y -> IO Hack.Application +toHackApp' y = do + let td = templateDir y + tg <- if null td + then return nullGroup + else directoryGroupRecursiveLazy td + return $ toHackApp'' y tg + +toHackApp'' :: Yesod y => y -> TemplateGroup -> Hack.Env -> IO Hack.Response +toHackApp'' y tg env = do let (Right resource) = splitPath $ Hack.pathInfo env types = httpAccept env verb = cs $ Hack.requestMethod env handler = handlers resource verb rr = cs env - -- FIXME don't do the templateDir thing for each request - let td = templateDir y - tg <- if null td - then return nullGroup - else directoryGroupRecursiveLazy td res <- runHandler handler errorHandler rr y tg types let langs = ["en"] -- FIXME responseToHackResponse langs res diff --git a/examples/fact.lhs b/examples/fact.lhs index 49a6f867..9b1e7e31 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -89,7 +89,7 @@ one piece of data. > factRedirect :: Handler y () > factRedirect = do -> i <- getParam "num" +> i <- runRequest $ getParam "num" > redirect $ "../" ++ i ++ "/" The following line would be unnecesary if we had a type signature on @@ -102,4 +102,4 @@ you could use CGI, FastCGI or a more powerful server. Just check out Hackage for options (any package starting hack-handler- should suffice). > main :: IO () -> main = putStrLn "Running..." >> run 3000 (toHackApp Fact) +> main = putStrLn "Running..." >> toHackApp Fact >>= run 3000 diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index 6bb06cb3..b5ee0924 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -26,5 +26,5 @@ helloGroup = template "real-template" "foo" (cs "bar") $ return [] main :: IO () main = do putStrLn "Running..." - run 3000 $ toHackApp HelloWorld + toHackApp HelloWorld >>= run 3000 \end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index de8a90de..371e8a04 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -15,5 +15,5 @@ helloWorld :: Handler HelloWorld HtmlObject helloWorld = return $ cs "Hello world!" main :: IO () -main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +main = putStrLn "Running..." >> toHackApp HelloWorld >>= run 3000 \end{code} From 1c3e02a2cd927036dade2af84b53b2d025770616 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jan 2010 01:14:35 +0200 Subject: [PATCH 5/5] Cleaned up some FIXMEs --- Yesod/Definitions.hs | 6 +++--- Yesod/Helpers/Auth.hs | 7 +++---- Yesod/Helpers/Static.hs | 19 +++++++++++++++---- Yesod/Resource.hs | 2 +- Yesod/Response.hs | 3 +-- 5 files changed, 23 insertions(+), 14 deletions(-) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index b3ff2d8d..8ad89f93 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -17,7 +17,7 @@ module Yesod.Definitions ( Verb (..) , Resource - , Approot (..) + , Approot , Language , Location (..) , showLocation @@ -55,7 +55,7 @@ type Resource = [String] -- | An absolute URL to the base of this application. This can almost be done -- programatically, but due to ambiguities in different ways of doing URL -- rewriting for (fast)cgi applications, it should be supplied by the user. -newtype Approot = Approot { unApproot :: String } -- FIXME make type syn? +type Approot = String type Language = String @@ -66,6 +66,6 @@ data Location = AbsLoc String | RelLoc String -- | Display a 'Location' in absolute form. showLocation :: Approot -> Location -> String showLocation _ (AbsLoc s) = s -showLocation (Approot ar) (RelLoc s) = ar ++ s +showLocation ar (RelLoc s) = ar ++ s type PathInfo = [String] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index be5914eb..43341b03 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -49,7 +49,7 @@ class YesodApproot a => YesodAuth a where getFullAuthRoot :: YesodAuth y => Handler y String getFullAuthRoot = do y <- getYesod - let (Approot ar) = approot y + ar <- getApproot return $ ar ++ authRoot y data AuthResource = @@ -168,15 +168,14 @@ authCheck = do authLogout :: YesodAuth y => Handler y HtmlObject authLogout = do deleteCookie authCookieName - y <- getYesod - let (Approot ar) = approot y + ar <- getApproot redirect ar -- FIXME check the DEST information authIdentifier :: YesodAuth y => Handler y String authIdentifier = do mi <- identifier - Approot ar <- getApproot + ar <- getApproot case mi of Nothing -> do rp <- requestPath diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 2b8ba726..61461248 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -25,19 +25,25 @@ module Yesod.Helpers.Static import qualified Data.ByteString.Lazy as B import System.Directory (doesFileExist) import Control.Applicative ((<$>)) +import Control.Monad import Yesod import Data.List (intercalate) type FileLookup = FilePath -> IO (Maybe B.ByteString) --- | A 'FileLookup' for files in a directory. +-- | A 'FileLookup' for files in a directory. Note that this function does not +-- check if the requested path does unsafe things, eg expose hidden files. You +-- should provide this checking elsewhere. +-- +-- If you are just using this in combination with serveStatic, serveStatic +-- provides this checking. fileLookupDir :: FilePath -> FileLookup fileLookupDir dir fp = do - let fp' = dir ++ '/' : fp -- FIXME incredibly insecure... + let fp' = dir ++ '/' : fp exists <- doesFileExist fp' if exists - then Just <$> B.readFile fp' + then Just <$> B.readFile fp' -- FIXME replace lazy I/O when possible else return Nothing serveStatic :: FileLookup -> Verb -> [String] @@ -47,11 +53,16 @@ serveStatic _ _ _ = notFound getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] getStatic fl fp' = do - let fp = intercalate "/" fp' -- FIXME check for . or .. + when (any isUnsafe fp') $ notFound + let fp = intercalate "/" fp' content <- liftIO $ fl fp case content of Nothing -> notFound Just bs -> return [(mimeType $ ext fp, Content bs)] + where + isUnsafe [] = True + isUnsafe ('.':_) = True + isUnsafe _ = False mimeType :: String -> ContentType mimeType "jpg" = TypeJpeg diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index ad28b3cf..581bfdad 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -244,7 +244,7 @@ checkRPNodes :: (MonadFailure OverlappingPatterns m, => [RPNode] -> m [RPNode] checkRPNodes nodes = do - _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes -- FIXME ugly + _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes mapM_ (\(RPNode _ v) -> checkVerbMap v) nodes return nodes where diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 6dc61c1c..b226684e 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} @@ -97,7 +97,6 @@ toPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") toPair (Header key value) = return (key, value) --- FIXME add test responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response responseToHackResponse _FIXMEls (Response sc hs ct c) = do