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

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

Browse Source
This commit is contained in:
Michael Snoyman 2014-06-01 16:12:36 +03:00
commit 0a3ae4ef66
26 changed files with 1105 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
yesod-auth/Yesod/Auth/Email.hs
View File

@ -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}>
<a href="@{tm registerR}">I don't have an account
<button type=submit .btn .btn-success>
_{Msg.LoginViaEmail}
&nbsp;
<a href="@{tm registerR}" .btn .btn-default>
_{Msg.RegisterLong}
|]
where
dispatch "GET" ["register"] = getRegisterR >>= sendResponse

196
yesod-auth/Yesod/Auth/GoogleEmail2.hs Normal file
View File

@ -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"

17
yesod-auth/Yesod/Auth/Message.hs
View File

@ -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 InvalidEmailAddress = "Invalid email address provided"
frenchMessage PasswordResetTitle = "Password Reset"
frenchMessage ProvideIdentifier = "Email or Username"
frenchMessage SendPasswordResetEmail = "Send password reset email"
frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
frenchMessage InvalidUsernamePass = "Invalid username/password combination"
-- TODO
frenchMessage i@(IdentifierNotFound _) = englishMessage i
frenchMessage NoIdentifierProvided = "Adresse électronique/nom d'utilisateur non spécifié"
frenchMessage InvalidEmailAddress = "Adresse électronique spécifiée invalide"
frenchMessage PasswordResetTitle = "Réinitialisation de mot de passe"
frenchMessage ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"
frenchMessage SendPasswordResetEmail = "Envoie d'un message électronique pour Réinitialisation le mot de passe"
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 = "Le couble nom d'utilisateur/mot de passe invalide"
frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident
norwegianBokmålMessage :: AuthMessage -> Text
norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"

429
yesod-auth/Yesod/PasswordStore.hs Executable file
View File

@ -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

13
yesod-auth/yesod-auth.cabal
View File

@ -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

38
yesod-bin/Devel.hs
View File

@ -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
[ ("content-type", "text/html")
, ("Refresh", "1")
]
refreshHtml
let onExc _ req
| maybe False (("application/json" `elem`) . parseHttpAccept)
(lookup "accept" $ requestHeaders req) =
return $ responseLBS status503
[ ("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

5
yesod-bin/Keter.hs
View File

@ -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)

2
yesod-bin/hsfiles/mongo.hsfiles
View File

@ -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

2
yesod-bin/hsfiles/mysql.hsfiles
View File

@ -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

2
yesod-bin/hsfiles/postgres-fay.hsfiles
View File

@ -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

2
yesod-bin/hsfiles/postgres.hsfiles
View File

@ -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

2
yesod-bin/hsfiles/simple.hsfiles
View File

@ -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

2
yesod-bin/hsfiles/sqlite.hsfiles
View File

@ -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

7
yesod-bin/yesod-bin.cabal
View File

@ -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

9
yesod-core/Yesod/Core/Types.hs
View File

@ -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 =

18
yesod-core/Yesod/Core/Widget.hs
View File

@ -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

2
yesod-core/yesod-core.cabal
View File

@ -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>

25
yesod-form/Yesod/Form/Fields.hs
View File

@ -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

2
yesod-form/Yesod/Form/Functions.hs
View File

@ -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,

4
yesod-form/yesod-form.cabal
View File

@ -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

80
yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs Normal file
View File

@ -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

196
yesod-static/Yesod/EmbeddedStatic/Css/Util.hs Normal file
View File

@ -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

9
yesod-static/yesod-static.cabal
View File

@ -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

28
yesod-test/Yesod/Test.hs
View File

@ -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
}

52
yesod-test/test/main.hs
View File

@ -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 ()

3
yesod-test/yesod-test.cabal
View File

@ -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