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

Beginning of new Rep file

Browse Source
This commit is contained in:
Michael Snoyman 2009-12-13 00:25:46 +02:00
parent a70fba9426
commit da3953c10c
7 changed files with 272 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
Data/Object/Html.hs
View File

@ -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\":\"<img src=\\\"file.jpg\\\">\"" ++
",\"foo\":[\"<br>\",\"&lt;hr&gt;\"]" ++
"}"
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

7
Yesod/Handler.hs
View File

@ -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

127
Yesod/Rep.hs Normal file
View File

@ -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

4
Yesod/Response.hs
View File

@ -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?

88
Yesod/Yesod.hs Normal file
View File

@ -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

2
runtests.hs
View File

@ -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
]

47
yesod.cabal
View File

@ -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