Added rudimentary JSON support

Yesod.hs

@@ -23,6 +23,7 @@ module Yesod
     , module Yesod.Form
     , module Web.Mime
     , module Yesod.Hamlet
+    , module Yesod.Json
     , Application
     , Method (..)
     , cs
@@ -32,10 +33,12 @@ module Yesod
 import Yesod.Response hiding (testSuite)
 import Yesod.Request hiding (testSuite)
 import Web.Mime hiding (testSuite)
+import Yesod.Json hiding (testSuite)
 #else
 import Yesod.Response
 import Yesod.Request
 import Web.Mime
+import Yesod.Json
 #endif
 
 import Yesod.Dispatch

Yesod/Helpers/Auth.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Auth
@@ -165,19 +164,25 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
                         Nothing -> helper xs
                         Just y -> y
 
-getCheck :: Yesod master => GHandler Auth master RepHtml
+getCheck :: Yesod master => GHandler Auth master RepHtmlJson
 getCheck = do
     ident <- maybeIdentifier
     dn <- displayName
-    -- FIXME applyLayoutJson
-    simpleApplyLayout "Authentication Status" $ [$hamlet|
+    let arg = (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn)
+    applyLayoutJson "Authentication Status" arg html json
+  where
+    html = [$hamlet|
 %h1 Authentication Status
 %dl
     %dt identifier
     %dd $fst$
     %dt displayName
     %dd $snd$
-|] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn)
+|]
+    json (ident, dn) =
+        jsonMap [ (jsonScalar $ cs "ident", jsonScalar ident)
+                , (jsonScalar $ cs "displayName", jsonScalar dn)
+                ]
 
 getLogout :: GHandler Auth master ()
 getLogout = do
@@ -215,7 +220,7 @@ redirectLogin = do
 {- FIXME
 -- | Determinge the path requested by the user (ie, the path info). This
 -- includes the query string.
-requestPath :: (Functor m, Monad m, RequestReader m) => m String --FIXME unused
+requestPath :: (Functor m, Monad m, RequestReader m) => m String
 requestPath = do
     env <- waiRequest
     let q = case B8.unpack $ W.queryString env of

Yesod/Json.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+module Yesod.Json
+    ( Json
+    , jsonToContent
+      -- * Generate Json output
+    , jsonScalar
+    , jsonList
+    , jsonList'
+    , jsonMap
+    , jsonMap'
+#if TEST
+    , testSuite
+#endif
+    )
+    where
+
+import Text.Hamlet.Monad
+import Control.Applicative
+import Data.Text (Text)
+import Web.Encodings
+import Yesod.Hamlet
+import Control.Monad (when)
+#if TEST
+import Yesod.Response hiding (testSuite)
+import Data.Text.Lazy (unpack)
+import qualified Data.Text as T
+#else
+import Yesod.Response
+#endif
+import Yesod.Handler
+
+#if TEST
+import Test.Framework (testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.HUnit hiding (Test)
+import Test.QuickCheck
+import Control.Monad (when)
+#endif
+
+newtype Json url m a = Json { unJson :: Hamlet url m a }
+    deriving (Functor, Applicative, Monad)
+
+jsonToContent :: Json (Routes sub) IO () -> GHandler sub master Content
+jsonToContent = hamletToContent . unJson
+
+htmlContentToText :: HtmlContent -> Text
+htmlContentToText (Encoded t) = t
+htmlContentToText (Unencoded t) = encodeHtml t
+
+jsonScalar :: Monad m => HtmlContent -> Json url m ()
+jsonScalar s = Json $ do
+    outputString "\""
+    output $ encodeJson $ htmlContentToText s
+    outputString "\""
+
+jsonList :: Monad m => [Json url m ()] -> Json url m ()
+jsonList = jsonList' . fromList
+
+jsonList' :: Monad m => Enumerator (Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type
+jsonList' (Enumerator enum) = do
+    Json $ outputString "["
+    _ <- enum go False
+    Json $ outputString "]"
+  where
+    go putComma j = do
+        when putComma $ Json $ outputString ","
+        () <- j
+        return $ Right True
+
+jsonMap :: Monad m => [(Json url m (), Json url m ())] -> Json url m ()
+jsonMap = jsonMap' . fromList
+
+jsonMap' :: Monad m => Enumerator (Json url m (), Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type
+jsonMap' (Enumerator enum) = do
+    Json $ outputString "{"
+    _ <- enum go False
+    Json $ outputString "}"
+  where
+    go putComma (k, v) = do
+        when putComma $ Json $ outputString ","
+        () <- k
+        Json $ outputString ":"
+        () <- v
+        return $ Right True
+
+#if TEST
+
+testSuite :: Test
+testSuite = testGroup "Yesod.Json"
+    [ testCase "simple output" caseSimpleOutput
+    ]
+
+caseSimpleOutput :: Assertion
+caseSimpleOutput = do
+    let j = do
+        jsonMap
+            [ (jsonScalar $ T.pack "foo" , jsonList
+                [ jsonScalar $ T.pack "bar"
+                , jsonScalar $ T.pack "baz"
+                ])
+            ]
+    t <- hamletToText id $ unJson j
+    "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack t
+
+#endif

Yesod/Yesod.hs

@@ -4,6 +4,7 @@ module Yesod.Yesod
     ( Yesod (..)
     , YesodSite (..)
     , simpleApplyLayout
+    , applyLayoutJson
     , getApproot
     ) where
 
@@ -16,6 +17,7 @@ import Control.Arrow ((***))
 import Network.Wai.Middleware.ClientSession
 import qualified Network.Wai as W
 import Yesod.Definitions
+import Yesod.Json
 
 import Web.Routes.Quasi (QuasiSite (..))
 
@@ -59,6 +61,24 @@ class YesodSite a => Yesod a where
     -- trailing slash.
     approot :: a -> Approot
 
+applyLayoutJson :: Yesod master
+                => String -- ^ title
+                -> x
+                -> (x -> Hamlet (Routes sub) IO ())
+                -> (x -> Json (Routes sub) IO ())
+                -> GHandler sub master RepHtmlJson
+applyLayoutJson t x toH toJ = do
+    let pc = PageContent
+                { pageTitle = cs t
+                , pageHead = return () -- FIXME allow user to supply?
+                , pageBody = toH x
+                }
+    y <- getYesodMaster
+    rr <- getRequest
+    html <- hamletToContent $ applyLayout y pc rr
+    json <- jsonToContent $ toJ x
+    return $ RepHtmlJson html json
+
 -- | A convenience wrapper around 'simpleApplyLayout for HTML-only data.
 simpleApplyLayout :: Yesod master
                   => String -- ^ title

runtests.hs

@@ -1,20 +1,18 @@
 import Test.Framework (defaultMain)
 
 import qualified Yesod.Response
-import qualified Yesod.Resource
 import qualified Yesod.Request
-import qualified Data.Object.Html
-import qualified Test.Errors
-import qualified Test.QuasiResource
+-- FIXME import qualified Test.Errors
+-- FIXME import qualified Test.QuasiResource
 import qualified Web.Mime
+import qualified Yesod.Json
 
 main :: IO ()
 main = defaultMain
     [ Yesod.Response.testSuite
-    , Yesod.Resource.testSuite
     , Yesod.Request.testSuite
-    , Data.Object.Html.testSuite
-    , Test.Errors.testSuite
-    , Test.QuasiResource.testSuite
+    -- FIXME , Test.Errors.testSuite
+    -- FIXME, Test.QuasiResource.testSuite
     , Web.Mime.testSuite
+    , Yesod.Json.testSuite
     ]

yesod.cabal

@@ -67,6 +67,7 @@ library
                      Yesod.Definitions
                      Yesod.Form
                      Yesod.Hamlet
+                     Yesod.Json
                      Yesod.Handler
                      Yesod.Dispatch
                      Yesod.Yesod