diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs deleted file mode 100644 index ca3fcbd7..00000000 --- a/Data/Object/Html.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- | An 'Html' data type and associated 'ConvertSuccess' instances. This has --- useful conversions in web development: --- --- * Automatic generation of simple HTML documents from 'HtmlObject' (mostly --- useful for testing, you would never want to actually show them to an end --- user). --- --- * Converts to JSON, which gives fully HTML escaped JSON. Very nice for Ajax. --- --- * Can be used with HStringTemplate. -module Data.Object.Html - ( -- * Data type - Html (..) - , HtmlDoc (..) - , HtmlFragment (..) - , HtmlObject - -- * XML helpers - , XmlDoc (..) - , cdata - -- * Standard 'Object' functions - , toHtmlObject - , fromHtmlObject - -- * Re-export - , module Data.Object -#if TEST - , testSuite -#endif - ) where - -import Data.Generics -import Data.Object.Text -import Data.Object.String -import Data.Object.Json -import qualified Data.Text.Lazy as TL -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) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -import Text.StringTemplate -#endif - --- | A single piece of HTML code. -data Html = - 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] - deriving (Eq, Show, Typeable) - --- | A full HTML document. -newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text } - -type HtmlObject = Object String Html - -instance ConvertSuccess Html HtmlObject where - convertSuccess = Scalar -instance ConvertSuccess [Html] HtmlObject where - convertSuccess = Sequence . map cs -instance ConvertSuccess [HtmlObject] HtmlObject where - convertSuccess = Sequence -instance ConvertSuccess [(String, HtmlObject)] HtmlObject where - convertSuccess = Mapping -instance ConvertSuccess [(String, Html)] HtmlObject where - convertSuccess = Mapping . map (second cs) -instance ConvertSuccess StringObject HtmlObject where - convertSuccess = mapKeysValues cs cs - -toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject -toHtmlObject = cs - -fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x -fromHtmlObject = ca - -instance ConvertSuccess String Html where - convertSuccess = Text . cs -instance ConvertSuccess TS.Text Html where - convertSuccess = Text -instance ConvertSuccess Text Html where - convertSuccess = Text . 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] HtmlObject where - convertSuccess = Sequence . map cs -instance ConvertSuccess [Text] HtmlObject where - convertSuccess = Sequence . map cs -instance ConvertSuccess [TS.Text] HtmlObject where - convertSuccess = Sequence . map 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 (($) . helper) rest 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 - -> ([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) = flip (foldr ($)) (map (htmlToText xml) l) - -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.fromChunks $ - cs "\n" - : htmlToText True h [] - --- | Wrap an 'Html' in CDATA for XML output. -cdata :: Html -> Html -cdata h = HtmlList - [ Html $ cs "" - ] - -instance ConvertSuccess (Html, Html) HtmlDoc where - convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $ - cs "\n" - : htmlToText False (Tag "html" [] $ HtmlList - [ Tag "head" [] h - , Tag "body" [] b - ] - ) [] -instance ConvertSuccess (Html, HtmlObject) HtmlDoc where - convertSuccess (x, y) = cs (x, cs y :: Html) -instance ConvertSuccess (Html, HtmlObject) JsonDoc where - convertSuccess (_, y) = cs y - -instance ConvertSuccess HtmlObject Html where - convertSuccess (Scalar h) = h - convertSuccess (Sequence hs) = Tag "ul" [] $ HtmlList $ map addLi hs - where - addLi = Tag "li" [] . cs - convertSuccess (Mapping pairs) = - Tag "dl" [] $ HtmlList $ concatMap addDtDd pairs where - addDtDd (k, v) = - [ Tag "dt" [] $ Text $ cs k - , Tag "dd" [] $ cs v - ] - -instance ConvertSuccess Html JsonScalar where - convertSuccess = cs . unHtmlFragment . cs -instance ConvertAttempt Html JsonScalar where - convertAttempt = return . cs - -instance ConvertSuccess HtmlObject JsonObject where - convertSuccess = mapKeysValues convertSuccess convertSuccess -instance ConvertAttempt HtmlObject JsonObject where - convertAttempt = return . cs - -instance ConvertSuccess HtmlObject JsonDoc where - convertSuccess = cs . (cs :: HtmlObject -> JsonObject) -instance ConvertAttempt HtmlObject JsonDoc where - convertAttempt = return . cs - -instance ToSElem HtmlObject where - 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 - helper = SM . cs - -#if TEST -caseHtmlToText :: Assertion -caseHtmlToText = do - let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList - [ Html $ cs "
Some HTML
" - , Text $ cs "<'this should be escaped'>" - , EmptyTag "img" [("src", "baz&")] - ] - let expected = - "

Some HTML
" ++ - "<'this should be escaped'>" ++ - "
" - unHtmlFragment (cs actual) @?= (cs expected :: Text) - -caseStringTemplate :: Assertion -caseStringTemplate = do - let content = Mapping - [ ("foo", Sequence [ Scalar $ Html $ cs "
" - , Scalar $ Text $ cs "
"]) - , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")]) - ] - let temp = newSTMP "foo:$o.foo$,bar:$o.bar$" - let expected = "foo:
<hr>,bar:" - expected @=? toString (setAttribute "o" content temp) - -caseJson :: Assertion -caseJson = do - let content = Mapping - [ ("foo", Sequence [ Scalar $ Html $ cs "
" - , Scalar $ Text $ cs "
"]) - , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")]) - ] - let expected = "{\"bar\":\"\"" ++ - ",\"foo\":[\"
\",\"<hr>\"]" ++ - "}" - JsonDoc (cs expected) @=? cs content - -testSuite :: Test -testSuite = testGroup "Data.Object.Html" - [ testCase "caseHtmlToText" caseHtmlToText - , testCase "caseStringTemplate" caseStringTemplate - , testCase "caseJson" caseJson - ] - -#endif diff --git a/Yesod.hs b/Yesod.hs index 59fec055..29b2e1dc 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,23 +21,21 @@ module Yesod , module Yesod.Handler , module Yesod.Resource , module Yesod.Form - , module Data.Object.Html - , module Yesod.Template , module Web.Mime + , module Yesod.Hamlet , Application , Method (..) + , cs ) where #if TEST import Yesod.Resource hiding (testSuite) import Yesod.Response hiding (testSuite) -import Data.Object.Html hiding (testSuite) import Yesod.Request hiding (testSuite) import Web.Mime hiding (testSuite) #else import Yesod.Resource import Yesod.Response -import Data.Object.Html import Yesod.Request import Web.Mime #endif @@ -47,4 +45,5 @@ import Yesod.Yesod import Yesod.Definitions import Yesod.Handler import Network.Wai (Application, Method (..)) -import Yesod.Template +import Yesod.Hamlet +import Data.Convertible.Text (cs) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 3a66c7cf..7b6b034b 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet ( hamletToContent , hamletToRepHtml , PageContent (..) , Hamlet , hamlet - , simpleContent , HtmlContent (..) + , HtmlObject ) where @@ -13,8 +18,8 @@ import Text.Hamlet import Text.Hamlet.Monad (outputHtml) import Yesod.Response import Yesod.Handler -import Data.Text (pack) -import Data.Convertible.Text (cs) +import Data.Convertible.Text +import Data.Object data PageContent url = PageContent { pageTitle :: IO HtmlContent @@ -22,13 +27,6 @@ data PageContent url = PageContent , pageBody :: Hamlet url IO () } -simpleContent :: String -> HtmlContent -> PageContent url -simpleContent title body = PageContent - { pageTitle = return $ Unencoded $ pack title - , pageHead = return () - , pageBody = outputHtml body - } - hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content hamletToContent h = do render <- getUrlRender @@ -45,3 +43,33 @@ hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml hamletToRepHtml h = do c <- hamletToContent h return $ RepHtml c + +instance Monad m => ConvertSuccess String (Hamlet url m ()) where + convertSuccess = outputHtml . Unencoded . cs +instance Monad m + => ConvertSuccess (Object String HtmlContent) (Hamlet url m ()) where + convertSuccess (Scalar h) = outputHtml h + convertSuccess (Sequence s) = template () where + template = [$hamlet| + %ul + $forall s' s + %li ^s^|] + s' _ = return $ fromList $ map cs s + convertSuccess (Mapping m) = template () where + template :: Monad m => () -> Hamlet url m () + template = [$hamlet| + %dl + $forall pairs pair + %dt $pair.key$ + %dd ^pair.val^|] + pairs _ = return $ fromList $ map go m + go (k, v) = Pair (return $ cs k) $ cs v +instance ConvertSuccess String HtmlContent where + convertSuccess = Unencoded . cs + +data Pair url m = Pair { key :: m HtmlContent, val :: Hamlet url m () } + +type HtmlObject = Object String HtmlContent + +instance ConvertSuccess (Object String String) HtmlObject where + convertSuccess = fmap cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3eaba5db..7c55033c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -52,10 +52,11 @@ import Control.Monad.Attempt import Control.Monad (liftM, ap) import System.IO -import Data.Object.Html import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W +import Data.Convertible.Text (cs) + type family Routes y data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String) @@ -155,8 +156,10 @@ sendFile ct = specialResponse . SendFile ct notFound :: Failure ErrorResponse m => m a notFound = failure NotFound -badMethod :: Failure ErrorResponse m => m a -badMethod = failure BadMethod +badMethod :: (RequestReader m, Failure ErrorResponse m) => m a +badMethod = do + w <- waiRequest + failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w permissionDenied :: Failure ErrorResponse m => m a permissionDenied = failure PermissionDenied diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 44164438..8ab1a5f7 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -23,7 +23,8 @@ module Yesod.Helpers.AtomFeed import Yesod import Data.Time.Clock (UTCTime) -import Web.Encodings (formatW3) +-- FIXME import Web.Encodings (formatW3) +import Data.Convertible.Text data AtomFeedResponse = AtomFeedResponse AtomFeed Approot @@ -48,11 +49,12 @@ data AtomFeedEntry = AtomFeedEntry { atomEntryLink :: Location , atomEntryUpdated :: UTCTime , atomEntryTitle :: String - , atomEntryContent :: Html + , atomEntryContent :: HtmlContent } instance ConvertSuccess AtomFeedResponse Content where - convertSuccess = cs . (cs :: Html -> XmlDoc) . cs + convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs +{- FIXME instance ConvertSuccess AtomFeedResponse Html where convertSuccess (AtomFeedResponse f ar) = Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList @@ -75,3 +77,4 @@ instance ConvertSuccess (AtomFeedEntry, Approot) Html where , Tag "title" [] $ cs $ atomEntryTitle e , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e ] +-} diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 2e4b643e..b80907f7 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -30,11 +31,11 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Yesod +import Data.Convertible.Text import Control.Monad.Attempt import qualified Data.ByteString.Char8 as B8 -import Data.Maybe (fromMaybe) import qualified Network.Wai as W import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -90,11 +91,13 @@ authHandler W.GET ["openid", "complete"] = rc authOpenidComplete authHandler _ ["login", "rpxnow"] = rc rpxnowLogin authHandler _ _ = notFound -data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +-- FIXME data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +{- FIXME instance ConvertSuccess OIDFormReq Html where convertSuccess (OIDFormReq Nothing _) = cs "" convertSuccess (OIDFormReq (Just s) _) = Tag "p" [("class", "message")] $ cs s +-} data ExpectedSingleParam = ExpectedSingleParam deriving (Show, Typeable) @@ -106,20 +109,21 @@ authOpenidForm = do case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x - let html = - HtmlList - [ case getParams rr "message" of - [] -> HtmlList [] - (m:_) -> Tag "p" [("class", "message")] $ cs m - , Tag "form" [("method", "get"), ("action", "forward/")] $ - HtmlList - [ Tag "label" [("for", "openid")] $ cs "OpenID: " - , EmptyTag "input" [("type", "text"), ("id", "openid"), - ("name", "openid")] - , EmptyTag "input" [("type", "submit"), ("value", "Login")] - ] - ] - applyLayout' "Log in via OpenID" html + let html = template (getParams rr "message") + simpleApplyLayout "Log in via OpenID" html + where + urlForward _ = error "FIXME urlForward" + hasMessage = return . not . null + message [] = return $ Encoded $ cs "" + message (m:_) = return $ Unencoded $ cs m + template = [$hamlet| +$if hasMessage + %p.message $message$ +%form!method=get!action=@urlForward@ + %label!for=openid OpenID: + %input#openid!type=text!name=openid + %input!type=submit!value=Login +|] authOpenidForward :: YesodAuth y => Handler y () authOpenidForward = do @@ -190,12 +194,15 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where authCheck :: Yesod y => Handler y ChooseRep authCheck = do - ident <- maybeIdentifier - dn <- displayName + _ident <- maybeIdentifier + _dn <- displayName + error "FIXME applyLayoutJson" + {- applyLayoutJson "Authentication Status" $ cs [ ("identifier", fromMaybe "" ident) , ("displayName", fromMaybe "" dn) ] + -} authLogout :: YesodAuth y => Handler y () authLogout = do diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 2a29e104..95e32c22 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -24,8 +24,9 @@ module Yesod.Helpers.Sitemap ) where import Yesod -import Web.Encodings (formatW3) +--FIXME import Web.Encodings (formatW3) import Data.Time (UTCTime) +import Data.Convertible.Text data SitemapChangeFreq = Always | Hourly @@ -42,8 +43,10 @@ instance ConvertSuccess SitemapChangeFreq String where convertSuccess Monthly = "monthly" convertSuccess Yearly = "yearly" convertSuccess Never = "never" +{- FIXME instance ConvertSuccess SitemapChangeFreq Html where convertSuccess = (cs :: String -> Html) . cs +-} data SitemapUrl = SitemapUrl { sitemapLoc :: Location @@ -53,7 +56,8 @@ data SitemapUrl = SitemapUrl } data SitemapResponse = SitemapResponse [SitemapUrl] Approot instance ConvertSuccess SitemapResponse Content where - convertSuccess = cs . (cs :: Html -> XmlDoc) . cs + convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs +{- FIXME instance ConvertSuccess SitemapResponse Html where convertSuccess (SitemapResponse urls ar) = Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls @@ -67,6 +71,7 @@ instance ConvertSuccess SitemapResponse Html where , Tag "changefreq" [] $ cs freq , Tag "priority" [] $ cs $ show pri ] +-} instance HasReps SitemapResponse where chooseRep = defChooseRep diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 9f1b6174..7651ca62 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 1d4035fb..0b5e59cc 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -49,6 +49,7 @@ import Control.Arrow ((***)) import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class import Control.Concurrent.MVar +import Control.Monad (liftM) #if TEST import Test.Framework (testGroup, Test) @@ -60,7 +61,7 @@ type ParamName = String type ParamValue = String type ParamError = String -class RequestReader m where +class Monad m => RequestReader m where getRequest :: m Request instance RequestReader ((->) Request) where getRequest = id @@ -69,8 +70,8 @@ languages :: (Functor m, RequestReader m) => m [Language] languages = reqLangs `fmap` getRequest -- | Get the req 'W.Request' value. -waiRequest :: (Functor m, RequestReader m) => m W.Request -waiRequest = reqWaiRequest `fmap` getRequest +waiRequest :: RequestReader m => m W.Request +waiRequest = reqWaiRequest `liftM` getRequest type RequestBodyContents = ( [(ParamName, ParamValue)] diff --git a/Yesod/Response.hs b/Yesod/Response.hs index ad4311ad..2c48a9bb 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -25,7 +25,6 @@ module Yesod.Response , HasReps (..) , defChooseRep , ioTextToContent - , hoToJsonContent -- ** Convenience wrappers , staticRep -- ** Specific content types @@ -59,7 +58,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text) import qualified Data.Text as T -import Data.Object.Json +import Data.Convertible.Text import Web.Encodings (formatW3) import qualified Network.Wai as W @@ -67,11 +66,9 @@ import qualified Network.Wai.Enumerator as WE #if TEST import Yesod.Request hiding (testSuite) -import Data.Object.Html hiding (testSuite) import Web.Mime hiding (testSuite) #else import Yesod.Request -import Data.Object.Html import Web.Mime #endif @@ -95,10 +92,6 @@ instance ConvertSuccess Text Content where convertSuccess lt = cs (cs lt :: L.ByteString) instance ConvertSuccess String Content where convertSuccess s = cs (cs s :: Text) -instance ConvertSuccess HtmlDoc Content where - convertSuccess = cs . unHtmlDoc -instance ConvertSuccess XmlDoc Content where - convertSuccess = cs . unXmlDoc type ChooseRep = [ContentType] -> IO (ContentType, Content) @@ -110,9 +103,6 @@ ioTextToContent = swapEnum . WE.fromLBS' . fmap cs swapEnum :: W.Enumerator -> Content swapEnum (W.Enumerator e) = ContentEnum e -hoToJsonContent :: HtmlObject -> Content -hoToJsonContent = cs . unJsonDoc . cs - -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep @@ -148,12 +138,6 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" -instance HasReps (Html, HtmlObject) where - chooseRep = defChooseRep - [ (TypeHtml, return . cs . unHtmlDoc . cs) - , (TypeJson, return . cs . unJsonDoc . cs) - ] - -- | Data with a single representation. staticRep :: ConvertSuccess x Content => ContentType @@ -201,7 +185,7 @@ data ErrorResponse = | InternalError String | InvalidArgs [(ParamName, ParamError)] | PermissionDenied - | BadMethod + | BadMethod String deriving (Show, Eq) getStatus :: ErrorResponse -> W.Status @@ -209,6 +193,7 @@ getStatus NotFound = W.Status404 getStatus (InternalError _) = W.Status500 getStatus (InvalidArgs _) = W.Status400 getStatus PermissionDenied = W.Status403 +getStatus (BadMethod _) = W.Status405 ----- header stuff -- | Headers to be added to a 'Result'. diff --git a/Yesod/Template.hs b/Yesod/Template.hs deleted file mode 100644 index b5b7a4f5..00000000 --- a/Yesod/Template.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -module Yesod.Template - ( YesodTemplate (..) - , NoSuchTemplate - , Template - , TemplateGroup - , loadTemplateGroup - , defaultApplyLayout - -- * HTML templates - , HtmlTemplate (..) - , templateHtml - , templateHtmlJson - , setHtmlAttrib - ) where - -import Data.Object.Html -import Data.Typeable (Typeable) -import Control.Exception (Exception) -import Data.Object.Text (Text) -import Text.StringTemplate -import Yesod.Response -import Yesod.Yesod -import Yesod.Handler -import Control.Monad (join) -import Yesod.Request (Request, getRequest) - -type Template = StringTemplate Text -type TemplateGroup = STGroup Text - -class Yesod y => YesodTemplate y where - getTemplateGroup :: y -> TemplateGroup - defaultTemplateAttribs :: y -> Request -> HtmlTemplate - -> IO HtmlTemplate - defaultTemplateAttribs _ _ = return - -getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup -getTemplateGroup' = getTemplateGroup `fmap` getYesod - -newtype NoSuchTemplate = NoSuchTemplate String - deriving (Show, Typeable) -instance Exception NoSuchTemplate - -loadTemplateGroup :: FilePath -> IO TemplateGroup -loadTemplateGroup = directoryGroupRecursiveLazy - -defaultApplyLayout :: YesodTemplate y - => y - -> Request - -> String -- ^ title - -> Html -- ^ body - -> Content -defaultApplyLayout y req t b = - case getStringTemplate "layout" $ getTemplateGroup y of - Nothing -> cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc) - Just temp -> - ioTextToContent - $ fmap (render . unHtmlTemplate) - $ defaultTemplateAttribs y req - $ setHtmlAttrib "title" t - $ setHtmlAttrib "content" b - $ HtmlTemplate temp - -type TemplateName = String -newtype HtmlTemplate = HtmlTemplate { unHtmlTemplate :: Template } - --- | Return a result using a template generating HTML alone. -templateHtml :: YesodTemplate y - => TemplateName - -> (HtmlTemplate -> IO HtmlTemplate) - -> Handler y RepHtml -templateHtml tn f = do - tg <- getTemplateGroup' - y <- getYesod - t <- case getStringTemplate tn tg of - Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn - Just x -> return x - rr <- getRequest - return $ RepHtml $ ioTextToContent - $ fmap (render . unHtmlTemplate) - $ join - $ fmap f - $ defaultTemplateAttribs y rr - $ HtmlTemplate t - -setHtmlAttrib :: ConvertSuccess x HtmlObject - => String -> x -> HtmlTemplate -> HtmlTemplate -setHtmlAttrib k v (HtmlTemplate t) = - HtmlTemplate $ setAttribute k (toHtmlObject v) t - --- | Return a result using a template and 'HtmlObject' generating either HTML --- or JSON output. -templateHtmlJson :: YesodTemplate y - => TemplateName - -> HtmlObject - -> (HtmlObject -> HtmlTemplate -> IO HtmlTemplate) - -> Handler y RepHtmlJson -templateHtmlJson tn ho f = do - tg <- getTemplateGroup' - y <- getYesod - rr <- getRequest - t <- case getStringTemplate tn tg of - Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn - Just x -> return x - return $ RepHtmlJson - ( ioTextToContent - $ fmap (render . unHtmlTemplate) - $ join - $ fmap (f ho) - $ defaultTemplateAttribs y rr - $ HtmlTemplate t - ) - (hoToJsonContent ho) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 34753fdb..612e3fb6 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -3,15 +3,12 @@ module Yesod.Yesod ( Yesod (..) , YesodSite (..) - , applyLayout' - , applyLayoutJson + , simpleApplyLayout , getApproot , toWaiApp , basicHandler ) where -import Data.Object.Html -import Data.Object.Json (unJsonDoc) import Yesod.Response import Yesod.Request import Yesod.Definitions @@ -19,6 +16,8 @@ import Yesod.Hamlet import Yesod.Handler hiding (badMethod) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 +import Data.Convertible.Text +import Text.Hamlet.Monad (fromList) import Data.Maybe (fromMaybe) import Web.Mime @@ -54,7 +53,7 @@ class YesodSite a => Yesod a where errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep errorHandler _ = defaultErrorHandler - -- | Applies some form of layout to and <body> contents of a page. + -- | Applies some form of layout to <title> and <body> contents of a page. FIXME: use a Maybe here to allow subsites to simply inherit. applyLayout :: a -> PageContent (Routes a) -> Request @@ -77,13 +76,17 @@ class YesodSite a => Yesod a where -- trailing slash. approot :: a -> Approot --- | A convenience wrapper around 'applyLayout'. -applyLayout' :: Yesod y - => String - -> Html - -> Handler y ChooseRep -applyLayout' t b = do - let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment $ cs b +-- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. +simpleApplyLayout :: Yesod y + => String -- ^ title + -> Hamlet (Routes y) IO () -- ^ body + -> Handler y ChooseRep +simpleApplyLayout t b = do + let pc = PageContent + { pageTitle = return $ Unencoded $ cs t + , pageHead = return () + , pageBody = b + } y <- getYesod rr <- getRequest content <- hamletToContent $ applyLayout y pc rr @@ -91,55 +94,60 @@ applyLayout' t b = do [ (TypeHtml, content) ] --- | A convenience wrapper around 'applyLayout' which provides a JSON --- representation of the body. -applyLayoutJson :: Yesod y - => String - -> HtmlObject - -> Handler y ChooseRep -applyLayoutJson t b = do - let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment - $ cs (cs b :: Html) - y <- getYesod - rr <- getRequest - htmlcontent <- hamletToContent $ applyLayout y pc rr - return $ chooseRep - [ (TypeHtml, htmlcontent) - , (TypeJson, cs $ unJsonDoc $ cs b) - ] - getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - applyLayout' "Not Found" $ cs $ toHtmlObject - [ ("Not found", cs $ W.pathInfo r :: String) - ] + simpleApplyLayout "Not Found" $ [$hamlet| +%h1 Not Found +%p $helper$ +|] r + where + helper = return . Unencoded . cs . W.pathInfo defaultErrorHandler PermissionDenied = - applyLayout' "Permission Denied" $ cs "Permission denied" + simpleApplyLayout "Permission Denied" $ [$hamlet| +%h1 Permission denied|] () defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" $ cs $ toHtmlObject - [ ("errorMsg", toHtmlObject "Invalid arguments") - , ("messages", toHtmlObject ia) - ] + simpleApplyLayout "Invalid Arguments" $ [$hamlet| +%h1 Invalid Arguments +%dl + $forall ias pair + %dt $pair.key$ + %dd $pair.val$ +|] () + where + ias _ = return $ fromList $ map go ia + go (k, v) = Pair (return $ Unencoded $ cs k) + (return $ Unencoded $ cs v) defaultErrorHandler (InternalError e) = - applyLayout' "Internal Server Error" $ cs $ toHtmlObject - [ ("Internal server error", e) - ] -defaultErrorHandler BadMethod = - applyLayout' "Bad Method" $ cs "Method Not Supported" + simpleApplyLayout "Internal Server Error" $ [$hamlet| +%h1 Internal Server Error +%p $message$ +|] e + where + message :: String -> IO HtmlContent + message = return . Unencoded . cs +defaultErrorHandler (BadMethod m) = + simpleApplyLayout "Bad Method" $ [$hamlet| +%h1 Method Not Supported +%p Method "$m'$" not supported +|] () + where + m' _ = return $ Unencoded $ cs m + +data Pair m k v = Pair { key :: m k, val :: m v } toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do - key <- encryptKey a + key' <- encryptKey a let mins = clientSessionDuration a return $ gzip $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession encryptedCookies key mins + $ \thePath -> clientsession encryptedCookies key' mins $ toWaiApp' a thePath toWaiApp' :: Yesod y @@ -161,7 +169,8 @@ toWaiApp' y resource session env = do print pathSegments let ya = case eurl of Left _ -> runHandler (errorHandler y NotFound) y render - Right url -> handleSite site render url method badMethod y + Right url -> handleSite site render url method + (badMethod method) y let eh er = runHandler (errorHandler y er) y render unYesodApp ya eh rr types >>= responseToWaiResponse @@ -187,8 +196,9 @@ basicHandler port app = do SS.run port app Just _ -> CGI.run app -badMethod :: YesodApp -badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts +badMethod :: String -> YesodApp +badMethod m = YesodApp $ \eh req cts + -> unYesodApp (eh $ BadMethod m) eh req cts fixSegs :: [String] -> [String] fixSegs [] = [] diff --git a/examples/fact.lhs b/examples/fact.lhs index 36f7a870..85af7b54 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -79,10 +79,11 @@ data, all with HTML entities escaped properly. These representations include: For simplicity here, we don't include a template, though it would be trivial to do so (see the hellotemplate example). -> getFactR i = applyLayoutJson "Factorial result" $ cs +> getFactR :: Integer -> Handler y ChooseRep -- FIXME remove +> getFactR _i = error "FIXME" {-simpleApplyLayout "Factorial result" $ cs > [ ("input", show i) > , ("result", show $ product [1..fromIntegral i :: Integer]) -> ] +> ]-} I've decided to have a redirect instead of serving the some data in two locations. It fits in more properly with the RESTful principal of one name for diff --git a/examples/hamlet.hs b/examples/hamlet.hs index 8c8a6c0e..268b3909 100644 --- a/examples/hamlet.hs +++ b/examples/hamlet.hs @@ -4,7 +4,6 @@ import Yesod import Network.Wai.Handler.SimpleServer -import Text.Hamlet data Ham = Ham @@ -21,7 +20,7 @@ data NextLink m = NextLink { nextLink :: m HamRoutes } nl :: Monad m => HamRoutes -> NextLink m nl = NextLink . return -template :: Monad m => NextLink (Hamlet HamRoutes m) -> Hamlet HamRoutes m () +template :: Monad m => NextLink m -> Hamlet HamRoutes m () template = [$hamlet| %a!href=@nextLink@ Next page |] diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs deleted file mode 100644 index ead588f3..00000000 --- a/examples/hellotemplate.lhs +++ /dev/null @@ -1,36 +0,0 @@ -\begin{code} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -import Yesod -import Network.Wai.Handler.SimpleServer - -data HelloWorld = HelloWorld TemplateGroup - -mkYesod "HelloWorld" [$parseRoutes| -/ Home GET -/groups Group GET -|] - -instance Yesod HelloWorld where - approot _ = "http://localhost:3000" -instance YesodTemplate HelloWorld where - getTemplateGroup (HelloWorld tg) = tg - defaultTemplateAttribs _ _ = return - . setHtmlAttrib "default" "<DEFAULT>" - -getHome :: Handler HelloWorld RepHtml -getHome = templateHtml "template" $ return - . setHtmlAttrib "title" "Hello world!" - . setHtmlAttrib "content" "Hey look!! I'm <auto escaped>!" - -getGroup :: YesodTemplate y => Handler y RepHtmlJson -getGroup = templateHtmlJson "real-template" (cs "bar") $ \ho -> - return . setHtmlAttrib "foo" ho - -main :: IO () -main = do - putStrLn "Running..." - loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000 -\end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index f7111808..052d891d 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -16,7 +16,7 @@ instance Yesod HelloWorld where approot _ = "http://localhost:3000" getHome :: Handler HelloWorld ChooseRep -getHome = applyLayout' "Hello World" $ cs "Hello world!" +getHome = simpleApplyLayout "Hello World" $ cs "Hello world!" main :: IO () main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000 diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index 892a2883..c6080b84 100644 --- a/examples/pretty-yaml.hs +++ b/examples/pretty-yaml.hs @@ -8,35 +8,60 @@ import Network.Wai.Handler.SimpleServer import Web.Encodings import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.Object.String -data PY = PY TemplateGroup +data PY = PY mkYesod "PY" [$parseRoutes| / Homepage GET POST |] -instance YesodTemplate PY where - getTemplateGroup (PY tg) = tg - defaultTemplateAttribs _ _ = return instance Yesod PY where approot _ = "http://localhost:3000" -getHomepage :: Handler PY RepHtml -getHomepage = templateHtml "pretty-yaml" return +template :: Monad m => TempArgs url m -> Hamlet url m () +template = [$hamlet| +!!! +%html + %head + %meta!charset=utf-8 + %title Pretty YAML + %body + %form!method=post!action=.!enctype=multipart/form-data + File name: + %input!type=file!name=yaml + %input!type=submit + $if hasYaml + %div ^yaml^ +|] -postHomepage :: Handler PY RepHtmlJson +data TempArgs url m = TempArgs + { hasYaml :: m Bool + , yaml :: Hamlet url m () + } + +getHomepage :: Handler PY RepHtml +getHomepage = hamletToRepHtml + $ template $ TempArgs (return False) (return ()) + +--FIXMEpostHomepage :: Handler PY RepHtmlJson +postHomepage :: Handler PY RepHtml postHomepage = do rr <- getRequest (_, files) <- liftIO $ reqRequestBody rr fi <- case lookup "yaml" files of Nothing -> invalidArgs [("yaml", "Missing input")] Just x -> return x - to <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi + so <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi + {- let ho' = fmap Text to templateHtmlJson "pretty-yaml" ho' $ \ho -> return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject) + -} + let ho = cs (so :: StringObject) :: HtmlObject + hamletToRepHtml $ template $ TempArgs (return True) (cs ho) main :: IO () main = do putStrLn "Running..." - loadTemplateGroup "examples" >>= toWaiApp . PY >>= run 3000 + toWaiApp PY >>= run 3000 diff --git a/examples/static.hs b/examples/static.hs index 7f8abb5a..bdc0557b 100644 --- a/examples/static.hs +++ b/examples/static.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet import Yesod import Yesod.Helpers.Static diff --git a/examples/tweedle.lhs b/examples/tweedle.lhs index 7e1cf058..00bfe98c 100755 --- a/examples/tweedle.lhs +++ b/examples/tweedle.lhs @@ -34,7 +34,7 @@ One of the goals of Yesod is to make it work with the compiler to help you progr To start with, we need a datatype to represent our program. We'll call this bug tracker "Tweedle", after Dr. Seuss's "Tweedle Beetle Battle" in "Fox in Socks" (my son absolutely loves this book). We'll be putting the complete state of the bug database in an MVar within this variable; in a production setting, you might instead put a database handle. -> data Tweedle = Tweedle Settings (MVar Category) TemplateGroup +> data Tweedle = Tweedle Settings (MVar Category) (For now, just ignore the TemplateGroup, its purpose becomes apparent later.) @@ -149,7 +149,7 @@ Note that this will die unless an issues file is present. We could instead check > issuesSO <- decodeFile $ issueFile settings > issues <- fromAttempt $ categoryFromSO issuesSO > missues <- newMVar issues -> tg <- loadTemplateGroup $ templatesDir settings +> tg <- error "FIXME switch to hamlet" -- loadTemplateGroup $ templatesDir settings > return $ Tweedle settings missues tg And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer. diff --git a/yesod.cabal b/yesod.cabal index f9f9abee..2f4b8da8 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,7 +53,6 @@ library syb, text >= 0.5 && < 0.8, convertible-text >= 0.2.0 && < 0.3, - HStringTemplate >= 0.6.2 && < 0.7, data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, template-haskell, @@ -71,8 +70,6 @@ library Yesod.Handler Yesod.Resource Yesod.Yesod - Yesod.Template - Data.Object.Html Yesod.Helpers.Auth Yesod.Helpers.Static Yesod.Helpers.AtomFeed @@ -82,7 +79,8 @@ library executable yesod ghc-options: -Wall - build-depends: file-embed >= 0.0.3 && < 0.1 + build-depends: file-embed >= 0.0.3 && < 0.1, + HStringTemplate >= 0.6.2 && < 0.7 main-is: CLI/yesod.hs executable runtests @@ -107,13 +105,13 @@ executable helloworld ghc-options: -Wall main-is: examples/helloworld.lhs -executable hellotemplate +executable hamlet if flag(buildsamples) Buildable: True else Buildable: False ghc-options: -Wall - main-is: examples/hellotemplate.lhs + main-is: examples/hamlet.hs executable fact if flag(buildsamples)