diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 4aebc768..a833d8c9 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -12,19 +12,19 @@ import Data.List data MyYesod = MyYesod -instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" +instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler" getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] pageIndex :: Handler MyYesod HtmlObject pageIndex = return $ toHtmlObject ["pageIndex"] -pageAdd :: Handler MyYesod RepChooser +pageAdd :: Handler MyYesod ChooseRep pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] -pageDetail :: String -> Handler MyYesod RepChooser +pageDetail :: String -> Handler MyYesod ChooseRep pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] pageDelete :: String -> Handler MyYesod HtmlObject pageDelete s = return $ toHtmlObject ["pageDelete", s] -pageUpdate :: String -> Handler MyYesod RepChooser +pageUpdate :: String -> Handler MyYesod ChooseRep pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] userInfo :: Int -> Handler MyYesod HtmlObject userInfo i = return $ toHtmlObject ["userInfo", show i] @@ -33,11 +33,11 @@ userVariable i s = return $ toHtmlObject ["userVariable", show i, s] userPage :: Int -> [String] -> Handler MyYesod HtmlObject userPage i p = return $ toHtmlObject ["userPage", show i, show p] -instance Show (Verb -> Handler MyYesod RepChooser) where +instance Show (Verb -> Handler MyYesod ChooseRep) where show _ = "verb -> handler" -instance Show (Resource -> Verb -> Handler MyYesod RepChooser) where +instance Show (Resource -> Verb -> Handler MyYesod ChooseRep) where show _ = "resource -> verb -> handler" -handler :: Resource -> Verb -> Handler MyYesod RepChooser +handler :: Resource -> Verb -> Handler MyYesod ChooseRep handler = [$resources| /static/*filepath/: getStatic /page/: @@ -55,7 +55,7 @@ handler = [$resources| Get: userPage |] -ph :: [String] -> Handler MyYesod RepChooser -> Assertion +ph :: [String] -> Handler MyYesod ChooseRep -> Assertion ph ss h = do let eh = return . chooseRep . toHtmlObject . show rr = error "No raw request" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2a2fb082..46ef947c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -95,8 +95,8 @@ getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) instance HasTemplateGroup (Handler yesod) where getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) -runHandler :: Handler yesod RepChooser - -> (ErrorResponse -> Handler yesod RepChooser) +runHandler :: Handler yesod ChooseRep + -> (ErrorResponse -> Handler yesod ChooseRep) -> RawRequest -> yesod -> TemplateGroup @@ -124,7 +124,7 @@ runHandler (Handler handler) eh rr y tg cts = do (ct, c) <- a cts return $ Response 200 headers ct c -safeEh :: ErrorResponse -> Handler yesod RepChooser +safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ toHtmlObject "Internal server error" diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index b0377c32..1e6854e5 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -40,7 +40,7 @@ data AtomFeed = AtomFeed , atomEntries :: [AtomFeedEntry] } instance HasReps AtomFeedResponse where - reps = + chooseRep = defChooseRep [ (TypeAtom, return . cs) ] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 39ff7114..900414c8 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -65,10 +65,10 @@ data AuthResource = | LoginRpxnow deriving (Show, Eq, Enum, Bounded) -rc :: HasReps x => Handler y x -> Handler y RepChooser +rc :: HasReps x => Handler y x -> Handler y ChooseRep rc = fmap chooseRep -authHandler :: YesodAuth y => Verb -> [String] -> Handler y RepChooser +authHandler :: YesodAuth y => Verb -> [String] -> Handler y ChooseRep authHandler Get ["check"] = rc authCheck authHandler Get ["logout"] = rc authLogout authHandler Get ["openid"] = rc authOpenidForm diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 04780092..ca7687b4 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -69,7 +69,7 @@ instance ConvertSuccess SitemapResponse Html where ] instance HasReps SitemapResponse where - reps = + chooseRep = defChooseRep [ (TypeXml, return . cs) ] diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index e0f846a0..6e4ff037 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -27,9 +27,9 @@ -- effort. module Yesod.Rep ( Content (..) - , RepChooser - , ContentPair + , ChooseRep , HasReps (..) + , defChooseRep -- * Specific types of representations , Plain (..) , plain @@ -77,38 +77,36 @@ instance ConvertSuccess HtmlDoc Content where instance ConvertSuccess XmlDoc Content where convertSuccess = cs . unXmlDoc -type ContentPair = (ContentType, Content) -type RepChooser = [ContentType] -> IO ContentPair +type ChooseRep = [ContentType] -> IO (ContentType, Content) -- | Any type which can be converted to representations. There must be at least -- one representation for each type. class HasReps a where - reps :: [(ContentType, a -> IO Content)] - chooseRep :: a -> RepChooser - chooseRep a ts = do - let (ct, c) = - case mapMaybe helper ts of - (x:_) -> x - [] -> case reps of - [] -> error "Empty reps" - (x:_) -> x - c' <- c a - return (ct, c') - where - --helper :: ContentType -> Maybe ContentPair - helper ct = do - c <- lookup ct reps - return (ct, c) + chooseRep :: a -> ChooseRep -instance HasReps RepChooser where - reps = error "reps of RepChooser" +-- | A helper method for generating 'HasReps' instances. +defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep +defChooseRep reps a ts = do + let (ct, c) = + case mapMaybe helper ts of + (x:_) -> x + [] -> case reps of + [] -> error "Empty reps" + (x:_) -> x + c' <- c a + return (ct, c') + where + helper ct = do + c <- lookup ct reps + return (ct, c) + +instance HasReps ChooseRep where chooseRep = id instance HasReps () where - reps = [(TypePlain, const $ return $ cs "")] + chooseRep = defChooseRep [(TypePlain, const $ return $ cs "")] instance HasReps [(ContentType, Content)] where - reps = error "reps of [(ContentType, Content)]" chooseRep a cts = return $ case filter (\(ct, _) -> ct `elem` cts) a of ((ct, c):_) -> (ct, c) @@ -119,7 +117,7 @@ instance HasReps [(ContentType, Content)] where newtype Plain = Plain { unPlain :: Text } deriving (Eq, Show) instance HasReps Plain where - reps = [(TypePlain, return . cs . unPlain)] + chooseRep = defChooseRep [(TypePlain, return . cs . unPlain)] plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs @@ -129,7 +127,7 @@ data Template = Template (StringTemplate Text) HtmlObject (IO [(String, HtmlObject)]) instance HasReps Template where - reps = [ (TypeHtml, + chooseRep = defChooseRep [ (TypeHtml, \(Template t name ho attrsIO) -> do attrs <- attrsIO return @@ -144,7 +142,7 @@ instance HasReps Template where -- FIXME data TemplateFile = TemplateFile FilePath HtmlObject instance HasReps TemplateFile where - reps = [ (TypeHtml, + chooseRep = defChooseRep [ (TypeHtml, \(TemplateFile fp h) -> do contents <- readFile fp let t = newSTMP contents @@ -156,19 +154,17 @@ instance HasReps TemplateFile where data Static = Static ContentType ByteString instance HasReps Static where - reps = error "reps of Static" chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs) data StaticFile = StaticFile ContentType FilePath instance HasReps StaticFile where - reps = error "reps of StaticFile" chooseRep (StaticFile ct fp) _ = do bs <- BL.readFile fp return (ct, Content $ const $ return bs) -- Useful instances of HasReps instance HasReps HtmlObject where - reps = + chooseRep = defChooseRep [ (TypeHtml, return . cs . unHtmlDoc . cs) , (TypeJson, return . cs . unJsonDoc . cs) ] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index bd59f9b8..daa9f15d 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -30,7 +30,7 @@ import Hack.Middleware.MethodOverride class Yesod a where -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, -- see the examples/fact.lhs sample. - handlers :: Resource -> Verb -> Handler a RepChooser + handlers :: Resource -> Verb -> Handler a ChooseRep -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -42,7 +42,7 @@ class Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: ErrorResponse -> Handler a RepChooser + errorHandler :: ErrorResponse -> Handler a ChooseRep errorHandler = defaultErrorHandler -- | The template directory. Blank means no templates. @@ -58,7 +58,7 @@ getApproot = approot `fmap` getYesod defaultErrorHandler :: Yesod y => ErrorResponse - -> Handler y RepChooser + -> Handler y ChooseRep defaultErrorHandler NotFound = do rr <- getRawRequest return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr