Content is now strict to fix memory bug

This commit is contained in:
Michael Snoyman 2009-11-29 01:01:21 +02:00
parent decdd8c9e2
commit 0a0e7e8f8a
4 changed files with 20 additions and 19 deletions

2
.gitignore vendored
View File

@ -1,4 +1,2 @@
dist dist
*.swp *.swp
*.hi
*.o

View File

@ -20,6 +20,7 @@ module Web.Restful
, module Web.Restful.Definitions , module Web.Restful.Definitions
, module Web.Restful.Handler , module Web.Restful.Handler
, module Web.Restful.Resource , module Web.Restful.Resource
, Application
) where ) where
import Data.Object import Data.Object
@ -29,3 +30,4 @@ import Web.Restful.Application
import Web.Restful.Definitions import Web.Restful.Definitions
import Web.Restful.Handler import Web.Restful.Handler
import Web.Restful.Resource import Web.Restful.Resource
import Hack (Application)

View File

@ -53,8 +53,8 @@ import Data.Object.Translate
import Data.Object.Instances 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.Lazy as LT import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LTE
import Web.Encodings (formatW3) import Web.Encodings (formatW3)
@ -73,29 +73,30 @@ data Response = Response Int [Header] ContentType Content
type ContentType = String type ContentType = String
data Content = ByteString LBS.ByteString -- | FIXME: Lazy in theory is better, but kills actual programs
| Text LT.Text data Content = ByteString SBS.ByteString
| TransText ([Language] -> LT.Text) | Text ST.Text
| TransText ([Language] -> ST.Text)
runContent :: [Language] -> Content -> LBS.ByteString runContent :: [Language] -> Content -> LBS.ByteString
runContent _ (ByteString lbs) = lbs runContent _ (ByteString sbs) = convertSuccess sbs
runContent _ (Text lt) = LTE.encodeUtf8 lt runContent _ (Text lt) = convertSuccess lt
runContent ls (TransText t) = LTE.encodeUtf8 $ t ls runContent ls (TransText t) = convertSuccess $ t ls
class ToContent a where class ToContent a where
toContent :: a -> Content toContent :: a -> Content
instance ToContent SBS.ByteString where instance ToContent SBS.ByteString where
toContent = ByteString . convertSuccess
instance ToContent LBS.ByteString where
toContent = ByteString toContent = ByteString
instance ToContent LBS.ByteString where
toContent = ByteString . convertSuccess
instance ToContent String where instance ToContent String where
toContent = Text . LT.pack toContent = Text . convertSuccess
instance ToContent Text where instance ToContent Text where
toContent = Text toContent = Text . convertSuccess
instance ToContent ([Language] -> String) where instance ToContent ([Language] -> String) where
toContent f = TransText $ LT.pack . f toContent f = TransText $ convertSuccess . f
instance ToContent Translator where instance ToContent Translator where
toContent = TransText toContent f = TransText $ convertSuccess . f
translateContent :: CanTranslate t => t -> Content translateContent :: CanTranslate t => t -> Content
translateContent t = toContent $ translate t translateContent t = toContent $ translate t
@ -167,14 +168,14 @@ 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, ConvertSuccess t Text) genResponse :: (Monad m, ToContent t)
=> ContentType => ContentType
-> t -> t
-> [RepT m] -> [RepT m]
genResponse ct t = [(ct, return $ Text $ convertSuccess t)] genResponse ct t = [(ct, return $ toContent t)]
-- | Return a response with a text/html content type. -- | Return a response with a text/html content type.
htmlResponse :: (Monad m, ConvertSuccess t Text) => 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. -- | Return a response from an Object.

View File

@ -1,5 +1,5 @@
name: restful name: restful
version: 0.1.10 version: 0.1.11
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>