Massive changes to response and handler stuff
This commit is contained in:
Michael Snoyman
parent
8720fcd6ef
commit
1decaa742b
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")]
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: restful
|
||||
version: 0.1.9
|
||||
version: 0.1.10
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -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,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user