diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 28312cc1..d5c01581 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,7 +23,6 @@ module Web.Restful.Application ) where import Web.Encodings -import qualified Data.ByteString.Lazy as B import Data.Object.Raw import Data.Enumerable import Control.Monad (when) @@ -58,13 +57,8 @@ class ResourceName a => RestfulApp a where , methodOverride ] - -- | Wrappers for cleaning up responses. Especially intended for - -- beautifying static HTML. FIXME more user friendly. - responseWrapper :: a -> String -> B.ByteString -> IO B.ByteString - responseWrapper _ _ = return - -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> Reps + errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? errorHandler _ rr NotFound = reps $ toRawObject $ "Not found: " ++ show rr errorHandler _ _ (Redirect url) = reps $ toRawObject $ "Redirect to: " ++ url @@ -119,21 +113,44 @@ toHackApplication :: RestfulApp resourceName -> (resourceName -> Verb -> Handler) -> Hack.Application toHackApplication sampleRN hm env = do + -- The following is safe since we run cleanPath as middleware let (Right resource) = splitPath $ Hack.pathInfo env - let (handler, urlParams', wrapper) = + let (handler :: Handler, urlParams') = case findResourceNames resource of - [] -> (notFound, [], const return) + [] -> (notFound, []) ((rn, urlParams''):_) -> let verb = toVerb $ Hack.requestMethod env - in (hm rn verb, urlParams'', responseWrapper rn) + in (hm rn verb, urlParams'') let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept - runHandler (errorHandler sampleRN rr) - wrapper - ctypes' - handler - rr + r <- + runHandler handler rr ctypes' >>= + either (applyErrorHandler sampleRN rr ctypes') return + responseToHackResponse (rawLanguages rr) r + +applyErrorHandler :: (RestfulApp ra, Monad m) + => ra + -> RawRequest + -> [ContentType] + -> ErrorResult + -> m Response +applyErrorHandler ra rr cts er = do + let (ct, c) = chooseRep cts (errorHandler ra rr er) + c' <- c + return $ Response + (getStatus er) + (getHeaders er) + ct + c' + +responseToHackResponse :: [String] -- ^ language list + -> Response -> IO Hack.Response +responseToHackResponse ls (Response sc hs ct c) = do + hs' <- mapM toPair hs + let hs'' = ("Content-Type", ct) : hs' + let asLBS = runContent ls c + return $ Hack.Response sc hs'' asLBS envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = @@ -145,4 +162,5 @@ envToRawRequest urlParams' env = $ Hack.hackInput env rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest rawPieces urlParams' gets' posts cookies' files env + langs = ["en"] -- FIXME + in RawRequest rawPieces urlParams' gets' posts cookies' files env langs diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 872c2323..4494384b 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Web.Restful.Handler @@ -35,31 +36,78 @@ module Web.Restful.Handler import Web.Restful.Request import Web.Restful.Response -import Control.Monad.Trans -import Control.Monad.Attempt.Class -import Control.Monad (liftM, ap) -import Control.Applicative +import Control.Exception hiding (Handler) -import Data.Maybe (fromJust) -import qualified Data.ByteString.Lazy as B -import qualified Hack -import qualified Control.OldException +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Attempt + +import Data.Typeable ------ Handler monad -newtype HandlerT m a = - HandlerT (RawRequest -> m (Either ErrorResult a, [Header])) +type HandlerT m = + ReaderT RawRequest ( + WriterT [Header] ( + AttemptT m + ) + ) type HandlerIO = HandlerT IO -type Handler = HandlerIO Reps +type Handler = HandlerIO [RepT HandlerIO] + +instance MonadRequestReader HandlerIO where + askRawRequest = ask + invalidParam _pt _pn _pe = error "invalidParam" + authRequired = error "authRequired" +instance Exception e => MonadFailure e HandlerIO where + failure = error "HandlerIO failure" class ToHandler a where toHandler :: a -> Handler +{- FIXME instance (Request r, ToHandler h) => ToHandler (r -> h) where toHandler f = parseRequest >>= toHandler . f +-} instance ToHandler Handler where toHandler = id +{- FIXME +instance HasReps r HandlerIO => ToHandler (HandlerIO r) where + toHandler = fmap reps +-} + +runHandler :: Handler + -> RawRequest + -> [ContentType] + -> IO (Either ErrorResult Response) +runHandler h rr cts = do + let ares = runAttemptT $ runWriterT $ runReaderT (joinHandler cts h) rr + ares' <- takeAllExceptions ares + return $ attempt (Left . toErrorResult) (Right . toResponse) ares' + where + takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) + takeAllExceptions ioa = + Control.Exception.catch ioa (return . Failure) + toErrorResult :: Exception e => e -> ErrorResult + toErrorResult e = + case cast e of + Just x -> x + Nothing -> InternalError $ show e + toResponse :: ((ContentType, Content), [Header]) -> Response + toResponse ((ct, c), hs) = Response 200 hs ct c + +joinHandler :: Monad m + => [ContentType] + -> m [RepT m] + -> m (ContentType, Content) +joinHandler cts rs = do + rs' <- rs + let (ct, c) = chooseRep cts rs' + c' <- c + return (ct, c') + +{- runHandler :: (ErrorResult -> Reps) -> (ContentType -> B.ByteString -> IO B.ByteString) -> [ContentType] @@ -67,9 +115,6 @@ runHandler :: (ErrorResult -> Reps) -> RawRequest -> IO Hack.Response runHandler eh wrapper ctypesAll (HandlerT inside) rr = do - (x, headers') <- Control.OldException.catch - (inside rr) - (\e -> return (Left $ InternalError $ show e, [])) let extraHeaders = case x of Left r -> getHeaders r @@ -85,67 +130,18 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do finalRep <- wrapper ctype $ selectedRep languages let headers'' = ("Content-Type", ctype) : headers return $! Hack.Response statusCode headers'' finalRep - -chooseRep :: Monad m - => Reps - -> [ContentType] - -> m Rep -chooseRep rs cs - | null rs = fail "All reps must have at least one representation" - | otherwise = do - let availCs = map fst rs - case filter (`elem` availCs) cs of - [] -> return $ head rs - [ctype] -> return (ctype, fromJust $ lookup ctype rs) - _ -> fail "Overlapping representations" - -instance MonadTrans HandlerT where - lift ma = HandlerT $ const $ do - a <- ma - return (Right a, []) - -instance MonadIO HandlerIO where - liftIO = lift - -instance Monad m => Functor (HandlerT m) where - fmap = liftM - -instance Monad m => Monad (HandlerT m) where - return = lift . return - fail s = HandlerT (const $ return (Left $ InternalError s, [])) - (HandlerT mx) >>= f = HandlerT $ \rr -> do - (x, hs1) <- mx rr - case x of - Left x' -> return (Left x', hs1) - Right a -> do - let (HandlerT b') = f a - (b, hs2) <- b' rr - return (b, hs1 ++ hs2) - -instance Monad m => Applicative (HandlerT m) where - pure = return - (<*>) = ap - -instance Monad m => MonadRequestReader (HandlerT m) where - askRawRequest = HandlerT $ \rr -> return (Right rr, []) - invalidParam ptype name msg = - errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)] - authRequired = errorResult PermissionDenied - -instance Monad m => MonadAttempt (HandlerT m) where - failure = errorResult . InternalError . show - wrapFailure _ = id -- We don't actually use exception types +-} ------ Special handlers -errorResult :: Monad m => ErrorResult -> HandlerT m a -errorResult er = HandlerT (const $ return (Left er, [])) +errorResult :: ErrorResult -> HandlerIO a +errorResult = lift . lift . failure -- FIXME more instances in Attempt? -- | Redirect to the given URL. -redirect :: Monad m => String -> HandlerT m a +redirect :: String -> HandlerIO a redirect = errorResult . Redirect -- | Return a 404 not found page. Also denotes no handler available. -notFound :: Monad m => HandlerT m a +notFound :: HandlerIO a notFound = errorResult NotFound ------- Headers @@ -166,4 +162,4 @@ header :: Monad m => String -> String -> HandlerT m () header a = addHeader . Header a addHeader :: Monad m => Header -> HandlerT m () -addHeader h = HandlerT (const $ return (Right (), [h])) +addHeader = tell . return diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 6e3207de..accbb097 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -97,7 +97,7 @@ authOpenidForm = do case dest of Just dest' -> addCookie 120 "DEST" dest' Nothing -> return () - htmlResponse html + return $ htmlResponse html authOpenidForward :: Handler authOpenidForward = do @@ -158,8 +158,8 @@ authCheck :: Handler authCheck = do ident <- maybeIdentifier case ident of - Nothing -> objectResponse [("status", "notloggedin")] - Just i -> objectResponse + Nothing -> return $ objectResponse [("status", "notloggedin")] + Just i -> return $ objectResponse [ ("status", "loggedin") , ("ident", i) ] @@ -167,4 +167,4 @@ authCheck = do authLogout :: Handler authLogout = do deleteCookie authCookieName - objectResponse [("status", "loggedout")] + return $ objectResponse [("status", "loggedout")] diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index de7a0a19..7a530998 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -46,7 +46,7 @@ getStatic fl = do content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> genResponse (mimeType $ ext fp) bs + Just bs -> return $ genResponse (mimeType $ ext fp) bs mimeType :: String -> String mimeType "jpg" = "image/jpeg" diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index c2e93460..f89b103f 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -55,6 +55,7 @@ import Control.Applicative (Applicative (..)) import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) +import Data.Object.Translate (Language) -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -232,6 +233,7 @@ data RawRequest = RawRequest , rawCookies :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo)] , rawEnv :: Hack.Env + , rawLanguages :: [Language] } deriving Show diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 44691429..cd768bf9 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -15,11 +17,18 @@ -- --------------------------------------------------------- module Web.Restful.Response - ( -- * Representations - Rep - , Reps + ( Response (..) + -- * Representations + , RepT + , chooseRep , HasReps (..) , ContentType + -- * Content + , Content + , ToContent (..) + , runContent + , lbsContent + , translateContent -- * Abnormal responses , ErrorResult (..) , getHeaders @@ -28,16 +37,11 @@ module Web.Restful.Response , Header (..) , toPair -- * Generic responses - , response , genResponse , htmlResponse , objectResponse -- * Tests , testSuite - -- * Translation - , TranslatorBS - , noTranslate - , translateBS ) where import Data.Time.Clock @@ -45,33 +49,72 @@ import Data.Object import Data.Object.Raw import Data.Object.Translate import Data.Object.Instances -import Data.ByteString.Lazy (ByteString) +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 import Web.Encodings (formatW3) import Test.Framework (testGroup, Test) +import Data.Generics +import Control.Exception (Exception) +import Data.Maybe (fromJust) + +data Response = Response Int [Header] ContentType Content + type ContentType = String -type TranslatorBS = [Language] -> ByteString -noTranslate :: LazyByteString lbs => lbs -> TranslatorBS -noTranslate lbs = const $ toLazyByteString lbs +data Content = ByteString LBS.ByteString + | Text LT.Text + | TransText ([Language] -> LT.Text) -translateBS :: CanTranslate t => t -> TranslatorBS -translateBS t langs = toLazyByteString $ translate t langs +runContent :: [Language] -> Content -> LBS.ByteString +runContent _ (ByteString lbs) = lbs +runContent _ (Text lt) = LTE.encodeUtf8 lt +runContent ls (TransText t) = LTE.encodeUtf8 $ t ls -type Rep = (ContentType, TranslatorBS) -type Reps = [Rep] +class ToContent a where + toContent :: a -> Content +instance ToContent LBS.ByteString where + toContent = ByteString +instance ToContent String where + toContent = Text . LT.pack +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 + +type RepT m = (ContentType, m Content) + +chooseRep :: Monad m + => [ContentType] + -> [RepT m] + -> RepT m +chooseRep cs rs + | null rs = error "All reps must have at least one representation" -- FIXME + | otherwise = do + let availCs = map fst rs + case filter (`elem` availCs) cs of + [] -> head rs + [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME + _ -> error "Overlapping representations" -- FIXME just take the first? -- | Something which can be represented as multiple content types. -- Each content type is called a representation of the data. -class HasReps a where +class Monad m => HasReps a m where -- | Provide an ordered list of possible representations, depending on -- content type. If the user asked for a specific response type (like -- text/html), then that will get priority. If not, then the first -- element in this list will be used. - reps :: a -> Reps + reps :: a -> [RepT m] -- | Abnormal return codes. data ErrorResult = @@ -80,6 +123,8 @@ data ErrorResult = | InternalError String | InvalidArgs [(String, String)] | PermissionDenied + deriving (Show, Typeable) +instance Exception ErrorResult getStatus :: ErrorResult -> Int getStatus (Redirect _) = 303 @@ -112,37 +157,36 @@ toPair (DeleteCookie key) = return toPair (Header key value) = return (key, value) ------ Generic responses --- | Lifts a 'HasReps' into a monad. -response :: (Monad m, HasReps reps) => reps -> m Reps -response = return . reps - +-- FIXME move these to Handler? -- | Return a response with an arbitrary content type. genResponse :: (Monad m, LazyByteString lbs) => ContentType -> lbs - -> m Reps -genResponse ct lbs = return [(ct, noTranslate lbs)] + -> [RepT m] +genResponse ct lbs = [(ct, return $ lbsContent lbs)] -- | Return a response with a text/html content type. -htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps +htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> [RepT m] htmlResponse = genResponse "text/html" --- | Return a response from an Object. -objectResponse :: (Monad m, ToObject o Raw Raw) => o -> m Reps -objectResponse o = return $ reps $ (toObject o :: RawObject) +-- | Return a response from an Object. FIXME use TextObject +objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m] +objectResponse = reps . toRawObject -- HasReps instances -instance HasReps () where - reps _ = [("text/plain", noTranslate "")] -instance HasReps RawObject where +instance Monad m => HasReps () m where + reps _ = [("text/plain", return $ lbsContent "")] +instance Monad m => HasReps RawObject m where -- FIXME TextObject reps o = - [ ("text/html", noTranslate $ unHtml $ safeFromObject o) - , ("application/json", noTranslate $ unJson $ safeFromObject o) - , ("text/yaml", noTranslate $ unYaml $ safeFromObject o) + [ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o) + , ("application/json", return $ lbsContent $ unJson $ safeFromObject o) + , ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o) ] -instance HasReps Reps where +{- FIXME +instance HasReps (Reps m) where reps = id +-} ----- Testing testSuite :: Test diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index fa2ad788..37e6e652 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response.AtomFeed @@ -29,9 +31,9 @@ data AtomFeed = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance HasReps AtomFeed where +instance Monad m => HasReps AtomFeed m where reps e = - [ ("application/atom+xml", noTranslate $ show e) + [ ("application/atom+xml", return $ toContent $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index f75a7601..de9d510b 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response.AtomFeed @@ -77,9 +79,9 @@ instance Show SitemapResponse where showLoc (AbsLoc s) = s showLoc (RelLoc s) = prefix ++ s -instance HasReps SitemapResponse where +instance Monad m => HasReps SitemapResponse m where reps res = - [ ("text/xml", noTranslate $ show res) + [ ("text/xml", return $ toContent $ show res) ] sitemap :: IO [SitemapUrl] -> Handler @@ -93,4 +95,4 @@ sitemap urls' = do robots :: Handler robots = do ar <- approot - genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" + return $ genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" diff --git a/restful.cabal b/restful.cabal index c7f65171..b7cfd4d9 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.9 +version: 0.1.10 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,7 +22,7 @@ library hack-handler-cgi >= 0.0.2, hack >= 2009.5.19, split >= 0.1.1, - authenticate >= 0.2.0, + authenticate >= 0.2.1, data-default >= 0.2, predicates >= 0.1, bytestring >= 0.9.1.4, @@ -40,7 +40,9 @@ library directory >= 1, transformers >= 0.1.4.0, monads-fd >= 0.0.0.1, - attempt + attempt, + syb, + text >= 0.5 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request,