Completely migrated from Raw to Text
This commit is contained in:
Michael Snoyman
parent
1decaa742b
commit
4262ffb38f
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Data.Object.Instances
|
||||
@ -16,84 +18,91 @@ module Data.Object.Instances
|
||||
( Json (..)
|
||||
, Yaml (..)
|
||||
, Html (..)
|
||||
, SafeFromObject (..)
|
||||
) where
|
||||
|
||||
import Data.Object
|
||||
import Data.Object.Raw
|
||||
import Data.Object.Text
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
import Data.ByteString.Class
|
||||
import Web.Encodings (encodeJson)
|
||||
import Text.Yaml (encode)
|
||||
import Text.Yaml (encodeText)
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import Data.Text.Lazy (Text)
|
||||
import Data.Convertible
|
||||
|
||||
class SafeFromObject a where
|
||||
safeFromObject :: RawObject -> a
|
||||
|
||||
newtype Json = Json { unJson :: B.ByteString }
|
||||
instance SafeFromObject Json where
|
||||
safeFromObject = Json . helper where
|
||||
helper :: RawObject -> B.ByteString
|
||||
helper (Scalar (Raw s)) = B.concat
|
||||
[ toLazyByteString "\""
|
||||
, encodeJson $ fromLazyByteString s
|
||||
, toLazyByteString "\""
|
||||
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) = B.concat
|
||||
[ toLazyByteString "["
|
||||
, B.intercalate (toLazyByteString ",") $ map helper s
|
||||
, toLazyByteString "]"
|
||||
helper (Sequence s) = LT.concat
|
||||
[ LT.pack "["
|
||||
, LT.intercalate (LT.pack ",") $ map helper s
|
||||
, LT.pack "]"
|
||||
]
|
||||
helper (Mapping m) = B.concat
|
||||
[ toLazyByteString "{"
|
||||
, B.intercalate (toLazyByteString ",") $ map helper2 m
|
||||
, toLazyByteString "}"
|
||||
helper (Mapping m) = LT.concat
|
||||
[ LT.pack "{"
|
||||
, LT.intercalate (LT.pack ",") $ map helper2 m
|
||||
, LT.pack "}"
|
||||
]
|
||||
helper2 :: (Raw, RawObject) -> B.ByteString
|
||||
helper2 (Raw k, v) = B.concat
|
||||
[ toLazyByteString "\""
|
||||
, encodeJson $ fromLazyByteString k
|
||||
, toLazyByteString "\":"
|
||||
helper2 :: (Text, TextObject) -> Text
|
||||
helper2 (k, v) = LT.concat
|
||||
[ LT.pack "\""
|
||||
, bsToText $ encodeJson $ convertSuccess k
|
||||
, LT.pack "\":"
|
||||
, helper v
|
||||
]
|
||||
|
||||
newtype Yaml = Yaml { unYaml :: B.ByteString }
|
||||
instance SafeFromObject Yaml where
|
||||
safeFromObject = Yaml . encode
|
||||
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 . 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 :: B.ByteString }
|
||||
newtype Html = Html { unHtml :: Text }
|
||||
|
||||
instance SafeFromObject Html where
|
||||
safeFromObject o = Html $ B.concat
|
||||
[ toLazyByteString "<!DOCTYPE html>\n<html><body>" -- FIXME full doc or just fragment?
|
||||
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
|
||||
, toLazyByteString "</body></html>"
|
||||
, LT.pack "</body></html>"
|
||||
] where
|
||||
helper :: RawObject -> B.ByteString
|
||||
helper (Scalar (Raw s)) = B.concat
|
||||
[ toLazyByteString "<p>"
|
||||
, toLazyByteString s
|
||||
, toLazyByteString "</p>"
|
||||
helper :: TextObject -> Text
|
||||
helper (Scalar s) = LT.concat
|
||||
[ LT.pack "<p>"
|
||||
, s
|
||||
, LT.pack "</p>"
|
||||
]
|
||||
helper (Sequence []) = toLazyByteString "<ul></ul>"
|
||||
helper (Sequence s) = B.concat
|
||||
[ toLazyByteString "<ul><li>"
|
||||
, B.intercalate (toLazyByteString "</li><li>") $ map helper s
|
||||
, toLazyByteString "</li></ul>"
|
||||
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) = B.concat $
|
||||
toLazyByteString "<dl>" :
|
||||
helper (Mapping m) = LT.concat $
|
||||
LT.pack "<dl>" :
|
||||
map helper2 m ++
|
||||
[ toLazyByteString "</dl>" ]
|
||||
helper2 :: (Raw, RawObject) -> B.ByteString
|
||||
helper2 (Raw k, v) = B.concat
|
||||
[ toLazyByteString "<dt>"
|
||||
, toLazyByteString k
|
||||
, toLazyByteString "</dt><dd>"
|
||||
[ LT.pack "</dl>" ]
|
||||
helper2 :: (Text, TextObject) -> Text
|
||||
helper2 (k, v) = LT.concat
|
||||
[ LT.pack "<dt>"
|
||||
, k
|
||||
, LT.pack "</dt><dd>"
|
||||
, helper v
|
||||
, toLazyByteString "</dd>"
|
||||
, LT.pack "</dd>"
|
||||
]
|
||||
|
||||
@ -23,9 +23,11 @@ module Web.Restful.Application
|
||||
) where
|
||||
|
||||
import Web.Encodings
|
||||
import Data.Object.Raw
|
||||
import Data.Object
|
||||
import Data.Object.Text
|
||||
import Data.Enumerable
|
||||
import Control.Monad (when)
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
import qualified Hack
|
||||
import Hack.Middleware.CleanPath
|
||||
@ -59,18 +61,18 @@ class ResourceName a => RestfulApp a where
|
||||
|
||||
-- | Output error response pages.
|
||||
errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig?
|
||||
errorHandler _ rr NotFound = reps $ toRawObject $ "Not found: " ++ show rr
|
||||
errorHandler _ rr NotFound = reps $ toTextObject $ "Not found: " ++ show rr
|
||||
errorHandler _ _ (Redirect url) =
|
||||
reps $ toRawObject $ "Redirect to: " ++ url
|
||||
reps $ toTextObject $ "Redirect to: " ++ url
|
||||
errorHandler _ _ (InternalError e) =
|
||||
reps $ toRawObject $ "Internal server error: " ++ e
|
||||
reps $ toTextObject $ "Internal server error: " ++ e
|
||||
errorHandler _ _ (InvalidArgs ia) =
|
||||
reps $ toRawObject
|
||||
[ ("errorMsg", toRawObject "Invalid arguments")
|
||||
, ("messages", toRawObject ia)
|
||||
reps $ Mapping
|
||||
[ (LT.pack "errorMsg", toTextObject "Invalid arguments")
|
||||
, (LT.pack "messages", toTextObject ia)
|
||||
]
|
||||
errorHandler _ _ PermissionDenied =
|
||||
reps $ toRawObject "Permission denied"
|
||||
reps $ toTextObject "Permission denied"
|
||||
|
||||
-- | Whether or not we should check for overlapping resource names.
|
||||
checkOverlaps :: a -> Bool
|
||||
|
||||
@ -88,7 +88,9 @@ runHandler h rr cts = do
|
||||
where
|
||||
takeAllExceptions :: IO (Attempt x) -> IO (Attempt x)
|
||||
takeAllExceptions ioa =
|
||||
Control.Exception.catch ioa (return . Failure)
|
||||
Control.Exception.catch ioa (return . someFailure)
|
||||
someFailure :: Control.Exception.SomeException -> Attempt v
|
||||
someFailure = Failure
|
||||
toErrorResult :: Exception e => e -> ErrorResult
|
||||
toErrorResult e =
|
||||
case cast e of
|
||||
|
||||
@ -27,7 +27,6 @@ module Web.Restful.Response
|
||||
, Content
|
||||
, ToContent (..)
|
||||
, runContent
|
||||
, lbsContent
|
||||
, translateContent
|
||||
-- * Abnormal responses
|
||||
, ErrorResult (..)
|
||||
@ -46,11 +45,10 @@ module Web.Restful.Response
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Object
|
||||
import Data.Object.Raw
|
||||
import Data.Object.Text
|
||||
import Data.Object.Translate
|
||||
import Data.Object.Instances
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.ByteString.Class
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.Text.Lazy.Encoding as LTE
|
||||
|
||||
@ -61,6 +59,9 @@ import Test.Framework (testGroup, Test)
|
||||
import Data.Generics
|
||||
import Control.Exception (Exception)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Convertible
|
||||
|
||||
import Data.Text.Lazy (Text)
|
||||
|
||||
data Response = Response Int [Header] ContentType Content
|
||||
|
||||
@ -81,14 +82,13 @@ instance ToContent LBS.ByteString where
|
||||
toContent = ByteString
|
||||
instance ToContent String where
|
||||
toContent = Text . LT.pack
|
||||
instance ToContent Text where
|
||||
toContent = Text
|
||||
instance ToContent ([Language] -> String) where
|
||||
toContent f = TransText $ LT.pack . f
|
||||
instance ToContent Translator where
|
||||
toContent = TransText
|
||||
|
||||
lbsContent :: LazyByteString lbs => lbs -> Content
|
||||
lbsContent = ByteString . toLazyByteString
|
||||
|
||||
translateContent :: CanTranslate t => t -> Content
|
||||
translateContent t = toContent $ translate t
|
||||
|
||||
@ -159,28 +159,28 @@ toPair (Header key value) = return (key, value)
|
||||
------ Generic responses
|
||||
-- FIXME move these to Handler?
|
||||
-- | Return a response with an arbitrary content type.
|
||||
genResponse :: (Monad m, LazyByteString lbs)
|
||||
genResponse :: (Monad m, ConvertSuccess t Text)
|
||||
=> ContentType
|
||||
-> lbs
|
||||
-> t
|
||||
-> [RepT m]
|
||||
genResponse ct lbs = [(ct, return $ lbsContent lbs)]
|
||||
genResponse ct t = [(ct, return $ Text $ convertSuccess t)]
|
||||
|
||||
-- | Return a response with a text/html content type.
|
||||
htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> [RepT m]
|
||||
htmlResponse :: (Monad m, ConvertSuccess t Text) => t -> [RepT m]
|
||||
htmlResponse = genResponse "text/html"
|
||||
|
||||
-- | Return a response from an Object. FIXME use TextObject
|
||||
objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m]
|
||||
objectResponse = reps . toRawObject
|
||||
-- | 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 $ lbsContent "")]
|
||||
instance Monad m => HasReps RawObject m where -- FIXME TextObject
|
||||
reps _ = [("text/plain", return $ toContent "")]
|
||||
instance Monad m => HasReps TextObject m where
|
||||
reps o =
|
||||
[ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o)
|
||||
, ("application/json", return $ lbsContent $ unJson $ safeFromObject o)
|
||||
, ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o)
|
||||
[ ("text/html", return $ toContent $ unHtml $ convertSuccess o)
|
||||
, ("application/json", return $ toContent $ unJson $ convertSuccess o)
|
||||
, ("text/yaml", return $ toContent $ unYaml $ convertSuccess o)
|
||||
]
|
||||
|
||||
{- FIXME
|
||||
|
||||
@ -40,9 +40,10 @@ library
|
||||
directory >= 1,
|
||||
transformers >= 0.1.4.0,
|
||||
monads-fd >= 0.0.0.1,
|
||||
attempt,
|
||||
attempt >= 0.0.2,
|
||||
syb,
|
||||
text >= 0.5
|
||||
text >= 0.5,
|
||||
convertible >= 1.2.0
|
||||
exposed-modules: Web.Restful,
|
||||
Web.Restful.Constants,
|
||||
Web.Restful.Request,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user