From da3953c10c1af21ef61e1a12ad3bad8ce051373d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 00:25:46 +0200 Subject: [PATCH] Beginning of new Rep file --- Data/Object/Html.hs | 27 +++++++--- Yesod/Handler.hs | 7 +++ Yesod/Rep.hs | 127 ++++++++++++++++++++++++++++++++++++++++++++ Yesod/Response.hs | 4 +- Yesod/Yesod.hs | 88 ++++++++++++++++++++++++++++++ runtests.hs | 2 + yesod.cabal | 47 ++++++++-------- 7 files changed, 272 insertions(+), 30 deletions(-) create mode 100644 Yesod/Rep.hs create mode 100644 Yesod/Yesod.hs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index a26c7d20..beb8e67e 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} -- | An 'Html' data type and associated 'HtmlObject'. This has useful -- conversions in web development: -- @@ -17,6 +18,9 @@ module Data.Object.Html Html (..) , HtmlDoc (..) , HtmlObject + -- * Standard 'Object' functions + , toHtmlObject + , fromHtmlObject #if TEST , testSuite #endif @@ -24,13 +28,14 @@ module Data.Object.Html import Data.Generics import Data.Object.Text -import Data.Object.JSON +import Data.Object.Json import Data.Convertible.Text import qualified Data.Text.Lazy as TL import Web.Encodings import Text.StringTemplate.Classes import qualified Data.Map as Map import Control.Arrow (second) +import Data.Attempt #if TEST import Test.Framework (testGroup, Test) @@ -48,12 +53,15 @@ data Html = deriving (Eq, Show, Typeable) -- | A full HTML document. -newtype HtmlDoc = HtmlDoc Text +newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text } type HtmlObject = Object String Html -cs :: ConvertSuccess x y => x -> y -cs = convertSuccess +toHtmlObject :: ToObject x String Html => x -> HtmlObject +toHtmlObject = toObject + +fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x +fromHtmlObject = fromObject instance ConvertSuccess Html Text where convertSuccess (Html t) = t @@ -94,11 +102,14 @@ instance ConvertSuccess HtmlObject Html where , Tag "dd" [] [cs v] ] +instance ConvertSuccess HtmlObject HtmlDoc where + convertSuccess = cs . (cs :: HtmlObject -> Html) + instance ConvertSuccess Html JsonScalar where convertSuccess = cs . (cs :: Html -> Text) instance ConvertSuccess HtmlObject JsonObject where convertSuccess = mapKeysValues convertSuccess convertSuccess -instance ConvertSuccess HtmlObject Json where +instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) instance ToSElem HtmlObject where @@ -152,7 +163,7 @@ caseJson = do let expected = "{\"bar\":\"\"" ++ ",\"foo\":[\"
\",\"<hr>\"]" ++ "}" - Json (cs expected) @=? cs content + JsonDoc (cs expected) @=? cs content testSuite :: Test testSuite = testGroup "Data.Object.Html" @@ -162,3 +173,7 @@ testSuite = testGroup "Data.Object.Html" ] #endif + +instance ToObject Char String Html where + toObject c = Scalar $ Text $ cs [c] + listToObject = Scalar . Text . cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6e199221..2d9233cc 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -19,6 +19,7 @@ module Yesod.Handler ( -- * Handler monad HandlerT + , HandlerT' -- FIXME , HandlerIO , Handler , runHandler @@ -53,6 +54,12 @@ type HandlerT m = ) type HandlerIO = HandlerT IO type Handler = HandlerIO [RepT HandlerIO] +type HandlerT' m a = + ReaderT RawRequest ( + AttemptT ( + WriterT [Header] m + ) + ) a -- FIXME shouldn't call error here... instance MonadRequestReader HandlerIO where diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs new file mode 100644 index 00000000..926825e1 --- /dev/null +++ b/Yesod/Rep.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Representations of data. A representation is basically how you display +-- information in a certain mime-type. For example, tree-style data can easily +-- be displayed as both JSON and Yaml. +-- +-- To save programmers\' fingers, the name of this module and all data types +-- and classes replaces the full word Representation with Rep. +-- +-- This concept is core to a RESTful framework. For example, if a user goes to +-- /movies/star-wars/, they'll want a HTML page describing the Star Wars movie. +-- However, if you've written an Ajax front-end, they might want than +-- information in XML or JSON format. There could also be another web service +-- that requests this information in a binary format to save on bandwidth. +-- +-- Since the vast majority of information that is dealt with in web +-- applications can be easily displayed using an 'Object', that is probably +-- your best bet on internal data format to use. If you need HTML escaping, +-- then specifically an 'HtmlObject' will be even better. +-- +-- By the way, I said above that the vast majority of information can be +-- contained in an 'Object' easily. The key word here is \"easily\"; in fact, +-- all data can be contained in an 'Object'; however, some of it requires more +-- effort. +module Yesod.Rep + ( + ContentType (..) + , Content + , Rep + , Reps + , HasReps (..) + , chooseRep + -- FIXME TemplateFile or some such... +#if TEST + , testSuite +#endif + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import Control.Applicative + +#if TEST +import Data.Object.Html hiding (testSuite) +#else +import Data.Object.Html +#endif + +import Data.Object.Json +import Data.Convertible.Text + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif + +data ContentType = + TypeHtml + | TypeJson + | TypeOther String + deriving Eq +instance Show ContentType where + show TypeHtml = "text/html" + show TypeJson = "application/json" + show (TypeOther s) = s + +newtype Content = Content ByteString + deriving (Eq, Show) + +instance ConvertSuccess Text Content where + convertSuccess = Content . cs +instance ConvertSuccess ByteString Content where + convertSuccess = Content + +type Rep a = (ContentType, a -> Content) +type Reps a = [Rep a] + +-- | Any type which can be converted to representations. There must be at least +-- one representation for each type. +class HasReps a where + reps :: Reps a + +chooseRep :: (Applicative f, HasReps a) + => f a + -> [ContentType] + -> f (ContentType, Content) +chooseRep fa ts = + let choices = rs' ++ rs + helper2 (ct, f) = + let fbs = f `fmap` fa + in pure (\bs -> (ct, bs)) <*> fbs + in if null rs + then error "Invalid empty reps" + else helper2 (head choices) + where + rs = reps + rs' = filter (\r -> fst r `elem` ts) rs + -- for type signature stuff + _ignored = pure (undefined :: Content) `asTypeOf` + (snd (head rs) `fmap` fa) + +-- Useful instances of HasReps +instance HasReps HtmlObject where + reps = + [ (TypeHtml, cs . unHtmlDoc . cs) + , (TypeJson, cs . unJsonDoc . cs) + ] + +#if TEST +caseChooseRep :: Assertion +caseChooseRep = do + let content = "IGNOREME" + a = Just $ toHtmlObject content + htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content + jsonbs = Content . cs $ "\"" ++ content ++ "\"" + chooseRep a [TypeHtml] @?= Just (TypeHtml, htmlbs) + chooseRep a [TypeJson] @?= Just (TypeJson, jsonbs) + chooseRep a [TypeHtml, TypeJson] @?= Just (TypeHtml, htmlbs) + chooseRep a [TypeOther "foo", TypeJson] @?= Just (TypeJson, jsonbs) + +testSuite :: Test +testSuite = testGroup "Yesod.Rep" + [ testCase "caseChooseRep" caseChooseRep + ] +#endif diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 4530a78a..14b3a299 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -106,11 +106,11 @@ chooseRep :: Monad m => [ContentType] -> [RepT m] -> RepT m -chooseRep cs rs +chooseRep cs' rs | null rs = error "All reps must have at least one representation" -- FIXME | otherwise = do let availCs = map fst rs - case filter (`elem` availCs) cs of + case filter (`elem` availCs) cs' of [] -> head rs [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME _ -> error "Overlapping representations" -- FIXME just take the first? diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs new file mode 100644 index 00000000..9cecddeb --- /dev/null +++ b/Yesod/Yesod.hs @@ -0,0 +1,88 @@ +-- | The basic typeclass for a Yesod application. +module Yesod.Yesod + ( Yesod (..) + , Handler + , toHackApp + ) where + +import Yesod.Rep +import Data.Object.Html (toHtmlObject) +import Yesod.Response hiding (reps, ContentType, Content, chooseRep) +import Yesod.Request +import Yesod.Constants +--import Yesod.Definitions +--import Yesod.Resource (checkResourceName) + +import Control.Applicative +--import Control.Monad (when) + +import qualified Hack +import Hack.Middleware.CleanPath +import Hack.Middleware.ClientSession +import Hack.Middleware.Gzip +import Hack.Middleware.Jsonp +import Hack.Middleware.MethodOverride + +type Handler a v = a -> IO v -- FIXME +type HandlerMap a = [(String, [ContentType] -> Handler a Content)] + +class Yesod a where + handlers :: HandlerMap a + + -- | The encryption key to be used for encrypting client sessions. + encryptKey :: a -> IO Word256 + encryptKey _ = getKey defaultKeyFile + + -- | All of the middlewares to install. + hackMiddleware :: a -> [Hack.Middleware] + hackMiddleware _ = + [ gzip + , cleanPath + , jsonp + , methodOverride + ] + + -- | Output error response pages. + errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> MyIdentity (ContentType, Content) -- FIXME better type sig? + errorHandler = defaultErrorHandler + -- | Whether or not we should check for overlapping resource names. + checkOverlaps :: a -> Bool + checkOverlaps = const True + +newtype MyIdentity a = MyIdentity { _unMyIdentity :: a } +instance Functor MyIdentity where + fmap f (MyIdentity a) = MyIdentity $ f a +instance Applicative MyIdentity where + pure = MyIdentity + (MyIdentity f) <*> (MyIdentity a) = MyIdentity $ f a + +defaultErrorHandler :: a + -> RawRequest + -> ErrorResult + -> [ContentType] + -> MyIdentity (ContentType, Content) +defaultErrorHandler _ rr NotFound = chooseRep $ pure . toHtmlObject $ + "Not found: " ++ show rr +defaultErrorHandler _ _ (Redirect url) = + chooseRep $ pure . toHtmlObject $ "Redirect to: " ++ url +defaultErrorHandler _ _ (InternalError e) = + chooseRep $ pure . toHtmlObject $ "Internal server error: " ++ e +defaultErrorHandler _ _ (InvalidArgs ia) = + chooseRep $ pure $ toHtmlObject + [ ("errorMsg", toHtmlObject "Invalid arguments") + , ("messages", toHtmlObject ia) + ] +defaultErrorHandler _ _ PermissionDenied = + chooseRep $ pure $ toHtmlObject "Permission denied" + +toHackApp :: Yesod y => y -> Hack.Application +toHackApp a env = do + -- FIXME when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? + key <- encryptKey a + let app' = toHackApp' a + clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... + app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] + app env + +toHackApp' :: Yesod y => y -> Hack.Application +toHackApp' = undefined -- FIXME diff --git a/runtests.hs b/runtests.hs index c2c41b0b..e4a7eaca 100644 --- a/runtests.hs +++ b/runtests.hs @@ -3,6 +3,7 @@ import Test.Framework (defaultMain) import qualified Yesod.Response import qualified Yesod.Utils import qualified Yesod.Resource +import qualified Yesod.Rep import qualified Data.Object.Html main :: IO () @@ -10,5 +11,6 @@ main = defaultMain [ Yesod.Response.testSuite , Yesod.Utils.testSuite , Yesod.Resource.testSuite + , Yesod.Rep.testSuite , Data.Object.Html.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index a3e56004..6c9e3538 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -40,32 +40,35 @@ library control-monad-attempt >= 0.0.0 && < 0.1, syb, text >= 0.5 && < 0.6, - convertible-text >= 0.0.0 && < 0.1, + convertible-text >= 0.0.1 && < 0.1, clientsession >= 0.0.1 && < 0.1, zlib >= 0.5.2.0 && < 0.6, containers >= 0.2.0.1 && < 0.3, HStringTemplate >= 0.6.2 && < 0.7, - data-object-json >= 0.0.0 && < 0.1 - exposed-modules: Yesod, - Yesod.Constants, - Yesod.Request, - Yesod.Response, - Yesod.Utils, - Yesod.Definitions, - Yesod.Handler, - Yesod.Application, - Yesod.Resource, - Data.Object.Html, - Data.Object.Instances, - Data.Object.Translate, - Hack.Middleware.MethodOverride, - Hack.Middleware.ClientSession, - Hack.Middleware.Jsonp, - Hack.Middleware.CleanPath, - Hack.Middleware.Gzip, - Yesod.Helpers.Auth, - Yesod.Helpers.Static, - Yesod.Helpers.AtomFeed, + data-object-json >= 0.0.0 && < 0.1, + attempt >= 0.2.1 && < 0.3 + exposed-modules: Yesod + Yesod.Constants + Yesod.Rep + Yesod.Request + Yesod.Response + Yesod.Utils + Yesod.Definitions + Yesod.Handler + Yesod.Application + Yesod.Resource + Yesod.Yesod + Data.Object.Html + Data.Object.Instances + Data.Object.Translate + Hack.Middleware.MethodOverride + Hack.Middleware.ClientSession + Hack.Middleware.Jsonp + Hack.Middleware.CleanPath + Hack.Middleware.Gzip + Yesod.Helpers.Auth + Yesod.Helpers.Static + Yesod.Helpers.AtomFeed Yesod.Helpers.Sitemap ghc-options: -Wall -Werror