lookupSessionBS/setSessionBS (#235)

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
 

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

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]

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