128 lines
3.9 KiB
Haskell
128 lines
3.9 KiB
Haskell
{-# 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
|