Beginning of new Rep file

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
+toHtmlObject :: ToObject x String Html => x -> HtmlObject
-cs = convertSuccess
+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

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

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

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?

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

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
     ]

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
+                     data-object-json >= 0.0.0 && < 0.1,
-    exposed-modules: Yesod,
+                     attempt >= 0.2.1 && < 0.3
-                     Yesod.Constants,
+    exposed-modules: Yesod
-                     Yesod.Request,
+                     Yesod.Constants
-                     Yesod.Response,
+                     Yesod.Rep
-                     Yesod.Utils,
+                     Yesod.Request
-                     Yesod.Definitions,
+                     Yesod.Response
-                     Yesod.Handler,
+                     Yesod.Utils
-                     Yesod.Application,
+                     Yesod.Definitions
-                     Yesod.Resource,
+                     Yesod.Handler
-                     Data.Object.Html,
+                     Yesod.Application
-                     Data.Object.Instances,
+                     Yesod.Resource
-                     Data.Object.Translate,
+                     Yesod.Yesod
-                     Hack.Middleware.MethodOverride,
+                     Data.Object.Html
-                     Hack.Middleware.ClientSession,
+                     Data.Object.Instances
-                     Hack.Middleware.Jsonp,
+                     Data.Object.Translate
-                     Hack.Middleware.CleanPath,
+                     Hack.Middleware.MethodOverride
-                     Hack.Middleware.Gzip,
+                     Hack.Middleware.ClientSession
-                     Yesod.Helpers.Auth,
+                     Hack.Middleware.Jsonp
-                     Yesod.Helpers.Static,
+                     Hack.Middleware.CleanPath
-                     Yesod.Helpers.AtomFeed,
+                     Hack.Middleware.Gzip
+                     Yesod.Helpers.Auth
+                     Yesod.Helpers.Static
+                     Yesod.Helpers.AtomFeed
                      Yesod.Helpers.Sitemap
     ghc-options:     -Wall -Werror