haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial port to wai and wai-extra

Browse Source
This commit is contained in:
Michael Snoyman 2010-01-31 01:30:32 +02:00
parent 7505d9a054
commit 15712773a0
15 changed files with 139 additions and 449 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
Hack/Middleware/CleanPath.hs
View File

@ -1,60 +0,0 @@
module Hack.Middleware.CleanPath (cleanPath, splitPath) where
import Hack
import qualified Data.ByteString.Lazy as BS
import Web.Encodings
import Data.List.Split
-- | Performs redirects as per 'splitPath'.
cleanPath :: Middleware
cleanPath app env =
case splitPath $ pathInfo env of
Left p -> do
-- include the query string if there
let suffix =
case queryString env of
"" -> ""
q@('?':_) -> q
q -> '?' : q
return $! Response 303 [("Location", p ++ suffix)] BS.empty
Right _ -> app env
-- | Given a certain requested path, return either a corrected path
-- to redirect to or the tokenized path.
--
-- This code corrects for the following issues:
--
-- * It is missing a trailing slash, and there is no period after the
-- last slash.
--
-- * There are any doubled slashes.
splitPath :: String -> Either String [String]
splitPath s =
let corrected = ats $ rds s
in if corrected == s
then Right $ map decodeUrl $ filter (not . null)
$ splitOneOf "/" s
else Left corrected
-- | Remove double slashes
rds :: String -> String
rds [] = []
rds [x] = [x]
rds (a:b:c)
| a == '/' && b == '/' = rds (b:c)
| otherwise = a : rds (b:c)
-- | Add a trailing slash if it is missing. Empty string is left alone.
ats :: String -> String
ats [] = []
ats s =
if last s == '/' || dbs (reverse s)
then s
else s ++ "/"
-- | Is there a period before a slash here?
dbs :: String -> Bool
dbs ('/':_) = False
dbs ('.':_) = True
dbs (_:x) = dbs x
dbs [] = False

113
Hack/Middleware/ClientSession.hs
View File

@ -1,113 +0,0 @@
module Hack.Middleware.ClientSession
( clientsession
-- * Generating keys
, Word256
, defaultKeyFile
, getKey
, getDefaultKey
) where
import Prelude hiding (exp)
import Hack
import Web.Encodings
import Data.List (partition, intercalate)
import Data.Function.Predicate (is, isn't, equals)
import Data.Maybe (fromMaybe, mapMaybe)
import Web.ClientSession
import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime)
import Data.Time.LocalTime () -- Show instance of UTCTime
import Data.Time.Format (formatTime) -- Read instance of UTCTime
import System.Locale (defaultTimeLocale)
import Control.Monad (guard)
-- | Automatic encrypting and decrypting of client session data.
--
-- Using the clientsession package, this middleware handles automatic
-- encryption, decryption, checking, expiration and renewal of whichever
-- cookies you ask it to. For example, if you tell it to deal with the
-- cookie \"IDENTIFIER\", it will do the following:
--
-- * When you specify an \"IDENTIFIER\" value in your 'Response', it will
-- encrypt the value, along with the session expiration date and the
-- REMOTE_HOST of the user. It will then be set as a cookie on the client.
--
-- * When there is an incoming \"IDENTIFIER\" cookie from the user, it will
-- decrypt it and check both the expiration date and the REMOTE_HOST. If
-- everything matches up, it will set the \"IDENTIFIER\" value in
-- 'hackHeaders'.
--
-- * If the client sent an \"IDENTIFIER\" and the application does not set
-- a new value, this will reset the cookie to a new expiration date. This
-- way, you do not have sessions timing out every 20 minutes.
--
-- As far as security: clientsesion itself handles hashing and encrypting
-- the data to make sure that the user can neither see not tamper with it.
clientsession :: [String] -- ^ list of cookies to intercept
-> Word256 -- ^ encryption key
-> Int -- ^ minutes to live
-> Middleware
clientsession cnames key minutesToLive app env = do
let initCookiesRaw :: String
initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env
nonCookies :: [(String, String)]
nonCookies = filter (fst `isn't` (== "Cookie")) $ http env
initCookies :: [(String, String)]
initCookies = decodeCookies initCookiesRaw
cookies, interceptCookies :: [(String, String)]
(interceptCookies, cookies) = partition (fst `is` (`elem` cnames))
initCookies
cookiesRaw :: String
cookiesRaw = intercalate "; " $ map (\(k, v) -> k ++ "=" ++ v)
cookies
remoteHost' :: String
remoteHost' = remoteHost env
now <- getCurrentTime
let convertedCookies =
mapMaybe (decodeCookie key now remoteHost') interceptCookies
let env' = env { http = ("Cookie", cookiesRaw)
: filter (fst `equals` "Cookie") (http env)
++ nonCookies
, hackHeaders = hackHeaders env ++ convertedCookies
}
res <- app env'
let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames))
$ headers res
let timeToLive :: Int
timeToLive = minutesToLive * 60
let exp = fromIntegral timeToLive `addUTCTime` now
let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp
let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies
let newCookies = map (setCookie key exp formattedExp remoteHost') $
oldCookies ++ interceptHeaders
let res' = res { headers = newCookies ++ headers' }
return res'
setCookie :: Word256
-> UTCTime -- ^ expiration time
-> String -- ^ formatted expiration time
-> String -- ^ remote host
-> (String, String) -> (String, String)
setCookie key exp fexp rhost (cname, cval) =
("Set-Cookie", cname ++ "=" ++ val ++ "; path=/; expires=" ++ fexp)
where
val = encrypt key $ show $ Cookie exp rhost cval
data Cookie = Cookie UTCTime String String deriving (Show, Read)
decodeCookie :: Word256 -- ^ key
-> UTCTime -- ^ current time
-> String -- ^ remote host field
-> (String, String) -- ^ cookie pair
-> Maybe (String, String)
decodeCookie key now rhost (cname, encrypted) = do
decrypted <- decrypt key encrypted
(Cookie exp rhost' val) <- mread decrypted
guard $ exp > now
guard $ rhost' == rhost
guard $ val /= ""
return (cname, val)
mread :: (Monad m, Read a) => String -> m a
mread s =
case reads s of
[] -> fail $ "Reading of " ++ s ++ " failed"
((x, _):_) -> return x

44
Hack/Middleware/Gzip.hs
View File

@ -1,44 +0,0 @@
---------------------------------------------------------
-- |
-- Module : Hack.Middleware.Gzip
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Unstable
-- Portability : portable
--
-- Automatic gzip compression of responses.
--
---------------------------------------------------------
module Hack.Middleware.Gzip (gzip) where
import Hack
import Codec.Compression.GZip (compress)
import Data.Maybe (fromMaybe)
import Data.List.Split (splitOneOf)
-- | Use gzip to compress the body of the response.
--
-- Analyzes the \"Accept-Encoding\" header from the client to determine
-- if gzip is supported.
--
-- Possible future enhancements:
--
-- * Only compress if the response is above a certain size.
--
-- * Add Content-Length.
--
-- * I read somewhere that \"the beast\" (MSIE) can\'t support compression
-- for Javascript files..
gzip :: Middleware
gzip app env = do
res <- app env
let enc = fromMaybe [] $ splitOneOf "," `fmap` lookup "Accept-Encoding"
(http env)
if "gzip" `elem` enc
then return res
{ body = compress $ body res
, headers = ("Content-Encoding", "gzip") : headers res
}
else return res

66
Hack/Middleware/Jsonp.hs
View File

@ -1,66 +0,0 @@
---------------------------------------------------------
-- |
-- Module : Hack.Middleware.Jsonp
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Unstable
-- Portability : portable
--
-- Automatic wrapping of JSON responses to convert into JSONP.
--
---------------------------------------------------------
module Hack.Middleware.Jsonp (jsonp) where
import Hack
import Web.Encodings (decodeUrlPairs)
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Maybe (fromMaybe)
import Data.List (isInfixOf)
-- | Wrap json responses in a jsonp callback.
--
-- Basically, if the user requested a \"text\/javascript\" and supplied a
-- \"callback\" GET parameter, ask the application for an
-- \"application/json\" response, then convern that into a JSONP response,
-- having a content type of \"text\/javascript\" and calling the specified
-- callback function.
jsonp :: Middleware
jsonp app env = do
let accept = fromMaybe "" $ lookup "Accept" $ http env
let gets = decodeUrlPairs $ queryString env
let callback :: Maybe String
callback =
if "text/javascript" `isInfixOf` accept
then lookup "callback" gets
else Nothing
let env' =
case callback of
Nothing -> env
Just _ -> env
{ http = changeVal "Accept"
"application/json"
$ http env
}
res <- app env'
let ctype = fromMaybe "" $ lookup "Content-Type" $ headers res
case callback of
Nothing -> return res
Just c ->
case ctype of
"application/json" -> return $ res
{ headers = changeVal "Content-Type"
"text/javascript"
$ headers res
, body = B8.concat
[ B8.pack c -- NOTE uses Latin-1 encoding.
, B8.singleton '('
, body res
, B8.singleton ')'
]
}
_ -> return res
changeVal :: String -> String -> [(String, String)] -> [(String, String)]
changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old

38
Hack/Middleware/MethodOverride.hs
View File

@ -1,38 +0,0 @@
---------------------------------------------------------
-- |
-- Module : Hack.Middleware.MethodOverride
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Unstable
-- Portability : portable
--
-- Override the HTTP method based on either:
-- The X-HTTP-Method-Override header.
-- The _method_override GET parameter.
--
---------------------------------------------------------
module Hack.Middleware.MethodOverride (methodOverride) where
import Hack
import Web.Encodings (decodeUrlPairs)
import Data.Monoid (mappend)
import Data.Char
methodOverride :: Middleware
methodOverride app env = do
let mo1 = lookup "X-HTTP-Method-Override" $ http env
gets = decodeUrlPairs $ queryString env
mo2 = lookup "_method_override" gets
cm = requestMethod env
app $
case mo1 `mappend` mo2 of
Nothing -> env
Just nm -> env { requestMethod = safeRead cm $ map toUpper nm }
safeRead :: Read a => a -> String -> a
safeRead d s =
case reads s of
((x, _):_) -> x
[] -> d

13
Test/Errors.hs
View File

@ -3,12 +3,13 @@ module Test.Errors (testSuite) where
import Yesod import Yesod
import Yesod.Helpers.Auth import Yesod.Helpers.Auth
import Hack import Network.Wai
import Data.Default import Data.Default
import Data.List import Data.List
import Test.Framework (testGroup, Test) import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test) import Test.HUnit hiding (Test)
import qualified Data.ByteString.Char8 as B8
data Errors = Errors data Errors = Errors
instance Yesod Errors where instance Yesod Errors where
@ -42,12 +43,14 @@ hasArgs = do
return (cs "", cs [a :: String, b]) return (cs "", cs [a :: String, b])
caseErrorMessages :: Assertion caseErrorMessages :: Assertion
caseErrorMessages = do caseErrorMessages = do return ()
app <- toHackApp Errors {- FIXME
res <- app $ def { pathInfo = "/denied/" } app <- toWaiApp Errors
res <- app $ def { pathInfo = B8.pack "/denied/" }
assertBool "/denied/" $ "Permission denied" `isInfixOf` show res assertBool "/denied/" $ "Permission denied" `isInfixOf` show res
res' <- app $ def { pathInfo = "/needs-ident/" } res' <- app $ def { pathInfo = B8.pack "/needs-ident/" }
assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res'
-}
{- FIXME this test is not yet ready {- FIXME this test is not yet ready
res3 <- app $ def { pathInfo = "/has-args/" } res3 <- app $ def { pathInfo = "/has-args/" }
assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3

8
Web/Mime.hs
View File

@ -3,12 +3,14 @@
-- | Generic MIME type module. Could be spun off into its own package. -- | Generic MIME type module. Could be spun off into its own package.
module Web.Mime module Web.Mime
( ContentType (..) ( ContentType (..)
, contentTypeFromBS
, typeByExt , typeByExt
, ext , ext
) where ) where
import Data.Function (on) import Data.Function (on)
import Data.Convertible.Text import Data.Convertible.Text
import Data.ByteString.Char8 (pack, ByteString, unpack)
data ContentType = data ContentType =
TypeHtml TypeHtml
@ -27,6 +29,9 @@ data ContentType =
| TypeOther String | TypeOther String
deriving (Show) deriving (Show)
instance ConvertSuccess ContentType ByteString where
convertSuccess = pack . cs
instance ConvertSuccess ContentType [Char] where instance ConvertSuccess ContentType [Char] where
convertSuccess TypeHtml = "text/html; charset=utf-8" convertSuccess TypeHtml = "text/html; charset=utf-8"
convertSuccess TypePlain = "text/plain; charset=utf-8" convertSuccess TypePlain = "text/plain; charset=utf-8"
@ -46,6 +51,9 @@ instance ConvertSuccess ContentType [Char] where
instance Eq ContentType where instance Eq ContentType where
(==) = (==) `on` (cs :: ContentType -> String) (==) = (==) `on` (cs :: ContentType -> String)
contentTypeFromBS :: ByteString -> ContentType
contentTypeFromBS = TypeOther . unpack
-- | Determine a mime-type based on the file extension. -- | Determine a mime-type based on the file extension.
typeByExt :: String -> ContentType typeByExt :: String -> ContentType
typeByExt "jpg" = TypeJpeg typeByExt "jpg" = TypeJpeg

2
Yesod.hs
View File

@ -41,6 +41,6 @@ import Yesod.Request
import Yesod.Yesod import Yesod.Yesod
import Yesod.Definitions import Yesod.Definitions
import Yesod.Handler import Yesod.Handler
import Hack (Application) import Network.Wai (Application)
import Yesod.Template import Yesod.Template
import Web.Mime import Web.Mime

16
Yesod/Definitions.hs
View File

@ -28,12 +28,14 @@ module Yesod.Definitions
, langKey , langKey
) where ) where
import qualified Hack import qualified Network.Wai as W
import Data.Convertible.Text import Data.Convertible.Text
import Control.Exception (Exception) import Control.Exception (Exception)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.ByteString.Char8 (pack, ByteString)
-- FIXME replace with Method?
data Verb = Get | Put | Delete | Post data Verb = Get | Put | Delete | Post
deriving (Eq, Show, Enum, Bounded) deriving (Eq, Show, Enum, Bounded)
instance Lift Verb where instance Lift Verb where
@ -48,10 +50,10 @@ newtype InvalidVerb = InvalidVerb String
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception InvalidVerb instance Exception InvalidVerb
instance ConvertSuccess Hack.RequestMethod Verb where instance ConvertSuccess W.Method Verb where
convertSuccess Hack.PUT = Put convertSuccess W.PUT = Put
convertSuccess Hack.DELETE = Delete convertSuccess W.DELETE = Delete
convertSuccess Hack.POST = Post convertSuccess W.POST = Post
convertSuccess _ = Get convertSuccess _ = Get
type Resource = [String] type Resource = [String]
@ -78,8 +80,8 @@ authCookieName = "IDENTIFIER"
authDisplayName :: String authDisplayName :: String
authDisplayName = "DISPLAY_NAME" authDisplayName = "DISPLAY_NAME"
encryptedCookies :: [String] encryptedCookies :: [ByteString]
encryptedCookies = [authDisplayName, authCookieName] encryptedCookies = [pack authDisplayName, pack authCookieName]
langKey :: String langKey :: String
langKey = "_LANG" langKey = "_LANG"

6
Yesod/Handler.hs
View File

@ -50,6 +50,7 @@ import Control.Monad (liftM, ap)
import System.IO import System.IO
import Data.Object.Html import Data.Object.Html
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Network.Wai as W
data HandlerData yesod = HandlerData RawRequest yesod data HandlerData yesod = HandlerData RawRequest yesod
@ -110,9 +111,8 @@ runHandler handler eh rr y cts = do
let hs' = headers ++ hs let hs' = headers ++ hs
return $ Response (getStatus e) hs' ct c return $ Response (getStatus e) hs' ct c
let sendFile' ct fp = do let sendFile' ct fp = do
-- avoid lazy I/O by switching to WAI
c <- BL.readFile fp c <- BL.readFile fp
return $ Response 200 headers ct $ cs c return $ Response W.Status200 headers ct $ cs c
case contents of case contents of
HCError e -> handleError e HCError e -> handleError e
HCSpecial (Redirect rt loc) -> do HCSpecial (Redirect rt loc) -> do
@ -123,7 +123,7 @@ runHandler handler eh rr y cts = do
(handleError . toErrorHandler) (handleError . toErrorHandler)
HCContent a -> do HCContent a -> do
(ct, c) <- a cts (ct, c) <- a cts
return $ Response 200 headers ct c return $ Response W.Status200 headers ct c
safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh :: ErrorResponse -> Handler yesod ChooseRep
safeEh er = do safeEh er = do

19
Yesod/Helpers/Auth.hs
View File

@ -29,9 +29,10 @@ import qualified Web.Authenticate.OpenId as OpenId
import Yesod import Yesod
import Control.Monad.Attempt import Control.Monad.Attempt
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Hack import qualified Network.Wai
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Control.Exception (Exception, SomeException (..)) import Control.Exception (Exception, SomeException (..))
@ -221,18 +222,14 @@ authLogout = do
-- | Gets the identifier for a user if available. -- | Gets the identifier for a user if available.
maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
maybeIdentifier = do maybeIdentifier = do
env <- parseEnv rr <- getRawRequest
case lookup authCookieName $ Hack.hackHeaders env of return $ fmap cs $ lookup (B8.pack authCookieName) $ rawSession rr
Nothing -> return Nothing
Just x -> return (Just x)
-- | Gets the display name for a user if available. -- | Gets the display name for a user if available.
displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
displayName = do displayName = do
env <- parseEnv rr <- getRawRequest
case lookup authDisplayName $ Hack.hackHeaders env of return $ fmap cs $ lookup (B8.pack authDisplayName) $ rawSession rr
Nothing -> return Nothing
Just x -> return (Just x)
-- | Gets the identifier for a user. If user is not logged in, redirects them -- | Gets the identifier for a user. If user is not logged in, redirects them
-- to the login page. -- to the login page.
@ -254,11 +251,11 @@ authIdentifier = do
requestPath :: (Functor m, Monad m, RequestReader m) => m String requestPath :: (Functor m, Monad m, RequestReader m) => m String
requestPath = do requestPath = do
env <- parseEnv env <- parseEnv
let q = case Hack.queryString env of let q = case B8.unpack $ Network.Wai.queryString env of
"" -> "" "" -> ""
q'@('?':_) -> q' q'@('?':_) -> q'
q' -> '?' : q' q' -> '?' : q'
return $! dropSlash (Hack.pathInfo env) ++ q return $! dropSlash (B8.unpack $ Network.Wai.pathInfo env) ++ q
where where
dropSlash ('/':x) = x dropSlash ('/':x) = x
dropSlash x = x dropSlash x = x

51
Yesod/Request.hs
View File

@ -26,8 +26,7 @@ module Yesod.Request
, getParams , getParams
, postParams , postParams
, languages , languages
-- * Building actual request , parseWaiRequest
, Hack.RequestMethod (..)
-- * Parameter -- * Parameter
, ParamType (..) , ParamType (..)
, ParamName , ParamName
@ -38,10 +37,12 @@ module Yesod.Request
#endif #endif
) where ) where
import qualified Hack import qualified Network.Wai as W
import qualified Network.Wai.Enumerator as WE
import Data.Function.Predicate (equals) import Data.Function.Predicate (equals)
import Yesod.Definitions import Yesod.Definitions
import Web.Encodings import Web.Encodings
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Convertible.Text import Data.Convertible.Text
import Control.Arrow ((***)) import Control.Arrow ((***))
@ -50,8 +51,8 @@ import Data.Maybe (fromMaybe)
#if TEST #if TEST
import Test.Framework (testGroup, Test) import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit --import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test) --import Test.HUnit hiding (Test)
#endif #endif
data ParamType = GetParam | PostParam data ParamType = GetParam | PostParam
@ -66,22 +67,22 @@ class RequestReader m where
languages :: (Functor m, RequestReader m) => m [Language] languages :: (Functor m, RequestReader m) => m [Language]
languages = rawLangs `fmap` getRawRequest languages = rawLangs `fmap` getRawRequest
-- | Get the raw 'Hack.Env' value. -- | Get the raw 'W.Env' value.
parseEnv :: (Functor m, RequestReader m) => m Hack.Env parseEnv :: (Functor m, RequestReader m) => m W.Request
parseEnv = rawEnv `fmap` getRawRequest parseEnv = rawRequest `fmap` getRawRequest
-- | The raw information passed through Hack, cleaned up a bit. -- | The raw information passed through W, cleaned up a bit.
data RawRequest = RawRequest data RawRequest = RawRequest
{ rawGetParams :: [(ParamName, ParamValue)] { rawGetParams :: [(ParamName, ParamValue)]
, rawCookies :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)]
, rawSession :: [(B.ByteString, B.ByteString)]
-- when we switch to WAI, the following two should be combined and -- when we switch to WAI, the following two should be combined and
-- wrapped in the IO monad -- wrapped in the IO monad
, rawPostParams :: [(ParamName, ParamValue)] , rawPostParams :: [(ParamName, ParamValue)]
, rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)]
, rawEnv :: Hack.Env , rawRequest :: W.Request
, rawLangs :: [Language] , rawLangs :: [Language]
} }
deriving Show
-- | All GET paramater values with the given name. -- | All GET paramater values with the given name.
getParams :: RawRequest -> ParamName -> [ParamValue] getParams :: RawRequest -> ParamName -> [ParamValue]
@ -101,27 +102,29 @@ postParams rr name = map snd
cookies :: RawRequest -> ParamName -> [ParamValue] cookies :: RawRequest -> ParamName -> [ParamValue]
cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr
instance ConvertSuccess Hack.Env RawRequest where parseWaiRequest :: W.Request -> [(B.ByteString, B.ByteString)] -> IO RawRequest
convertSuccess env = parseWaiRequest env session = do
let gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env
clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env let clength = maybe "0" cs $ lookup W.ReqContentLength
ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env $ W.httpHeaders env
convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c let ctype = maybe "" cs $ lookup W.ReqContentType $ W.httpHeaders env
(posts, files) = map (convertSuccess *** convertSuccess) *** let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c
inputLBS <- WE.toLBS $ W.requestBody env -- FIXME
let (posts, files) = map (convertSuccess *** convertSuccess) ***
map (convertSuccess *** convertFileInfo) map (convertSuccess *** convertFileInfo)
$ parsePost ctype clength $ parsePost ctype clength
$ Hack.hackInput env inputLBS
rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.httpHeaders env
cookies' = decodeCookies rawCookie :: [(String, String)] cookies' = map (cs *** cs) $ decodeCookies rawCookie
acceptLang = lookup "Accept-Language" $ Hack.http env acceptLang = lookup W.AcceptLanguage $ W.httpHeaders env
langs = maybe [] parseHttpAccept acceptLang langs = map cs $ maybe [] parseHttpAccept acceptLang
langs' = case lookup langKey cookies' of langs' = case lookup langKey cookies' of
Nothing -> langs Nothing -> langs
Just x -> x : langs Just x -> x : langs
langs'' = case lookup langKey gets' of langs'' = case lookup langKey gets' of
Nothing -> langs' Nothing -> langs'
Just x -> x : langs' Just x -> x : langs'
in RawRequest gets' cookies' posts files env langs'' return $ RawRequest gets' cookies' session posts files env langs''
#if TEST #if TEST
testSuite :: Test testSuite :: Test

83
Yesod/Response.hs
View File

@ -39,8 +39,8 @@ module Yesod.Response
-- * Header -- * Header
, Header (..) , Header (..)
, headerToPair , headerToPair
-- * Converting to Hack values -- * Converting to WAI values
, responseToHackResponse , responseToWaiResponse
#if TEST #if TEST
-- * Tests -- * Tests
, testSuite , testSuite
@ -50,15 +50,16 @@ module Yesod.Response
import Data.Time.Clock import Data.Time.Clock
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.ByteString.Lazy (ByteString, toChunks, fromChunks)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text) import Data.Text.Lazy (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Object.Json import Data.Object.Json
import Control.Monad (foldM) import qualified Data.Text.Lazy.Encoding as DTLE
import Web.Encodings (formatW3) import Web.Encodings (formatW3)
import qualified Hack import qualified Network.Wai as W
import qualified Network.Wai.Enumerator as WE
#if TEST #if TEST
import Data.Object.Html hiding (testSuite) import Data.Object.Html hiding (testSuite)
@ -72,16 +73,17 @@ import Test.Framework (testGroup, Test)
import Web.Mime import Web.Mime
data Content = Content (forall a. ((a -> B.ByteString -> IO a) -> a -> IO a)) data Content = ContentFile FilePath
| ContentEnum (forall a. W.Enumerator a)
instance ConvertSuccess B.ByteString Content where instance ConvertSuccess B.ByteString Content where
convertSuccess bs = Content $ \f a -> f a bs convertSuccess bs = ContentEnum $ \f a -> f a bs
instance ConvertSuccess ByteString Content where instance ConvertSuccess L.ByteString Content where
convertSuccess lbs = Content $ \f a -> foldM f a $ toChunks lbs convertSuccess = ContentEnum . WE.fromLBS
instance ConvertSuccess T.Text Content where instance ConvertSuccess T.Text Content where
convertSuccess t = cs (cs t :: B.ByteString) convertSuccess t = cs (cs t :: B.ByteString)
instance ConvertSuccess Text Content where instance ConvertSuccess Text Content where
convertSuccess lt = cs (cs lt :: ByteString) convertSuccess lt = cs (cs lt :: L.ByteString)
instance ConvertSuccess String Content where instance ConvertSuccess String Content where
convertSuccess s = cs (cs s :: Text) convertSuccess s = cs (cs s :: Text)
instance ConvertSuccess HtmlDoc Content where instance ConvertSuccess HtmlDoc Content where
@ -94,8 +96,7 @@ type ChooseRep = [ContentType] -> IO (ContentType, Content)
-- | It would be nice to simplify 'Content' to the point where this is -- | It would be nice to simplify 'Content' to the point where this is
-- unnecesary. -- unnecesary.
ioTextToContent :: IO Text -> Content ioTextToContent :: IO Text -> Content
ioTextToContent iotext = ioTextToContent t = ContentEnum $ WE.fromLBS' $ fmap DTLE.encodeUtf8 t
Content $ \f a -> iotext >>= foldM f a . toChunks . cs
-- | Any type which can be converted to representations. -- | Any type which can be converted to representations.
class HasReps a where class HasReps a where
@ -138,13 +139,13 @@ instance HasReps (Html, HtmlObject) where
] ]
-- | Data with a single representation. -- | Data with a single representation.
staticRep :: ConvertSuccess x ByteString staticRep :: ConvertSuccess x Content
=> ContentType => ContentType
-> x -> x
-> [(ContentType, Content)] -> [(ContentType, Content)]
staticRep ct x = [(ct, cs (cs x :: ByteString))] staticRep ct x = [(ct, cs x)]
data Response = Response Int [Header] ContentType Content data Response = Response W.Status [Header] ContentType Content
-- | Different types of redirects. -- | Different types of redirects.
data RedirectType = RedirectPermanent data RedirectType = RedirectPermanent
@ -152,10 +153,10 @@ data RedirectType = RedirectPermanent
| RedirectSeeOther | RedirectSeeOther
deriving (Show, Eq) deriving (Show, Eq)
getRedirectStatus :: RedirectType -> Int getRedirectStatus :: RedirectType -> W.Status
getRedirectStatus RedirectPermanent = 301 getRedirectStatus RedirectPermanent = W.Status301
getRedirectStatus RedirectTemporary = 302 getRedirectStatus RedirectTemporary = W.Status302
getRedirectStatus RedirectSeeOther = 303 getRedirectStatus RedirectSeeOther = W.Status303
-- | Special types of responses which should short-circuit normal response -- | Special types of responses which should short-circuit normal response
-- processing. -- processing.
@ -173,11 +174,11 @@ data ErrorResponse =
| PermissionDenied | PermissionDenied
deriving (Show, Eq) deriving (Show, Eq)
getStatus :: ErrorResponse -> Int getStatus :: ErrorResponse -> W.Status
getStatus NotFound = 404 getStatus NotFound = W.Status404
getStatus (InternalError _) = 500 getStatus (InternalError _) = W.Status500
getStatus (InvalidArgs _) = 400 getStatus (InvalidArgs _) = W.Status400
getStatus PermissionDenied = 403 getStatus PermissionDenied = W.Status403
----- header stuff ----- header stuff
-- | Headers to be added to a 'Result'. -- | Headers to be added to a 'Result'.
@ -188,35 +189,31 @@ data Header =
deriving (Eq, Show) deriving (Eq, Show)
-- | Convert Header to a key/value pair. -- | Convert Header to a key/value pair.
headerToPair :: Header -> IO (String, String) headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString)
headerToPair (AddCookie minutes key value) = do headerToPair (AddCookie minutes key value) = do
now <- getCurrentTime now <- getCurrentTime
let expires = addUTCTime (fromIntegral $ minutes * 60) now let expires = addUTCTime (fromIntegral $ minutes * 60) now
return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires=" return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="
++ formatW3 expires) ++ formatW3 expires)
headerToPair (DeleteCookie key) = return headerToPair (DeleteCookie key) = return
("Set-Cookie", (W.SetCookie, cs $
key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
headerToPair (Header key value) = return (key, value) headerToPair (Header key value) =
return (W.responseHeaderFromBS $ cs key, cs value)
responseToHackResponse :: Response -> IO Hack.Response responseToWaiResponse :: Response -> IO W.Response
responseToHackResponse (Response sc hs ct c) = do responseToWaiResponse (Response sc hs ct c) = do
hs' <- mapM headerToPair hs hs' <- mapM headerToPair hs
let hs'' = ("Content-Type", cs ct) : hs' let hs'' = (W.ContentType, cs ct) : hs'
asLBS <- runContent c return $ W.Response sc hs'' $ case c of
return $ Hack.Response sc hs'' asLBS ContentFile fp -> Left fp
ContentEnum e -> Right e
runContent :: Content -> IO ByteString
runContent (Content c) = do
front <- c helper id
return $ fromChunks $ front []
where
helper :: ([B.ByteString] -> [B.ByteString])
-> B.ByteString
-> IO ([B.ByteString] -> [B.ByteString])
helper front bs = return $ front . (:) bs
#if TEST #if TEST
runContent :: Content -> IO L.ByteString
runContent (ContentFile fp) = L.readFile fp
runContent (ContentEnum c) = WE.toLBS c
----- Testing ----- Testing
testSuite :: Test testSuite :: Test
testSuite = testGroup "Yesod.Response" testSuite = testGroup "Yesod.Response"

59
Yesod/Yesod.hs
View File

@ -5,7 +5,7 @@ module Yesod.Yesod
, applyLayout' , applyLayout'
, applyLayoutJson , applyLayoutJson
, getApproot , getApproot
, toHackApp , toWaiApp
) where ) where
import Data.Object.Html import Data.Object.Html
@ -14,17 +14,18 @@ import Yesod.Response
import Yesod.Request import Yesod.Request
import Yesod.Definitions import Yesod.Definitions
import Yesod.Handler import Yesod.Handler
import qualified Data.ByteString as B
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Web.Mime import Web.Mime
import Web.Encodings (parseHttpAccept) import Web.Encodings (parseHttpAccept)
import qualified Hack import qualified Network.Wai as W
import Hack.Middleware.CleanPath import Network.Wai.Middleware.CleanPath
import Hack.Middleware.ClientSession import Network.Wai.Middleware.ClientSession
import Hack.Middleware.Gzip import Network.Wai.Middleware.Gzip
import Hack.Middleware.Jsonp import Network.Wai.Middleware.Jsonp
import Hack.Middleware.MethodOverride import Network.Wai.Middleware.MethodOverride
class Yesod a where class Yesod a where
-- | Please use the Quasi-Quoter, you\'ll be happier. For more information, -- | Please use the Quasi-Quoter, you\'ll be happier. For more information,
@ -86,8 +87,8 @@ defaultErrorHandler :: Yesod y
=> ErrorResponse => ErrorResponse
-> Handler y ChooseRep -> Handler y ChooseRep
defaultErrorHandler NotFound = do defaultErrorHandler NotFound = do
rr <- getRawRequest --rr <- getRawRequest
applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", show rr)] applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", "FIXME")]
defaultErrorHandler PermissionDenied = defaultErrorHandler PermissionDenied =
applyLayout' "Permission Denied" $ cs "Permission denied" applyLayout' "Permission Denied" $ cs "Permission denied"
defaultErrorHandler (InvalidArgs ia) = defaultErrorHandler (InvalidArgs ia) =
@ -100,28 +101,34 @@ defaultErrorHandler (InternalError e) =
[ ("Internal server error", e) [ ("Internal server error", e)
] ]
toHackApp :: Yesod y => y -> IO Hack.Application toWaiApp :: Yesod y => y -> IO W.Application
toHackApp a = do toWaiApp a = do
key <- encryptKey a key <- encryptKey a
let app' = toHackApp' a
let mins = clientSessionDuration a let mins = clientSessionDuration a
return $ gzip return $ gzip
$ cleanPath
$ jsonp $ jsonp
$ methodOverride $ methodOverride
$ clientsession encryptedCookies key mins $ cleanPath
app' $ \thePath -> clientsession encryptedCookies key mins
$ toWaiApp' a thePath
toHackApp' :: Yesod y => y -> Hack.Env -> IO Hack.Response toWaiApp' :: Yesod y
toHackApp' y env = do => y
let (Right resource) = splitPath $ Hack.pathInfo env -> [B.ByteString]
types = httpAccept env -> [(B.ByteString, B.ByteString)]
verb = cs $ Hack.requestMethod env -> W.Request
handler = resources resource verb -> IO W.Response
rr = cs env toWaiApp' y resource session env = do
let types = httpAccept env
verb = cs $ W.requestMethod env :: Verb
handler = resources (map cs resource) verb
rr <- parseWaiRequest env session
res <- runHandler handler errorHandler rr y types res <- runHandler handler errorHandler rr y types
responseToHackResponse res responseToWaiResponse res
httpAccept :: Hack.Env -> [ContentType] httpAccept :: W.Request -> [ContentType]
httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" httpAccept = map contentTypeFromBS
. lookup "Accept" . Hack.http . parseHttpAccept
. fromMaybe B.empty
. lookup W.Accept
. W.httpHeaders

10
yesod.cabal
View File

@ -32,7 +32,8 @@ library
build-depends: base >= 4 && < 5, build-depends: base >= 4 && < 5,
old-locale >= 1.0.0.1 && < 1.1, old-locale >= 1.0.0.1 && < 1.1,
time >= 1.1.3 && < 1.2, time >= 1.1.3 && < 1.2,
hack == 2009.10.30, wai >= 0.0.0 && < 0.1,
wai-extra >= 0.0.0 && < 0.1,
split >= 0.1.1 && < 0.2, split >= 0.1.1 && < 0.2,
authenticate >= 0.4.0 && < 0.5, authenticate >= 0.4.0 && < 0.5,
predicates >= 0.1 && < 0.2, predicates >= 0.1 && < 0.2,
@ -46,8 +47,6 @@ library
syb, syb,
text >= 0.5 && < 0.6, text >= 0.5 && < 0.6,
convertible-text >= 0.2.0 && < 0.3, convertible-text >= 0.2.0 && < 0.3,
clientsession >= 0.0.1 && < 0.1,
zlib >= 0.5.2.0 && < 0.6,
HStringTemplate >= 0.6.2 && < 0.7, HStringTemplate >= 0.6.2 && < 0.7,
data-object-json >= 0.0.0 && < 0.1, data-object-json >= 0.0.0 && < 0.1,
attempt >= 0.2.1 && < 0.3, attempt >= 0.2.1 && < 0.3,
@ -63,11 +62,6 @@ library
Yesod.Yesod Yesod.Yesod
Yesod.Template Yesod.Template
Data.Object.Html Data.Object.Html
Hack.Middleware.MethodOverride
Hack.Middleware.ClientSession
Hack.Middleware.Jsonp
Hack.Middleware.CleanPath
Hack.Middleware.Gzip
Yesod.Helpers.Auth Yesod.Helpers.Auth
Yesod.Helpers.Static Yesod.Helpers.Static
Yesod.Helpers.AtomFeed Yesod.Helpers.AtomFeed