diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs
index 8ed6ff77..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 (..)
@@ -26,6 +27,8 @@ module Data.Object.Html
-- * Standard 'Object' functions
, toHtmlObject
, fromHtmlObject
+ -- * Re-export
+ , module Data.Object
#if TEST
, testSuite
#endif
@@ -35,11 +38,12 @@ import Data.Generics
import Data.Object.Text
import Data.Object.Json
import qualified Data.Text.Lazy as TL
-import Data.ByteString.Lazy (ByteString)
+import qualified Data.Text as TS
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,68 @@ 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 "\""
- ]
+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
+ 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 ""
- , cs n
- , 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
-instance ConvertSuccess Html Text where
- convertSuccess = htmlToText False
+newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text }
+instance ConvertSuccess Html HtmlFragment where
+ convertSuccess h = HtmlFragment . 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 }
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
@@ -130,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
@@ -159,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/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 ed28c533..e5e38ecc 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 =
@@ -169,15 +169,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/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
diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs
index 6a77c233..581bfdad 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
@@ -246,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
@@ -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/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
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}
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,