Merge remote-tracking branch 'origin/master' into yesod-1.4

yesod-auth/Yesod/Auth/Email.hs

@@ -45,7 +45,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Text (Text)
 import Yesod.Core
-import qualified Crypto.PasswordStore as PS
+import qualified Yesod.PasswordStore as PS
 import qualified Text.Email.Validate
 import qualified Yesod.Auth.Message as Msg
 import Control.Applicative ((<$>), (<*>))
@@ -250,8 +250,11 @@ $newline never
                 <input type="password" name="password">
         <tr>
             <td colspan="2">
-                <input type="submit" value=_{Msg.LoginViaEmail}>
+                <button type=submit .btn .btn-success>
-                <a href="@{tm registerR}">I don't have an account
+                    _{Msg.LoginViaEmail}
+                &nbsp;
+                <a href="@{tm registerR}" .btn .btn-default>
+                    _{Msg.RegisterLong}
 |]
   where
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+-- | Use an email address as an identifier via Google's login system.
+--
+-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
+-- on Google's now deprecated OpenID system. For more information, see
+-- <https://developers.google.com/+/api/auth-migration>.
+--
+-- By using this plugin, you are trusting Google to validate an email address,
+-- and requiring users to have a Google account. On the plus side, you get to
+-- use email addresses as the identifier, many users have existing Google
+-- accounts, the login system has been long tested (as opposed to BrowserID),
+-- and it requires no credential managing or setup (as opposed to Email).
+--
+-- In order to use this plugin:
+--
+-- * Create an application on the Google Developer Console <https://console.developers.google.com/>
+--
+-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)
+--
+-- * Enable the Google+ API.
+--
+-- Since 1.3.1
+module Yesod.Auth.GoogleEmail2
+    ( authGoogleEmail
+    , forwardUrl
+    ) where
+
+import           Blaze.ByteString.Builder (fromByteString, toByteString)
+import           Control.Applicative      ((<$>), (<*>))
+import           Control.Arrow            (second)
+import           Control.Monad            (liftM, unless)
+import           Data.Aeson.Parser        (json')
+import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
+                                           withObject)
+import           Data.Conduit             (($$+-))
+import           Data.Conduit.Attoparsec  (sinkParser)
+import           Data.Monoid              (mappend)
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
+import           Network.HTTP.Client      (parseUrl, requestHeaders,
+                                           responseBody, urlEncodedBody)
+import           Network.HTTP.Conduit     (http)
+import           Network.HTTP.Types       (renderQueryText)
+import           Network.Mail.Mime        (randomString)
+import           System.Random            (newStdGen)
+import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
+                                           AuthRoute, Creds (Creds),
+                                           Route (PluginR), YesodAuth,
+                                           authHttpManager, setCredsRedirect)
+import qualified Yesod.Auth.Message       as Msg
+import           Yesod.Core               (HandlerSite, MonadHandler,
+                                           getRouteToParent, getUrlRender,
+                                           getYesod, invalidArgs, lift,
+                                           liftBase, lookupGetParam,
+                                           lookupSession, notFound, redirect,
+                                           setSession, whamlet, (.:))
+
+pid :: Text
+pid = "googleemail2"
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR pid ["forward"]
+
+csrfKey :: Text
+csrfKey = "_GOOGLE_CSRF_TOKEN"
+
+getCsrfToken :: MonadHandler m => m (Maybe Text)
+getCsrfToken = lookupSession csrfKey
+
+getCreateCsrfToken :: MonadHandler m => m Text
+getCreateCsrfToken = do
+    mtoken <- getCsrfToken
+    case mtoken of
+        Just token -> return token
+        Nothing -> do
+            stdgen <- liftBase newStdGen
+            let token = T.pack $ fst $ randomString 10 stdgen
+            setSession csrfKey token
+            return token
+
+authGoogleEmail :: YesodAuth m
+                => Text -- ^ client ID
+                -> Text -- ^ client secret
+                -> AuthPlugin m
+authGoogleEmail clientID clientSecret =
+    AuthPlugin pid dispatch login
+  where
+    complete = PluginR pid ["complete"]
+
+    getDest :: MonadHandler m
+            => (Route Auth -> Route (HandlerSite m))
+            -> m Text
+    getDest tm = do
+        csrf <- getCreateCsrfToken
+        render <- getUrlRender
+        let qs = map (second Just)
+                [ ("scope", "email")
+                , ("state", csrf)
+                , ("redirect_uri", render $ tm complete)
+                , ("response_type", "code")
+                , ("client_id", clientID)
+                , ("access_type", "offline")
+                ]
+        return $ decodeUtf8
+               $ toByteString
+               $ fromByteString "https://accounts.google.com/o/oauth2/auth"
+                    `mappend` renderQueryText True qs
+
+    login tm = do
+        url <- getDest tm
+        [whamlet|<a href=#{url}>_{Msg.LoginGoogle}|]
+    dispatch "GET" ["forward"] = do
+        tm <- getRouteToParent
+        lift (getDest tm) >>= redirect
+
+    dispatch "GET" ["complete"] = do
+        mstate <- lookupGetParam "state"
+        case mstate of
+            Nothing -> invalidArgs ["CSRF state from Google is missing"]
+            Just state -> do
+                mtoken <- getCsrfToken
+                unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]
+        mcode <- lookupGetParam "code"
+        code <-
+            case mcode of
+                Nothing -> invalidArgs ["Missing code paramter"]
+                Just c -> return c
+
+        render <- getUrlRender
+
+        req' <- parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
+        let req =
+                urlEncodedBody
+                    [ ("code", encodeUtf8 code)
+                    , ("client_id", encodeUtf8 clientID)
+                    , ("client_secret", encodeUtf8 clientSecret)
+                    , ("redirect_uri", encodeUtf8 $ render complete)
+                    , ("grant_type", "authorization_code")
+                    ]
+                    req'
+                        { requestHeaders = []
+                        }
+        manager <- liftM authHttpManager $ lift getYesod
+        res <- http req manager
+        value <- responseBody res $$+- sinkParser json'
+        Tokens accessToken _idToken tokenType <-
+            case parseEither parseJSON value of
+                Left e -> error e
+                Right t -> return t
+
+        unless (tokenType == "Bearer") $ error $ "Unknown token type: " ++ show tokenType
+
+        req2' <- parseUrl "https://www.googleapis.com/plus/v1/people/me"
+        let req2 = req2'
+                { requestHeaders =
+                    [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken)
+                    ]
+                }
+        res2 <- http req2 manager
+        value2 <- responseBody res2 $$+- sinkParser json'
+        Person emails <-
+            case parseEither parseJSON value2 of
+                Left e -> error e
+                Right x -> return x
+        email <-
+            case map emailValue $ filter (\e -> emailType e == "account") emails of
+                [e] -> return e
+                [] -> error "No account email"
+                x -> error $ "Too many account emails: " ++ show x
+        lift $ setCredsRedirect $ Creds pid email []
+
+    dispatch _ _ = notFound
+
+data Tokens = Tokens Text Text Text
+instance FromJSON Tokens where
+    parseJSON = withObject "Tokens" $ \o -> Tokens
+        <$> o .: "access_token"
+        <*> o .: "id_token"
+        <*> o .: "token_type"
+
+data Person = Person [Email]
+instance FromJSON Person where
+    parseJSON = withObject "Person" $ \o -> Person
+        <$> o .: "emails"
+
+data Email = Email
+    { emailValue :: Text
+    , emailType  :: Text
+    }
+    deriving Show
+instance FromJSON Email where
+    parseJSON = withObject "Email" $ \o -> Email
+        <$> o .: "value"
+        <*> o .: "type"

yesod-auth/Yesod/Auth/Message.hs

@@ -311,15 +311,14 @@ frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
 frenchMessage LoginTitle = "Se connecter"
 frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"
 frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"
-frenchMessage NoIdentifierProvided = "No email/username provided"
+frenchMessage NoIdentifierProvided = "Adresse électronique/nom d'utilisateur non spécifié"
-frenchMessage InvalidEmailAddress = "Invalid email address provided"
+frenchMessage InvalidEmailAddress = "Adresse électronique spécifiée invalide"
-frenchMessage PasswordResetTitle = "Password Reset"
+frenchMessage PasswordResetTitle = "Réinitialisation de mot de passe"
-frenchMessage ProvideIdentifier = "Email or Username"
+frenchMessage ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"
-frenchMessage SendPasswordResetEmail = "Send password reset email"
+frenchMessage SendPasswordResetEmail = "Envoie d'un message électronique pour Réinitialisation le mot de passe"
-frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+frenchMessage PasswordResetPrompt = "Entrez votre adresse électronique ou votre nom d'utilisateur ci-dessous, et un message électronique de réinitialisation de mot de passe vous sera envoyé."
-frenchMessage InvalidUsernamePass = "Invalid username/password combination"
+frenchMessage InvalidUsernamePass = "Le couble nom d'utilisateur/mot de passe invalide"
--- TODO
+frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident
-frenchMessage i@(IdentifierNotFound _) = englishMessage i
 
 norwegianBokmålMessage :: AuthMessage -> Text
 norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"

yesod-auth/Yesod/PasswordStore.hs

@@ -0,0 +1,429 @@
+{-# LANGUAGE OverloadedStrings, BangPatterns #-}
+{-# LANGUAGE CPP #-}
+-- |
+-- Module      : Crypto.PasswordStore
+-- Copyright   : (c) Peter Scott, 2011
+-- License     : BSD-style
+--
+-- Maintainer  : pjscott@iastate.edu
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Securely store hashed, salted passwords. If you need to store and verify
+-- passwords, there are many wrong ways to do it, most of them all too
+-- common. Some people store users' passwords in plain text. Then, when an
+-- attacker manages to get their hands on this file, they have the passwords for
+-- every user's account. One step up, but still wrong, is to simply hash all
+-- passwords with SHA1 or something. This is vulnerable to rainbow table and
+-- dictionary attacks. One step up from that is to hash the password along with
+-- a unique salt value. This is vulnerable to dictionary attacks, since guessing
+-- a password is very fast. The right thing to do is to use a slow hash
+-- function, to add some small but significant delay, that will be negligible
+-- for legitimate users but prohibitively expensive for someone trying to guess
+-- passwords by brute force. That is what this library does. It iterates a
+-- SHA256 hash, with a random salt, a few thousand times. This scheme is known
+-- as PBKDF1, and is generally considered secure; there is nothing innovative
+-- happening here.
+--
+-- The API here is very simple. What you store are called /password hashes/.
+-- They are strings (technically, ByteStrings) that look like this:
+--
+-- > "sha256|14|jEWU94phx4QzNyH94Qp4CQ==|5GEw+jxP/4WLgzt9VS3Ee3nhqBlDsrKiB+rq7JfMckU="
+--
+-- Each password hash shows the algorithm, the strength (more on that later),
+-- the salt, and the hashed-and-salted password. You store these on your server,
+-- in a database, for when you need to verify a password. You make a password
+-- hash with the 'makePassword' function. Here's an example:
+--
+-- > >>> makePassword "hunter2" 14
+-- > "sha256|14|Zo4LdZGrv/HYNAUG3q8WcA==|zKjbHZoTpuPLp1lh6ATolWGIKjhXvY4TysuKvqtNFyk="
+--
+-- This will hash the password @\"hunter2\"@, with strength 12, which is a good
+-- default value. The strength here determines how long the hashing will
+-- take. When doing the hashing, we iterate the SHA256 hash function
+-- @2^strength@ times, so increasing the strength by 1 makes the hashing take
+-- twice as long. When computers get faster, you can bump up the strength a
+-- little bit to compensate. You can strengthen existing password hashes with
+-- the 'strengthenPassword' function. Note that 'makePassword' needs to generate
+-- random numbers, so its return type is 'IO' 'ByteString'. If you want to avoid
+-- the 'IO' monad, you can generate your own salt and pass it to
+-- 'makePasswordSalt'.
+--
+-- Your strength value should not be less than 12, and 14 is a good default
+-- value at the time of this writing, in 2013.
+--
+-- Once you've got your password hashes, the second big thing you need to do
+-- with them is verify passwords against them. When a user gives you a password,
+-- you compare it with a password hash using the 'verifyPassword' function:
+--
+-- > >>> verifyPassword "wrong guess" passwordHash
+-- > False
+-- > >>> verifyPassword "hunter2" passwordHash
+-- > True
+--
+-- These two functions are really all you need. If you want to make existing
+-- password hashes stronger, you can use 'strengthenPassword'. Just pass it an
+-- existing password hash and a new strength value, and it will return a new
+-- password hash with that strength value, which will match the same password as
+-- the old password hash.
+--
+-- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact
+-- iteration count. This does not have a significant effect on security, but can
+-- be handy for compatibility with other code.
+
+module Yesod.PasswordStore (
+
+        -- * Algorithms
+        pbkdf1,                 -- :: ByteString -> Salt -> Int -> ByteString
+        pbkdf2,                 -- :: ByteString -> Salt -> Int -> ByteString
+
+        -- * Registering and verifying passwords
+        makePassword,           -- :: ByteString -> Int -> IO ByteString
+        makePasswordWith,       -- :: (ByteString -> Salt -> Int -> ByteString) ->
+                                --    ByteString -> Int -> IO ByteString
+        makePasswordSalt,       -- :: ByteString -> ByteString -> Int -> ByteString
+        makePasswordSaltWith,   -- :: (ByteString -> Salt -> Int -> ByteString) ->
+                                --    ByteString -> Salt -> Int -> ByteString
+        verifyPassword,         -- :: ByteString -> ByteString -> Bool
+        verifyPasswordWith,     -- :: (ByteString -> Salt -> Int -> ByteString) ->
+                                --    (Int -> Int) -> ByteString -> ByteString -> Bool
+
+        -- * Updating password hash strength
+        strengthenPassword,     -- :: ByteString -> Int -> ByteString
+        passwordStrength,       -- :: ByteString -> Int
+
+        -- * Utilities
+        Salt,
+        isPasswordFormatValid,  -- :: ByteString -> Bool
+        genSaltIO,              -- :: IO Salt
+        genSaltRandom,          -- :: (RandomGen b) => b -> (Salt, b)
+        makeSalt,               -- :: ByteString -> Salt
+        exportSalt,             -- :: Salt -> ByteString
+        importSalt              -- :: ByteString -> Salt
+  ) where
+
+
+import qualified Crypto.Hash as CH
+import qualified Crypto.Hash.SHA256 as H
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Binary as Binary
+import Control.Monad
+import Control.Monad.ST
+import Data.Byteable (toBytes)
+import Data.STRef
+import Data.Bits
+import Data.ByteString.Char8 (ByteString)
+import Data.ByteString.Base64 (encode, decodeLenient)
+import System.IO
+import System.Random
+import Data.Maybe
+import qualified Control.Exception
+
+---------------------
+-- Cryptographic base
+---------------------
+
+-- | PBKDF1 key-derivation function. Takes a password, a 'Salt', and a number of
+-- iterations. The number of iterations should be at least 1000, and probably
+-- more. 5000 is a reasonable number, computing almost instantaneously. This
+-- will give a 32-byte 'ByteString' as output. Both the salt and this 32-byte
+-- key should be stored in the password file. When a user wishes to authenticate
+-- a password, just pass it and the salt to this function, and see if the output
+-- matches.
+pbkdf1 :: ByteString -> Salt -> Int -> ByteString
+pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)
+    where first_hash = H.finalize $ H.init `H.update` password `H.update` salt
+
+-- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
+-- or more. If the number of rounds specified is 0, the ByteString will be
+-- returned unmodified.
+hashRounds :: ByteString -> Int -> ByteString
+hashRounds (!bs) 0 = bs
+hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
+
+-- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
+hmacSHA256 :: ByteString
+           -- ^ The secret (the salt)
+           -> ByteString
+           -- ^ The clear-text message
+           -> ByteString
+           -- ^ The encoded message
+hmacSHA256 secret msg =
+    toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
+
+-- | PBKDF2 key-derivation function.
+-- For details see @http://tools.ietf.org/html/rfc2898@.
+-- @32@ is the most common digest size for @SHA256@, and is
+-- what the algorithm internally uses.
+-- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
+pbkdf2 :: ByteString -> Salt -> Int -> ByteString
+pbkdf2 password (SaltBS salt) c =
+    let hLen = 32
+        dkLen = hLen in go hLen dkLen
+  where
+    go hLen dkLen | dkLen > (2^32 - 1) * hLen = error "Derived key too long."
+                  | otherwise =
+                      let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)
+                          !r = dkLen - (l - 1) * hLen
+                          chunks = [f i | i <- [1 .. l]]
+                      in (B.concat . init $ chunks) `B.append` B.take r (last chunks)
+
+    -- The @f@ function, as defined in the spec.
+    -- It calls 'u' under the hood.
+    f :: Int -> ByteString
+    f i = let !u1 = hmacSHA256 password (salt `B.append` int i)
+      -- Using the ST Monad, for maximum performance.
+      in runST $ do
+          u <- newSTRef u1
+          accum <- newSTRef u1
+          forM_ [2 .. c] $ \_ -> do
+            modifySTRef' u (hmacSHA256 password)
+            currentU <- readSTRef u
+            modifySTRef' accum (`xor'` currentU)
+          readSTRef accum
+
+    -- int(i), as defined in the spec.
+    int :: Int -> ByteString
+    int i = let str = BL.unpack . Binary.encode $ i
+            in BS.pack $ drop (length str - 4) str
+
+    -- | A convenience function to XOR two 'ByteString' together.
+    xor' :: ByteString -> ByteString -> ByteString
+    xor' !b1 !b2 = BS.pack $ BS.zipWith xor b1 b2
+
+-- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
+-- system RNG as a fallback. This is the function used to generate salts by
+-- 'makePassword'.
+genSaltIO :: IO Salt
+genSaltIO =
+    Control.Exception.catch genSaltDevURandom def
+  where
+    def :: IOError -> IO Salt
+    def _ = genSaltSysRandom
+
+-- | Generate a 'Salt' from @\/dev\/urandom@.
+genSaltDevURandom :: IO Salt
+genSaltDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do
+                      rawSalt <- B.hGet h 16
+                      return $ makeSalt rawSalt
+
+-- | Generate a 'Salt' from 'System.Random'.
+genSaltSysRandom :: IO Salt
+genSaltSysRandom = randomChars >>= return . makeSalt . B.pack
+    where randomChars = sequence $ replicate 16 $ randomRIO ('\NUL', '\255')
+
+-----------------------
+-- Password hash format
+-----------------------
+
+-- Format: "sha256|strength|salt|hash", where strength is an unsigned int, salt
+-- is a base64-encoded 16-byte random number, and hash is a base64-encoded hash
+-- value.
+
+-- | Try to parse a password hash.
+readPwHash :: ByteString -> Maybe (Int, Salt, ByteString)
+readPwHash pw | length broken /= 4
+                || algorithm /= "sha256"
+                || B.length hash /= 44 = Nothing
+              | otherwise = case B.readInt strBS of
+                              Just (strength, _) -> Just (strength, SaltBS salt, hash)
+                              Nothing -> Nothing
+    where broken = B.split '|' pw
+          [algorithm, strBS, salt, hash] = broken
+
+-- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where
+-- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded
+-- 'ByteString's.
+writePwHash :: (Int, Salt, ByteString) -> ByteString
+writePwHash (strength, SaltBS salt, hash) =
+    B.intercalate "|" ["sha256", B.pack (show strength), salt, hash]
+
+-----------------
+-- High level API
+-----------------
+
+-- | Hash a password with a given strength (14 is a good default). The output of
+-- this function can be written directly to a password file or
+-- database. Generates a salt using high-quality randomness from
+-- @\/dev\/urandom@ or (if that is not available, for example on Windows)
+-- 'System.Random', which is included in the hashed output.
+makePassword :: ByteString -> Int -> IO ByteString
+makePassword = makePasswordWith pbkdf1
+
+-- | A generic version of 'makePassword', which allow the user
+-- to choose the algorithm to use.
+--
+-- >>> makePasswordWith pbkdf1 "password" 14
+--
+makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
+                 -- ^ The algorithm to use (e.g. pbkdf1)
+                 -> ByteString
+                 -- ^ The password to encrypt
+                 -> Int
+                 -- ^ log2 of the number of iterations
+                 -> IO ByteString
+makePasswordWith algorithm password strength = do
+  salt <- genSaltIO
+  return $ makePasswordSaltWith algorithm (2^) password salt strength
+
+-- | A generic version of 'makePasswordSalt', meant to give the user
+-- the maximum control over the generation parameters.
+-- Note that, unlike 'makePasswordWith', this function takes the @raw@
+-- number of iterations. This means the user will need to specify a
+-- sensible value, typically @10000@ or @20000@.
+makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)
+                     -- ^ A function modeling an algorithm (e.g. 'pbkdf1')
+                     -> (Int -> Int)
+                     -- ^ A function to modify the strength
+                     -> ByteString
+                     -- ^ A password, given as clear text
+                     -> Salt
+                     -- ^ A hash 'Salt'
+                     -> Int
+                     -- ^ The password strength (e.g. @10000, 20000, etc.@)
+                     -> ByteString
+makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash (strength, salt, hash)
+    where hash = encode $ algorithm pwd salt (strengthModifier strength)
+
+-- | Hash a password with a given strength (14 is a good default), using a given
+-- salt. The output of this function can be written directly to a password file
+-- or database. Example:
+--
+-- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
+-- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
+makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
+makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
+
+-- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies
+-- the password @userInput@ given by the user against the stored password
+-- hash @pwHash@, with the hashing algorithm @algorithm@.  Returns 'True' if the
+-- given password is correct, and 'False' if it is not.
+-- This function allows the programmer to specify the algorithm to use,
+-- e.g. 'pbkdf1' or 'pbkdf2'.
+-- Note: If you want to verify a password previously generated with
+-- 'makePasswordSaltWith', but without modifying the number of iterations,
+-- you can do:
+--
+-- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."
+-- > True
+--
+verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)
+                   -- ^ A function modeling an algorithm (e.g. pbkdf1)
+                   -> (Int -> Int)
+                   -- ^ A function to modify the strength
+                   -> ByteString
+                   -- ^ User password
+                   -> ByteString
+                   -- ^ The generated hash (e.g. sha256|14...)
+                   -> Bool
+verifyPasswordWith algorithm strengthModifier userInput pwHash =
+    case readPwHash pwHash of
+      Nothing -> False
+      Just (strength, salt, goodHash) ->
+          encode (algorithm userInput salt (strengthModifier strength)) == goodHash
+
+-- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.
+verifyPassword :: ByteString -> ByteString -> Bool
+verifyPassword = verifyPasswordWith pbkdf1 (2^)
+
+-- | Try to strengthen a password hash, by hashing it some more
+-- times. @'strengthenPassword' pwHash new_strength@ will return a new password
+-- hash with strength at least @new_strength@. If the password hash already has
+-- strength greater than or equal to @new_strength@, then it is returned
+-- unmodified. If the password hash is invalid and does not parse, it will be
+-- returned without comment.
+--
+-- This function can be used to periodically update your password database when
+-- computers get faster, in order to keep up with Moore's law. This isn't hugely
+-- important, but it's a good idea.
+strengthenPassword :: ByteString -> Int -> ByteString
+strengthenPassword pwHash newstr =
+    case readPwHash pwHash of
+      Nothing -> pwHash
+      Just (oldstr, salt, hashB64) ->
+          if oldstr < newstr then
+              writePwHash (newstr, salt, newHash)
+          else
+              pwHash
+          where newHash = encode $ hashRounds hash extraRounds
+                extraRounds = (2^newstr) - (2^oldstr)
+                hash = decodeLenient hashB64
+
+-- | Return the strength of a password hash.
+passwordStrength :: ByteString -> Int
+passwordStrength pwHash = case readPwHash pwHash of
+                            Nothing               -> 0
+                            Just (strength, _, _) -> strength
+
+------------
+-- Utilities
+------------
+
+-- | A salt is a unique random value which is stored as part of the password
+-- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you
+-- really know what you're doing, you can create them from your own ByteString
+-- values with 'makeSalt'.
+newtype Salt = SaltBS ByteString
+    deriving (Show, Eq, Ord)
+
+-- | Create a 'Salt' from a 'ByteString'. The input must be at least 8
+-- characters, and can contain arbitrary bytes. Most users will not need to use
+-- this function.
+makeSalt :: ByteString -> Salt
+makeSalt = SaltBS . encode . check_length
+    where check_length salt | B.length salt < 8 =
+                                error "Salt too short. Minimum length is 8 characters."
+                            | otherwise = salt
+
+-- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be
+-- base64-encoded. Most users will not need to use this function.
+exportSalt :: Salt -> ByteString
+exportSalt (SaltBS bs) = bs
+
+-- | Convert a raw 'ByteString' into a 'Salt'.
+-- Use this function with caution, since using a weak salt will result in a
+-- weak password.
+importSalt :: ByteString -> Salt
+importSalt = SaltBS
+
+-- | Is the format of a password hash valid? Attempts to parse a given password
+-- hash. Returns 'True' if it parses correctly, and 'False' otherwise.
+isPasswordFormatValid :: ByteString -> Bool
+isPasswordFormatValid = isJust . readPwHash
+
+-- | Generate a 'Salt' with 128 bits of data taken from a given random number
+-- generator. Returns the salt and the updated random number generator. This is
+-- meant to be used with 'makePasswordSalt' by people who would prefer to either
+-- use their own random number generator or avoid the 'IO' monad.
+genSaltRandom :: (RandomGen b) => b -> (Salt, b)
+genSaltRandom gen = (salt, newgen)
+    where rands _ 0 = []
+          rands g n = (a, g') : rands g' (n-1 :: Int)
+              where (a, g') = randomR ('\NUL', '\255') g
+          salt   = makeSalt $ B.pack $ map fst (rands gen 16)
+          newgen = snd $ last (rands gen 16)
+
+#if !MIN_VERSION_base(4, 6, 0)
+-- | Strict version of 'modifySTRef'
+modifySTRef' :: STRef s a -> (a -> a) -> ST s ()
+modifySTRef' ref f = do
+    x <- readSTRef ref
+    let x' = f x
+    x' `seq` writeSTRef ref x'
+#endif
+
+#if MIN_VERSION_bytestring(0, 10, 0)
+toStrict :: BL.ByteString -> BS.ByteString
+toStrict = BL.toStrict
+
+fromStrict :: BS.ByteString -> BL.ByteString
+fromStrict = BL.fromStrict
+#else
+toStrict :: BL.ByteString -> BS.ByteString
+toStrict = BS.concat . BL.toChunks
+
+fromStrict :: BS.ByteString -> BL.ByteString
+fromStrict = BL.fromChunks . return
+#endif

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.3.0.4
+version:         1.3.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -45,7 +45,6 @@ library
                    , persistent-template     >= 1.2       && < 2.1
                    , http-conduit            >= 1.5
                    , aeson                   >= 0.5
-                   , pwstore-fast            >= 2.2
                    , lifted-base             >= 0.1
                    , blaze-html              >= 0.5
                    , blaze-markup            >= 0.5.1
@@ -57,6 +56,14 @@ library
                    , resourcet
                    , safe
                    , time
+                   , base64-bytestring
+                   , byteable
+                   , binary
+                   , http-client
+                   , blaze-builder
+                   , conduit
+                   , conduit-extra
+                   , attoparsec-conduit
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId
@@ -66,7 +73,9 @@ library
                      Yesod.Auth.Rpxnow
                      Yesod.Auth.Message
                      Yesod.Auth.GoogleEmail
+                     Yesod.Auth.GoogleEmail2
     other-modules:   Yesod.Auth.Routes
+                     Yesod.PasswordStore
     ghc-options:     -Wall
 
 source-repository head

yesod-bin/Devel.hs

@@ -77,9 +77,10 @@ import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
 #if MIN_VERSION_http_reverse_proxy(0, 2, 0)
 import qualified Network.HTTP.ReverseProxy             as ReverseProxy
 #endif
-import           Network.HTTP.Types                    (status200)
+import           Network.HTTP.Types                    (status200, status503)
 import           Network.Socket                        (sClose)
-import           Network.Wai                           (responseLBS)
+import           Network.Wai                           (responseLBS, requestHeaders)
+import           Network.Wai.Parse                     (parseHttpAccept)
 import           Network.Wai.Handler.Warp              (run)
 import           SrcLoc                                (Located)
 import           Data.FileEmbed        (embedFile)
@@ -135,11 +136,18 @@ reverseProxy opts iappPort = do
     manager <- newManager def
 #endif
     let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
-    let onExc _ _ = return $ responseLBS status200
+    let onExc _ req
-            [ ("content-type", "text/html")
+            | maybe False (("application/json" `elem`) . parseHttpAccept)
-            , ("Refresh", "1")
+                (lookup "accept" $ requestHeaders req) =
-            ]
+                    return $ responseLBS status503
-            refreshHtml
+                        [ ("Retry-After", "1")
+                        ]
+                        "{\"message\":\"Recompiling\"}"
+            | otherwise = return $ responseLBS status200
+                [ ("content-type", "text/html")
+                , ("Refresh", "1")
+                ]
+                refreshHtml
 
     let runProxy =
             run (develPort opts) $ waiProxyToSettings
@@ -207,7 +215,8 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
     putStrLn $ "Yesod devel server. "  ++ terminator ++ " to quit"
     void $ forkIO $ do
       filesModified <- newEmptyMVar
-      watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
+      void $ forkIO $
+        void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
       evalStateT (mainOuterLoop iappPort filesModified) Map.empty
     after
     writeLock opts
@@ -268,7 +277,10 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
                    liftIO $ I.writeIORef iappPort appPort
 
                    (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
-                        { env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0
+                        { env = Just $ Map.toList
+                                     $ Map.insert "PORT" (show appPort)
+                                     $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
+                                     $ Map.fromList env0
                         }
                    derefMap <- get
                    watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
@@ -410,7 +422,7 @@ failWith msg = do
     exitFailure
 
 checkFileList :: FileList -> D.Library -> [FilePath]
-checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
+checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
   where
     al = allModules lib
     -- a file is only a possible 'module file' if all path pieces start with a capital letter
@@ -420,6 +432,12 @@ checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
     isUnlisted file = not (toModuleName file `Set.member` al)
     toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension
 
+    isSetup "Setup.hs" = True
+    isSetup "./Setup.hs" = True
+    isSetup "Setup.lhs" = True
+    isSetup "./Setup.lhs" = True
+    isSetup _ = False
+
 allModules :: D.Library -> Set.Set String
 allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
     where

yesod-bin/Keter.hs

@@ -62,7 +62,10 @@ keter cabal noBuild = do
     L.writeFile fp $ compress $ Tar.write archive
 
     case Map.lookup "copy-to" value of
-        Just (String s) -> run "scp" [fp, T.unpack s]
+        Just (String s) ->
+            case parseMaybe (.: "copy-to-port") value of
+                Just i -> run "scp" ["-P" ++ show (i :: Int), fp, T.unpack s]
+                Nothing -> run "scp" [fp, T.unpack s]
         _ -> return ()
 
 try' :: IO a -> IO (Either SomeException a)

yesod-bin/hsfiles/mongo.hsfiles

@@ -175,7 +175,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
-        (120 * 60) -- 120 minutes
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     defaultLayout widget = do

yesod-bin/hsfiles/mysql.hsfiles

@@ -182,7 +182,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
-        (120 * 60) -- 120 minutes
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     defaultLayout widget = do

yesod-bin/hsfiles/postgres-fay.hsfiles

@@ -186,7 +186,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
-        (120 * 60) -- 120 minutes
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     defaultLayout widget = do

yesod-bin/hsfiles/postgres.hsfiles

@@ -182,7 +182,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
-        (120 * 60) -- 120 minutes
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     defaultLayout widget = do

yesod-bin/hsfiles/simple.hsfiles

@@ -160,7 +160,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
-        (120 * 60) -- 120 minutes
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     defaultLayout widget = do

yesod-bin/hsfiles/sqlite.hsfiles

@@ -182,7 +182,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
-        (120 * 60) -- 120 minutes
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     defaultLayout widget = do

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.2.8.1
+version:         1.2.9.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -75,7 +75,7 @@ executable             yesod
                      , unordered-containers
                      , yaml               >= 0.8          && < 0.9
                      , optparse-applicative >= 0.5
-                     , fsnotify           >= 0.0          && < 0.1
+                     , fsnotify           >= 0.0          && < 0.2
                      , split              >= 0.2          && < 0.3
                      , file-embed
                      , conduit            >= 0.5          && < 1.2
@@ -91,10 +91,11 @@ executable             yesod
                      , transformers
                      , warp               >= 1.3.7.5
                      , wai                >= 1.4
+                     , wai-extra
                      , data-default-class
                      , streaming-commons
 
-    ghc-options:       -Wall -threaded
+    ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs
     other-modules:     Scaffolding.Scaffolder
                        Devel

yesod-core/Yesod/Core/Types.hs

@@ -17,6 +17,9 @@ import           Control.Exception                  (Exception)
 import           Control.Monad                      (liftM, ap)
 import           Control.Monad.Base                 (MonadBase (liftBase))
 import           Control.Monad.Catch                (MonadCatch (..))
+#if MIN_VERSION_exceptions(0,6,0)
+import           Control.Monad.Catch                (MonadMask (..))
+#endif
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel, LogSource,
                                                      MonadLogger (..))
@@ -419,6 +422,9 @@ instance MonadThrow m => MonadThrow (WidgetT site m) where
 
 instance MonadCatch m => MonadCatch (HandlerT site m) where
   catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
+#if MIN_VERSION_exceptions(0,6,0)
+instance MonadMask m => MonadMask (HandlerT site m) where
+#endif
   mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
     where q u (HandlerT b) = HandlerT (u . b)
   uninterruptibleMask a =
@@ -426,6 +432,9 @@ instance MonadCatch m => MonadCatch (HandlerT site m) where
       where q u (HandlerT b) = HandlerT (u . b)
 instance MonadCatch m => MonadCatch (WidgetT site m) where
   catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
+#if MIN_VERSION_exceptions(0,6,0)
+instance MonadMask m => MonadMask (WidgetT site m) where
+#endif
   mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
     where q u (WidgetT b) = WidgetT (u . b)
   uninterruptibleMask a =

yesod-core/Yesod/Core/Widget.hs

@@ -83,10 +83,16 @@ instance render ~ RY site => ToWidget site (render -> Html) where
     toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
 instance render ~ RY site => ToWidget site (render -> Css) where
     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
+instance ToWidget site Css where
+    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidget site (render -> CssBuilder) where
     toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
+instance ToWidget site CssBuilder where
+    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
 instance render ~ RY site => ToWidget site (render -> Javascript) where
     toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
+instance ToWidget site Javascript where
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
 instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
     toWidget = liftWidgetT
 instance ToWidget site Html where
@@ -105,8 +111,12 @@ class ToWidgetMedia site a where
                   -> m ()
 instance render ~ RY site => ToWidgetMedia site (render -> Css) where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
+instance ToWidgetMedia site Css where
+    toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
     toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
+instance ToWidgetMedia site CssBuilder where
+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
 
 class ToWidgetBody site a where
     toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
@@ -115,6 +125,8 @@ instance render ~ RY site => ToWidgetBody site (render -> Html) where
     toWidgetBody = toWidget
 instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
     toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
+instance ToWidgetBody site Javascript where
+    toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
 instance ToWidgetBody site Html where
     toWidgetBody = toWidget
 
@@ -125,10 +137,16 @@ instance render ~ RY site => ToWidgetHead site (render -> Html) where
     toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
 instance render ~ RY site => ToWidgetHead site (render -> Css) where
     toWidgetHead = toWidget
+instance ToWidgetHead site Css where
+    toWidgetHead = toWidget
 instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
     toWidgetHead = toWidget
+instance ToWidgetHead site CssBuilder where
+    toWidgetHead = toWidget
 instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
     toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
+instance ToWidgetHead site Javascript where
+    toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
 instance ToWidgetHead site Html where
     toWidgetHead = toWidgetHead . const
 

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.2.14
+version:         1.2.15.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

yesod-form/Yesod/Form/Fields.hs

@@ -84,7 +84,10 @@ import Database.Persist (PersistMonadBackend, PersistEntityBackend)
 import Text.Blaze.Html.Renderer.String (renderHtml)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
-import Data.Text as T (Text, concat, intercalate, unpack, pack, splitOn)
+import Data.Text as T ( Text, append, concat, cons, head
+                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
+                      )
+import qualified Data.Text as T (drop, dropWhile)  
 import qualified Data.Text.Read
 
 import qualified Data.Map as Map
@@ -121,7 +124,7 @@ $newline never
 doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
 doubleField = Field
     { fieldParse = parseHelper $ \s ->
-        case Data.Text.Read.double s of
+        case Data.Text.Read.double (prependZero s) of
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidNumber s
 
@@ -174,7 +177,7 @@ $newline never
 -- | A newtype wrapper around a 'Text' that converts newlines to HTML
 -- br-tags.
 newtype Textarea = Textarea { unTextarea :: Text }
-    deriving (Show, Read, Eq, PersistField, Ord)
+    deriving (Show, Read, Eq, PersistField, Ord, ToJSON, FromJSON)
 instance PersistFieldSql Textarea where
     sqlType _ = SqlString
 instance ToHtml Textarea where
@@ -735,3 +738,19 @@ $newline never
 incrInts :: Ints -> Ints
 incrInts (IntSingle i) = IntSingle $ i + 1
 incrInts (IntCons i is) = (i + 1) `IntCons` is
+
+
+-- | Adds a '0' to some text so that it may be recognized as a double.
+--   The read ftn does not recognize ".3" as 0.3 nor "-.3" as -0.3, so this
+--   function changes ".xxx" to "0.xxx" and "-.xxx" to "-0.xxx"
+
+prependZero :: Text -> Text
+prependZero t0 = if T.null t1
+                 then t1
+                 else if T.head t1 == '.'
+                      then '0' `T.cons` t1
+                      else if "-." `T.isPrefixOf` t1
+                           then "-0." `T.append` (T.drop 2 t1)
+                           else t1
+
+  where t1 = T.dropWhile ((==) ' ') t0

yesod-form/Yesod/Form/Functions.hs

@@ -186,7 +186,7 @@ runFormGeneric :: Monad m
                -> [Text]
                -> Maybe (Env, FileEnv)
                -> m (a, Enctype)
-runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 1)
+runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0)
 
 -- | This function is used to both initially render a form and to later extract
 -- results from it. Note that, due to CSRF protection and a few other issues,

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         1.3.8.2
+version:         1.3.9
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -17,7 +17,7 @@ library
                    , yesod-core            >= 1.2      && < 1.3
                    , yesod-persistent      >= 1.2      && < 1.3
                    , time                  >= 1.1.4
-                   , hamlet                >= 1.1
+                   , hamlet                >= 1.1.8
                    , shakespeare
                    , shakespeare-css       >= 1.0
                    , shakespeare-js        >= 1.0.2

yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Manipulate CSS urls.
+--
+-- * Make relative urls absolute (useful when combining assets)
+module Yesod.EmbeddedStatic.Css.AbsoluteUrl (
+  -- * Absolute urls
+    absoluteUrls
+  , absoluteUrlsAt
+  , absoluteUrlsWith
+  , absCssUrlsFileProd
+  , absCssUrlsProd
+) where
+
+import Prelude hiding (FilePath)
+import Yesod.EmbeddedStatic.Generators
+import Yesod.EmbeddedStatic.Types
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy.Encoding as TL
+import Control.Monad ((>=>))
+import Data.Maybe (fromMaybe)
+import Filesystem.Path.CurrentOS ((</>), collapse, FilePath, fromText, toText, encodeString, decodeString)
+
+import Yesod.EmbeddedStatic.Css.Util
+
+-------------------------------------------------------------------------------
+-- Generator
+-------------------------------------------------------------------------------
+
+-- | Anchors relative CSS image urls
+absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here
+                     -> FilePath
+                     -> IO BL.ByteString
+absCssUrlsFileProd dir file = do
+    contents <- T.readFile (encodeString file)
+    return $ TL.encodeUtf8 $ absCssUrlsProd dir contents
+
+absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here
+               -> T.Text
+               -> TL.Text
+absCssUrlsProd dir contents =
+    let css = either error id $ parseCssUrls contents
+    in  renderCssWith toAbsoluteUrl css
+  where
+    toAbsoluteUrl (UrlReference rel) = T.concat
+        [ "url('/"
+        , (either id id $ toText $ collapse $ dir </> fromText rel)
+        , "')"
+        ]
+
+
+-- | Equivalent to passing the same string twice to 'absoluteUrlsAt'.
+absoluteUrls :: FilePath -> Generator
+absoluteUrls f = absoluteUrlsAt (encodeString f) f
+
+-- | Equivalent to passing @return@ to 'absoluteUrlsWith'.
+absoluteUrlsAt :: Location -> FilePath -> Generator
+absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing
+
+-- | Automatically make relative urls absolute
+--
+-- During development, leave CSS as is.
+--
+-- When CSS is organized into a directory structure, it will work properly for individual requests for each file.
+-- During production, we want to combine and minify CSS as much as possible.
+-- The combination process combines files from different directories, messing up relative urls.
+-- This pre-processor makes relative urls absolute
+absoluteUrlsWith ::
+    Location -- ^ The location the CSS file should appear in the static subsite
+  -> FilePath -- ^ Path to the CSS file.
+  -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter.
+                     -> Generator
+absoluteUrlsWith loc file mpostFilter =
+    return [ cssProductionFilter (absCssUrlsFileProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file
+    ]
+  where
+    postFilter = fromMaybe (return . cssContent) mpostFilter

yesod-static/Yesod/EmbeddedStatic/Css/Util.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-}
+module Yesod.EmbeddedStatic.Css.Util where
+
+import Prelude hiding (FilePath)
+import Control.Applicative
+import Control.Monad (void, foldM)
+import Data.Hashable (Hashable)
+import Data.Monoid
+import Network.Mime (MimeType, defaultMimeLookup)
+import Filesystem.Path.CurrentOS (FilePath, directory, (</>), dropExtension, filename, toText, decodeString, encodeString, fromText, absolute)
+import Text.CSS.Parse (parseBlocks)
+import Language.Haskell.TH (litE, stringL)
+import Text.CSS.Render (renderBlocks)
+import Yesod.EmbeddedStatic.Types
+import Yesod.EmbeddedStatic (pathToName)
+import Data.Default (def)
+
+import qualified Blaze.ByteString.Builder as B
+import qualified Blaze.ByteString.Builder.Char.Utf8 as B
+import qualified Data.Attoparsec.Text as P
+import qualified Data.Attoparsec.ByteString.Lazy as PBL
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.HashMap.Lazy as M
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TL
+
+-------------------------------------------------------------------------------
+-- Loading CSS
+-------------------------------------------------------------------------------
+
+-- | In the parsed CSS, this will be an image reference that we want to replace.
+-- the contents will be the filepath.
+newtype UrlReference = UrlReference T.Text
+    deriving (Show, Eq, Hashable, Ord)
+
+type EithUrl = (T.Text, Either T.Text UrlReference)
+
+-- | The parsed CSS
+type Css = [(T.Text, [EithUrl])]
+
+-- | Parse the filename out of url('filename')
+parseUrl :: P.Parser T.Text
+parseUrl = do
+    P.skipSpace
+    void $ P.string "url('"
+    P.takeTill (== '\'')
+
+checkForUrl :: T.Text -> T.Text -> EithUrl
+checkForUrl n@("background-image") v = parseBackgroundImage n v
+checkForUrl n@("src") v = parseBackgroundImage n v
+checkForUrl n v = (n, Left v)
+
+-- | Check if a given CSS attribute is a background image referencing a local file
+checkForImage :: T.Text -> T.Text -> EithUrl
+checkForImage n@("background-image") v = parseBackgroundImage n v
+checkForImage n v = (n, Left v)
+
+parseBackgroundImage :: T.Text -> T.Text -> EithUrl
+parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of
+    Left _ -> Left v -- Can't parse url
+    Right url -> -- maybe we should find a uri parser
+        if any (`T.isPrefixOf` url) ["http://", "https://", "//"] || absolute (fromText url)
+            then Left v
+            else Right $ UrlReference url)
+
+parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css
+parseCssWith urlParser contents =
+    let mparsed = parseBlocks contents in
+    case mparsed of
+        Left err -> Left err
+        Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]
+
+parseCssUrls :: T.Text -> Either String Css
+parseCssUrls = parseCssWith checkForUrl
+
+parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css
+parseCssFileWith urlParser fp = do
+    mparsed <- parseCssWith urlParser <$> T.readFile (encodeString fp)
+    case mparsed of
+        Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err
+        Right css -> return css
+
+parseCssFileUrls :: FilePath -> IO Css
+parseCssFileUrls = parseCssFileWith checkForUrl
+
+renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text
+renderCssWith urlRenderer css =
+    TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css]
+  where
+    render (n, Left b) = (n, b)
+    render (n, Right f) = (n, urlRenderer f)
+
+-- | Load an image map from the images in the CSS
+loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a)
+loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css]
+    where
+        load imap (Left _) = return imap
+        load imap (Right f) | f `M.member` imap = return imap
+        load imap (Right f@(UrlReference path)) = do
+            img <- loadImage (dir </> fromText path)
+            return $ maybe imap (\i -> M.insert f i imap) img
+
+
+-- | If you tack on additional CSS post-processing filters, they use this as an argument.
+data CssGeneration = CssGeneration {
+                       cssContent :: BL.ByteString
+                     , cssStaticLocation :: Location
+                     , cssFileLocation :: FilePath
+                     }
+
+mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration
+mkCssGeneration loc file content =
+    CssGeneration { cssContent = content
+                  , cssStaticLocation = loc
+                  , cssFileLocation = file
+                  }
+
+cssProductionFilter ::
+       (FilePath ->  IO BL.ByteString) -- ^ a filter to be run on production
+     -> Location -- ^ The location the CSS file should appear in the static subsite
+     -> FilePath -- ^ Path to the CSS file.
+     -> Entry
+cssProductionFilter prodFilter loc file =
+    def { ebHaskellName = Just $ pathToName loc
+        , ebLocation = loc
+        , ebMimeType = "text/css"
+        , ebProductionContent = prodFilter file
+        , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]
+        , ebDevelExtraFiles = Nothing
+        }
+
+cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry
+cssProductionImageFilter prodFilter loc file =
+  (cssProductionFilter prodFilter loc file)
+    { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]
+    , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |]
+    }
+
+-------------------------------------------------------------------------------
+-- Helpers for the generators
+-------------------------------------------------------------------------------
+
+-- For development, all we need to do is update the background-image url to base64 encode it.
+-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse
+-- using css-parse.  Instead we write a simple custom parser.
+
+parseBackground :: Location -> FilePath -> PBL.Parser B.Builder
+parseBackground loc file = do
+    void $ PBL.string "background-image"
+    s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
+    void $ PBL.word8 58 -- colon
+    s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
+    void $ PBL.string "url('"
+    url <- PBL.takeWhile (/= 39) -- single quote
+    void $ PBL.string "')"
+
+    let b64 = B64.encode $ T.encodeUtf8 (either id id $ toText (directory file)) <> url
+        newUrl = B.fromString (encodeString $ filename $ decodeString loc) <> B.fromString "/" <> B.fromByteString b64
+
+    return $ B.fromByteString "background-image"
+          <> B.fromByteString s1
+          <> B.fromByteString ":"
+          <> B.fromByteString s2
+          <> B.fromByteString "url('"
+          <> newUrl
+          <> B.fromByteString "')"
+
+parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder
+parseDev loc file b = do
+    b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8)
+    (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b')
+
+develPassThrough :: Location -> FilePath -> IO BL.ByteString
+develPassThrough _ = BL.readFile . encodeString
+
+-- | Create the CSS during development
+develBgImgB64 :: Location -> FilePath -> IO BL.ByteString
+develBgImgB64 loc file = do
+    ct <- BL.readFile $ encodeString file
+    case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of
+        Left err -> error err
+        Right b -> return $ B.toLazyByteString b
+
+-- | Serve the extra image files during development
+develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
+develExtraFiles loc parts =
+    case reverse parts of
+        (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do
+            let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ either id id $ toText $ dropExtension $ fromText file
+            ct <- BL.readFile $ T.unpack file'
+            return $ Just (defaultMimeLookup file', ct)
+        _ -> return Nothing

yesod-static/yesod-static.cabal

@@ -1,5 +1,5 @@
 name:            yesod-static
-version:         1.2.2.5
+version:         1.2.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -56,12 +56,19 @@ library
                    , process
                    , async
 
+                   , attoparsec            >= 0.10
+                   , blaze-builder         >= 0.3
+                   , css-text              >= 0.1.2
+                   , hashable              >= 1.1
+
     exposed-modules: Yesod.Static
                      Yesod.EmbeddedStatic
                      Yesod.EmbeddedStatic.Generators
                      Yesod.EmbeddedStatic.Types
+                     Yesod.EmbeddedStatic.Css.AbsoluteUrl
 
     other-modules:   Yesod.EmbeddedStatic.Internal
+                     Yesod.EmbeddedStatic.Css.Util
 
     ghc-options:     -Wall
     extensions: TemplateHaskell

yesod-test/Yesod/Test.hs

@@ -75,6 +75,7 @@ module Yesod.Test
     , bodyContains
     , htmlAllContain
     , htmlAnyContain
+    , htmlNoneContain
     , htmlCount
 
     -- * Grab information
@@ -319,7 +320,7 @@ assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
 bodyEquals :: String -> YesodExample site ()
 bodyEquals text = withResponse $ \ res ->
   liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $
-    (simpleBody res) == BSL8.pack text
+    (simpleBody res) == encodeUtf8 (TL.pack text)
 
 -- | Assert the last response has the given text. The check is performed using the response
 -- body in full text form.
@@ -329,7 +330,7 @@ bodyContains text = withResponse $ \ res ->
     (simpleBody res) `contains` text
 
 contains :: BSL8.ByteString -> String -> Bool
-contains a b = DL.isInfixOf b (BSL8.unpack a)
+contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)
 
 -- | Queries the html using a css selector, and all matched elements must contain
 -- the given string.
@@ -353,6 +354,19 @@ htmlAnyContain query search = do
     _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $
           DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
 
+-- | Queries the html using a css selector, and fails if any matched
+-- element contains the given string (in other words, it is the logical
+-- inverse of htmlAnyContains).
+--
+-- Since 1.2.2
+htmlNoneContain :: Query -> String -> YesodExample site ()
+htmlNoneContain query search = do
+  matches <- htmlQuery query
+  case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
+    [] -> return ()
+    found -> failure $ "Found " <> T.pack (show $ length found) <>
+                " instances of " <> T.pack search <> " in " <> query <> " elements"
+
 -- | Performs a css query on the last response and asserts the matched elements
 -- are as many as expected.
 htmlCount :: Query -> Int -> YesodExample site ()
@@ -364,7 +378,7 @@ htmlCount query count = do
 -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec)
 printBody :: YesodExample site ()
 printBody = withResponse $ \ SResponse { simpleBody = b } ->
-  liftIO $ hPutStrLn stderr $ BSL8.unpack b
+  liftIO $ BSL8.hPutStrLn stderr b
 
 -- | Performs a CSS query and print the matches to stderr.
 printMatches :: Query -> YesodExample site ()
@@ -504,7 +518,7 @@ setUrl url' = do
     let (urlPath, urlQuery) = T.break (== '?') url
     ST.modify $ \rbd -> rbd
         { rbdPath =
-            case DL.filter (/="") $ T.split (== '/') urlPath of
+            case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
                 ("http:":_:rest) -> rest
                 ("https:":_:rest) -> rest
                 x -> x
@@ -539,7 +553,9 @@ request reqBuilder = do
       , rbdGets = []
       , rbdHeaders = []
       }
-    let path = T.cons '/' $ T.intercalate "/" rbdPath
+    let path
+            | null rbdPath = "/"
+            | otherwise = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath
 
     -- expire cookies and filter them for the current path. TODO: support max age
     currentUtc <- liftIO getCurrentTime
@@ -644,7 +660,7 @@ request reqBuilder = do
       , remoteHost = Sock.SockAddrInet 1 2
       , requestHeaders = headers ++ extraHeaders
       , rawPathInfo = TE.encodeUtf8 urlPath
-      , pathInfo = DL.filter (/="") $ T.split (== '/') urlPath
+      , pathInfo = H.decodePathSegments $ TE.encodeUtf8 urlPath
       , rawQueryString = H.renderQuery False urlQuery
       , queryString = urlQuery
       }

yesod-test/test/main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 import Test.HUnit hiding (Test)
@@ -13,6 +14,8 @@ import Text.XML
 import Data.Text (Text)
 import Data.Monoid ((<>))
 import Control.Applicative
+import Network.Wai (pathInfo)
+import Data.Maybe (fromMaybe)
 
 import Data.ByteString.Lazy.Char8 ()
 import qualified Data.Map as Map
@@ -106,6 +109,39 @@ main = hspec $ do
                     addNonce
                 statusIs 200
                 bodyEquals "12345"
+            yit "finding html" $ do
+                get ("/html" :: Text)
+                statusIs 200
+                htmlCount "p" 2
+                htmlAllContain "p" "Hello"
+                htmlAnyContain "p" "World"
+                htmlAnyContain "p" "Moon"
+                htmlNoneContain "p" "Sun"
+
+        ydescribe "utf8 paths" $ do
+            yit "from path" $ do
+                get ("/dynamic1/שלום" :: Text)
+                statusIs 200
+                bodyEquals "שלום"
+            yit "from path, type-safe URL" $ do
+                get $ LiteAppRoute ["dynamic1", "שלום"]
+                statusIs 200
+                printBody
+                bodyEquals "שלום"
+            yit "from WAI" $ do
+                get ("/dynamic2/שלום" :: Text)
+                statusIs 200
+                bodyEquals "שלום"
+    describe "cookies" $ yesodSpec cookieApp $ do
+        yit "should send the cookie #730" $ do
+            get ("/" :: Text)
+            statusIs 200
+            post ("/cookie/foo" :: Text)
+            statusIs 302
+            get ("/" :: Text)
+            statusIs 200
+            printBody
+            bodyContains "Foo"
 
 instance RenderMessage LiteApp FormMessage where
     renderMessage _ _ = defaultFormMessage
@@ -117,6 +153,10 @@ app = liteApp $ do
         case mfoo of
             Nothing -> return "Hello world!"
             Just foo -> return $ "foo=" <> foo
+    onStatic "dynamic1" $ withDynamic $ \d -> dispatchTo $ return (d :: Text)
+    onStatic "dynamic2" $ onStatic "שלום" $ dispatchTo $ do
+        req <- waiRequest
+        return $ pathInfo req !! 1
     onStatic "post" $ dispatchTo $ do
         mfoo <- lookupPostParam "foo"
         case mfoo of
@@ -131,3 +171,15 @@ app = liteApp $ do
         case mfoo of
             FormSuccess (foo, _) -> return $ toHtml foo
             _ -> defaultLayout widget
+    onStatic "html" $ dispatchTo $
+        return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)
+
+
+cookieApp :: LiteApp
+cookieApp = liteApp $ do
+    dispatchTo $ fromMaybe "no message available" <$> getMessage
+    onStatic "cookie" $ do
+        onStatic "foo" $ dispatchTo $ do
+            setMessage "Foo"
+            redirect ("/cookie/home" :: Text)
+            return ()

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.2.1.2
+version:            1.2.2
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
@@ -59,6 +59,7 @@ test-suite test
                           , yesod-core
                           , yesod-form
                           , text
+                          , wai
 
 source-repository head
   type: git