diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 8c289da7..5ec42cc3 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -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 diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 43f38aec..547ebadc 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -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 diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 1305d4ec..c194faaf 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -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 - [ "\n" - , "" - , "" - , encodeHtml $ atomTitle f - , "" - , "" - , "" - , "" - , formatW3 $ atomUpdated f - , "" - , "" - , encodeHtml $ atomLinkHome f - , "" - , concatMap show $ atomEntries f - , "" +instance ConvertSuccess AtomFeed Content where + convertSuccess = cs . (cs :: AtomFeed -> Text) +instance ConvertSuccess AtomFeed Text where + convertSuccess f = TL.concat + [ cs "\n" + , cs "" + , cs "" + , encodeHtml $ cs $ atomTitle f + , cs "" + , cs "" + , cs "" + , cs "" + , cs $ formatW3 $ atomUpdated f + , cs "" + , cs "" + , encodeHtml $ cs $ atomLinkHome f + , cs "" + , TL.concat $ map cs $ atomEntries f + , cs "" ] -instance Show AtomFeedEntry where - show e = concat - [ "" - , "" - , encodeHtml $ atomEntryLink e - , "" - , "" - , "" - , formatW3 $ atomEntryUpdated e - , "" - , "" - , encodeHtml $ atomEntryTitle e - , "" - , "" - , "" +instance ConvertSuccess AtomFeedEntry Text where + convertSuccess e = TL.concat + [ cs "" + , cs "" + , encodeHtml $ cs $ atomEntryLink e + , cs "" + , cs "" + , cs "" + , cs $ formatW3 $ atomEntryUpdated e + , cs "" + , cs "" + , encodeHtml $ cs $ atomEntryTitle e + , cs "" + , cs "" + , cs "" ] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e443ab18..087e65b0 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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) _) = "

" ++ encodeHtml s ++ - "

" +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 ++ - "
" ++ - "OpenID: " ++ - "" ++ - "
" + 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 () diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index b6b6d337..e5cc9ab8 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -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) = - "\n" ++ - "" ++ - concatMap helper urls ++ - "" +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 "\n" + , cs "" + , TL.concat $ map helper urls + , cs "" + ] 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 [ "" , encodeHtml $ showLoc loc , "" , formatW3 modTime , "" - , show freq + , cs freq , "" , show pri , "" ] 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 diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 02952ca6..c0f96443 100644 --- a/Yesod/Rep.hs +++ b/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)