haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Completely migrated from Raw to Text

Browse Source
This commit is contained in:
Michael Snoyman 2009-11-15 01:30:45 +02:00
parent 1decaa742b
commit 4262ffb38f
5 changed files with 98 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
Data/Object/Instances.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
--------------------------------------------------------- ---------------------------------------------------------
-- --
-- Module : Data.Object.Instances -- Module : Data.Object.Instances
@ -16,84 +18,91 @@ module Data.Object.Instances
( Json (..) ( Json (..)
, Yaml (..) , Yaml (..)
, Html (..) , Html (..)
, SafeFromObject (..)
) where ) where
import Data.Object import Data.Object
import Data.Object.Raw import Data.Object.Text
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
import Data.ByteString.Class
import Web.Encodings (encodeJson) 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 newtype Json = Json { unJson :: Text }
safeFromObject :: RawObject -> a instance ConvertAttempt (Object Text Text) Json where
convertAttempt = return . convertSuccess
newtype Json = Json { unJson :: B.ByteString } instance ConvertSuccess (Object Text Text) Json where
instance SafeFromObject Json where convertSuccess = Json . helper where
safeFromObject = Json . helper where helper :: TextObject -> Text
helper :: RawObject -> B.ByteString helper (Scalar s) = LT.concat
helper (Scalar (Raw s)) = B.concat [ LT.pack "\""
[ toLazyByteString "\"" , bsToText $ encodeJson $ convertSuccess s
, encodeJson $ fromLazyByteString s , LT.pack "\""
, toLazyByteString "\""
] ]
helper (Sequence s) = B.concat helper (Sequence s) = LT.concat
[ toLazyByteString "[" [ LT.pack "["
, B.intercalate (toLazyByteString ",") $ map helper s , LT.intercalate (LT.pack ",") $ map helper s
, toLazyByteString "]" , LT.pack "]"
] ]
helper (Mapping m) = B.concat helper (Mapping m) = LT.concat
[ toLazyByteString "{" [ LT.pack "{"
, B.intercalate (toLazyByteString ",") $ map helper2 m , LT.intercalate (LT.pack ",") $ map helper2 m
, toLazyByteString "}" , LT.pack "}"
] ]
helper2 :: (Raw, RawObject) -> B.ByteString helper2 :: (Text, TextObject) -> Text
helper2 (Raw k, v) = B.concat helper2 (k, v) = LT.concat
[ toLazyByteString "\"" [ LT.pack "\""
, encodeJson $ fromLazyByteString k , bsToText $ encodeJson $ convertSuccess k
, toLazyByteString "\":" , LT.pack "\":"
, helper v , helper v
] ]
newtype Yaml = Yaml { unYaml :: B.ByteString } bsToText :: B.ByteString -> Text
instance SafeFromObject Yaml where bsToText = convertSuccess
safeFromObject = Yaml . encode
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: -- | Represents as an entire HTML 5 document by using the following:
-- --
-- * A scalar is a paragraph. -- * A scalar is a paragraph.
-- * A sequence is an unordered list. -- * A sequence is an unordered list.
-- * A mapping is a definition list. -- * A mapping is a definition list.
newtype Html = Html { unHtml :: B.ByteString } newtype Html = Html { unHtml :: Text }
instance SafeFromObject Html where instance ConvertAttempt (Object Text Text) Html where
safeFromObject o = Html $ B.concat convertAttempt = return . convertSuccess
[ toLazyByteString "<!DOCTYPE html>\n<html><body>" -- FIXME full doc or just fragment? 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 , helper o
, toLazyByteString "</body></html>" , LT.pack "</body></html>"
] where ] where
helper :: RawObject -> B.ByteString helper :: TextObject -> Text
helper (Scalar (Raw s)) = B.concat helper (Scalar s) = LT.concat
[ toLazyByteString "<p>" [ LT.pack "<p>"
, toLazyByteString s , s
, toLazyByteString "</p>" , LT.pack "</p>"
] ]
helper (Sequence []) = toLazyByteString "<ul></ul>" helper (Sequence []) = LT.pack "<ul></ul>"
helper (Sequence s) = B.concat helper (Sequence s) = LT.concat
[ toLazyByteString "<ul><li>" [ LT.pack "<ul><li>"
, B.intercalate (toLazyByteString "</li><li>") $ map helper s , LT.intercalate (LT.pack "</li><li>") $ map helper s
, toLazyByteString "</li></ul>" , LT.pack "</li></ul>"
] ]
helper (Mapping m) = B.concat $ helper (Mapping m) = LT.concat $
toLazyByteString "<dl>" : LT.pack "<dl>" :
map helper2 m ++ map helper2 m ++
[ toLazyByteString "</dl>" ] [ LT.pack "</dl>" ]
helper2 :: (Raw, RawObject) -> B.ByteString helper2 :: (Text, TextObject) -> Text
helper2 (Raw k, v) = B.concat helper2 (k, v) = LT.concat
[ toLazyByteString "<dt>" [ LT.pack "<dt>"
, toLazyByteString k , k
, toLazyByteString "</dt><dd>" , LT.pack "</dt><dd>"
, helper v , helper v
, toLazyByteString "</dd>" , LT.pack "</dd>"
] ]

18
Web/Restful/Application.hs
View File

@ -23,9 +23,11 @@ module Web.Restful.Application
) where ) where
import Web.Encodings import Web.Encodings
import Data.Object.Raw import Data.Object
import Data.Object.Text
import Data.Enumerable import Data.Enumerable
import Control.Monad (when) import Control.Monad (when)
import qualified Data.Text.Lazy as LT
import qualified Hack import qualified Hack
import Hack.Middleware.CleanPath import Hack.Middleware.CleanPath
@ -59,18 +61,18 @@ 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 $ toRawObject $ "Not found: " ++ show rr errorHandler _ rr NotFound = reps $ toTextObject $ "Not found: " ++ show rr
errorHandler _ _ (Redirect url) = errorHandler _ _ (Redirect url) =
reps $ toRawObject $ "Redirect to: " ++ url reps $ toTextObject $ "Redirect to: " ++ url
errorHandler _ _ (InternalError e) = errorHandler _ _ (InternalError e) =
reps $ toRawObject $ "Internal server error: " ++ e reps $ toTextObject $ "Internal server error: " ++ e
errorHandler _ _ (InvalidArgs ia) = errorHandler _ _ (InvalidArgs ia) =
reps $ toRawObject reps $ Mapping
[ ("errorMsg", toRawObject "Invalid arguments") [ (LT.pack "errorMsg", toTextObject "Invalid arguments")
, ("messages", toRawObject ia) , (LT.pack "messages", toTextObject ia)
] ]
errorHandler _ _ PermissionDenied = errorHandler _ _ PermissionDenied =
reps $ toRawObject "Permission denied" 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

4
Web/Restful/Handler.hs
View File

@ -88,7 +88,9 @@ runHandler h rr cts = do
where where
takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) takeAllExceptions :: IO (Attempt x) -> IO (Attempt x)
takeAllExceptions ioa = 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 :: Exception e => e -> ErrorResult
toErrorResult e = toErrorResult e =
case cast e of case cast e of

36
Web/Restful/Response.hs
View File

@ -27,7 +27,6 @@ module Web.Restful.Response
, Content , Content
, ToContent (..) , ToContent (..)
, runContent , runContent
, lbsContent
, translateContent , translateContent
-- * Abnormal responses -- * Abnormal responses
, ErrorResult (..) , ErrorResult (..)
@ -46,11 +45,10 @@ module Web.Restful.Response
import Data.Time.Clock import Data.Time.Clock
import Data.Object import Data.Object
import Data.Object.Raw import Data.Object.Text
import Data.Object.Translate import Data.Object.Translate
import Data.Object.Instances import Data.Object.Instances
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Class
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LTE import qualified Data.Text.Lazy.Encoding as LTE
@ -61,6 +59,9 @@ import Test.Framework (testGroup, Test)
import Data.Generics import Data.Generics
import Control.Exception (Exception) import Control.Exception (Exception)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Convertible
import Data.Text.Lazy (Text)
data Response = Response Int [Header] ContentType Content data Response = Response Int [Header] ContentType Content
@ -81,14 +82,13 @@ instance ToContent LBS.ByteString where
toContent = ByteString toContent = ByteString
instance ToContent String where instance ToContent String where
toContent = Text . LT.pack toContent = Text . LT.pack
instance ToContent Text where
toContent = Text
instance ToContent ([Language] -> String) where instance ToContent ([Language] -> String) where
toContent f = TransText $ LT.pack . f toContent f = TransText $ LT.pack . f
instance ToContent Translator where instance ToContent Translator where
toContent = TransText toContent = TransText
lbsContent :: LazyByteString lbs => lbs -> Content
lbsContent = ByteString . toLazyByteString
translateContent :: CanTranslate t => t -> Content translateContent :: CanTranslate t => t -> Content
translateContent t = toContent $ translate t translateContent t = toContent $ translate t
@ -159,28 +159,28 @@ toPair (Header key value) = return (key, value)
------ Generic responses ------ Generic responses
-- FIXME move these to Handler? -- FIXME move these to Handler?
-- | Return a response with an arbitrary content type. -- | Return a response with an arbitrary content type.
genResponse :: (Monad m, LazyByteString lbs) genResponse :: (Monad m, ConvertSuccess t Text)
=> ContentType => ContentType
-> lbs -> t
-> [RepT m] -> [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. -- | 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" htmlResponse = genResponse "text/html"
-- | Return a response from an Object. FIXME use TextObject -- | Return a response from an Object.
objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m] objectResponse :: (Monad m, ToObject o Text Text) => o -> [RepT m]
objectResponse = reps . toRawObject objectResponse = reps . toTextObject
-- HasReps instances -- HasReps instances
instance Monad m => HasReps () m where instance Monad m => HasReps () m where
reps _ = [("text/plain", return $ lbsContent "")] reps _ = [("text/plain", return $ toContent "")]
instance Monad m => HasReps RawObject m where -- FIXME TextObject instance Monad m => HasReps TextObject m where
reps o = reps o =
[ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o) [ ("text/html", return $ toContent $ unHtml $ convertSuccess o)
, ("application/json", return $ lbsContent $ unJson $ safeFromObject o) , ("application/json", return $ toContent $ unJson $ convertSuccess o)
, ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o) , ("text/yaml", return $ toContent $ unYaml $ convertSuccess o)
] ]
{- FIXME {- FIXME

5
restful.cabal
View File

@ -40,9 +40,10 @@ library
directory >= 1, directory >= 1,
transformers >= 0.1.4.0, transformers >= 0.1.4.0,
monads-fd >= 0.0.0.1, monads-fd >= 0.0.0.1,
attempt, attempt >= 0.0.2,
syb, syb,
text >= 0.5 text >= 0.5,
convertible >= 1.2.0
exposed-modules: Web.Restful, exposed-modules: Web.Restful,
Web.Restful.Constants, Web.Restful.Constants,
Web.Restful.Request, Web.Restful.Request,