Large-scale switch from String and Ascii to Text
This commit is contained in:
Michael Snoyman
parent
571ec80d16
commit
b1abfd1a6a
@ -46,7 +46,6 @@ import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue)
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Blaze.Html5 as TBH
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
@ -56,11 +55,11 @@ import Web.Cookie (parseCookies)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Data.Text as TS
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
|
||||
import Blaze.ByteString.Builder (Builder, toByteString)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import Data.List (foldl')
|
||||
|
||||
#if GHC7
|
||||
@ -104,7 +103,7 @@ class RenderRoute (Route a) => Yesod a where
|
||||
--
|
||||
-- * You do not use any features that require absolute URLs, such as Atom
|
||||
-- feeds and XML sitemaps.
|
||||
approot :: a -> H.Ascii
|
||||
approot :: a -> Text
|
||||
|
||||
-- | The encryption key to be used for encrypting client sessions.
|
||||
-- Returning 'Nothing' disables sessions.
|
||||
@ -215,10 +214,10 @@ class RenderRoute (Route a) => Yesod a where
|
||||
-- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
|
||||
-- necessary when you are serving the content outside the context of a
|
||||
-- Yesod application, such as via memcached.
|
||||
addStaticContent :: String -- ^ filename extension
|
||||
-> String -- ^ mime-type
|
||||
addStaticContent :: Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> GHandler sub a (Maybe (Either String (Route a, [(String, String)])))
|
||||
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
|
||||
addStaticContent _ _ _ = return Nothing
|
||||
|
||||
-- | Whether or not to tie a session to a specific IP address. Defaults to
|
||||
@ -292,7 +291,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
|
||||
hs'' = map (headerToPair getExpires) hs'
|
||||
hs''' = ("Content-Type", ct) : hs''
|
||||
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized String
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
|
||||
@ -408,6 +407,7 @@ widgetToPageContent (GWidget w) = do
|
||||
let title = maybe mempty unTitle mTitle
|
||||
let scripts = runUniqueList scripts'
|
||||
let stylesheets = runUniqueList stylesheets'
|
||||
-- FIXME check size of cassius/julius template
|
||||
let cssToHtml = preEscapedLazyText . renderCss
|
||||
celper :: Cassius url -> Hamlet url
|
||||
celper = fmap cssToHtml
|
||||
@ -415,8 +415,7 @@ widgetToPageContent (GWidget w) = do
|
||||
jelper :: Julius url -> Hamlet url
|
||||
jelper = fmap jsToHtml
|
||||
|
||||
renderFIXME <- getUrlRenderParams
|
||||
let render a b = renderFIXME a $ map (TS.pack *** TS.pack) b
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
Nothing -> Nothing
|
||||
@ -441,9 +440,13 @@ widgetToPageContent (GWidget w) = do
|
||||
let renderLoc' render' (Local url) = render' url []
|
||||
renderLoc' _ (Remote s) = s
|
||||
let mkScriptTag (Script loc attrs) render' =
|
||||
foldl' addAttr TBH.script (("src", T.pack $ renderLoc' render' loc) : attrs) $ return ()
|
||||
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
|
||||
let mkLinkTag (Stylesheet loc attrs) render' =
|
||||
foldl' addAttr TBH.link (("rel", "stylesheet") : ("href", T.pack $ renderLoc' render' loc) : attrs)
|
||||
foldl' addAttr TBH.link
|
||||
( ("rel", "stylesheet")
|
||||
: ("href", renderLoc' render' loc)
|
||||
: attrs
|
||||
)
|
||||
let head'' =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
@ -475,11 +478,11 @@ yesodRender :: Yesod y
|
||||
=> y
|
||||
-> Route y
|
||||
-> [(Text, Text)]
|
||||
-> String -- FIXME
|
||||
-> Text
|
||||
yesodRender y u qs =
|
||||
S8.unpack $ toByteString $
|
||||
TE.decodeUtf8 $ toByteString $
|
||||
fromMaybe
|
||||
(joinPath y (fromByteString $ approot y) ps
|
||||
(joinPath y (fromText $ approot y) ps
|
||||
$ qs ++ qs')
|
||||
(urlRenderOverride y u)
|
||||
where
|
||||
|
||||
@ -41,6 +41,7 @@ module Yesod.Handler
|
||||
, redirect
|
||||
, redirectParams
|
||||
, redirectString
|
||||
, redirectText
|
||||
, redirectToPost
|
||||
-- ** Errors
|
||||
, notFound
|
||||
@ -124,6 +125,12 @@ import qualified Network.HTTP.Types as H
|
||||
import Control.Failure (Failure (failure))
|
||||
|
||||
import Text.Hamlet
|
||||
import Text.Blaze (preEscapedText)
|
||||
import qualified Text.Blaze.Renderer.Text
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import Control.Monad.IO.Control (MonadControlIO)
|
||||
import Control.Monad.Trans.Control (MonadTransControl, liftControl, control)
|
||||
@ -144,7 +151,6 @@ import qualified Data.ByteString.Char8 as S8
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as TS
|
||||
|
||||
-- | The type-safe URLs associated with a site argument.
|
||||
type family Route a
|
||||
@ -157,7 +163,7 @@ data HandlerData sub master = HandlerData
|
||||
, handlerSub :: sub
|
||||
, handlerMaster :: master
|
||||
, handlerRoute :: Maybe (Route sub)
|
||||
, handlerRender :: (Route master -> [(Text, Text)] -> String) -- FIXME replace output String with Ascii
|
||||
, handlerRender :: (Route master -> [(Text, Text)] -> Text)
|
||||
, handlerToMaster :: Route sub -> Route master
|
||||
}
|
||||
|
||||
@ -251,7 +257,7 @@ type GHInner s m monad = -- FIXME collapse the stack
|
||||
monad
|
||||
))))
|
||||
|
||||
type SessionMap = Map.Map String String
|
||||
type SessionMap = Map.Map Text Text
|
||||
|
||||
type Endo a = a -> a
|
||||
|
||||
@ -274,13 +280,13 @@ data YesodAppResult
|
||||
data HandlerContents =
|
||||
HCContent H.Status ChooseRep
|
||||
| HCError ErrorResponse
|
||||
| HCSendFile ContentType FilePath
|
||||
| HCRedirect RedirectType H.Ascii
|
||||
| HCCreated H.Ascii
|
||||
| HCSendFile ContentType FilePath -- FIXME replace FilePath with opaque type from system-filepath?
|
||||
| HCRedirect RedirectType Text
|
||||
| HCCreated Text
|
||||
| HCWai W.Response
|
||||
|
||||
instance Error HandlerContents where
|
||||
strMsg = HCError . InternalError
|
||||
strMsg = HCError . InternalError . T.pack
|
||||
|
||||
instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
|
||||
failure = GHandler . lift . throwError . HCError
|
||||
@ -301,9 +307,10 @@ rbHelper req =
|
||||
(map fix1 *** map fix2) <$> iter
|
||||
where
|
||||
iter = NWP.parseRequestBody NWP.lbsSink req
|
||||
fix1 = bsToChars *** bsToChars
|
||||
fix1 = go *** go
|
||||
fix2 (x, NWP.FileInfo a b c) =
|
||||
(bsToChars x, FileInfo (bsToChars a) (bsToChars b) c)
|
||||
(go x, FileInfo (go a) (go b) c)
|
||||
go = decodeUtf8With lenientDecode
|
||||
|
||||
-- | Get the sub application argument.
|
||||
getYesodSub :: Monad m => GGHandler sub master m sub
|
||||
@ -314,7 +321,7 @@ getYesod :: Monad m => GGHandler sub master m master
|
||||
getYesod = handlerMaster `liftM` GHandler ask
|
||||
|
||||
-- | Get the URL rendering function.
|
||||
getUrlRender :: Monad m => GGHandler sub master m (Route master -> String)
|
||||
getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
|
||||
getUrlRender = do
|
||||
x <- handlerRender `liftM` GHandler ask
|
||||
return $ flip x []
|
||||
@ -322,7 +329,7 @@ getUrlRender = do
|
||||
-- | The URL rendering function with query-string parameters.
|
||||
getUrlRenderParams
|
||||
:: Monad m
|
||||
=> GGHandler sub master m (Route master -> [(Text, Text)] -> String)
|
||||
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
|
||||
getUrlRenderParams = handlerRender `liftM` GHandler ask
|
||||
|
||||
-- | Get the route requested by the user. If this is a 404 response- where the
|
||||
@ -339,7 +346,7 @@ getRouteToMaster = handlerToMaster `liftM` GHandler ask
|
||||
-- 'GHandler' into an 'W.Application'. Should not be needed by users.
|
||||
runHandler :: HasReps c
|
||||
=> GHandler sub master c
|
||||
-> (Route master -> [(Text, Text)] -> String)
|
||||
-> (Route master -> [(Text, Text)] -> Text)
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> master
|
||||
@ -350,7 +357,7 @@ runHandler handler mrender sroute tomr ma sa =
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
Just x -> x
|
||||
Nothing -> InternalError $ show e
|
||||
Nothing -> InternalError $ T.pack $ show e
|
||||
let hd = HandlerData
|
||||
{ handlerRequest = rr
|
||||
, handlerSub = sa
|
||||
@ -384,7 +391,7 @@ runHandler handler mrender sroute tomr ma sa =
|
||||
return $ YARPlain status (headers []) ct c finalSession
|
||||
HCError e -> handleError e
|
||||
HCRedirect rt loc -> do
|
||||
let hs = Header "Location" loc : headers []
|
||||
let hs = Header "Location" (encodeUtf8 loc) : headers []
|
||||
return $ YARPlain
|
||||
(getRedirectStatus rt) hs typePlain emptyContent
|
||||
finalSession
|
||||
@ -392,7 +399,7 @@ runHandler handler mrender sroute tomr ma sa =
|
||||
(sendFile' ct fp)
|
||||
(handleError . toErrorHandler)
|
||||
HCCreated loc -> do
|
||||
let hs = Header "Location" loc : headers []
|
||||
let hs = Header "Location" (encodeUtf8 loc) : headers []
|
||||
return $ YARPlain
|
||||
H.status201
|
||||
hs
|
||||
@ -427,13 +434,15 @@ redirectParams :: Monad mo
|
||||
-> GGHandler sub master mo a
|
||||
redirectParams rt url params = do
|
||||
r <- getUrlRenderParams
|
||||
redirectString rt $ S8.pack $ r url params
|
||||
redirectString rt $ r url params
|
||||
|
||||
-- | Redirect to the given URL.
|
||||
redirectString :: Monad mo => RedirectType -> H.Ascii -> GGHandler sub master mo a
|
||||
redirectString rt = GHandler . lift . throwError . HCRedirect rt
|
||||
redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
|
||||
redirectText rt = GHandler . lift . throwError . HCRedirect rt
|
||||
redirectString = redirectText
|
||||
{-# DEPRECATED redirectString "Use redirectText instead" #-}
|
||||
|
||||
ultDestKey :: String
|
||||
ultDestKey :: Text
|
||||
ultDestKey = "_ULT"
|
||||
|
||||
-- | Sets the ultimate destination variable to the given route.
|
||||
@ -446,7 +455,7 @@ setUltDest dest = do
|
||||
setUltDestString $ render dest
|
||||
|
||||
-- | Same as 'setUltDest', but use the given string.
|
||||
setUltDestString :: Monad mo => String -> GGHandler sub master mo ()
|
||||
setUltDestString :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
setUltDestString = setSession ultDestKey
|
||||
|
||||
-- | Same as 'setUltDest', but uses the current page.
|
||||
@ -462,8 +471,7 @@ setUltDest' = do
|
||||
tm <- getRouteToMaster
|
||||
gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
|
||||
render <- getUrlRenderParams
|
||||
let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b
|
||||
setUltDestString $ renderFIXME (tm r) gets'
|
||||
setUltDestString $ render (tm r) gets'
|
||||
|
||||
-- | Redirect to the ultimate destination in the user's session. Clear the
|
||||
-- value from the session.
|
||||
@ -476,16 +484,16 @@ redirectUltDest :: Monad mo
|
||||
redirectUltDest rt def = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
deleteSession ultDestKey
|
||||
maybe (redirect rt def) (redirectString rt . S8.pack) mdest
|
||||
maybe (redirect rt def) (redirectText rt) mdest
|
||||
|
||||
msgKey :: String
|
||||
msgKey :: Text
|
||||
msgKey = "_MSG"
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessage :: Monad mo => Html -> GGHandler sub master mo ()
|
||||
setMessage = setSession msgKey . lbsToChars . renderHtml
|
||||
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
|
||||
|
||||
-- | Gets the message in the user's session, if available, and then clears the
|
||||
-- variable.
|
||||
@ -493,7 +501,7 @@ setMessage = setSession msgKey . lbsToChars . renderHtml
|
||||
-- See 'setMessage'.
|
||||
getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
|
||||
getMessage = do
|
||||
mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey
|
||||
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
|
||||
deleteSession msgKey
|
||||
return mmsg
|
||||
|
||||
@ -521,7 +529,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s
|
||||
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
|
||||
sendResponseCreated url = do
|
||||
r <- getUrlRender
|
||||
GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url
|
||||
GHandler $ lift $ throwError $ HCCreated $ r url
|
||||
|
||||
-- | Send a 'W.Response'. Please note: this function is rarely
|
||||
-- necessary, and will /disregard/ any changes to response headers and session
|
||||
@ -542,11 +550,11 @@ badMethod = do
|
||||
failure $ BadMethod $ W.requestMethod w
|
||||
|
||||
-- | Return a 403 permission denied page.
|
||||
permissionDenied :: Failure ErrorResponse m => String -> m a
|
||||
permissionDenied :: Failure ErrorResponse m => Text -> m a
|
||||
permissionDenied = failure . PermissionDenied
|
||||
|
||||
-- | Return a 400 invalid arguments page.
|
||||
invalidArgs :: Failure ErrorResponse m => [String] -> m a
|
||||
invalidArgs :: Failure ErrorResponse m => [Text] -> m a
|
||||
invalidArgs = failure . InvalidArgs
|
||||
|
||||
------- Headers
|
||||
@ -564,8 +572,8 @@ deleteCookie = addHeader . DeleteCookie
|
||||
|
||||
-- | Set the language in the user session. Will show up in 'languages' on the
|
||||
-- next request.
|
||||
setLanguage :: Monad mo => String -> GGHandler sub master mo ()
|
||||
setLanguage = setSession $ S8.unpack langKey
|
||||
setLanguage :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
setLanguage = setSession langKey
|
||||
|
||||
-- | Set an arbitrary response header.
|
||||
setHeader :: Monad mo
|
||||
@ -601,13 +609,13 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123
|
||||
-- and hashed cookie on the client. This ensures that all data is secure and
|
||||
-- not tampered with.
|
||||
setSession :: Monad mo
|
||||
=> String -- ^ key
|
||||
-> String -- ^ value
|
||||
=> Text -- ^ key
|
||||
-> Text -- ^ value
|
||||
-> GGHandler sub master mo ()
|
||||
setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
|
||||
|
||||
-- | Unsets a session variable. See 'setSession'.
|
||||
deleteSession :: Monad mo => String -> GGHandler sub master mo ()
|
||||
deleteSession :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
|
||||
|
||||
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
|
||||
@ -640,7 +648,7 @@ localNoCurrent =
|
||||
GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
|
||||
|
||||
-- | Lookup for session data.
|
||||
lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue)
|
||||
lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
|
||||
lookupSession n = GHandler $ do
|
||||
m <- liftM ghsSession $ lift $ lift $ lift get
|
||||
return $ Map.lookup n m
|
||||
@ -653,7 +661,7 @@ handlerToYAR :: (HasReps a, HasReps b)
|
||||
=> m -- ^ master site foundation
|
||||
-> s -- ^ sub site foundation
|
||||
-> (Route s -> Route m)
|
||||
-> (Route m -> [(Text, Text)] -> String) -- ^ url render FIXME
|
||||
-> (Route m -> [(Text, Text)] -> Text)
|
||||
-> (ErrorResponse -> GHandler s m a)
|
||||
-> Request
|
||||
-> Maybe (Route s)
|
||||
@ -782,8 +790,7 @@ hamletToContent :: Monad mo
|
||||
=> Hamlet (Route master) -> GGHandler sub master mo Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRenderParams
|
||||
let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b
|
||||
return $ toContent $ h renderFIXME
|
||||
return $ toContent $ h render
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: Monad mo
|
||||
|
||||
@ -41,6 +41,7 @@ import Data.List (nub)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.Encoding.Error as T
|
||||
@ -54,6 +55,7 @@ import Control.Exception (Exception)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.HTTP.Types as A
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.String (IsString)
|
||||
|
||||
#if GHC7
|
||||
#define HAMLET hamlet
|
||||
@ -65,9 +67,9 @@ import Data.CaseInsensitive (CI)
|
||||
-- from 'SpecialResponse' in that they allow for custom error pages.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
| InternalError String
|
||||
| InvalidArgs [String]
|
||||
| PermissionDenied String
|
||||
| InternalError Text
|
||||
| InvalidArgs [Text]
|
||||
| PermissionDenied Text
|
||||
| BadMethod H.Method
|
||||
deriving (Show, Eq, Typeable)
|
||||
instance Exception ErrorResponse
|
||||
@ -80,10 +82,10 @@ data Header =
|
||||
| Header (CI A.Ascii) A.Ascii
|
||||
deriving (Eq, Show)
|
||||
|
||||
langKey :: A.Ascii
|
||||
langKey :: IsString a => a
|
||||
langKey = "_LANG"
|
||||
|
||||
data Location url = Local url | Remote String -- FIXME Text
|
||||
data Location url = Local url | Remote Text
|
||||
deriving (Show, Eq)
|
||||
locationToHamlet :: Location url -> Hamlet url
|
||||
locationToHamlet (Local url) = [HAMLET|\@{url}
|
||||
@ -111,6 +113,7 @@ newtype Head url = Head (Hamlet url)
|
||||
newtype Body url = Body (Hamlet url)
|
||||
deriving Monoid
|
||||
|
||||
-- FIXME remove these functions
|
||||
lbsToChars :: L.ByteString -> String
|
||||
lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode
|
||||
|
||||
@ -120,10 +123,10 @@ bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode
|
||||
charsToBs :: String -> S.ByteString
|
||||
charsToBs = T.encodeUtf8 . T.pack
|
||||
|
||||
nonceKey :: String
|
||||
nonceKey :: IsString a => a
|
||||
nonceKey = "_NONCE"
|
||||
|
||||
sessionName :: A.Ascii
|
||||
sessionName :: IsString a => a
|
||||
sessionName = "_SESSION"
|
||||
|
||||
data GWData a = GWData
|
||||
|
||||
@ -24,6 +24,7 @@ import Data.Text (Text)
|
||||
import Data.Monoid (mappend)
|
||||
import qualified Blaze.ByteString.Builder
|
||||
import qualified Blaze.ByteString.Builder.Char8
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
||||
{-|
|
||||
@ -86,7 +87,7 @@ sendRedirect y segments' env =
|
||||
, ("Location", Blaze.ByteString.Builder.toByteString dest')
|
||||
] "Redirecting"
|
||||
where
|
||||
dest = joinPath y (Blaze.ByteString.Builder.fromByteString $ approot y) segments' []
|
||||
dest = joinPath y (fromText $ approot y) segments' []
|
||||
dest' =
|
||||
if S.null (W.rawQueryString env)
|
||||
then dest
|
||||
|
||||
@ -4,34 +4,37 @@ module Yesod.Internal.Request
|
||||
) where
|
||||
|
||||
import Yesod.Request
|
||||
import Control.Arrow (first, (***))
|
||||
import Control.Arrow (first, second)
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import Yesod.Internal
|
||||
import qualified Network.Wai as W
|
||||
import System.Random (randomR, newStdGen)
|
||||
import Web.Cookie (parseCookies)
|
||||
import Web.Cookie (parseCookiesText)
|
||||
import Data.Monoid (mempty)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.Text (Text, pack)
|
||||
import Network.HTTP.Types (queryToQueryText)
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
parseWaiRequest :: W.Request
|
||||
-> [(String, String)] -- ^ session
|
||||
-> [(Text, Text)] -- ^ session
|
||||
-> Maybe a
|
||||
-> IO Request
|
||||
parseWaiRequest env session' key' = do
|
||||
let gets' = map (bsToChars *** maybe "" bsToChars)
|
||||
$ W.queryString env
|
||||
let gets' = queryToQueryText $ W.queryString env
|
||||
let reqCookie = maybe mempty id $ lookup "Cookie"
|
||||
$ W.requestHeaders env
|
||||
cookies' = parseCookies reqCookie
|
||||
cookies' = parseCookiesText reqCookie
|
||||
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
|
||||
langs = map S8.unpack $ maybe [] NWP.parseHttpAccept acceptLang
|
||||
langs' = case lookup (S8.unpack langKey) session' of
|
||||
langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
|
||||
langs' = case lookup langKey session' of
|
||||
Nothing -> langs
|
||||
Just x -> x : langs
|
||||
langs'' = case lookup langKey cookies' of
|
||||
Nothing -> langs'
|
||||
Just x -> S8.unpack x : langs'
|
||||
langs''' = case lookup (S8.unpack langKey) gets' of
|
||||
Just x -> x : langs'
|
||||
langs''' = case join $ lookup langKey gets' of
|
||||
Nothing -> langs''
|
||||
Just x -> x : langs''
|
||||
nonce <- case (key', lookup nonceKey session') of
|
||||
@ -39,8 +42,9 @@ parseWaiRequest env session' key' = do
|
||||
(_, Just x) -> return $ Just x
|
||||
(_, Nothing) -> do
|
||||
g <- newStdGen
|
||||
return $ Just $ fst $ randomString 10 g
|
||||
return $ Request gets' cookies' env langs''' nonce
|
||||
return $ Just $ pack $ fst $ randomString 10 g
|
||||
let gets'' = map (second $ fromMaybe "") gets'
|
||||
return $ Request gets'' cookies' env langs''' nonce
|
||||
where
|
||||
randomString len =
|
||||
first (map toChar) . sequence' (replicate len (randomR (0, 61)))
|
||||
|
||||
@ -8,11 +8,13 @@ import Data.Serialize
|
||||
import Data.Time
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Monad (guard)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Control.Arrow ((***))
|
||||
|
||||
encodeSession :: CS.Key
|
||||
-> UTCTime -- ^ expire time
|
||||
-> ByteString -- ^ remote host
|
||||
-> [(String, String)] -- ^ session
|
||||
-> [(Text, Text)] -- ^ session
|
||||
-> ByteString -- ^ cookie value
|
||||
encodeSession key expire rhost session' =
|
||||
CS.encrypt key $ encode $ SessionCookie expire rhost session'
|
||||
@ -21,7 +23,7 @@ decodeSession :: CS.Key
|
||||
-> UTCTime -- ^ current time
|
||||
-> ByteString -- ^ remote host field
|
||||
-> ByteString -- ^ cookie value
|
||||
-> Maybe [(String, String)]
|
||||
-> Maybe [(Text, Text)]
|
||||
decodeSession key now rhost encrypted = do
|
||||
decrypted <- CS.decrypt key encrypted
|
||||
SessionCookie expire rhost' session' <-
|
||||
@ -30,14 +32,14 @@ decodeSession key now rhost encrypted = do
|
||||
guard $ rhost' == rhost
|
||||
return session'
|
||||
|
||||
data SessionCookie = SessionCookie UTCTime ByteString [(String, String)]
|
||||
data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)]
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = putTime a >> put b >> put c
|
||||
put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c)
|
||||
get = do
|
||||
a <- getTime
|
||||
b <- get
|
||||
c <- get
|
||||
c <- map (pack *** pack) `fmap` get
|
||||
return $ SessionCookie a b c
|
||||
|
||||
putTime :: Putter UTCTime
|
||||
|
||||
@ -31,10 +31,6 @@ module Yesod.Request
|
||||
, lookupPostParams
|
||||
, lookupCookies
|
||||
, lookupFiles
|
||||
-- * Parameter type synonyms
|
||||
, ParamName
|
||||
, ParamValue
|
||||
, ParamError
|
||||
) where
|
||||
|
||||
import qualified Network.Wai as W
|
||||
@ -43,11 +39,7 @@ import Control.Monad.IO.Class
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
|
||||
import Data.Maybe (listToMaybe)
|
||||
import qualified Network.HTTP.Types as A
|
||||
|
||||
type ParamName = String
|
||||
type ParamValue = String
|
||||
type ParamError = String
|
||||
import Data.Text (Text)
|
||||
|
||||
-- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler
|
||||
|
||||
@ -70,7 +62,7 @@ class Monad m => RequestReader m where
|
||||
-- * Accept-Language HTTP header.
|
||||
--
|
||||
-- This is handled by parseWaiRequest (not exposed).
|
||||
languages :: RequestReader m => m [String]
|
||||
languages :: RequestReader m => m [Text]
|
||||
languages = reqLangs `liftM` getRequest
|
||||
|
||||
-- | Get the request\'s 'W.Request' value.
|
||||
@ -79,74 +71,74 @@ waiRequest = reqWaiRequest `liftM` getRequest
|
||||
|
||||
-- | A tuple containing both the POST parameters and submitted files.
|
||||
type RequestBodyContents =
|
||||
( [(ParamName, ParamValue)]
|
||||
, [(ParamName, FileInfo)]
|
||||
( [(Text, Text)]
|
||||
, [(Text, FileInfo)]
|
||||
)
|
||||
|
||||
data FileInfo = FileInfo
|
||||
{ fileName :: String
|
||||
, fileContentType :: String
|
||||
{ fileName :: Text
|
||||
, fileContentType :: Text
|
||||
, fileContent :: BL.ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The parsed request information.
|
||||
data Request = Request
|
||||
{ reqGetParams :: [(ParamName, ParamValue)]
|
||||
, reqCookies :: [(A.Ascii, A.Ascii)]
|
||||
{ reqGetParams :: [(Text, Text)]
|
||||
, reqCookies :: [(Text, Text)]
|
||||
, reqWaiRequest :: W.Request
|
||||
-- | Languages which the client supports.
|
||||
, reqLangs :: [String]
|
||||
, reqLangs :: [Text]
|
||||
-- | A random, session-specific nonce used to prevent CSRF attacks.
|
||||
, reqNonce :: Maybe String
|
||||
, reqNonce :: Maybe Text
|
||||
}
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookup' a = map snd . filter (\x -> a == fst x)
|
||||
|
||||
-- | Lookup for GET parameters.
|
||||
lookupGetParams :: RequestReader m => ParamName -> m [ParamValue]
|
||||
lookupGetParams :: RequestReader m => Text -> m [Text]
|
||||
lookupGetParams pn = do
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqGetParams rr
|
||||
|
||||
-- | Lookup for GET parameters.
|
||||
lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)
|
||||
lookupGetParam :: RequestReader m => Text -> m (Maybe Text)
|
||||
lookupGetParam = liftM listToMaybe . lookupGetParams
|
||||
|
||||
-- | Lookup for POST parameters.
|
||||
lookupPostParams :: RequestReader m
|
||||
=> ParamName
|
||||
-> m [ParamValue]
|
||||
=> Text
|
||||
-> m [Text]
|
||||
lookupPostParams pn = do
|
||||
(pp, _) <- runRequestBody
|
||||
return $ lookup' pn pp
|
||||
|
||||
lookupPostParam :: (MonadIO m, RequestReader m)
|
||||
=> ParamName
|
||||
-> m (Maybe ParamValue)
|
||||
=> Text
|
||||
-> m (Maybe Text)
|
||||
lookupPostParam = liftM listToMaybe . lookupPostParams
|
||||
|
||||
-- | Lookup for POSTed files.
|
||||
lookupFile :: (MonadIO m, RequestReader m)
|
||||
=> ParamName
|
||||
=> Text
|
||||
-> m (Maybe FileInfo)
|
||||
lookupFile = liftM listToMaybe . lookupFiles
|
||||
|
||||
-- | Lookup for POSTed files.
|
||||
lookupFiles :: RequestReader m
|
||||
=> ParamName
|
||||
=> Text
|
||||
-> m [FileInfo]
|
||||
lookupFiles pn = do
|
||||
(_, files) <- runRequestBody
|
||||
return $ lookup' pn files
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookie :: RequestReader m => A.Ascii -> m (Maybe A.Ascii)
|
||||
lookupCookie :: RequestReader m => Text -> m (Maybe Text)
|
||||
lookupCookie = liftM listToMaybe . lookupCookies
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookies :: RequestReader m => A.Ascii -> m [A.Ascii]
|
||||
lookupCookies :: RequestReader m => Text -> m [Text]
|
||||
lookupCookies pn = do
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqCookies rr
|
||||
|
||||
@ -38,6 +38,7 @@ module Yesod.Widget
|
||||
|
||||
import Data.Monoid
|
||||
import Control.Monad.Trans.RWS
|
||||
import Text.Blaze (preEscapedText)
|
||||
import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
@ -75,7 +76,7 @@ instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where
|
||||
toHamletValue = runGWidget'
|
||||
htmlToHamletMonad = GWidget' . addHtml
|
||||
urlToHamletMonad url params = GWidget' $
|
||||
addHamlet $ \r -> preEscapedString (r url params)
|
||||
addHamlet $ \r -> preEscapedText (r url params)
|
||||
fromHamletValue = GWidget'
|
||||
instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where
|
||||
return = GWidget' . return
|
||||
@ -130,17 +131,17 @@ addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub
|
||||
addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()
|
||||
addStylesheetRemote :: Monad m => Text -> GGWidget sub master m ()
|
||||
addStylesheetRemote = flip addStylesheetRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m ()
|
||||
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m ()
|
||||
addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
|
||||
addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
|
||||
addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget sub master m ()
|
||||
addStylesheetEither = either addStylesheet addStylesheetRemote
|
||||
|
||||
addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
|
||||
addScriptEither :: Monad m => Either (Route master) Text -> GGWidget sub master m ()
|
||||
addScriptEither = either addScript addScriptRemote
|
||||
|
||||
-- | Link to the specified local script.
|
||||
@ -152,11 +153,11 @@ addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub mast
|
||||
addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemote :: Monad m => String -> GGWidget sub master m ()
|
||||
addScriptRemote :: Monad m => Text -> GGWidget sub master m ()
|
||||
addScriptRemote = flip addScriptRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m ()
|
||||
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m ()
|
||||
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Include raw Javascript in the page's script tag.
|
||||
|
||||
@ -8,12 +8,12 @@ synopsis: Creation of type-safe, RESTful web applications.
|
||||
description:
|
||||
Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.
|
||||
.
|
||||
The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.
|
||||
The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://docs.yesodweb.com/
|
||||
homepage: http://www.yesodweb.com/
|
||||
|
||||
flag test
|
||||
description: Build the executable to run unit tests
|
||||
@ -34,7 +34,7 @@ library
|
||||
, text >= 0.5 && < 0.12
|
||||
, template-haskell
|
||||
, web-routes-quasi >= 0.7 && < 0.8
|
||||
, hamlet >= 0.7.3 && < 0.8
|
||||
, hamlet >= 0.8 && < 0.9
|
||||
, blaze-builder >= 0.2.1 && < 0.4
|
||||
, transformers >= 0.2 && < 0.3
|
||||
, clientsession >= 0.6 && < 0.7
|
||||
@ -45,7 +45,7 @@ library
|
||||
, containers >= 0.2 && < 0.5
|
||||
, monad-control >= 0.2 && < 0.3
|
||||
, enumerator >= 0.4.7 && < 0.5
|
||||
, cookie >= 0.2 && < 0.3
|
||||
, cookie >= 0.2.1 && < 0.3
|
||||
, blaze-html >= 0.4 && < 0.5
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, case-insensitive >= 0.2 && < 0.3
|
||||
|
||||
Loading…
Reference in New Issue
Block a user