diff --git a/Yesod.hs b/Yesod.hs index baaf4880..988a4baf 100644 --- a/Yesod.hs +++ b/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 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 04147fc3..195c2d59 100644 --- a/Yesod/Helpers/Auth.hs +++ b/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 diff --git a/Yesod/Json.hs b/Yesod/Json.hs new file mode 100644 index 00000000..b6848e9c --- /dev/null +++ b/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 diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d40b1464..f4939fe2 100644 --- a/Yesod/Yesod.hs +++ b/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 diff --git a/runtests.hs b/runtests.hs index 91a0a81b..01d34d1d 100644 --- a/runtests.hs +++ b/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 ] diff --git a/yesod.cabal b/yesod.cabal index 067a0e5c..fc8cd07d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -67,6 +67,7 @@ library Yesod.Definitions Yesod.Form Yesod.Hamlet + Yesod.Json Yesod.Handler Yesod.Dispatch Yesod.Yesod