Removed many of the special Show instances.
Show should be for debug usage only. In general, using ConvertSuccess as a replacement. Also now replacing some String outputs with Text outputs.
This commit is contained in:
Michael Snoyman
parent
603ebb3672
commit
1f57f38aac
@ -50,6 +50,7 @@ data Html =
|
||||
| Text 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.
|
||||
@ -63,6 +64,11 @@ toHtmlObject = toObject
|
||||
fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x
|
||||
fromHtmlObject = fromObject
|
||||
|
||||
instance ConvertSuccess String Html where
|
||||
convertSuccess = Text . cs
|
||||
instance ConvertSuccess Text Html where
|
||||
convertSuccess = Text
|
||||
|
||||
instance ConvertSuccess Html Text where
|
||||
convertSuccess (Html t) = t
|
||||
convertSuccess (Text t) = encodeHtml t
|
||||
@ -82,6 +88,7 @@ instance ConvertSuccess Html Text where
|
||||
, showAttribs as
|
||||
, cs ">"
|
||||
]
|
||||
convertSuccess (HtmlList l) = TL.concat $ map cs l
|
||||
|
||||
instance ConvertSuccess Html HtmlDoc where
|
||||
convertSuccess h = HtmlDoc $ TL.concat
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Definitions
|
||||
@ -21,9 +23,20 @@ module Yesod.Definitions
|
||||
|
||||
import qualified Hack
|
||||
import Data.Convertible.Text
|
||||
import Control.Exception (Exception)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
data Verb = Get | Put | Delete | Post
|
||||
deriving (Eq, Show)
|
||||
instance ConvertAttempt String Verb where
|
||||
convertAttempt "Get" = return Get
|
||||
convertAttempt "Put" = return Put
|
||||
convertAttempt "Delete" = return Delete
|
||||
convertAttempt "Post" = return Post
|
||||
convertAttempt s = failure $ InvalidVerb s
|
||||
newtype InvalidVerb = InvalidVerb String
|
||||
deriving (Show, Typeable)
|
||||
instance Exception InvalidVerb
|
||||
|
||||
instance ConvertSuccess Hack.RequestMethod Verb where
|
||||
convertSuccess Hack.PUT = Put
|
||||
|
||||
@ -20,7 +20,9 @@ module Yesod.Helpers.AtomFeed
|
||||
) where
|
||||
|
||||
import Yesod.Rep
|
||||
import Data.Convertible.Text (cs)
|
||||
import Data.Convertible.Text
|
||||
import Data.Text.Lazy (Text)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import Data.Time.Clock
|
||||
import Web.Encodings
|
||||
@ -34,7 +36,7 @@ data AtomFeed = AtomFeed
|
||||
}
|
||||
instance HasReps AtomFeed where
|
||||
reps =
|
||||
[ (TypeAtom, return . cs . show)
|
||||
[ (TypeAtom, return . cs)
|
||||
]
|
||||
|
||||
data AtomFeedEntry = AtomFeedEntry
|
||||
@ -44,46 +46,48 @@ data AtomFeedEntry = AtomFeedEntry
|
||||
, atomEntryContent :: String
|
||||
}
|
||||
|
||||
instance Show AtomFeed where
|
||||
show f = concat
|
||||
[ "<?xml version='1.0' encoding='utf-8' ?>\n"
|
||||
, "<feed xmlns='http://www.w3.org/2005/Atom'>"
|
||||
, "<title>"
|
||||
, encodeHtml $ atomTitle f
|
||||
, "</title>"
|
||||
, "<link rel='self' href='"
|
||||
, encodeHtml $ atomLinkSelf f
|
||||
, "'/>"
|
||||
, "<link href='"
|
||||
, encodeHtml $ atomLinkHome f
|
||||
, "'/>"
|
||||
, "<updated>"
|
||||
, formatW3 $ atomUpdated f
|
||||
, "</updated>"
|
||||
, "<id>"
|
||||
, encodeHtml $ atomLinkHome f
|
||||
, "</id>"
|
||||
, concatMap show $ atomEntries f
|
||||
, "</feed>"
|
||||
instance ConvertSuccess AtomFeed Content where
|
||||
convertSuccess = cs . (cs :: AtomFeed -> Text)
|
||||
instance ConvertSuccess AtomFeed Text where
|
||||
convertSuccess f = TL.concat
|
||||
[ cs "<?xml version='1.0' encoding='utf-8' ?>\n"
|
||||
, cs "<feed xmlns='http://www.w3.org/2005/Atom'>"
|
||||
, cs "<title>"
|
||||
, encodeHtml $ cs $ atomTitle f
|
||||
, cs "</title>"
|
||||
, cs "<link rel='self' href='"
|
||||
, encodeHtml $ cs $ atomLinkSelf f
|
||||
, cs "'/>"
|
||||
, cs "<link href='"
|
||||
, encodeHtml $ cs $ atomLinkHome f
|
||||
, cs "'/>"
|
||||
, cs "<updated>"
|
||||
, cs $ formatW3 $ atomUpdated f
|
||||
, cs "</updated>"
|
||||
, cs "<id>"
|
||||
, encodeHtml $ cs $ atomLinkHome f
|
||||
, cs "</id>"
|
||||
, TL.concat $ map cs $ atomEntries f
|
||||
, cs "</feed>"
|
||||
]
|
||||
|
||||
instance Show AtomFeedEntry where
|
||||
show e = concat
|
||||
[ "<entry>"
|
||||
, "<id>"
|
||||
, encodeHtml $ atomEntryLink e
|
||||
, "</id>"
|
||||
, "<link href='"
|
||||
, encodeHtml $ atomEntryLink e
|
||||
, "' />"
|
||||
, "<updated>"
|
||||
, formatW3 $ atomEntryUpdated e
|
||||
, "</updated>"
|
||||
, "<title>"
|
||||
, encodeHtml $ atomEntryTitle e
|
||||
, "</title>"
|
||||
, "<content type='html'><![CDATA["
|
||||
, atomEntryContent e
|
||||
, "]]></content>"
|
||||
, "</entry>"
|
||||
instance ConvertSuccess AtomFeedEntry Text where
|
||||
convertSuccess e = TL.concat
|
||||
[ cs "<entry>"
|
||||
, cs "<id>"
|
||||
, encodeHtml $ cs $ atomEntryLink e
|
||||
, cs "</id>"
|
||||
, cs "<link href='"
|
||||
, encodeHtml $ cs $ atomEntryLink e
|
||||
, cs "' />"
|
||||
, cs "<updated>"
|
||||
, cs $ formatW3 $ atomEntryUpdated e
|
||||
, cs "</updated>"
|
||||
, cs "<title>"
|
||||
, encodeHtml $ cs $ atomEntryTitle e
|
||||
, cs "</title>"
|
||||
, cs "<content type='html'><![CDATA["
|
||||
, cs $ atomEntryContent e
|
||||
, cs "]]></content>"
|
||||
, cs "</entry>"
|
||||
]
|
||||
|
||||
@ -27,7 +27,7 @@ import qualified Web.Authenticate.OpenId as OpenId
|
||||
import Data.Enumerable
|
||||
|
||||
import Data.Object.Html
|
||||
import Data.Convertible.Text (cs)
|
||||
import Data.Convertible.Text
|
||||
|
||||
import Yesod
|
||||
import Yesod.Constants
|
||||
@ -82,20 +82,22 @@ authResourcePattern LoginRpxnow = "/auth/login/rpxnow/"
|
||||
data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
|
||||
instance Request OIDFormReq where
|
||||
parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest"
|
||||
instance Show OIDFormReq where
|
||||
show (OIDFormReq Nothing _) = ""
|
||||
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
|
||||
"</p>"
|
||||
instance ConvertSuccess OIDFormReq Html where
|
||||
convertSuccess (OIDFormReq Nothing _) = cs ""
|
||||
convertSuccess (OIDFormReq (Just s) _) =
|
||||
Tag "p" [("class", "message")] [cs s]
|
||||
|
||||
authOpenidForm :: Handler y HtmlObject
|
||||
authOpenidForm = do
|
||||
m@(OIDFormReq _ dest) <- parseRequest
|
||||
let html =
|
||||
show m ++
|
||||
"<form method='get' action='forward/'>" ++
|
||||
"OpenID: <input type='text' name='openid'>" ++
|
||||
"<input type='submit' value='Login'>" ++
|
||||
"</form>"
|
||||
HtmlList
|
||||
[ cs m
|
||||
, Tag "form" [("method", "get"), ("action", "forward/")]
|
||||
[ Tag "label" [("for", "openid")] [cs "OpenID: "]
|
||||
, EmptyTag "input" [("type", "submit"), ("value", "Login")]
|
||||
]
|
||||
]
|
||||
case dest of
|
||||
Just dest' -> addCookie 120 "DEST" dest'
|
||||
Nothing -> return ()
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Helpers.Sitemap
|
||||
@ -26,10 +27,10 @@ import Yesod.Definitions
|
||||
import Yesod.Handler
|
||||
import Yesod.Rep
|
||||
import Web.Encodings
|
||||
import qualified Hack
|
||||
import Yesod.Request
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Convertible.Text (cs)
|
||||
import Data.Convertible.Text
|
||||
import Data.Text.Lazy (Text)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Yesod.Yesod
|
||||
|
||||
data SitemapLoc = AbsLoc String | RelLoc String
|
||||
@ -40,14 +41,14 @@ data SitemapChangeFreq = Always
|
||||
| Monthly
|
||||
| Yearly
|
||||
| Never
|
||||
instance Show SitemapChangeFreq where
|
||||
show Always = "always"
|
||||
show Hourly = "hourly"
|
||||
show Daily = "daily"
|
||||
show Weekly = "weekly"
|
||||
show Monthly = "monthly"
|
||||
show Yearly = "yearly"
|
||||
show Never = "never"
|
||||
instance ConvertSuccess SitemapChangeFreq String where
|
||||
convertSuccess Always = "always"
|
||||
convertSuccess Hourly = "hourly"
|
||||
convertSuccess Daily = "daily"
|
||||
convertSuccess Weekly = "weekly"
|
||||
convertSuccess Monthly = "monthly"
|
||||
convertSuccess Yearly = "yearly"
|
||||
convertSuccess Never = "never"
|
||||
|
||||
data SitemapUrl = SitemapUrl
|
||||
{ sitemapLoc :: SitemapLoc
|
||||
@ -55,45 +56,41 @@ data SitemapUrl = SitemapUrl
|
||||
, sitemapChangeFreq :: SitemapChangeFreq
|
||||
, priority :: Double
|
||||
}
|
||||
data SitemapRequest = SitemapRequest String Int
|
||||
data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl]
|
||||
instance Show SitemapResponse where -- FIXME very ugly, use Text instead
|
||||
show (SitemapResponse (SitemapRequest host port) urls) =
|
||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
|
||||
"<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">" ++
|
||||
concatMap helper urls ++
|
||||
"</urlset>"
|
||||
data SitemapResponse = SitemapResponse [SitemapUrl] Approot
|
||||
instance ConvertSuccess SitemapResponse Content where
|
||||
convertSuccess = cs . (cs :: SitemapResponse -> Text)
|
||||
instance ConvertSuccess SitemapResponse Text where
|
||||
convertSuccess (SitemapResponse urls (Approot ar)) = TL.concat
|
||||
[ cs "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
|
||||
, cs "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">"
|
||||
, TL.concat $ map helper urls
|
||||
, cs "</urlset>"
|
||||
]
|
||||
where
|
||||
prefix = "http://" ++ host ++
|
||||
case port of
|
||||
80 -> ""
|
||||
_ -> ':' : show port
|
||||
helper (SitemapUrl loc modTime freq pri) = concat
|
||||
helper (SitemapUrl loc modTime freq pri) = cs $ concat
|
||||
[ "<url><loc>"
|
||||
, encodeHtml $ showLoc loc
|
||||
, "</loc><lastmod>"
|
||||
, formatW3 modTime
|
||||
, "</lastmod><changefreq>"
|
||||
, show freq
|
||||
, cs freq
|
||||
, "</changefreq><priority>"
|
||||
, show pri
|
||||
, "</priority></url>"
|
||||
]
|
||||
showLoc (AbsLoc s) = s
|
||||
showLoc (RelLoc s) = prefix ++ s
|
||||
showLoc (RelLoc s) = ar ++ s
|
||||
|
||||
instance HasReps SitemapResponse where
|
||||
reps =
|
||||
[ (TypeXml, return . cs . show)
|
||||
[ (TypeXml, return . cs)
|
||||
]
|
||||
|
||||
sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse
|
||||
sitemap :: Yesod yesod => IO [SitemapUrl] -> Handler yesod SitemapResponse
|
||||
sitemap urls' = do
|
||||
env <- parseEnv
|
||||
-- FIXME
|
||||
let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env)
|
||||
yesod <- getYesod
|
||||
urls <- liftIO urls'
|
||||
return $ SitemapResponse req urls
|
||||
return $ SitemapResponse urls $ approot yesod
|
||||
|
||||
robots :: Yesod yesod => Handler yesod Plain
|
||||
robots = do
|
||||
|
||||
33
Yesod/Rep.hs
33
Yesod/Rep.hs
@ -78,23 +78,24 @@ data ContentType =
|
||||
| TypeOgv
|
||||
| TypeOctet
|
||||
| TypeOther String
|
||||
instance Show ContentType where
|
||||
show TypeHtml = "text/html"
|
||||
show TypePlain = "text/plain"
|
||||
show TypeJson = "application/json"
|
||||
show TypeXml = "text/xml"
|
||||
show TypeAtom = "application/atom+xml"
|
||||
show TypeJpeg = "image/jpeg"
|
||||
show TypePng = "image/png"
|
||||
show TypeGif = "image/gif"
|
||||
show TypeJavascript = "text/javascript"
|
||||
show TypeCss = "text/css"
|
||||
show TypeFlv = "video/x-flv"
|
||||
show TypeOgv = "video/ogg"
|
||||
show TypeOctet = "application/octet-stream"
|
||||
show (TypeOther s) = s
|
||||
deriving (Show)
|
||||
instance ConvertSuccess ContentType String where
|
||||
convertSuccess TypeHtml = "text/html"
|
||||
convertSuccess TypePlain = "text/plain"
|
||||
convertSuccess TypeJson = "application/json"
|
||||
convertSuccess TypeXml = "text/xml"
|
||||
convertSuccess TypeAtom = "application/atom+xml"
|
||||
convertSuccess TypeJpeg = "image/jpeg"
|
||||
convertSuccess TypePng = "image/png"
|
||||
convertSuccess TypeGif = "image/gif"
|
||||
convertSuccess TypeJavascript = "text/javascript"
|
||||
convertSuccess TypeCss = "text/css"
|
||||
convertSuccess TypeFlv = "video/x-flv"
|
||||
convertSuccess TypeOgv = "video/ogg"
|
||||
convertSuccess TypeOctet = "application/octet-stream"
|
||||
convertSuccess (TypeOther s) = s
|
||||
instance Eq ContentType where
|
||||
(==) = (==) `on` show
|
||||
(==) = (==) `on` (cs :: ContentType -> String)
|
||||
|
||||
newtype Content = Content { unContent :: ByteString }
|
||||
deriving (Eq, Show)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user