Removed Data.Object.Instances
This commit is contained in:
Michael Snoyman
parent
00115f02d4
commit
002f6ef788
@ -1,107 +0,0 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- Module : Data.Object.Instances
|
|
||||||
-- Copyright : Michael Snoyman
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
||||||
-- Stability : Stable
|
|
||||||
-- Portability : portable
|
|
||||||
--
|
|
||||||
-- Instances for converting various types of data into Data.Object.Object.
|
|
||||||
--
|
|
||||||
---------------------------------------------------------
|
|
||||||
module Data.Object.Instances
|
|
||||||
( Json (..)
|
|
||||||
, Yaml (..)
|
|
||||||
, Html (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Object.Text
|
|
||||||
import qualified Data.ByteString.Lazy as B
|
|
||||||
import Web.Encodings (encodeJson)
|
|
||||||
import Text.Yaml (encodeText')
|
|
||||||
import qualified Data.Text.Lazy as LT
|
|
||||||
import Data.Text.Lazy (Text)
|
|
||||||
import Data.Convertible.Text
|
|
||||||
|
|
||||||
newtype Json = Json { unJson :: Text }
|
|
||||||
instance ConvertAttempt (Object Text Text) Json where
|
|
||||||
convertAttempt = return . convertSuccess
|
|
||||||
instance ConvertSuccess (Object Text Text) Json where
|
|
||||||
convertSuccess = Json . helper where
|
|
||||||
helper :: TextObject -> Text
|
|
||||||
helper (Scalar s) = LT.concat
|
|
||||||
[ LT.pack "\""
|
|
||||||
, bsToText $ encodeJson $ convertSuccess s
|
|
||||||
, LT.pack "\""
|
|
||||||
]
|
|
||||||
helper (Sequence s) = LT.concat
|
|
||||||
[ LT.pack "["
|
|
||||||
, LT.intercalate (LT.pack ",") $ map helper s
|
|
||||||
, LT.pack "]"
|
|
||||||
]
|
|
||||||
helper (Mapping m) = LT.concat
|
|
||||||
[ LT.pack "{"
|
|
||||||
, LT.intercalate (LT.pack ",") $ map helper2 m
|
|
||||||
, LT.pack "}"
|
|
||||||
]
|
|
||||||
helper2 :: (Text, TextObject) -> Text
|
|
||||||
helper2 (k, v) = LT.concat
|
|
||||||
[ LT.pack "\""
|
|
||||||
, bsToText $ encodeJson $ convertSuccess k
|
|
||||||
, LT.pack "\":"
|
|
||||||
, helper v
|
|
||||||
]
|
|
||||||
|
|
||||||
bsToText :: B.ByteString -> Text
|
|
||||||
bsToText = convertSuccess
|
|
||||||
|
|
||||||
newtype Yaml = Yaml { unYaml :: Text }
|
|
||||||
instance ConvertAttempt (Object Text Text) Yaml where
|
|
||||||
convertAttempt = return . convertSuccess
|
|
||||||
instance ConvertSuccess (Object Text Text) Yaml where
|
|
||||||
convertSuccess = Yaml . convertSuccess . encodeText'
|
|
||||||
|
|
||||||
-- | Represents as an entire HTML 5 document by using the following:
|
|
||||||
--
|
|
||||||
-- * A scalar is a paragraph.
|
|
||||||
-- * A sequence is an unordered list.
|
|
||||||
-- * A mapping is a definition list.
|
|
||||||
newtype Html = Html { unHtml :: Text }
|
|
||||||
|
|
||||||
instance ConvertAttempt (Object Text Text) Html where
|
|
||||||
convertAttempt = return . convertSuccess
|
|
||||||
instance ConvertSuccess (Object Text Text) Html where
|
|
||||||
convertSuccess o = Html $ LT.concat
|
|
||||||
[ LT.pack "<!DOCTYPE html>\n<html><body>" -- FIXME full doc or just fragment?
|
|
||||||
, helper o
|
|
||||||
, LT.pack "</body></html>"
|
|
||||||
] where
|
|
||||||
helper :: TextObject -> Text
|
|
||||||
helper (Scalar s) = LT.concat
|
|
||||||
[ LT.pack "<p>"
|
|
||||||
, s
|
|
||||||
, LT.pack "</p>"
|
|
||||||
]
|
|
||||||
helper (Sequence []) = LT.pack "<ul></ul>"
|
|
||||||
helper (Sequence s) = LT.concat
|
|
||||||
[ LT.pack "<ul><li>"
|
|
||||||
, LT.intercalate (LT.pack "</li><li>") $ map helper s
|
|
||||||
, LT.pack "</li></ul>"
|
|
||||||
]
|
|
||||||
helper (Mapping m) = LT.concat $
|
|
||||||
LT.pack "<dl>" :
|
|
||||||
map helper2 m ++
|
|
||||||
[ LT.pack "</dl>" ]
|
|
||||||
helper2 :: (Text, TextObject) -> Text
|
|
||||||
helper2 (k, v) = LT.concat
|
|
||||||
[ LT.pack "<dt>"
|
|
||||||
, k
|
|
||||||
, LT.pack "</dt><dd>"
|
|
||||||
, helper v
|
|
||||||
, LT.pack "</dd>"
|
|
||||||
]
|
|
||||||
@ -23,8 +23,6 @@ module Yesod.Application
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Web.Encodings
|
import Web.Encodings
|
||||||
import Data.Object.Text
|
|
||||||
import Data.Object.String
|
|
||||||
import Data.Enumerable
|
import Data.Enumerable
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
|
|
||||||
@ -63,19 +61,6 @@ class ResourceName a => RestfulApp a where
|
|||||||
|
|
||||||
-- | Output error response pages.
|
-- | Output error response pages.
|
||||||
errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig?
|
errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig?
|
||||||
errorHandler _ rr NotFound = reps $ toTextObject $
|
|
||||||
"Not found: " ++ show rr
|
|
||||||
errorHandler _ _ (Redirect url) =
|
|
||||||
reps $ toTextObject $ "Redirect to: " ++ url
|
|
||||||
errorHandler _ _ (InternalError e) =
|
|
||||||
reps $ toTextObject $ "Internal server error: " ++ e
|
|
||||||
errorHandler _ _ (InvalidArgs ia) =
|
|
||||||
reps $ toTextObject $ toStringObject
|
|
||||||
[ ("errorMsg", toStringObject "Invalid arguments")
|
|
||||||
, ("messages", toStringObject ia)
|
|
||||||
]
|
|
||||||
errorHandler _ _ PermissionDenied =
|
|
||||||
reps $ toTextObject "Permission denied"
|
|
||||||
|
|
||||||
-- | Whether or not we should check for overlapping resource names.
|
-- | Whether or not we should check for overlapping resource names.
|
||||||
checkOverlaps :: a -> Bool
|
checkOverlaps :: a -> Bool
|
||||||
|
|||||||
@ -154,6 +154,12 @@ rpxnowLogin apiKey = do
|
|||||||
header authCookieName $ Rpxnow.identifier ident
|
header authCookieName $ Rpxnow.identifier ident
|
||||||
redirect dest
|
redirect dest
|
||||||
|
|
||||||
|
authCheck :: Handler
|
||||||
|
authCheck = error "authCheck"
|
||||||
|
|
||||||
|
authLogout :: Handler
|
||||||
|
authLogout = error "authLogout"
|
||||||
|
{- FIXME
|
||||||
authCheck :: Handler
|
authCheck :: Handler
|
||||||
authCheck = do
|
authCheck = do
|
||||||
ident <- maybeIdentifier
|
ident <- maybeIdentifier
|
||||||
@ -168,3 +174,4 @@ authLogout :: Handler
|
|||||||
authLogout = do
|
authLogout = do
|
||||||
deleteCookie authCookieName
|
deleteCookie authCookieName
|
||||||
return $ objectResponse [("status", "loggedout")]
|
return $ objectResponse [("status", "loggedout")]
|
||||||
|
-}
|
||||||
|
|||||||
@ -38,7 +38,6 @@ module Yesod.Response
|
|||||||
-- * Generic responses
|
-- * Generic responses
|
||||||
, genResponse
|
, genResponse
|
||||||
, htmlResponse
|
, htmlResponse
|
||||||
, objectResponse
|
|
||||||
#if TEST
|
#if TEST
|
||||||
-- * Tests
|
-- * Tests
|
||||||
, testSuite
|
, testSuite
|
||||||
@ -47,8 +46,6 @@ module Yesod.Response
|
|||||||
|
|
||||||
import Yesod.Definitions
|
import Yesod.Definitions
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Data.Object.Text
|
|
||||||
import Data.Object.Instances
|
|
||||||
import qualified Data.ByteString as SBS
|
import qualified Data.ByteString as SBS
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import qualified Data.Text as ST
|
import qualified Data.Text as ST
|
||||||
@ -171,25 +168,6 @@ genResponse ct t = [(ct, return $ toContent t)]
|
|||||||
htmlResponse :: (Monad m, ToContent t) => t -> [RepT m]
|
htmlResponse :: (Monad m, ToContent t) => t -> [RepT m]
|
||||||
htmlResponse = genResponse "text/html"
|
htmlResponse = genResponse "text/html"
|
||||||
|
|
||||||
-- | Return a response from an Object.
|
|
||||||
objectResponse :: (Monad m, ToObject o Text Text) => o -> [RepT m]
|
|
||||||
objectResponse = reps . toTextObject
|
|
||||||
|
|
||||||
-- HasReps instances
|
|
||||||
instance Monad m => HasReps () m where
|
|
||||||
reps _ = [("text/plain", return $ toContent "")]
|
|
||||||
instance Monad m => HasReps TextObject m where
|
|
||||||
reps o =
|
|
||||||
[ ("text/html", return $ toContent $ unHtml $ convertSuccess o)
|
|
||||||
, ("application/json", return $ toContent $ unJson $ convertSuccess o)
|
|
||||||
, ("text/yaml", return $ toContent $ unYaml $ convertSuccess o)
|
|
||||||
]
|
|
||||||
|
|
||||||
{- FIXME
|
|
||||||
instance HasReps (Reps m) where
|
|
||||||
reps = id
|
|
||||||
-}
|
|
||||||
|
|
||||||
#if TEST
|
#if TEST
|
||||||
----- Testing
|
----- Testing
|
||||||
testSuite :: Test
|
testSuite :: Test
|
||||||
|
|||||||
@ -55,7 +55,6 @@ library
|
|||||||
Yesod.Resource
|
Yesod.Resource
|
||||||
Yesod.Yesod
|
Yesod.Yesod
|
||||||
Data.Object.Html
|
Data.Object.Html
|
||||||
Data.Object.Instances
|
|
||||||
Hack.Middleware.MethodOverride
|
Hack.Middleware.MethodOverride
|
||||||
Hack.Middleware.ClientSession
|
Hack.Middleware.ClientSession
|
||||||
Hack.Middleware.Jsonp
|
Hack.Middleware.Jsonp
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user