diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 60cc6666..609ce8d0 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -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 "\n" -- 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 "\n" -- FIXME full doc or just fragment? , helper o - , toLazyByteString "" + , LT.pack "" ] where - helper :: RawObject -> B.ByteString - helper (Scalar (Raw s)) = B.concat - [ toLazyByteString "

" - , toLazyByteString s - , toLazyByteString "

" + helper :: TextObject -> Text + helper (Scalar s) = LT.concat + [ LT.pack "

" + , s + , LT.pack "

" ] - helper (Sequence []) = toLazyByteString "" - helper (Sequence s) = B.concat - [ toLazyByteString "" + helper (Sequence []) = LT.pack "" + helper (Sequence s) = LT.concat + [ LT.pack "" ] - helper (Mapping m) = B.concat $ - toLazyByteString "
" : + helper (Mapping m) = LT.concat $ + LT.pack "
" : map helper2 m ++ - [ toLazyByteString "
" ] - helper2 :: (Raw, RawObject) -> B.ByteString - helper2 (Raw k, v) = B.concat - [ toLazyByteString "
" - , toLazyByteString k - , toLazyByteString "
" + [ LT.pack "
" ] + helper2 :: (Text, TextObject) -> Text + helper2 (k, v) = LT.concat + [ LT.pack "
" + , k + , LT.pack "
" , helper v - , toLazyByteString "
" + , LT.pack "" ] diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index d5c01581..3f1b8a2b 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -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 diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 4494384b..8b06eebd 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -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 diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index cd768bf9..7f822d09 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -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 diff --git a/restful.cabal b/restful.cabal index b7cfd4d9..12cfd6bb 100644 --- a/restful.cabal +++ b/restful.cabal @@ -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,