diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 3f1b8a2b..b1cb0cac 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,11 +23,10 @@ module Web.Restful.Application ) where import Web.Encodings -import Data.Object import Data.Object.Text +import Data.Object.String import Data.Enumerable import Control.Monad (when) -import qualified Data.Text.Lazy as LT import qualified Hack import Hack.Middleware.CleanPath @@ -61,15 +60,16 @@ class ResourceName a => RestfulApp a where -- | Output error response pages. errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? - errorHandler _ rr NotFound = reps $ toTextObject $ "Not found: " ++ show rr + errorHandler _ rr NotFound = reps $ toTextObject $ + "Not found: " ++ show rr errorHandler _ _ (Redirect url) = reps $ toTextObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = reps $ toTextObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - reps $ Mapping - [ (LT.pack "errorMsg", toTextObject "Invalid arguments") - , (LT.pack "messages", toTextObject ia) + reps $ toTextObject $ toStringObject + [ ("errorMsg", toStringObject "Invalid arguments") + , ("messages", toStringObject ia) ] errorHandler _ _ PermissionDenied = reps $ toTextObject "Permission denied" diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 8b06eebd..5d8b2feb 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -89,8 +89,8 @@ runHandler h rr cts = do takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) takeAllExceptions ioa = Control.Exception.catch ioa (return . someFailure) - someFailure :: Control.Exception.SomeException -> Attempt v - someFailure = Failure + someFailure :: Control.Exception.SomeException -> Attempt v -- FIXME + someFailure = failure toErrorResult :: Exception e => e -> ErrorResult toErrorResult e = case cast e of diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index accbb097..dc372c76 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -107,23 +107,23 @@ authOpenidForward = do show (Hack.serverPort env) ++ "/auth/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete - case res of - Failure err -> redirect $ "/auth/openid/?message=" - ++ encodeUrl (show err) - Success url -> redirect url + attempt + (\err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (show err)) + redirect + res authOpenidComplete :: Handler authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" res <- runAttemptT $ OpenId.authenticate gets' - case res of - Failure err -> redirect $ "/auth/openid/?message=" + let onFailure err = redirect $ "/auth/openid/?message=" ++ encodeUrl (show err) - Success (OpenId.Identifier ident) -> do + let onSuccess (OpenId.Identifier ident) = do deleteCookie "DEST" header authCookieName ident redirect $ fromMaybe "/" dest + attempt onFailure onSuccess res -- | token dest data RpxnowRequest = RpxnowRequest String (Maybe String) diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 7a530998..ca933044 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 -> return $ genResponse (mimeType $ ext fp) bs + Just bs -> return [(mimeType $ ext fp, return $ toContent bs)] mimeType :: String -> String mimeType "jpg" = "image/jpeg" diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 7f822d09..1fdc2f5a 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -48,6 +48,7 @@ import Data.Object import Data.Object.Text import Data.Object.Translate import Data.Object.Instances +import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LTE @@ -78,6 +79,8 @@ runContent ls (TransText t) = LTE.encodeUtf8 $ t ls class ToContent a where toContent :: a -> Content +instance ToContent SBS.ByteString where + toContent = ByteString . convertSuccess instance ToContent LBS.ByteString where toContent = ByteString instance ToContent String where