From fec0d4282757d44ff3c9c05f277ae1622603f718 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 24 Jan 2012 18:43:30 +0200 Subject: [PATCH] lookupSessionBS/setSessionBS (#235) --- yesod-core/Yesod/Handler.hs | 18 +++++++++++++++--- yesod-core/Yesod/Internal/Core.hs | 2 +- yesod-core/Yesod/Internal/Request.hs | 14 ++++++++++---- yesod-core/Yesod/Internal/Session.hs | 13 +++++++------ 4 files changed, 33 insertions(+), 14 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 3f9b22ad..4eb71197 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -70,8 +70,10 @@ module Yesod.Handler -- * Session , SessionMap , lookupSession + , lookupSessionBS , getSession , setSession + , setSessionBS , deleteSession -- ** Ultimate destination , setUltDest @@ -272,7 +274,7 @@ data GHState = GHState , ghsHeaders :: Endo [Header] } -type SessionMap = Map.Map Text Text +type SessionMap = Map.Map Text S.ByteString -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as @@ -678,7 +680,13 @@ expiresAt = setHeader "Expires" . formatRFC1123 setSession :: Text -- ^ key -> Text -- ^ value -> GHandler sub master () -setSession k = modify . modSession . Map.insert k +setSession k = setSessionBS k . encodeUtf8 + +-- | Same as 'setSession', but uses binary data for the value. +setSessionBS :: Text + -> S.ByteString + -> GHandler sub master () +setSessionBS k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: Text -> GHandler sub master () @@ -725,7 +733,11 @@ localNoCurrent = -- | Lookup for session data. lookupSession :: Text -> GHandler s m (Maybe Text) -lookupSession n = do +lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS + +-- | Lookup for session data in binary format. +lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString) +lookupSessionBS n = do m <- liftM ghsSession get return $ Map.lookup n m diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index e5525551..a8cffde0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -402,7 +402,7 @@ defaultYesodRunner handler master sub murl toMasterRoute mkey req = do (Just key, Just nonce) -> encodeSession key iv exp' host $ Map.toList - $ Map.insert nonceKey nonce sm + $ Map.insert nonceKey (TE.encodeUtf8 nonce) sm _ -> mempty hs' = case mkey of diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 9dec2262..063db67f 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -17,6 +17,7 @@ import Yesod.Internal import qualified Network.Wai as W import System.Random (RandomGen, newStdGen, randomRs) import Web.Cookie (parseCookiesText) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText) @@ -25,6 +26,8 @@ import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L import qualified Data.Set as Set import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) -- | The parsed request information. data Request = Request @@ -38,14 +41,14 @@ data Request = Request } parseWaiRequest :: W.Request - -> [(Text, Text)] -- ^ session + -> [(Text, ByteString)] -- ^ session -> Maybe a -> IO Request parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen parseWaiRequest' :: RandomGen g => W.Request - -> [(Text, Text)] -- ^ session + -> [(Text, ByteString)] -- ^ session -> Maybe a -> g -> Request @@ -57,10 +60,13 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' non cookies' = maybe [] parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang + + lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k + -- The language preferences are prioritized as follows: langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG , lookup langKey cookies' -- Cookie _LANG - , lookup langKey session' -- Session _LANG + , lookupText langKey session' -- Session _LANG ] ++ langs -- Accept-Language(s) -- Github issue #195. We want to add an extra two-letter version of any @@ -73,7 +79,7 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' non -- generated. nonce = case (key', lookup nonceKey session') of (Nothing, _) -> Nothing - (_, Just x) -> Just x + (_, Just x) -> Just $ decodeUtf8With lenientDecode x _ -> Just $ pack $ randomString 10 gen addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 15122adf..76fcef95 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -9,13 +9,14 @@ import Data.Time import Data.ByteString (ByteString) import Control.Monad (guard) import Data.Text (Text, pack, unpack) -import Control.Arrow ((***)) +import Control.Arrow (first) +import Control.Applicative ((<$>)) encodeSession :: CS.Key -> CS.IV -> UTCTime -- ^ expire time -> ByteString -- ^ remote host - -> [(Text, Text)] -- ^ session + -> [(Text, ByteString)] -- ^ session -> ByteString -- ^ cookie value encodeSession key iv expire rhost session' = CS.encrypt key iv $ encode $ SessionCookie expire rhost session' @@ -24,7 +25,7 @@ decodeSession :: CS.Key -> UTCTime -- ^ current time -> ByteString -- ^ remote host field -> ByteString -- ^ cookie value - -> Maybe [(Text, Text)] + -> Maybe [(Text, ByteString)] decodeSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie expire rhost' session' <- @@ -33,14 +34,14 @@ decodeSession key now rhost encrypted = do guard $ rhost' == rhost return session' -data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)] +data SessionCookie = SessionCookie UTCTime ByteString [(Text, ByteString)] deriving (Show, Read) instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c) + put (SessionCookie a b c) = putTime a >> put b >> put (map (first unpack) c) get = do a <- getTime b <- get - c <- map (pack *** pack) `fmap` get + c <- map (first pack) <$> get return $ SessionCookie a b c putTime :: Putter UTCTime