diff --git a/TODO b/TODO index b74fc905..e69de29b 100644 --- a/TODO +++ b/TODO @@ -1 +0,0 @@ -Catch exceptions and return as 500 errors diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 847928ee..ba0da8f7 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -41,6 +41,7 @@ import Control.Applicative import Data.Maybe (fromJust) import qualified Data.ByteString.Lazy as B import qualified Hack +import qualified Control.OldException ------ Handler monad newtype HandlerT m a = @@ -55,7 +56,9 @@ runHandler :: (ErrorResult -> Reps) -> RawRequest -> IO Hack.Response runHandler eh wrapper ctypesAll (HandlerT inside) rr = do - (x, headers') <- inside rr + (x, headers') <- Control.OldException.catch + (inside rr) + (\e -> return (Left $ InternalError $ show e, [])) let extraHeaders = case x of Left r -> getHeaders r @@ -67,14 +70,15 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do Left r -> getStatus r Right _ -> 200 (ctype, selectedRep) <- chooseRep outReps ctypesAll - finalRep <- wrapper ctype selectedRep + let languages = [] -- FIXME + finalRep <- wrapper ctype $ selectedRep languages let headers'' = ("Content-Type", ctype) : headers return $! Hack.Response statusCode headers'' finalRep chooseRep :: Monad m - => [(ContentType, B.ByteString)] + => Reps -> [ContentType] - -> m (ContentType, B.ByteString) + -> m Rep chooseRep rs cs | null rs = fail "All reps must have at least one representation" | otherwise = do diff --git a/Web/Restful/I18N.hs b/Web/Restful/I18N.hs new file mode 100644 index 00000000..945cf4d6 --- /dev/null +++ b/Web/Restful/I18N.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.I18N +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Simple method for internationalization. +-- +--------------------------------------------------------- +module Web.Restful.I18N + ( Language + , Translator + , I18N (..) + , toTranslator + ) where + +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as BS +import Data.ByteString.Class + +type Language = String +type Translator = [Language] -> B.ByteString + +class I18N a where + translate :: a -> Translator + +instance I18NString a => I18N a where + translate a langs = toLazyByteString $ helper langs where + helper [] = defTrans a + helper (l:ls) = + case tryTranslate a l of + Nothing -> helper ls + Just s -> s + +class I18NString a where + defTrans :: a -> String + tryTranslate :: a -> Language -> Maybe String + +toTranslator :: LazyByteString lbs => lbs -> Translator +toTranslator = translate . toLazyByteString + +instance I18N B.ByteString where + translate = const + +instance I18N BS.ByteString where + translate bs _ = toLazyByteString bs + +instance I18NString String where + defTrans = id + tryTranslate = const . Just diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index b7db0128..e56f84c4 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -15,7 +15,8 @@ --------------------------------------------------------- module Web.Restful.Response ( -- * Representations - Reps + Rep + , Reps , HasReps (..) , ContentType -- * Abnormal responses @@ -32,21 +33,24 @@ module Web.Restful.Response , objectResponse -- * Tests , testSuite + -- * Re-export + , module Web.Restful.I18N ) where import Data.ByteString.Class import Data.Time.Clock import Data.Object hiding (testSuite) -import qualified Data.ByteString.Lazy as B import Data.Object.Instances import Web.Encodings (formatW3) +import Web.Restful.I18N import Test.Framework (testGroup, Test) type ContentType = String -type Reps = [(ContentType, B.ByteString)] +type Rep = (ContentType, Translator) +type Reps = [Rep] -- | Something which can be represented as multiple content types. -- Each content type is called a representation of the data. @@ -105,7 +109,7 @@ genResponse :: (Monad m, LazyByteString lbs) => ContentType -> lbs -> m Reps -genResponse ct lbs = return [(ct, toLazyByteString lbs)] +genResponse ct lbs = return [(ct, toTranslator lbs)] -- | Return a response with a text/html content type. htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps @@ -117,15 +121,15 @@ objectResponse = return . reps . toRawObject -- HasReps instances instance HasReps () where - reps _ = [("text/plain", toLazyByteString "")] + reps _ = [("text/plain", translate "")] instance HasReps RawObject where reps o = - [ ("text/html", unHtml $ safeFromObject o) - , ("application/json", unJson $ safeFromObject o) - , ("text/yaml", unYaml $ safeFromObject o) + [ ("text/html", translate $ unHtml $ safeFromObject o) + , ("application/json", translate $ unJson $ safeFromObject o) + , ("text/yaml", translate $ unYaml $ safeFromObject o) ] -instance HasReps [(ContentType, B.ByteString)] where +instance HasReps Reps where reps = id ----- Testing diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index 8f093a49..2efed8bf 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -21,7 +21,6 @@ import Web.Restful.Response import Data.Time.Clock import Web.Encodings -import Data.ByteString.Class data AtomFeed = AtomFeed { atomTitle :: String @@ -32,7 +31,7 @@ data AtomFeed = AtomFeed } instance HasReps AtomFeed where reps e = - [ ("application/atom+xml", toLazyByteString $ show e) + [ ("application/atom+xml", translate $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index fd86adde..9e28a9ed 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -24,7 +24,6 @@ import Web.Restful.Response import Web.Encodings import qualified Hack import Web.Restful.Request -import Data.ByteString.Class import Data.Time (UTCTime) data SitemapLoc = AbsLoc String | RelLoc String @@ -79,7 +78,7 @@ instance Show SitemapResponse where instance HasReps SitemapResponse where reps res = - [ ("text/xml", toLazyByteString $ show res) + [ ("text/xml", translate $ show res) ] sitemap :: IO [SitemapUrl] -> Handler diff --git a/restful.cabal b/restful.cabal index fe8e7e91..e2e2bc47 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.5 +version: 0.1.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -47,6 +47,7 @@ library Web.Restful.Handler, Web.Restful.Application, Web.Restful.Resource, + Web.Restful.I18N, Data.Object.Instances, Hack.Middleware.MethodOverride, Web.Restful.Helpers.Auth,