haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed many of the special Show instances.

Browse Source 
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 2009-12-15 01:26:57 +02:00
parent 603ebb3672
commit 1f57f38aac
6 changed files with 124 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Data/Object/Html.hs
View File

@ -50,6 +50,7 @@ data Html =
| Text Text -- ^ Text which should be HTML escaped. | Text Text -- ^ Text which should be HTML escaped.
| Tag String [(String, String)] [Html] -- ^ Tag which needs a closing tag. | Tag String [(String, String)] [Html] -- ^ Tag which needs a closing tag.
| EmptyTag String [(String, String)] -- ^ Tag without a closing tag. | EmptyTag String [(String, String)] -- ^ Tag without a closing tag.
| HtmlList [Html]
deriving (Eq, Show, Typeable) deriving (Eq, Show, Typeable)
-- | A full HTML document. -- | A full HTML document.
@ -63,6 +64,11 @@ toHtmlObject = toObject
fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x
fromHtmlObject = fromObject fromHtmlObject = fromObject
instance ConvertSuccess String Html where
convertSuccess = Text . cs
instance ConvertSuccess Text Html where
convertSuccess = Text
instance ConvertSuccess Html Text where instance ConvertSuccess Html Text where
convertSuccess (Html t) = t convertSuccess (Html t) = t
convertSuccess (Text t) = encodeHtml t convertSuccess (Text t) = encodeHtml t
@ -82,6 +88,7 @@ instance ConvertSuccess Html Text where
, showAttribs as , showAttribs as
, cs ">" , cs ">"
] ]
convertSuccess (HtmlList l) = TL.concat $ map cs l
instance ConvertSuccess Html HtmlDoc where instance ConvertSuccess Html HtmlDoc where
convertSuccess h = HtmlDoc $ TL.concat convertSuccess h = HtmlDoc $ TL.concat

13
Yesod/Definitions.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------- ---------------------------------------------------------
-- --
-- Module : Yesod.Definitions -- Module : Yesod.Definitions
@ -21,9 +23,20 @@ module Yesod.Definitions
import qualified Hack import qualified Hack
import Data.Convertible.Text import Data.Convertible.Text
import Control.Exception (Exception)
import Data.Typeable (Typeable)
data Verb = Get | Put | Delete | Post data Verb = Get | Put | Delete | Post
deriving (Eq, Show) 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 instance ConvertSuccess Hack.RequestMethod Verb where
convertSuccess Hack.PUT = Put convertSuccess Hack.PUT = Put

88
Yesod/Helpers/AtomFeed.hs
View File

@ -20,7 +20,9 @@ module Yesod.Helpers.AtomFeed
) where ) where
import Yesod.Rep 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 Data.Time.Clock
import Web.Encodings import Web.Encodings
@ -34,7 +36,7 @@ data AtomFeed = AtomFeed
} }
instance HasReps AtomFeed where instance HasReps AtomFeed where
reps = reps =
[ (TypeAtom, return . cs . show) [ (TypeAtom, return . cs)
] ]
data AtomFeedEntry = AtomFeedEntry data AtomFeedEntry = AtomFeedEntry
@ -44,46 +46,48 @@ data AtomFeedEntry = AtomFeedEntry
, atomEntryContent :: String , atomEntryContent :: String
} }
instance Show AtomFeed where instance ConvertSuccess AtomFeed Content where
show f = concat convertSuccess = cs . (cs :: AtomFeed -> Text)
[ "<?xml version='1.0' encoding='utf-8' ?>\n" instance ConvertSuccess AtomFeed Text where
, "<feed xmlns='http://www.w3.org/2005/Atom'>" convertSuccess f = TL.concat
, "<title>" [ cs "<?xml version='1.0' encoding='utf-8' ?>\n"
, encodeHtml $ atomTitle f , cs "<feed xmlns='http://www.w3.org/2005/Atom'>"
, "</title>" , cs "<title>"
, "<link rel='self' href='" , encodeHtml $ cs $ atomTitle f
, encodeHtml $ atomLinkSelf f , cs "</title>"
, "'/>" , cs "<link rel='self' href='"
, "<link href='" , encodeHtml $ cs $ atomLinkSelf f
, encodeHtml $ atomLinkHome f , cs "'/>"
, "'/>" , cs "<link href='"
, "<updated>" , encodeHtml $ cs $ atomLinkHome f
, formatW3 $ atomUpdated f , cs "'/>"
, "</updated>" , cs "<updated>"
, "<id>" , cs $ formatW3 $ atomUpdated f
, encodeHtml $ atomLinkHome f , cs "</updated>"
, "</id>" , cs "<id>"
, concatMap show $ atomEntries f , encodeHtml $ cs $ atomLinkHome f
, "</feed>" , cs "</id>"
, TL.concat $ map cs $ atomEntries f
, cs "</feed>"
] ]
instance Show AtomFeedEntry where instance ConvertSuccess AtomFeedEntry Text where
show e = concat convertSuccess e = TL.concat
[ "<entry>" [ cs "<entry>"
, "<id>" , cs "<id>"
, encodeHtml $ atomEntryLink e , encodeHtml $ cs $ atomEntryLink e
, "</id>" , cs "</id>"
, "<link href='" , cs "<link href='"
, encodeHtml $ atomEntryLink e , encodeHtml $ cs $ atomEntryLink e
, "' />" , cs "' />"
, "<updated>" , cs "<updated>"
, formatW3 $ atomEntryUpdated e , cs $ formatW3 $ atomEntryUpdated e
, "</updated>" , cs "</updated>"
, "<title>" , cs "<title>"
, encodeHtml $ atomEntryTitle e , encodeHtml $ cs $ atomEntryTitle e
, "</title>" , cs "</title>"
, "<content type='html'><![CDATA[" , cs "<content type='html'><![CDATA["
, atomEntryContent e , cs $ atomEntryContent e
, "]]></content>" , cs "]]></content>"
, "</entry>" , cs "</entry>"
] ]

22
Yesod/Helpers/Auth.hs
View File

@ -27,7 +27,7 @@ import qualified Web.Authenticate.OpenId as OpenId
import Data.Enumerable import Data.Enumerable
import Data.Object.Html import Data.Object.Html
import Data.Convertible.Text (cs) import Data.Convertible.Text
import Yesod import Yesod
import Yesod.Constants import Yesod.Constants
@ -82,20 +82,22 @@ authResourcePattern LoginRpxnow = "/auth/login/rpxnow/"
data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
instance Request OIDFormReq where instance Request OIDFormReq where
parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest"
instance Show OIDFormReq where instance ConvertSuccess OIDFormReq Html where
show (OIDFormReq Nothing _) = "" convertSuccess (OIDFormReq Nothing _) = cs ""
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++ convertSuccess (OIDFormReq (Just s) _) =
"</p>" Tag "p" [("class", "message")] [cs s]
authOpenidForm :: Handler y HtmlObject authOpenidForm :: Handler y HtmlObject
authOpenidForm = do authOpenidForm = do
m@(OIDFormReq _ dest) <- parseRequest m@(OIDFormReq _ dest) <- parseRequest
let html = let html =
show m ++ HtmlList
"<form method='get' action='forward/'>" ++ [ cs m
"OpenID: <input type='text' name='openid'>" ++ , Tag "form" [("method", "get"), ("action", "forward/")]
"<input type='submit' value='Login'>" ++ [ Tag "label" [("for", "openid")] [cs "OpenID: "]
"</form>" , EmptyTag "input" [("type", "submit"), ("value", "Login")]
]
]
case dest of case dest of
Just dest' -> addCookie 120 "DEST" dest' Just dest' -> addCookie 120 "DEST" dest'
Nothing -> return () Nothing -> return ()

61
Yesod/Helpers/Sitemap.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
--------------------------------------------------------- ---------------------------------------------------------
-- --
-- Module : Yesod.Helpers.Sitemap -- Module : Yesod.Helpers.Sitemap
@ -26,10 +27,10 @@ import Yesod.Definitions
import Yesod.Handler import Yesod.Handler
import Yesod.Rep import Yesod.Rep
import Web.Encodings import Web.Encodings
import qualified Hack
import Yesod.Request
import Data.Time (UTCTime) 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 import Yesod.Yesod
data SitemapLoc = AbsLoc String | RelLoc String data SitemapLoc = AbsLoc String | RelLoc String
@ -40,14 +41,14 @@ data SitemapChangeFreq = Always
| Monthly | Monthly
| Yearly | Yearly
| Never | Never
instance Show SitemapChangeFreq where instance ConvertSuccess SitemapChangeFreq String where
show Always = "always" convertSuccess Always = "always"
show Hourly = "hourly" convertSuccess Hourly = "hourly"
show Daily = "daily" convertSuccess Daily = "daily"
show Weekly = "weekly" convertSuccess Weekly = "weekly"
show Monthly = "monthly" convertSuccess Monthly = "monthly"
show Yearly = "yearly" convertSuccess Yearly = "yearly"
show Never = "never" convertSuccess Never = "never"
data SitemapUrl = SitemapUrl data SitemapUrl = SitemapUrl
{ sitemapLoc :: SitemapLoc { sitemapLoc :: SitemapLoc
@ -55,45 +56,41 @@ data SitemapUrl = SitemapUrl
, sitemapChangeFreq :: SitemapChangeFreq , sitemapChangeFreq :: SitemapChangeFreq
, priority :: Double , priority :: Double
} }
data SitemapRequest = SitemapRequest String Int data SitemapResponse = SitemapResponse [SitemapUrl] Approot
data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] instance ConvertSuccess SitemapResponse Content where
instance Show SitemapResponse where -- FIXME very ugly, use Text instead convertSuccess = cs . (cs :: SitemapResponse -> Text)
show (SitemapResponse (SitemapRequest host port) urls) = instance ConvertSuccess SitemapResponse Text where
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++ convertSuccess (SitemapResponse urls (Approot ar)) = TL.concat
"<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">" ++ [ cs "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
concatMap helper urls ++ , cs "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">"
"</urlset>" , TL.concat $ map helper urls
, cs "</urlset>"
]
where where
prefix = "http://" ++ host ++ helper (SitemapUrl loc modTime freq pri) = cs $ concat
case port of
80 -> ""
_ -> ':' : show port
helper (SitemapUrl loc modTime freq pri) = concat
[ "<url><loc>" [ "<url><loc>"
, encodeHtml $ showLoc loc , encodeHtml $ showLoc loc
, "</loc><lastmod>" , "</loc><lastmod>"
, formatW3 modTime , formatW3 modTime
, "</lastmod><changefreq>" , "</lastmod><changefreq>"
, show freq , cs freq
, "</changefreq><priority>" , "</changefreq><priority>"
, show pri , show pri
, "</priority></url>" , "</priority></url>"
] ]
showLoc (AbsLoc s) = s showLoc (AbsLoc s) = s
showLoc (RelLoc s) = prefix ++ s showLoc (RelLoc s) = ar ++ s
instance HasReps SitemapResponse where instance HasReps SitemapResponse where
reps = 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 sitemap urls' = do
env <- parseEnv yesod <- getYesod
-- FIXME
let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env)
urls <- liftIO urls' urls <- liftIO urls'
return $ SitemapResponse req urls return $ SitemapResponse urls $ approot yesod
robots :: Yesod yesod => Handler yesod Plain robots :: Yesod yesod => Handler yesod Plain
robots = do robots = do

33
Yesod/Rep.hs
View File

@ -78,23 +78,24 @@ data ContentType =
| TypeOgv | TypeOgv
| TypeOctet | TypeOctet
| TypeOther String | TypeOther String
instance Show ContentType where deriving (Show)
show TypeHtml = "text/html" instance ConvertSuccess ContentType String where
show TypePlain = "text/plain" convertSuccess TypeHtml = "text/html"
show TypeJson = "application/json" convertSuccess TypePlain = "text/plain"
show TypeXml = "text/xml" convertSuccess TypeJson = "application/json"
show TypeAtom = "application/atom+xml" convertSuccess TypeXml = "text/xml"
show TypeJpeg = "image/jpeg" convertSuccess TypeAtom = "application/atom+xml"
show TypePng = "image/png" convertSuccess TypeJpeg = "image/jpeg"
show TypeGif = "image/gif" convertSuccess TypePng = "image/png"
show TypeJavascript = "text/javascript" convertSuccess TypeGif = "image/gif"
show TypeCss = "text/css" convertSuccess TypeJavascript = "text/javascript"
show TypeFlv = "video/x-flv" convertSuccess TypeCss = "text/css"
show TypeOgv = "video/ogg" convertSuccess TypeFlv = "video/x-flv"
show TypeOctet = "application/octet-stream" convertSuccess TypeOgv = "video/ogg"
show (TypeOther s) = s convertSuccess TypeOctet = "application/octet-stream"
convertSuccess (TypeOther s) = s
instance Eq ContentType where instance Eq ContentType where
(==) = (==) `on` show (==) = (==) `on` (cs :: ContentType -> String)
newtype Content = Content { unContent :: ByteString } newtype Content = Content { unContent :: ByteString }
deriving (Eq, Show) deriving (Eq, Show)