Merge branch 'master' of git@github.com:snoyberg/yesod

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 "<?xml version='1.0' encoding='utf-8' ?>\n"
-        , htmlToText True h
-        ]
+    convertSuccess h = XmlDoc $ TL.fromChunks $
+        cs "<?xml version='1.0' encoding='utf-8' ?>\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 "<!DOCTYPE html><html><head><title>HtmlDoc (autogenerated)"
-        , cs "</title></head><body>"
-        , cs h
-        , cs "</body></html>"
-        ]
+    convertSuccess h = HtmlDoc $ TL.fromChunks $
+        cs "<!DOCTYPE html>\n<html><head><title>HtmlDoc (autogenerated)</title></head><body>"
+        : htmlToText False h
+        [cs "</body></html>"]
 
 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

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

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]

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

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

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
 

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

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

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

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

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}

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}

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,