Merge branch 'master' into auth-json-2

Conflicts:
	yesod-auth/Yesod/Auth.hs
	yesod-auth/Yesod/Auth/Email.hs
	yesod-auth/yesod-auth.cabal

.gitignore

@@ -1,3 +1,4 @@
+*~
 *.o
 *.o_p
 *.hi
@@ -10,5 +11,8 @@ yesod/foobar/
 .cabal-sandbox/
 cabal.sandbox.config
 /vendor/
-/.shelly/
+.shelly/
-/tarballs/
+tarballs/
+*.swp
+dist
+client_session_key.aes

.travis.yml

@@ -9,3 +9,5 @@ script:
     - echo Done
     - cabal-meta install --enable-tests
     - mega-sdist --test
+    - cabal install mega-sdist hspec cabal-meta cabal-src
+    - cabal-meta install --force-reinstalls

README

@@ -0,0 +1,15 @@
+Authentication methods for Haskell web applications.
+
+Note for Rpxnow: 
+By default on some (all?) installs wget does not come with root certificates
+for SSL.  If this is the case then Web.Authenticate.Rpxnow.authenticate will
+fail as wget cannot establish a secure connection to rpxnow's servers.
+
+A simple *nix solution, if potentially insecure (man in the middle attacks as
+you are downloading the certs) is to grab a copy of the certs extracted from
+those that come with firefox, hosted by CURL at
+http://curl.haxx.se/ca/cacert.pem , put them somewhere (for ex,
+~/.wget/cacert.pem) and then edit your ~/.wgetrc to include:
+ca_certificate=~/.wget/cacert.pem
+
+This should fix the problem.

authenticate-oauth/.gitignore

@@ -0,0 +1,6 @@
+.DS_Store
+*.hi
+*.o
+dist
+*~
+cabal-dev

authenticate-oauth/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2008, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

authenticate-oauth/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

authenticate-oauth/Web/Authenticate/OAuth.hs

@@ -0,0 +1,455 @@
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+module Web.Authenticate.OAuth
+    ( -- * Data types
+      OAuth, def, newOAuth, oauthServerName, oauthRequestUri, oauthAccessTokenUri,
+      oauthAuthorizeUri, oauthSignatureMethod, oauthConsumerKey,
+      oauthConsumerSecret, oauthCallback, oauthRealm, oauthVersion,
+      OAuthVersion(..), SignMethod(..), Credential(..), OAuthException(..),
+      -- * Operations for credentials
+      newCredential, emptyCredential, insert, delete, inserts, injectVerifier,
+      -- * Signature
+      signOAuth, genSign,
+      -- * Url & operation for authentication
+      authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential,
+      getTokenCredential, getTemporaryCredentialWithScope,
+      getAccessTokenProxy, getTemporaryCredentialProxy,
+      getTokenCredentialProxy, 
+      getAccessToken', getTemporaryCredential',
+      -- * Utility Methods
+      paramEncode, addScope, addMaybeProxy
+    ) where
+import Network.HTTP.Conduit
+import Data.Data
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import Data.Maybe
+import Network.HTTP.Types (parseSimpleQuery, SimpleQuery)
+import Control.Exception
+import Control.Monad
+import Data.List (sortBy)
+import System.Random
+import Data.Char
+import Data.Digest.Pure.SHA
+import Data.ByteString.Base64
+import Data.Time
+import Numeric
+#if MIN_VERSION_RSA(2, 0, 0)
+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1)
+#else
+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1)
+#endif
+import Crypto.Types.PubKey.RSA (PrivateKey(..), PublicKey(..))
+import Network.HTTP.Types (Header)
+import Blaze.ByteString.Builder (toByteString)
+import Control.Monad.IO.Class (MonadIO)
+import Network.HTTP.Types (renderSimpleQuery, status200)
+import Data.Conduit (($$), ($=), Source)
+import qualified Data.Conduit.List as CL
+import Data.Conduit.Blaze (builderToByteString)
+import Blaze.ByteString.Builder (Builder)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Resource
+import Data.Default
+import qualified Data.IORef as I
+
+-- | Data type for OAuth client (consumer).
+-- 
+-- The constructor for this data type is not exposed. 
+-- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance, 
+-- and then use the records below to make modifications.
+-- This approach allows us to add configuration options without breaking backwards compatibility.
+data OAuth = OAuth { oauthServerName      :: String -- ^ Service name (default: @\"\"@)
+                   , oauthRequestUri      :: String
+                   -- ^ URI to request temporary credential (default: @\"\"@).
+                   --   You MUST specify if you use 'getTemporaryCredential'', 'getTemporaryCredentialProxy'
+                   --   or 'getTemporaryCredential'; otherwise you can just leave this empty.
+                   , oauthAccessTokenUri  :: String
+                   -- ^ Uri to obtain access token (default: @\"\"@).
+                   --   You MUST specify if you use 'getAcessToken' or 'getAccessToken'';
+                   --   otherwise you can just leave this empty.
+                   , oauthAuthorizeUri    :: String
+                   -- ^ Uri to authorize (default: @\"\"@).
+                   --   You MUST specify if you use 'authorizeUrl' or 'authorizeZUrl'';
+                   --   otherwise you can just leave this empty. 
+                   , oauthSignatureMethod :: SignMethod
+                   -- ^ Signature Method (default: 'HMACSHA1')
+                   , oauthConsumerKey     :: BS.ByteString
+                   -- ^ Consumer key (You MUST specify)
+                   , oauthConsumerSecret  :: BS.ByteString
+                   -- ^ Consumer Secret (You MUST specify)
+                   , oauthCallback        :: Maybe BS.ByteString
+                   -- ^ Callback uri to redirect after authentication (default: @Nothing@)
+                   , oauthRealm           :: Maybe BS.ByteString
+                   -- ^ Optional authorization realm (default: @Nothing@)
+                   , oauthVersion         :: OAuthVersion
+                   -- ^ OAuth spec version (default: 'OAuth10a')
+                   } deriving (Show, Eq, Ord, Read, Data, Typeable)
+
+data OAuthVersion = OAuth10     -- ^ OAuth protocol ver 1.0 (no oauth_verifier; differs from RFC 5849).
+                  | OAuth10a    -- ^ OAuth protocol ver 1.0a. This corresponds to community's 1.0a spec and RFC 5849.
+                    deriving (Show, Eq, Ord, Data, Typeable, Read)
+
+-- | Default value for OAuth datatype.
+-- You must specify at least oauthServerName, URIs and Tokens.
+newOAuth :: OAuth
+newOAuth = OAuth { oauthSignatureMethod = HMACSHA1
+                 , oauthCallback = Nothing
+                 , oauthRealm    = Nothing
+                 , oauthServerName = ""
+                 , oauthRequestUri = ""
+                 , oauthAccessTokenUri = ""
+                 , oauthAuthorizeUri = ""
+                 , oauthConsumerKey = error "You MUST specify oauthConsumerKey parameter."
+                 , oauthConsumerSecret = error "You MUST specify oauthConsumerSecret parameter."
+                 , oauthVersion = OAuth10a
+                 }
+
+instance Default OAuth where
+  def = newOAuth
+
+-- | Data type for signature method.
+data SignMethod = PLAINTEXT
+                | HMACSHA1
+                | RSASHA1 PrivateKey
+                  deriving (Show, Eq, Ord, Read, Data, Typeable)
+deriving instance Ord PrivateKey
+deriving instance Ord PublicKey
+
+-- | Data type for redential.
+data Credential = Credential { unCredential :: [(BS.ByteString, BS.ByteString)] }
+                  deriving (Show, Eq, Ord, Read, Data, Typeable)
+
+-- | Empty credential.
+emptyCredential :: Credential
+emptyCredential = Credential []
+
+-- | Convenient function to create 'Credential' with OAuth Token and Token Secret.
+newCredential :: BS.ByteString -- ^ value for oauth_token
+              -> BS.ByteString -- ^ value for oauth_token_secret
+              -> Credential
+newCredential tok sec = Credential [("oauth_token", tok), ("oauth_token_secret", sec)]
+
+token, tokenSecret :: Credential -> BS.ByteString
+token = fromMaybe "" . lookup "oauth_token" . unCredential
+tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential
+
+data OAuthException = OAuthException String
+                      deriving (Show, Eq, Data, Typeable)
+
+instance Exception OAuthException
+
+toStrict :: BSL.ByteString -> BS.ByteString
+toStrict = BS.concat . BSL.toChunks
+
+fromStrict :: BS.ByteString -> BSL.ByteString
+fromStrict = BSL.fromChunks . return
+
+-- | Get temporary credential for requesting acces token.
+getTemporaryCredential :: (MonadResource m, MonadBaseControl IO m)
+                       => OAuth         -- ^ OAuth Application
+                       -> Manager
+                       -> m Credential -- ^ Temporary Credential (Request Token & Secret).
+getTemporaryCredential = getTemporaryCredential' id
+
+-- | Get temporary credential for requesting access token with Scope parameter.
+getTemporaryCredentialWithScope :: (MonadResource m, MonadBaseControl IO m)
+                                => BS.ByteString -- ^ Scope parameter string
+                                -> OAuth         -- ^ OAuth Application
+                                -> Manager
+                                -> m Credential -- ^ Temporay Credential (Request Token & Secret).
+getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs)
+
+#if MIN_VERSION_http_conduit(2, 0, 0)
+addScope :: BS.ByteString -> Request -> Request
+#else
+addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m
+#endif
+addScope scope req | BS.null scope = req
+                   | otherwise     = urlEncodedBody [("scope", scope)] req
+
+-- | Get temporary credential for requesting access token via the proxy.
+getTemporaryCredentialProxy :: (MonadResource m, MonadBaseControl IO m)
+                            => Maybe Proxy   -- ^ Proxy
+                            -> OAuth         -- ^ OAuth Application
+                            -> Manager
+                            -> m Credential -- ^ Temporary Credential (Request Token & Secret).
+getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m
+
+getTemporaryCredential' :: (MonadResource m, MonadBaseControl IO m)
+#if MIN_VERSION_http_conduit(2, 0, 0)
+                        => (Request -> Request)       -- ^ Request Hook
+#else
+                        => (Request m -> Request m)   -- ^ Request Hook
+#endif
+                        -> OAuth                      -- ^ OAuth Application
+                        -> Manager
+                        -> m Credential    -- ^ Temporary Credential (Request Token & Secret).
+getTemporaryCredential' hook oa manager = do
+  let req = fromJust $ parseUrl $ oauthRequestUri oa
+      crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential
+  req' <- signOAuth oa crd $ hook (req { method = "POST" }) 
+  rsp <- httpLbs req' manager
+  if responseStatus rsp == status200
+    then do
+      let dic = parseSimpleQuery . toStrict . responseBody $ rsp
+      return $ Credential dic
+    else liftIO . throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)
+
+-- | URL to obtain OAuth verifier.
+authorizeUrl :: OAuth           -- ^ OAuth Application
+             -> Credential      -- ^ Temporary Credential (Request Token & Secret)
+             -> String          -- ^ URL to authorize
+authorizeUrl = authorizeUrl' $ \oa -> const [("oauth_consumer_key", oauthConsumerKey oa)]
+
+-- | Convert OAuth and Credential to URL to authorize.
+--   This takes function to choice parameter to pass to the server other than
+--   /oauth_callback/ or /oauth_token/.
+authorizeUrl' :: (OAuth -> Credential -> SimpleQuery)
+              -> OAuth           -- ^ OAuth Application
+              -> Credential      -- ^ Temporary Credential (Request Token & Secret)
+              -> String          -- ^ URL to authorize
+authorizeUrl' f oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries)
+  where fixed   = ("oauth_token", token cr):f oa cr
+        queries = 
+          case oauthCallback oa of
+            Nothing       -> fixed
+            Just callback -> ("oauth_callback", callback):fixed
+
+
+-- | Get Access token.
+getAccessToken, getTokenCredential
+               :: (MonadResource m, MonadBaseControl IO m)
+               => OAuth         -- ^ OAuth Application
+               -> Credential    -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
+               -> Manager
+               -> m Credential -- ^ Token Credential (Access Token & Secret)
+getAccessToken = getAccessToken' id
+
+-- | Get Access token via the proxy.
+getAccessTokenProxy, getTokenCredentialProxy
+               :: (MonadResource m, MonadBaseControl IO m)
+               => Maybe Proxy   -- ^ Proxy
+               -> OAuth         -- ^ OAuth Application
+               -> Credential    -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
+               -> Manager
+               -> m Credential -- ^ Token Credential (Access Token & Secret)
+getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p
+
+getAccessToken' :: (MonadResource m, MonadBaseControl IO m)
+#if MIN_VERSION_http_conduit(2, 0, 0)
+                => (Request -> Request)       -- ^ Request Hook
+#else
+                => (Request m -> Request m)   -- ^ Request Hook
+#endif
+                -> OAuth                      -- ^ OAuth Application
+                -> Credential                 -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
+                -> Manager
+                -> m Credential     -- ^ Token Credential (Access Token & Secret)
+getAccessToken' hook oa cr manager = do
+  let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
+  rsp <- flip httpLbs manager =<< signOAuth oa (if oauthVersion oa == OAuth10 then delete "oauth_verifier" cr else cr) req
+  if responseStatus rsp == status200
+    then do
+      let dic = parseSimpleQuery . toStrict . responseBody $ rsp
+      return $ Credential dic
+    else liftIO . throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp)
+
+getTokenCredential = getAccessToken
+getTokenCredentialProxy = getAccessTokenProxy
+
+insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
+insertMap key val = ((key,val):) . filter ((/=key).fst)
+
+deleteMap :: Eq a => a -> [(a,b)] -> [(a,b)]
+deleteMap k = filter ((/=k).fst)
+
+-- | Insert an oauth parameter into given 'Credential'.
+insert :: BS.ByteString -- ^ Parameter Name
+       -> BS.ByteString -- ^ Value
+       -> Credential    -- ^ Credential
+       -> Credential    -- ^ Result
+insert k v = Credential . insertMap k v . unCredential
+
+-- | Convenient method for inserting multiple parameters into credential.
+inserts :: [(BS.ByteString, BS.ByteString)] -> Credential -> Credential
+inserts = flip $ foldr (uncurry insert)
+
+-- | Remove an oauth parameter for key from given 'Credential'.
+delete :: BS.ByteString -- ^ Parameter name
+       -> Credential    -- ^ Credential
+       -> Credential    -- ^ Result
+delete key = Credential . deleteMap key . unCredential
+
+injectVerifier :: BS.ByteString -> Credential -> Credential
+injectVerifier = insert "oauth_verifier"
+
+-- | Add OAuth headers & sign to 'Request'.
+signOAuth :: (MonadUnsafeIO m)
+          => OAuth              -- ^ OAuth Application
+          -> Credential         -- ^ Credential
+#if MIN_VERSION_http_conduit(2, 0, 0)
+          -> Request            -- ^ Original Request
+          -> m Request          -- ^ Signed OAuth Request
+#else
+          -> Request m          -- ^ Original Request
+          -> m (Request m)    -- ^ Signed OAuth Request
+#endif
+signOAuth oa crd req = do
+  crd' <- addTimeStamp =<< addNonce crd
+  let tok = injectOAuthToCred oa crd'
+  sign <- genSign oa tok req
+  return $ addAuthHeader prefix (insert "oauth_signature" sign tok) req
+  where
+    prefix = case oauthRealm oa of
+      Nothing -> "OAuth "
+      Just v  -> "OAuth realm=\"" `BS.append` v `BS.append` "\","
+
+baseTime :: UTCTime
+baseTime = UTCTime day 0
+  where
+    day = ModifiedJulianDay 40587
+
+showSigMtd :: SignMethod -> BS.ByteString
+showSigMtd PLAINTEXT = "PLAINTEXT"
+showSigMtd HMACSHA1  = "HMAC-SHA1"
+showSigMtd (RSASHA1 _) = "RSA-SHA1"
+
+addNonce :: MonadUnsafeIO m => Credential -> m Credential
+addNonce cred = do
+  nonce <- unsafeLiftIO $ replicateM 10 (randomRIO ('a','z')) -- FIXME very inefficient
+  return $ insert "oauth_nonce" (BS.pack nonce) cred
+
+addTimeStamp :: MonadUnsafeIO m => Credential -> m Credential
+addTimeStamp cred = do
+  stamp <- (floor . (`diffUTCTime` baseTime)) `liftM` unsafeLiftIO getCurrentTime
+  return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred
+
+injectOAuthToCred :: OAuth -> Credential -> Credential
+injectOAuthToCred oa cred =
+    inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa)
+            , ("oauth_consumer_key", oauthConsumerKey oa)
+            , ("oauth_version", "1.0")
+            ] cred
+
+#if MIN_VERSION_http_conduit(2, 0, 0)
+genSign :: MonadUnsafeIO m => OAuth -> Credential -> Request -> m BS.ByteString
+#else
+genSign :: MonadUnsafeIO m => OAuth -> Credential -> Request m -> m BS.ByteString
+#endif
+genSign oa tok req =
+  case oauthSignatureMethod oa of
+    HMACSHA1 -> do
+      text <- getBaseString tok req
+      let key  = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
+      return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text
+    PLAINTEXT ->
+      return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
+    RSASHA1 pr ->
+#if MIN_VERSION_RSA(2, 0, 0)
+      liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA1 pr) (getBaseString tok req)
+#else
+      liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)
+#endif
+
+#if MIN_VERSION_http_conduit(2, 0, 0)
+addAuthHeader :: BS.ByteString -> Credential -> Request -> Request
+#else
+addAuthHeader :: BS.ByteString -> Credential -> Request a -> Request a
+#endif
+addAuthHeader prefix (Credential cred) req =
+  req { requestHeaders = insertMap "Authorization" (renderAuthHeader prefix cred) $ requestHeaders req }
+
+renderAuthHeader :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> BS.ByteString
+renderAuthHeader prefix = (prefix `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"",  paramEncode b, "\""]) . filter ((`elem` ["oauth_token", "oauth_verifier", "oauth_consumer_key", "oauth_signature_method", "oauth_timestamp", "oauth_nonce", "oauth_version", "oauth_callback", "oauth_signature"]) . fst)
+
+-- | Encode a string using the percent encoding method for OAuth.
+paramEncode :: BS.ByteString -> BS.ByteString
+paramEncode = BS.concatMap escape
+  where
+    escape c | isAscii c && (isAlpha c || isDigit c || c `elem` "-._~") = BS.singleton c
+             | otherwise = let num = map toUpper $ showHex (ord c) ""
+                               oct = '%' : replicate (2 - length num) '0' ++ num
+                           in BS.pack oct
+
+#if MIN_VERSION_http_conduit(2, 0, 0)
+getBaseString :: MonadUnsafeIO m => Credential -> Request -> m BSL.ByteString
+#else
+getBaseString :: MonadUnsafeIO m => Credential -> Request m -> m BSL.ByteString
+#endif
+getBaseString tok req = do
+  let bsMtd  = BS.map toUpper $ method req
+      isHttps = secure req
+      scheme = if isHttps then "https" else "http"
+      bsPort = if (isHttps && port req /= 443) || (not isHttps && port req /= 80)
+                 then ':' `BS.cons` BS.pack (show $ port req) else ""
+      bsURI = BS.concat [scheme, "://", host req, bsPort, path req]
+      bsQuery = parseSimpleQuery $ queryString req
+  bsBodyQ <- if isBodyFormEncoded $ requestHeaders req
+                  then liftM parseSimpleQuery $ toLBS (requestBody req)
+                  else return []
+  let bsAuthParams = filter ((`elem`["oauth_consumer_key","oauth_token", "oauth_version","oauth_signature_method","oauth_timestamp", "oauth_nonce", "oauth_verifier", "oauth_version","oauth_callback"]).fst) $ unCredential tok
+      allParams = bsQuery++bsBodyQ++bsAuthParams
+      bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple
+                   $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams
+  -- parameter encoding method in OAuth is slight different from ordinary one.
+  -- So this is OK.
+  return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
+
+#if MIN_VERSION_http_conduit(2, 0, 0)
+toLBS :: MonadUnsafeIO m => RequestBody -> m BS.ByteString
+toLBS (RequestBodyLBS l) = return $ toStrict l
+toLBS (RequestBodyBS s) = return s
+toLBS (RequestBodyBuilder _ b) = return $ toByteString b
+toLBS (RequestBodyStream _ givesPopper) = toLBS' givesPopper
+toLBS (RequestBodyStreamChunked givesPopper) = toLBS' givesPopper
+
+type Popper = IO BS.ByteString
+type NeedsPopper a = Popper -> IO a
+type GivesPopper a = NeedsPopper a -> IO a
+
+toLBS' :: MonadUnsafeIO m => GivesPopper () -> m BS.ByteString
+-- FIXME probably shouldn't be using MonadUnsafeIO
+toLBS' gp = unsafeLiftIO $ do
+    ref <- I.newIORef BS.empty
+    gp (go ref)
+    I.readIORef ref
+  where
+    go ref popper =
+        loop id
+      where
+        loop front = do
+            bs <- popper
+            if BS.null bs
+                then I.writeIORef ref $ BS.concat $ front []
+                else loop (front . (bs:))
+#else
+toLBS :: MonadUnsafeIO m => RequestBody m -> m BS.ByteString
+toLBS (RequestBodyLBS l) = return $ toStrict l
+toLBS (RequestBodyBS s) = return s
+toLBS (RequestBodyBuilder _ b) = return $ toByteString b
+toLBS (RequestBodySource _ src) = toLBS' src
+toLBS (RequestBodySourceChunked src) = toLBS' src
+
+toLBS' :: MonadUnsafeIO m => Source m Builder -> m BS.ByteString
+toLBS' src = liftM BS.concat $ src $= builderToByteString $$ CL.consume
+#endif
+
+isBodyFormEncoded :: [Header] -> Bool
+isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"
+
+compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering
+compareTuple (a,b) (c,d) =
+  case compare a c of
+    LT -> LT
+    EQ -> compare b d
+    GT -> GT
+
+#if MIN_VERSION_http_conduit(2, 0, 0)
+addMaybeProxy :: Maybe Proxy -> Request -> Request
+#else
+addMaybeProxy :: Maybe Proxy -> Request m -> Request m
+#endif
+addMaybeProxy p req = req { proxy = p }

authenticate-oauth/Web/Authenticate/OAuth/IO.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+-- | This Module provides interface for the instance of 'MonadIO' instead of 'MonadIO'.
+-- What this module do is just adding 'withManager' or 'runResourceT'.
+module Web.Authenticate.OAuth.IO
+    {-# DEPRECATED "This module is deprecated; rewrite your code using MonadResource" #-}
+    ( 
+      module Web.Authenticate.OAuth,
+      getAccessToken,
+      getTemporaryCredential, getTemporaryCredentialWithScope,
+      getTemporaryCredentialProxy, getTemporaryCredential',
+      getTokenCredential,
+      getAccessTokenProxy, getTokenCredentialProxy, 
+      getAccessToken'
+    ) where
+import Network.HTTP.Conduit
+import qualified Web.Authenticate.OAuth as OA
+import Web.Authenticate.OAuth hiding
+    (getAccessToken,
+     getTemporaryCredential, getTemporaryCredentialWithScope,
+     getTemporaryCredentialProxy, getTemporaryCredential',
+     getTokenCredential, getTemporaryCredentialWithScope,
+     getAccessTokenProxy, getTemporaryCredentialProxy,
+     getTokenCredentialProxy,
+     getAccessToken', getTemporaryCredential')
+import Data.Conduit
+import Control.Monad.IO.Class
+import qualified Data.ByteString.Char8 as BS
+
+
+-- | Get temporary credential for requesting acces token.
+getTemporaryCredential :: MonadIO m
+                       => OA.OAuth        -- ^ OAuth Application
+                       -> m OA.Credential -- ^ Temporary Credential (Request Token & Secret).
+getTemporaryCredential = liftIO . withManager . OA.getTemporaryCredential
+
+-- | Get temporary credential for requesting access token with Scope parameter.
+getTemporaryCredentialWithScope :: MonadIO m
+                                => BS.ByteString -- ^ Scope parameter string
+                                -> OAuth         -- ^ OAuth Application
+                                -> m Credential -- ^ Temporay Credential (Request Token & Secret).
+getTemporaryCredentialWithScope bs oa =
+  liftIO $ withManager $ OA.getTemporaryCredentialWithScope bs oa
+
+
+-- | Get temporary credential for requesting access token via the proxy.
+getTemporaryCredentialProxy :: MonadIO m
+                            => Maybe Proxy   -- ^ Proxy
+                            -> OAuth         -- ^ OAuth Application
+                            -> m Credential -- ^ Temporary Credential (Request Token & Secret).
+getTemporaryCredentialProxy p oa = liftIO $ withManager $ OA.getTemporaryCredential' (addMaybeProxy p) oa
+
+getTemporaryCredential' :: MonadIO m
+#if MIN_VERSION_http_conduit(2, 0, 0)
+                        => (Request -> Request)                                 -- ^ Request Hook
+#else
+                        => (Request (ResourceT IO) -> Request (ResourceT IO))   -- ^ Request Hook
+#endif
+                        -> OAuth                      -- ^ OAuth Application
+                        -> m Credential -- ^ Temporary Credential (Request Token & Secret).
+getTemporaryCredential' hook oa = liftIO $ withManager $ OA.getTemporaryCredential' hook oa
+
+
+-- | Get Access token.
+getAccessToken, getTokenCredential
+               :: MonadIO m
+               => OAuth         -- ^ OAuth Application
+               -> Credential    -- ^ Temporary Credential with oauth_verifier
+               -> m Credential -- ^ Token Credential (Access Token & Secret)
+getAccessToken oa cr = liftIO $ withManager $ OA.getAccessToken oa cr
+
+-- | Get Access token via the proxy.
+getAccessTokenProxy, getTokenCredentialProxy
+               :: MonadIO m
+               => Maybe Proxy   -- ^ Proxy
+               -> OAuth         -- ^ OAuth Application
+               -> Credential    -- ^ Temporary Credential with oauth_verifier
+               -> m Credential -- ^ Token Credential (Access Token & Secret)
+getAccessTokenProxy p oa cr = liftIO $ withManager $ OA.getAccessTokenProxy p oa cr
+
+getAccessToken' :: MonadIO m
+#if MIN_VERSION_http_conduit(2, 0, 0)
+                => (Request -> Request)                                 -- ^ Request Hook
+#else
+                => (Request (ResourceT IO) -> Request (ResourceT IO))   -- ^ Request Hook
+#endif
+                -> OAuth                      -- ^ OAuth Application
+                -> Credential                 -- ^ Temporary Credential with oauth_verifier
+                -> m Credential     -- ^ Token Credential (Access Token & Secret)
+getAccessToken' hook oa cr = liftIO $ withManager $ OA.getAccessToken' hook oa cr
+
+
+getTokenCredential = getAccessToken
+getTokenCredentialProxy = getAccessTokenProxy

authenticate-oauth/authenticate-oauth.cabal

@@ -0,0 +1,39 @@
+
+name:            authenticate-oauth
+version:         1.4.0.7
+license:         BSD3
+license-file:    LICENSE
+author:          Hiromi Ishii
+maintainer:      Hiromi Ishii
+synopsis:        Library to authenticate with OAuth for Haskell web applications.
+description:     OAuth authentication, e.g. Twitter.
+category:        Web
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://github.com/yesodweb/authenticate
+
+library
+    build-depends:   base                          >= 4        && < 5
+                   , http-conduit                  >= 1.4
+                   , transformers                  >= 0.1      && < 0.4
+                   , bytestring                    >= 0.9
+                   , crypto-pubkey-types           >= 0.1      && < 0.5
+                   , RSA                           >= 1.2      && < 2.1
+                   , time
+                   , data-default
+                   , base64-bytestring             >= 0.1      && < 1.1
+                   , SHA                           >= 1.4      && < 1.7
+                   , random
+                   , http-types                    >= 0.6      && < 0.9
+                   , blaze-builder
+                   , conduit                       >= 0.4
+                   , resourcet                     >= 0.3      && < 0.5
+                   , blaze-builder-conduit         >= 0.4
+                   , monad-control                 >= 0.3      && < 0.4
+    exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/authenticate.git

authenticate/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2008, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

authenticate/OpenId2/Discovery.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Network.OpenID.Discovery
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   :
+-- Portability :
+--
+
+module OpenId2.Discovery (
+    -- * Discovery
+    discover
+  , Discovery (..)
+  ) where
+
+-- Friends
+import OpenId2.Types
+import OpenId2.XRDS
+
+-- Libraries
+import Data.Char
+import Data.Maybe
+import Network.HTTP.Conduit
+import qualified Data.ByteString.Char8 as S8
+import Control.Arrow (first)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad (mplus, liftM)
+import qualified Data.CaseInsensitive as CI
+import Data.Text (Text, unpack)
+import Data.Text.Lazy (toStrict)
+import qualified Data.Text as T
+import Data.Text.Lazy.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import Text.HTML.TagSoup (parseTags, Tag (TagOpen))
+import Control.Applicative ((<$>), (<*>))
+import Network.HTTP.Types (status200)
+import Control.Exception (throwIO)
+import Data.Conduit (MonadBaseControl, MonadResource)
+
+data Discovery = Discovery1 Text (Maybe Text)
+               | Discovery2 Provider Identifier IdentType
+    deriving Show
+
+-- | Attempt to resolve an OpenID endpoint, and user identifier.
+discover :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Identifier -> Manager -> m Discovery
+discover ident@(Identifier i) manager = do
+    res1 <- discoverYADIS ident Nothing 10 manager
+    case res1 of
+        Just (x, y, z) -> return $ Discovery2 x y z
+        Nothing -> do
+            res2 <- discoverHTML ident manager
+            case res2 of
+                Just x -> return x
+                Nothing -> liftIO $ throwIO $ DiscoveryException $ unpack i
+
+-- YADIS-Based Discovery -------------------------------------------------------
+
+-- | Attempt a YADIS based discovery, given a valid identifier.  The result is
+--   an OpenID endpoint, and the actual identifier for the user.
+discoverYADIS :: (MonadResource m, MonadBaseControl IO m)
+              => Identifier
+              -> Maybe String
+              -> Int -- ^ remaining redirects
+              -> Manager
+              -> m (Maybe (Provider, Identifier, IdentType))
+discoverYADIS _ _ 0 _ = liftIO $ throwIO $ TooManyRedirects
+#if MIN_VERSION_http_conduit(1,6,0)
+    []
+#endif
+discoverYADIS ident mb_loc redirects manager = do
+    let uri = fromMaybe (unpack $ identifier ident) mb_loc
+    req <- liftIO $ parseUrl uri
+    res <- httpLbs req
+#if MIN_VERSION_http_conduit(1, 9, 0)
+        { checkStatus = \_ _ _ -> Nothing
+#else
+        { checkStatus = \_ _ -> Nothing
+#endif
+        } manager
+    let mloc = fmap S8.unpack
+             $ lookup "x-xrds-location"
+             $ map (first $ map toLower . S8.unpack . CI.original)
+             $ responseHeaders res
+    let mloc' = if mloc == mb_loc then Nothing else mloc
+    if responseStatus res == status200
+        then
+          case mloc' of
+            Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager
+            Nothing  -> do
+              let mdoc = parseXRDS $ responseBody res
+              case mdoc of
+                  Just doc -> return $ parseYADIS ident doc
+                  Nothing -> return Nothing
+        else return Nothing
+
+
+-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml
+-- document.
+parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)
+parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
+  where
+  isOpenId svc = do
+    let tys = serviceTypes svc
+        localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc
+        f (x,y) | x `elem` tys = Just y
+                | otherwise    = Nothing
+    (lid, itype) <- listToMaybe $ mapMaybe f
+      [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent))
+      -- claimed identifiers
+      , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent))
+      , ("http://openid.net/signon/1.0"           , (localId, ClaimedIdent))
+      , ("http://openid.net/signon/1.1"           , (localId, ClaimedIdent))
+      ]
+    uri <- listToMaybe $ serviceURIs svc
+    return (Provider uri, lid, itype)
+
+
+-- HTML-Based Discovery --------------------------------------------------------
+
+-- | Attempt to discover an OpenID endpoint, from an HTML document.  The result
+-- will be an endpoint on success, and the actual identifier of the user.
+discoverHTML :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery)
+discoverHTML ident'@(Identifier ident) manager = do
+    req <- liftIO $ parseUrl $ unpack ident
+    lbs <- liftM responseBody $ httpLbs req manager
+    return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs
+
+-- | Parse out an OpenID endpoint and an actual identifier from an HTML
+-- document.
+parseHTML :: Identifier -> Text -> Maybe Discovery
+parseHTML ident = resolve
+                . filter isOpenId
+                . mapMaybe linkTag
+                . parseTags
+  where
+    isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel
+    resolve1 ls = do
+      server <- lookup "openid.server" ls
+      let delegate = lookup "openid.delegate" ls
+      return $ Discovery1 server delegate
+    resolve2 ls = do
+      prov <- lookup "openid2.provider" ls
+      let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
+      -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only
+      -- result in a claimed identifier.
+      return $ Discovery2 (Provider prov) lid ClaimedIdent
+    resolve ls = resolve2 ls `mplus` resolve1 ls
+
+
+-- | Filter out link tags from a list of html tags.
+linkTag :: Tag Text -> Maybe (Text, Text)
+linkTag (TagOpen "link" as) = (,) <$> lookup "rel" as <*> lookup "href" as
+linkTag _x = Nothing

authenticate/OpenId2/Normalization.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE FlexibleContexts #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Network.OpenID.Normalization
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   : 
+-- Portability : 
+--
+
+module OpenId2.Normalization
+    ( normalize
+    ) where
+
+-- Friends
+import OpenId2.Types
+
+-- Libraries
+import Control.Applicative
+import Control.Monad
+import Data.List
+import Network.URI
+    ( uriToString, normalizeCase, normalizeEscape
+    , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment
+    )
+import Data.Text (Text, pack, unpack)
+import Control.Monad.IO.Class
+import Control.Exception (throwIO)
+
+normalize :: MonadIO m => Text -> m Identifier
+normalize ident =
+    case normalizeIdentifier $ Identifier ident of
+        Just i -> return i
+        Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident
+
+-- | Normalize an identifier, discarding XRIs.
+normalizeIdentifier :: Identifier -> Maybe Identifier
+normalizeIdentifier  = normalizeIdentifier' (const Nothing)
+
+
+-- | Normalize the user supplied identifier, using a supplied function to
+-- normalize an XRI.
+normalizeIdentifier' :: (String -> Maybe String) -> Identifier
+                     -> Maybe Identifier
+normalizeIdentifier' xri (Identifier str')
+  | null str                  = Nothing
+  | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str
+  | head str `elem` "=@+$!"   = (Identifier . pack) `fmap` xri str
+  | otherwise = fmt `fmap` (url >>= norm)
+  where
+    str = unpack str'
+    url = parseURI str <|> parseURI ("http://" ++ str)
+
+    norm uri = validScheme >> return u
+      where
+        scheme'     = uriScheme uri
+        validScheme = guard (scheme' == "http:" || scheme' == "https:")
+        u = uri { uriFragment = "", uriPath = path' }
+        path' | null (uriPath uri) = "/"
+              | otherwise          = uriPath uri
+
+    fmt u = Identifier
+          $ pack
+          $ normalizePathSegments
+          $ normalizeEscape
+          $ normalizeCase
+          $ uriToString (const "") u []

authenticate/OpenId2/Types.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Network.OpenID.Types
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   : 
+-- Portability : 
+--
+
+module OpenId2.Types (
+    Provider (..)
+  , Identifier (..)
+  , IdentType (..)
+  , AuthenticateException (..)
+  ) where
+
+-- Libraries
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Web.Authenticate.Internal
+import Data.Text (Text)
+
+-- | An OpenID provider.
+newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show)
+
+-- | A valid OpenID identifier.
+newtype Identifier = Identifier { identifier :: Text }
+    deriving (Eq, Ord, Show, Read, Data, Typeable)
+
+data IdentType = OPIdent | ClaimedIdent
+    deriving (Eq, Ord, Show, Read, Data, Typeable)

authenticate/OpenId2/XRDS.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE OverloadedStrings #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Text.XRDS
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   :
+-- Portability :
+--
+
+module OpenId2.XRDS (
+    -- * Types
+    XRDS
+  , Service(..)
+
+    -- * Parsing
+  , parseXRDS
+  ) where
+
+-- Libraries
+import Control.Monad ((>=>))
+import Data.Maybe (listToMaybe)
+import Text.XML (parseLBS, def)
+import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute)
+import qualified Data.ByteString.Lazy as L
+import Data.Text (Text)
+import qualified Data.Text.Read
+
+-- Types -----------------------------------------------------------------------
+
+type XRDS = [XRD]
+
+type XRD = [Service]
+
+data Service = Service
+  { serviceTypes      :: [Text]
+  , serviceMediaTypes :: [Text]
+  , serviceURIs       :: [Text]
+  , serviceLocalIDs   :: [Text]
+  , servicePriority   :: Maybe Int
+  } deriving Show
+
+parseXRDS :: L.ByteString -> Maybe XRDS
+parseXRDS str =
+    either
+        (const Nothing)
+        (Just . parseXRDS' . fromDocument)
+        (parseLBS def str)
+
+parseXRDS' :: Cursor -> [[Service]]
+parseXRDS' = element "{xri://$xrds}XRDS" &/
+             element "{xri://$xrd*($v*2.0)}XRD" &|
+             parseXRD
+
+parseXRD :: Cursor -> [Service]
+parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService
+
+parseService :: Cursor -> [Service]
+parseService c =
+    if null types then [] else [Service
+        { serviceTypes = types
+        , serviceMediaTypes = mtypes
+        , serviceURIs = uris
+        , serviceLocalIDs = localids
+        , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe
+        }]
+  where
+    types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content
+    mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content
+    uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content
+    localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content
+    readMaybe t =
+        case Data.Text.Read.signed Data.Text.Read.decimal t of
+            Right (i, "") -> Just i
+            _ -> Nothing

authenticate/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

authenticate/Web/Authenticate/BrowserId.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Web.Authenticate.BrowserId
+    ( browserIdJs
+    , checkAssertion
+    ) where
+
+import Data.Text (Text)
+import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, Manager, method, urlEncodedBody)
+import Data.Aeson (json, Value (Object, String))
+import Data.Attoparsec.Lazy (parse, maybeResult)
+import qualified Data.HashMap.Lazy as Map
+import Data.Text.Encoding (encodeUtf8)
+import Control.Monad.IO.Class (liftIO)
+import Data.Conduit (MonadBaseControl, MonadResource)
+
+-- | Location of the Javascript file hosted by browserid.org
+browserIdJs :: Text
+browserIdJs = "https://login.persona.org/include.js"
+
+checkAssertion :: (MonadResource m, MonadBaseControl IO m)
+               => Text -- ^ audience
+               -> Text -- ^ assertion
+               -> Manager
+               -> m (Maybe Text)
+checkAssertion audience assertion manager = do
+    req' <- liftIO $ parseUrl "https://verifier.login.persona.org/verify"
+    let req = urlEncodedBody
+                [ ("audience", encodeUtf8 audience)
+                , ("assertion", encodeUtf8 assertion)
+                ] req' { method = "POST" }
+    res <- httpLbs req manager
+    let lbs = responseBody res
+    return $ maybeResult (parse json lbs) >>= getEmail
+  where
+    getEmail (Object o) =
+        case (Map.lookup "status" o, Map.lookup "email" o) of
+            (Just (String "okay"), Just (String e)) -> Just e
+            _ -> Nothing
+    getEmail _ = Nothing

authenticate/Web/Authenticate/Internal.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Web.Authenticate.Internal
+    ( AuthenticateException (..)
+    ) where
+
+import Data.Typeable (Typeable)
+import Control.Exception (Exception)
+
+data AuthenticateException =
+      RpxnowException String
+    | NormalizationException String
+    | DiscoveryException String
+    | AuthenticationException String
+  deriving (Show, Typeable)
+instance Exception AuthenticateException

authenticate/Web/Authenticate/OpenId.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Web.Authenticate.OpenId
+    ( -- * Functions
+      getForwardUrl
+    , authenticate
+    , authenticateClaimed
+      -- * Types
+    , AuthenticateException (..)
+    , Identifier (..)
+      -- ** Response
+    , OpenIdResponse
+    , oirOpLocal
+    , oirParams
+    , oirClaimed
+    ) where
+
+import Control.Monad.IO.Class
+import OpenId2.Normalization (normalize)
+import OpenId2.Discovery (discover, Discovery (..))
+import OpenId2.Types
+import Control.Monad (unless)
+import qualified Data.Text as T
+import Data.Text.Lazy.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Text.Lazy (toStrict)
+import Network.HTTP.Conduit
+    ( parseUrl, urlEncodedBody, responseBody, httpLbs
+    , Manager
+    )
+import Control.Arrow ((***), second)
+import Data.List (unfoldr)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, pack, unpack)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Blaze.ByteString.Builder (toByteString)
+import Network.HTTP.Types (renderQueryText)
+import Control.Exception (throwIO)
+import Data.Conduit (MonadBaseControl, MonadResource)
+
+getForwardUrl
+    :: (MonadResource m, MonadBaseControl IO m)
+    => Text -- ^ The openid the user provided.
+    -> Text -- ^ The URL for this application\'s complete page.
+    -> Maybe Text -- ^ Optional realm
+    -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
+    -> Manager
+    -> m Text -- ^ URL to send the user to.
+getForwardUrl openid' complete mrealm params manager = do
+    let realm = fromMaybe complete mrealm
+    claimed <- normalize openid'
+    disc <- discover claimed manager
+    let helper s q = return $ T.concat
+            [ s
+            , if "?" `T.isInfixOf` s then "&" else "?"
+            , decodeUtf8 (toByteString $ renderQueryText False $ map (second Just) q)
+            ]
+    case disc of
+        Discovery1 server mdelegate -> helper server
+                $ ("openid.mode", "checkid_setup")
+                : ("openid.identity", maybe (identifier claimed) id mdelegate)
+                : ("openid.return_to", complete)
+                : ("openid.realm", realm)
+                : ("openid.trust_root", complete)
+                : params
+        Discovery2 (Provider p) (Identifier i) itype -> do
+            let (claimed', identity') =
+                    case itype of
+                        ClaimedIdent -> (identifier claimed, i)
+                        OPIdent ->
+                            let x = "http://specs.openid.net/auth/2.0/identifier_select"
+                             in (x, x)
+            helper p
+                $ ("openid.ns", "http://specs.openid.net/auth/2.0")
+                : ("openid.mode", "checkid_setup")
+                : ("openid.claimed_id", claimed')
+                : ("openid.identity", identity')
+                : ("openid.return_to", complete)
+                : ("openid.realm", realm)
+                : params
+
+authenticate
+    :: (MonadBaseControl IO m, MonadResource m, MonadIO m)
+    => [(Text, Text)]
+    -> Manager
+    -> m (Identifier, [(Text, Text)])
+authenticate ps m = do
+    x <- authenticateClaimed ps m
+    return (oirOpLocal x, oirParams x)
+{-# DEPRECATED authenticate "Use authenticateClaimed" #-}
+
+data OpenIdResponse = OpenIdResponse
+    { oirOpLocal :: Identifier
+    , oirParams :: [(Text, Text)]
+    , oirClaimed :: Maybe Identifier
+    }
+
+authenticateClaimed
+    :: (MonadBaseControl IO m, MonadResource m, MonadIO m)
+    => [(Text, Text)]
+    -> Manager
+    -> m OpenIdResponse
+authenticateClaimed params manager = do
+    unless (lookup "openid.mode" params == Just "id_res")
+        $ liftIO $ throwIO $ case lookup "openid.mode" params of
+                      Nothing -> AuthenticationException "openid.mode was not found in the params."
+                      (Just m)
+                            | m == "error" ->
+                                case lookup "openid.error" params of
+                                  Nothing -> AuthenticationException "An error occurred, but no error message was provided."
+                                  (Just e) -> AuthenticationException $ unpack e
+                            | otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res."
+    ident <- case lookup "openid.identity" params of
+                Just i -> return i
+                Nothing ->
+                    liftIO $ throwIO $ AuthenticationException "Missing identity"
+    discOP <- normalize ident >>= flip discover manager
+
+    let endpoint d =
+            case d of
+                Discovery1 p _ -> p
+                Discovery2 (Provider p) _ _ -> p
+    let params' = map (encodeUtf8 *** encodeUtf8)
+                $ ("openid.mode", "check_authentication")
+                : filter (\(k, _) -> k /= "openid.mode") params
+    req' <- liftIO $ parseUrl $ unpack $ endpoint discOP
+    let req = urlEncodedBody params' req'
+    rsp <- httpLbs req manager
+    let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp
+
+    claimed <-
+        case lookup "openid.claimed_id" params of
+            Nothing -> return Nothing
+            Just claimed' -> do
+                -- need to validate that this provider can speak for the given
+                -- claimed identifier
+                claimedN <- normalize claimed'
+                discC <- discover claimedN manager
+                return $
+                    if endpoint discOP == endpoint discC
+                        then Just claimedN
+                        else Nothing
+
+    case lookup "is_valid" rps of
+        Just "true" -> return OpenIdResponse
+            { oirOpLocal = Identifier ident
+            , oirParams  = rps
+            , oirClaimed = claimed
+            }
+        _ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate"
+
+-- | Turn a response body into a list of parameters.
+parseDirectResponse :: Text -> [(Text, Text)]
+parseDirectResponse  =
+    map (pack *** pack) . unfoldr step . unpack
+  where
+    step []  = Nothing
+    step str = case split (== '\n') str of
+      (ps,rest) -> Just (split (== ':') ps,rest)
+
+split :: (a -> Bool) -> [a] -> ([a],[a])
+split p as = case break p as of
+  (xs,_:ys) -> (xs,ys)
+  pair      -> pair

authenticate/Web/Authenticate/OpenId/Providers.hs

@@ -0,0 +1,44 @@
+-- | OpenIDs for a number of common OPs. When a function takes a 'String'
+-- parameter, that 'String' is the username.
+module Web.Authenticate.OpenId.Providers
+    ( google
+    , yahoo
+    , livejournal
+    , myspace
+    , wordpress
+    , blogger
+    , verisign
+    , typepad
+    , myopenid
+    , claimid
+    ) where
+
+google :: String
+google = "https://www.google.com/accounts/o8/id"
+
+yahoo :: String
+yahoo = "http://me.yahoo.com/"
+
+livejournal :: String -> String
+livejournal u = concat ["http://", u, ".livejournal.com/"]
+
+myspace :: String -> String
+myspace = (++) "http://www.myspace.com/"
+
+wordpress :: String -> String
+wordpress u = concat ["http://", u, ".wordpress.com/"]
+
+blogger :: String -> String
+blogger u = concat ["http://", u, ".blogger.com/"]
+
+verisign :: String -> String
+verisign u = concat ["http://", u, ".pip.verisignlabs.com/"]
+
+typepad :: String -> String
+typepad u = concat ["http://", u, ".typepad.com/"]
+
+myopenid :: String -> String
+myopenid u = concat ["http://", u, ".myopenid.com/"]
+
+claimid :: String -> String
+claimid = (++) "http://claimid.com/"

authenticate/Web/Authenticate/Rpxnow.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+---------------------------------------------------------
+--
+-- Module        : Web.Authenticate.Rpxnow
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- Stability     : Unstable
+-- Portability   : portable
+--
+-- Facilitates authentication with "http://rpxnow.com/".
+--
+---------------------------------------------------------
+module Web.Authenticate.Rpxnow
+    ( Identifier (..)
+    , authenticate
+    , AuthenticateException (..)
+    ) where
+
+import Data.Aeson
+import Network.HTTP.Conduit
+import Control.Monad.IO.Class
+import Data.Maybe
+import Control.Monad
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import Web.Authenticate.Internal
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Data.Attoparsec.Lazy (parse)
+import qualified Data.Attoparsec.Lazy as AT
+import Data.Text (Text)
+import qualified Data.Aeson.Types
+import qualified Data.HashMap.Lazy as Map
+import Control.Applicative ((<$>), (<*>))
+import Control.Exception (throwIO)
+import Data.Conduit (MonadBaseControl, MonadResource)
+
+-- | Information received from Rpxnow after a valid login.
+data Identifier = Identifier
+    { identifier :: Text
+    , extraData :: [(Text, Text)]
+    }
+    deriving (Eq, Ord, Read, Show, Data, Typeable)
+
+-- | Attempt to log a user in.
+authenticate :: (MonadResource m, MonadBaseControl IO m)
+             => String -- ^ API key given by RPXNOW.
+             -> String -- ^ Token passed by client.
+             -> Manager
+             -> m Identifier
+authenticate apiKey token manager = do
+    let body = L.fromChunks
+            [ "apiKey="
+            , S.pack apiKey
+            , "&token="
+            , S.pack token
+            ]
+    req' <- liftIO $ parseUrl "https://rpxnow.com"
+    let req =
+            req'
+                { method = "POST"
+                , path = "api/v2/auth_info"
+                , requestHeaders =
+                    [ ("Content-Type", "application/x-www-form-urlencoded")
+                    ]
+                , requestBody = RequestBodyLBS body
+                }
+    res <- httpLbs req manager
+    let b = responseBody res
+    o <- unResult $ parse json b
+    --m <- fromMapping o
+    let mstat = flip Data.Aeson.Types.parse o $ \v ->
+                case v of
+                    Object m -> m .: "stat"
+                    _ -> mzero
+    case mstat of
+        Success "ok" -> return ()
+        Success stat -> liftIO $ throwIO $ RpxnowException $
+            "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
+        _ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response"
+    case Data.Aeson.Types.parse parseProfile o of
+        Success x -> return x
+        Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e
+
+unResult :: MonadIO m => AT.Result a -> m a
+unResult = either (liftIO . throwIO . RpxnowException) return . AT.eitherResult
+
+parseProfile :: Value -> Data.Aeson.Types.Parser Identifier
+parseProfile (Object m) = do
+    profile <- m .: "profile"
+    Identifier
+        <$> (profile .: "identifier")
+        <*> return (mapMaybe go (Map.toList profile))
+  where
+    go ("identifier", _) = Nothing
+    go (k, String v) = Just (k, v)
+    go _ = Nothing
+parseProfile _ = mzero

authenticate/authenticate.cabal

@@ -0,0 +1,48 @@
+name:            authenticate
+version:         1.3.2.6
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman, Hiromi Ishii, Arash Rouhani
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Authentication methods for Haskell web applications.
+description:
+    Focus is on third-party authentication methods, such as OpenID and BrowserID.
+    .
+    Note: Facebook support is now provided by the fb package: <http://hackage.haskell.org/package/fb>.
+category:        Web
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://github.com/yesodweb/authenticate
+
+library
+    build-depends:   base                          >= 4        && < 5
+                   , aeson                         >= 0.5
+                   , http-conduit                  >= 1.5
+                   , tagsoup                       >= 0.12
+                   , transformers                  >= 0.1
+                   , bytestring                    >= 0.9
+                   , network
+                   , case-insensitive              >= 0.2
+                   , text
+                   , http-types                    >= 0.6
+                   , xml-conduit                   >= 1.0
+                   , blaze-builder
+                   , attoparsec
+                   , containers
+                   , unordered-containers
+                   , conduit                       >= 0.5
+    exposed-modules: Web.Authenticate.Rpxnow,
+                     Web.Authenticate.OpenId,
+                     Web.Authenticate.BrowserId,
+                     Web.Authenticate.OpenId.Providers
+    other-modules:   Web.Authenticate.Internal,
+                     OpenId2.Discovery,
+                     OpenId2.Normalization,
+                     OpenId2.Types,
+                     OpenId2.XRDS
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/authenticate.git

authenticate/browserid.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+import Yesod
+import Web.Authenticate.BrowserId
+import Data.Maybe (fromMaybe)
+import Network.HTTP.Conduit
+import Data.Text (Text)
+
+data BID = BID
+mkYesod "BID" [parseRoutes|
+/ RootR GET
+/complete/#Text CompleteR GET
+|]
+
+instance Yesod BID where approot = ApprootStatic "http://localhost:3000"
+
+getRootR = defaultLayout $ do
+    addScriptRemote browserIdJs
+    addJulius [julius|
+function bidClick() {
+    navigator.id.getVerifiedEmail(function(assertion) {
+        if (assertion) {
+            document.location = "/complete/" + assertion;
+        } else {
+            alert("Invalid BrowserId login");
+        }
+    });
+}
+|]
+    addHamlet [hamlet|
+<p>
+    <a href="javascript:bidClick();">
+        <img src="https://browserid.org/i/sign_in_red.png">
+|]
+
+getCompleteR assertion = do
+    memail <- withManager $ checkAssertion "localhost:3000" assertion
+    defaultLayout $ addHamlet [hamlet|
+<p>You tried to log in, let's see if it worked.
+$maybe email <- memail
+    <p>Yes it did! You are: #{email}
+$nothing
+    <p>Nope, sorry
+|]
+
+main = warp 3000 BID

authenticate/openid2.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+import Yesod.Core
+import Web.Authenticate.OpenId
+import qualified Web.Authenticate.OpenId.Providers as P
+import Network.HTTP.Conduit
+import Yesod.Form
+import Network.Wai.Handler.Warp (run)
+import Text.Lucius (lucius)
+
+data OID = OID
+mkYesod "OID" [parseRoutes|
+/ RootR GET
+/forward ForwardR GET
+/complete CompleteR GET
+|]
+
+instance Yesod OID where
+    approot = ApprootStatic "http://localhost:3000"
+
+getRootR :: Handler RepHtml
+getRootR = defaultLayout [whamlet|
+<form action="@{ForwardR}">
+    OpenId: #
+    <input type="text" name="openid_identifier" value="http://">
+    <input type="submit">
+<form action="@{ForwardR}">
+    <input type="hidden" name="openid_identifier" value=#{P.google}>
+    <input type="submit" value=Google>
+|]
+
+instance RenderMessage OID FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+getForwardR :: Handler ()
+getForwardR = do
+    openid <- runInputGet $ ireq textField "openid_identifier"
+    render <- getUrlRender
+    url <- withManager $ getForwardUrl openid (render CompleteR) Nothing []
+    redirect url
+
+getCompleteR :: Handler RepHtml
+getCompleteR = do
+    params <- reqGetParams `fmap` getRequest
+    oir <- withManager $ authenticateClaimed params
+    defaultLayout $ do
+        toWidget [lucius|
+table {
+    border-collapse: collapse;
+}
+th, td {
+    border: 1px solid #666;
+    padding: 5px;
+    vertical-align: top;
+}
+th {
+    text-align: right;
+}
+|]
+        [whamlet|
+<p>Successfully logged in.
+<table>
+    <tr>
+        <th>OP Local
+        <td>#{identifier $ oirOpLocal oir}
+    <tr>
+        <th>Claimed
+        <td>
+            $maybe c <- oirClaimed oir
+                \#{identifier c}
+            $nothing
+                <i>none
+    <tr>
+        <th>Params
+        <td>
+            <table>
+                $forall (k, v) <- oirParams oir
+                    <tr>
+                        <th>#{k}
+                        <td>#{v}
+    <tr>
+        <th>GET params
+        <td>
+            <table>
+                $forall (k, v) <- params
+                    <tr>
+                        <th>#{k}
+                        <td>#{v}
+|]
+
+main :: IO ()
+main = toWaiApp OID >>= run 3000

authenticate/rpxnow.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+import Yesod
+import Web.Authenticate.Rpxnow
+import Data.Maybe (fromMaybe)
+import qualified Data.Aeson as A
+import qualified Data.Vector as V
+import qualified Data.Map as M
+import Data.Text (unpack)
+
+appName :: String
+appName = "yesod-test"
+apiKey = "c8043882f14387d7ad8dfc99a1a8dab2e028f690"
+data RP = RP
+type Handler = GHandler RP RP
+
+mkYesod "RP" [parseRoutes|
+/ RootR GET
+/complete CompleteR POST
+|]
+
+instance Yesod RP where approot _ = "http://localhost:3000"
+
+getRootR :: Handler RepHtml
+getRootR = defaultLayout [hamlet|
+<iframe src="http://#{appName}.rpxnow.com/openid/embed?token_url=@{CompleteR}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
+|]
+
+postCompleteR :: Handler RepHtml
+postCompleteR = do
+    Just token <- lookupPostParam "token"
+    Identifier ident extra <- liftIO $ authenticate apiKey $ unpack token
+    defaultLayout [hamlet|
+<h1>Ident: #{ident}
+<h2>Extra: #{show $ extra}
+|]
+
+main :: IO ()
+main = warpDebug 3000 RP

package-list.sh

@@ -3,7 +3,7 @@
 pkgs=(      ./yesod-routes
             ./yesod-core
             ./yesod-json
-            ./crypto-conduit
+            ./cryptohash-conduit
             ./authenticate/authenticate
             ./yesod-static
             ./yesod-persistent

sources.txt

@@ -9,3 +9,6 @@
 ./yesod-test
 ./yesod-bin
 ./yesod
+./authenticate
+./yesod-eventsource
+./yesod-websockets

yesod-auth-oauth/yesod-auth-oauth.cabal

@@ -3,7 +3,7 @@ version:         1.2.0
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
-maintainer:      Hiromi Ishii
+maintainer:      Michael Litchard
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
@@ -24,7 +24,7 @@ library
                    , bytestring              >= 0.9.1.4
                    , yesod-core              >= 1.2       && < 1.3
                    , yesod-auth              >= 1.2       && < 1.3
-                   , text                    >= 0.7       && < 0.12
+                   , text                    >= 0.7       && < 1.1
                    , yesod-form              >= 1.3       && < 1.4
                    , transformers            >= 0.2.2     && < 0.4
                    , lifted-base             >= 0.2       && < 0.3

yesod-auth/Yesod/Auth.hs

@@ -96,6 +96,10 @@ data Creds master = Creds
 class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
     type AuthId master
 
+    -- | specify the layout. Uses defaultLayout by default
+    authLayout :: WidgetT master IO () -> HandlerT master IO Html
+    authLayout = defaultLayout
+
     -- | Default destination on successful login, if no other
     -- destination exists.
     loginDest :: master -> Route master
@@ -114,7 +118,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     loginHandler :: AuthHandler master Html
     loginHandler = do
         tp <- getRouteToParent
-        lift $ defaultLayout $ do
+        lift $ authLayout $ do
             setTitleI Msg.LoginTitle
             master <- getYesod
             mapM_ (flip apLogin tp) (authPlugins master)
@@ -273,7 +277,7 @@ setCredsRedirect creds = do
         Nothing ->
             case authRoute y of
                 Nothing -> do
-                    messageJson401 "Invalid Login" $ defaultLayout $
+                    messageJson401 "Invalid Login" $ authLayout $
                         toWidget [shamlet|<h1>Invalid login|]
                 Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
         Just aid -> do
@@ -298,6 +302,15 @@ setCreds doRedirects creds =
                   Nothing -> return ()
                   Just aid -> setSession credsKey $ toPathPiece aid
 
+-- | same as defaultLayoutJson, but uses authLayout
+authLayoutJson :: (YesodAuth site, ToJSON j)
+                  => WidgetT site IO ()  -- ^ HTML
+                  -> HandlerT site IO j  -- ^ JSON
+                  -> HandlerT site IO TypedContent
+authLayoutJson w json = selectRep $ do
+    provideRep $ authLayout w
+    provideRep $ fmap toJSON json
+
 -- | Clears current user credentials for the session.
 --
 -- Since 1.1.7
@@ -314,7 +327,7 @@ clearCreds doRedirects = do
 getCheckR :: AuthHandler master TypedContent
 getCheckR = lift $ do
     creds <- maybeAuthId
-    defaultLayoutJson (do
+    authLayoutJson (do
         setTitle "Authentication Status"
         toWidget $ html' creds) (return $ jsonCreds creds)
   where

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Auth.BrowserId
     ( authBrowserId
-    , createOnClick
+    , createOnClick, createOnClickOverride
     , def
     , BrowserIdSettings
     , bisAudience
@@ -107,14 +107,16 @@ $newline never
 
 -- | Generates a function to handle on-click events, and returns that function
 -- name.
-createOnClick :: BrowserIdSettings
+createOnClickOverride :: BrowserIdSettings
               -> (Route Auth -> Route master)
+              -> Maybe (Route master)
               -> WidgetT master IO Text
-createOnClick BrowserIdSettings {..} toMaster = do
+createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
     unless bisLazyLoad $ addScriptRemote browserIdJs
     onclick <- newIdent
     render <- getUrlRender
-    let login = toJSON $ getPath $ render (toMaster LoginR)
+    let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)
+        loginRoute = maybe (toMaster LoginR) id mOnRegistration
     toWidget [julius|
         function #{rawJS onclick}() {
             if (navigator.id) {
@@ -152,3 +154,10 @@ createOnClick BrowserIdSettings {..} toMaster = do
     getPath t = fromMaybe t $ do
         uri <- parseURI $ T.unpack t
         return $ T.pack $ uriPath uri
+
+-- | Generates a function to handle on-click events, and returns that function
+-- name.
+createOnClick :: BrowserIdSettings
+              -> (Route Auth -> Route master)
+              -> WidgetT master IO Text
+createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

yesod-auth/Yesod/Auth/Email.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Rank2Types #-}
 module Yesod.Auth.Email
     ( -- * Plugin
       authEmail
@@ -24,6 +25,10 @@ module Yesod.Auth.Email
      -- * Misc
     , loginLinkKey
     , setLoginLinkKey
+     -- * Default handlers
+    , defaultRegisterHandler
+    , defaultForgotPasswordHandler
+    , defaultSetPasswordHandler
     ) where
 
 import Network.Mail.Mime (randomString)
@@ -174,7 +179,7 @@ class ( YesodAuth site
     confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
     confirmationEmailSentResponse identifier = do
         mr <- getMessageRender
-        messageJson401 (mr msg) $ defaultLayout $ do
+        messageJson401 (mr msg) $ authLayout $ do
               setTitleI Msg.ConfirmationEmailSentTitle
               [whamlet|<p>_{msg}|]
       where
@@ -182,15 +187,48 @@ class ( YesodAuth site
 
     -- | Additional normalization of email addresses, besides standard canonicalization.
     --
-    -- Default: do nothing. Note that in future versions of Yesod, the default
+    -- Default: Lower case the email address.
-    -- will change to lower casing the email address. At that point, you will
-    -- need to either ensure your database values are migrated to lower case,
-    -- or change this default back to doing nothing.
     --
     -- Since 1.2.3
     normalizeEmailAddress :: site -> Text -> Text
     normalizeEmailAddress _ = TS.toLower
 
+    -- | Handler called to render the registration page.  The
+    -- default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultRegisterHandler'.
+    --
+    -- Since: 1.2.6.
+    registerHandler :: AuthHandler site Html
+    registerHandler = defaultRegisterHandler
+
+    -- | Handler called to render the \"forgot password\" page.
+    -- The default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultForgotPasswordHandler'.
+    --
+    -- Since: 1.2.6.
+    forgotPasswordHandler :: AuthHandler site Html
+    forgotPasswordHandler = defaultForgotPasswordHandler
+
+    -- | Handler called to render the \"set password\" page.  The
+    -- default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultSetPasswordHandler'.
+    --
+    -- Since: 1.2.6.
+    setPasswordHandler ::
+         Bool
+         -- ^ Whether the old password is needed.  If @True@, a
+         -- field for the old password should be presented.
+         -- Otherwise, just two fields for the new password are
+         -- needed.
+      -> AuthHandler site TypedContent
+    setPasswordHandler = defaultSetPasswordHandler
+
 
 authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
@@ -227,10 +265,16 @@ $newline never
     dispatch _ _ = notFound
 
 getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
-getRegisterR = do
+getRegisterR = registerHandler
+
+-- | Default implementation of 'registerHandler'.
+--
+-- Since: 1.2.6
+defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
+defaultRegisterHandler = do
     email <- newIdent
     tp <- getRouteToParent
-    lift $ defaultLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
             <p>_{Msg.EnterEmail}
@@ -287,10 +331,16 @@ postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Typ
 postRegisterR = registerHelper False registerR
 
 getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
-getForgotPasswordR = do
+getForgotPasswordR = forgotPasswordHandler
+
+-- | Default implementation of 'forgotPasswordHandler'.
+--
+-- Since: 1.2.6
+defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
+defaultForgotPasswordHandler = do
     tp <- getRouteToParent
     email <- newIdent
-    lift $ defaultLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.PasswordResetTitle
         [whamlet|
             <p>_{Msg.PasswordResetPrompt}
@@ -329,7 +379,7 @@ getVerifyR lid key = do
         _ -> invalidKey mr
   where
     msgIk = Msg.InvalidKey
-    invalidKey mr = messageJson401 (mr msgIk) $ lift $ defaultLayout $ do
+    invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
         setTitleI msgIk
         [whamlet|
 $newline never
@@ -376,17 +426,24 @@ getPasswordR = do
     case maid of
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
         Just _ -> do
-            pass0 <- newIdent
-            pass1 <- newIdent
-            pass2 <- newIdent
-            tp <- getRouteToParent
             needOld <- maybe (return True) (lift . needOldPassword) maid
-            mr <- lift getMessageRender
+            setPasswordHandler needOld
-            selectRep $ do
+
-              provideJsonMessage $ mr Msg.SetPass
+-- | Default implementation of 'setPasswordHandler'.
-              provideRep $ lift $ defaultLayout $ do
+--
-                setTitleI Msg.SetPassTitle
+-- Since: 1.2.6
-                [whamlet|
+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
+defaultSetPasswordHandler needOld = do
+    tp <- getRouteToParent
+    pass0 <- newIdent
+    pass1 <- newIdent
+    pass2 <- newIdent
+    mr <- lift getMessageRender
+    selectRep $ do
+      provideJsonMessage $ mr Msg.SetPass
+      provideRep $ lift $ authLayout $ do
+          setTitleI Msg.SetPassTitle
+          [whamlet|
 $newline never
 <h3>_{Msg.SetPass}
 <form method="post" action="@{tp setpassR}">
@@ -465,7 +522,7 @@ saltLength = 5
 -- | Salt a password with a randomly generated salt.
 saltPass :: Text -> IO Text
 saltPass = fmap (decodeUtf8With lenientDecode)
-         . flip PS.makePassword 12
+         . flip PS.makePassword 14
          . encodeUtf8
 
 saltPass' :: String -> String -> String

yesod-auth/Yesod/Auth/HashDB.hs

@@ -18,6 +18,11 @@
 -- Stability   :  Stable
 -- Portability :  Portable
 --
+-- /WARNING/: This module was /not/ designed with security in mind, and is not
+-- suitable for production sites. In the near future, it will likely be either
+-- deprecated or rewritten to have a more secure implementation. For more
+-- information, see: <https://github.com/yesodweb/yesod/issues/668>.
+--
 -- A yesod-auth AuthPlugin designed to look users up in Persist where
 -- their user id's and a salted SHA1 hash of their password is stored.
 --

yesod-bin/Devel.hs

@@ -69,7 +69,7 @@ import           Data.Conduit.Network                  (HostPreference (HostIPv4
 import           Network                               (withSocketsDo)
 #if MIN_VERSION_http_conduit(2, 0, 0)
 import           Network.HTTP.Conduit                  (conduitManagerSettings, newManager)
-import           Data.Default                          (def)
+import           Data.Default.Class                    (def)
 #else
 import           Network.HTTP.Conduit                  (def, newManager)
 #endif

yesod-bin/GhcBuild.hs

@@ -42,7 +42,11 @@ import           MonadUtils         (liftIO)
 import           Panic              (throwGhcException, panic)
 import           SrcLoc             (Located, mkGeneralLocated)
 import qualified StaticFlags
+#if __GLASGOW_HASKELL__ >= 707
+import           DynFlags           (ldInputs)
+#else
 import           StaticFlags        (v_Ld_inputs)
+#endif
 import           System.FilePath    (normalise, (</>))
 import           Util               (consIORef, looksLikeModuleName)
 
@@ -162,7 +166,15 @@ buildPackage' argv2 ld ar = do
     o_files <- mapM (\x -> compileFile hsc_env StopLn x)
 #endif
                  non_hs_srcs
+#if __GLASGOW_HASKELL__ >= 707
+    let dflags4 = dflags3
+            { ldInputs = map (DF.FileOption "") (reverse o_files)
+                      ++ ldInputs dflags3
+            }
+    GHC.setSessionDynFlags dflags4
+#else
     liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+#endif
     targets <- mapM (uncurry GHC.guessTarget) hs_srcs
     GHC.setTargets targets
     ok_flag <- GHC.load GHC.LoadAllTargets

yesod-bin/HsFile.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module HsFile (mkHsFile) where
+import Text.ProjectTemplate (createTemplate)
+import Data.Conduit 
+    ( ($$), (=$), runResourceT, ResourceT, ConduitM, awaitForever, yield, Source )
+import qualified Data.Conduit.List as CL
+import Prelude hiding (FilePath)
+import Filesystem.Path ( FilePath )
+import Filesystem.Path.CurrentOS ( encodeString )
+import qualified Filesystem as F
+import qualified Data.ByteString as BS
+import Control.Monad.IO.Class (liftIO)
+
+traverse :: FilePath -> Source (ResourceT IO) FilePath
+traverse dir = do
+    liftIO (F.listDirectory dir) >>= mapM_ go
+  where
+    go fp = do
+        isFile' <- liftIO $ F.isFile fp
+        if isFile'
+            then yield fp
+            else do
+                isDir <- liftIO $ F.isDirectory fp
+                if isDir
+                    then traverse fp
+                    else return ()
+
+mkHsFile :: IO ()
+mkHsFile = runResourceT $ traverse "."
+        $$ readIt
+        =$ createTemplate 
+        =$ awaitForever (liftIO . BS.putStr)
+
+-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
+readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) ()
+readIt = CL.map $ \i -> (i, liftIO $ BS.readFile $ encodeString i)
+

yesod-bin/hsfiles/mongo.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -35,7 +36,8 @@ import Network.Wai.Middleware.RequestLogger
 import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
 import qualified Database.Persist
 import Network.HTTP.Conduit (newManager, conduitManagerSettings)
-import System.Log.FastLogger (newLoggerSet, defaultBufSize)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
 import Network.Wai.Logger (clockDateCacher)
 import Data.Default (def)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
@@ -53,7 +55,7 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
 makeApplication conf = do
     foundation <- makeFoundation conf
 
@@ -68,7 +70,8 @@ makeApplication conf = do
 
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
-    return $ logWare app
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare app, logFunc)
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
@@ -81,8 +84,18 @@ makeFoundation conf = do
               Database.Persist.applyEnv
     p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
 
-    loggerSet' <- newLoggerSet defaultBufSize Nothing
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            updateLoop
+    _ <- forkIO updateLoop
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App conf s p manager dbconf logger
@@ -92,7 +105,7 @@ makeFoundation conf = do
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
-    defaultDevelApp loader makeApplication
+    defaultDevelApp loader (fmap fst . makeApplication)
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
@@ -226,7 +239,10 @@ instance YesodAuth App where
         case x of
             Just (Entity uid _) -> return $ Just uid
             Nothing -> do
-                fmap Just $ insert $ User (credsIdent creds) Nothing
+                fmap Just $ insert User
+                    { userIdent = credsIdent creds
+                    , userPassword = Nothing
+                    }
 
     -- You can add other plugins like BrowserID, email or OAuth here
     authPlugins _ = [authBrowserId def, authGoogleEmail]
@@ -387,7 +403,7 @@ library
                 DeriveDataTypeable
 
     build-depends: base                          >= 4          && < 5
-                 , yesod                         >= 1.2        && < 1.3
+                 , yesod                         >= 1.2.5      && < 1.3
                  , yesod-core                    >= 1.2        && < 1.3
                  , yesod-auth                    >= 1.2        && < 1.3
                  , yesod-static                  >= 1.2        && < 1.3
@@ -404,16 +420,16 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
-                 , fast-logger                   >= 2.1        && < 2.2
+                 , fast-logger                   >= 2.1.4      && < 2.2
                  , wai-logger                    >= 2.1        && < 2.2
 
 executable         PROJECTNAME
@@ -580,12 +596,12 @@ combineScripts = combineScripts' development combineSettings
 {-# START_FILE app/main.hs #-}
 import Prelude              (IO)
 import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main   (defaultMain)
+import Yesod.Default.Main   (defaultMainLog)
 import Settings             (parseExtra)
 import Application          (makeApplication)
 
 main :: IO ()
-main = defaultMain (fromArgs parseExtra) makeApplication
+main = defaultMainLog (fromArgs parseExtra) makeApplication
 
 {-# START_FILE BASE64 config/favicon.ico #-}
 AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
@@ -792,7 +808,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -802,9 +818,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/mysql.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -37,7 +38,8 @@ import qualified Database.Persist
 import Database.Persist.Sql (runMigration)
 import Network.HTTP.Conduit (newManager, conduitManagerSettings)
 import Control.Monad.Logger (runLoggingT)
-import System.Log.FastLogger (newLoggerSet, defaultBufSize)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
 import Network.Wai.Logger (clockDateCacher)
 import Data.Default (def)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
@@ -55,7 +57,7 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
 makeApplication conf = do
     foundation <- makeFoundation conf
 
@@ -70,7 +72,8 @@ makeApplication conf = do
 
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
-    return $ logWare app
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare app, logFunc)
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
@@ -83,8 +86,18 @@ makeFoundation conf = do
               Database.Persist.applyEnv
     p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
 
-    loggerSet' <- newLoggerSet defaultBufSize Nothing
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            updateLoop
+    _ <- forkIO updateLoop
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App conf s p manager dbconf logger
@@ -99,7 +112,7 @@ makeFoundation conf = do
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
-    defaultDevelApp loader makeApplication
+    defaultDevelApp loader (fmap fst . makeApplication)
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
@@ -235,7 +248,10 @@ instance YesodAuth App where
         case x of
             Just (Entity uid _) -> return $ Just uid
             Nothing -> do
-                fmap Just $ insert $ User (credsIdent creds) Nothing
+                fmap Just $ insert User
+                    { userIdent = credsIdent creds
+                    , userPassword = Nothing
+                    }
 
     -- You can add other plugins like BrowserID, email or OAuth here
     authPlugins _ = [authBrowserId def, authGoogleEmail]
@@ -391,7 +407,7 @@ library
                 DeriveDataTypeable
 
     build-depends: base                          >= 4          && < 5
-                 , yesod                         >= 1.2        && < 1.3
+                 , yesod                         >= 1.2.5      && < 1.3
                  , yesod-core                    >= 1.2        && < 1.3
                  , yesod-auth                    >= 1.2        && < 1.3
                  , yesod-static                  >= 1.2        && < 1.3
@@ -408,16 +424,16 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
-                 , fast-logger                   >= 2.1        && < 2.2
+                 , fast-logger                   >= 2.1.4      && < 2.2
                  , wai-logger                    >= 2.1        && < 2.2
 
 executable         PROJECTNAME
@@ -584,12 +600,12 @@ combineScripts = combineScripts' development combineSettings
 {-# START_FILE app/main.hs #-}
 import Prelude              (IO)
 import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main   (defaultMain)
+import Yesod.Default.Main   (defaultMainLog)
 import Settings             (parseExtra)
 import Application          (makeApplication)
 
 main :: IO ()
-main = defaultMain (fromArgs parseExtra) makeApplication
+main = defaultMainLog (fromArgs parseExtra) makeApplication
 
 {-# START_FILE BASE64 config/favicon.ico #-}
 AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
@@ -822,7 +838,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -832,9 +848,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/postgres-fay.hsfiles

@@ -15,6 +15,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -39,7 +40,8 @@ import Database.Persist.Sql (runMigration)
 import Network.HTTP.Conduit (newManager, conduitManagerSettings)
 import Yesod.Fay (getFaySite)
 import Control.Monad.Logger (runLoggingT)
-import System.Log.FastLogger (newLoggerSet, defaultBufSize)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
 import Network.Wai.Logger (clockDateCacher)
 import Data.Default (def)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
@@ -58,7 +60,7 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
 makeApplication conf = do
     foundation <- makeFoundation conf
 
@@ -73,7 +75,8 @@ makeApplication conf = do
 
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
-    return $ logWare app
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare app, logFunc)
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
@@ -86,8 +89,18 @@ makeFoundation conf = do
               Database.Persist.applyEnv
     p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
 
-    loggerSet' <- newLoggerSet defaultBufSize Nothing
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            updateLoop
+    _ <- forkIO updateLoop
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App conf s p manager dbconf onCommand logger
@@ -102,7 +115,7 @@ makeFoundation conf = do
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
-    defaultDevelApp loader makeApplication
+    defaultDevelApp loader (fmap fst . makeApplication)
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
@@ -248,7 +261,10 @@ instance YesodAuth App where
         case x of
             Just (Entity uid _) -> return $ Just uid
             Nothing -> do
-                fmap Just $ insert $ User (credsIdent creds) Nothing
+                fmap Just $ insert User
+                    { userIdent = credsIdent creds
+                    , userPassword = Nothing
+                    }
 
     -- You can add other plugins like BrowserID, email or OAuth here
     authPlugins _ = [authBrowserId def, authGoogleEmail]
@@ -427,7 +443,7 @@ library
                 DeriveDataTypeable
 
     build-depends: base                          >= 4          && < 5
-                 , yesod                         >= 1.2        && < 1.3
+                 , yesod                         >= 1.2.5      && < 1.3
                  , yesod-core                    >= 1.2        && < 1.3
                  , yesod-auth                    >= 1.2        && < 1.3
                  , yesod-static                  >= 1.2        && < 1.3
@@ -445,16 +461,16 @@ library
                  , shakespeare-js                >= 1.2        && < 1.3
                  , shakespeare-text              >= 1.0        && < 1.1
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
-                 , fast-logger                   >= 2.1        && < 2.2
+                 , fast-logger                   >= 2.1.4      && < 2.2
                  , wai-logger                    >= 2.1        && < 2.2
 
 executable         PROJECTNAME
@@ -633,12 +649,12 @@ combineScripts = combineScripts' development combineSettings
 {-# START_FILE app/main.hs #-}
 import Prelude              (IO)
 import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main   (defaultMain)
+import Yesod.Default.Main   (defaultMainLog)
 import Settings             (parseExtra)
 import Application          (makeApplication)
 
 main :: IO ()
-main = defaultMain (fromArgs parseExtra) makeApplication
+main = defaultMainLog (fromArgs parseExtra) makeApplication
 
 {-# START_FILE BASE64 config/favicon.ico #-}
 AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
@@ -846,7 +862,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -856,9 +872,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/postgres.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -37,7 +38,8 @@ import qualified Database.Persist
 import Database.Persist.Sql (runMigration)
 import Network.HTTP.Conduit (newManager, conduitManagerSettings)
 import Control.Monad.Logger (runLoggingT)
-import System.Log.FastLogger (newLoggerSet, defaultBufSize)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
 import Network.Wai.Logger (clockDateCacher)
 import Data.Default (def)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
@@ -55,7 +57,7 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
 makeApplication conf = do
     foundation <- makeFoundation conf
 
@@ -70,7 +72,8 @@ makeApplication conf = do
 
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
-    return $ logWare app
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare app, logFunc)
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
@@ -83,8 +86,18 @@ makeFoundation conf = do
               Database.Persist.applyEnv
     p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
 
-    loggerSet' <- newLoggerSet defaultBufSize Nothing
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            updateLoop
+    _ <- forkIO updateLoop
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App conf s p manager dbconf logger
@@ -99,7 +112,7 @@ makeFoundation conf = do
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
-    defaultDevelApp loader makeApplication
+    defaultDevelApp loader (fmap fst . makeApplication)
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
@@ -235,7 +248,10 @@ instance YesodAuth App where
         case x of
             Just (Entity uid _) -> return $ Just uid
             Nothing -> do
-                fmap Just $ insert $ User (credsIdent creds) Nothing
+                fmap Just $ insert User
+                    { userIdent = credsIdent creds
+                    , userPassword = Nothing
+                    }
 
     -- You can add other plugins like BrowserID, email or OAuth here
     authPlugins _ = [authBrowserId def, authGoogleEmail]
@@ -391,7 +407,7 @@ library
                 DeriveDataTypeable
 
     build-depends: base                          >= 4          && < 5
-                 , yesod                         >= 1.2        && < 1.3
+                 , yesod                         >= 1.2.5      && < 1.3
                  , yesod-core                    >= 1.2        && < 1.3
                  , yesod-auth                    >= 1.2        && < 1.3
                  , yesod-static                  >= 1.2        && < 1.3
@@ -408,16 +424,16 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
-                 , fast-logger                   >= 2.1        && < 2.2
+                 , fast-logger                   >= 2.1.4      && < 2.2
                  , wai-logger                    >= 2.1        && < 2.2
 
 executable         PROJECTNAME
@@ -584,12 +600,12 @@ combineScripts = combineScripts' development combineSettings
 {-# START_FILE app/main.hs #-}
 import Prelude              (IO)
 import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main   (defaultMain)
+import Yesod.Default.Main   (defaultMainLog)
 import Settings             (parseExtra)
 import Application          (makeApplication)
 
 main :: IO ()
-main = defaultMain (fromArgs parseExtra) makeApplication
+main = defaultMainLog (fromArgs parseExtra) makeApplication
 
 {-# START_FILE BASE64 config/favicon.ico #-}
 AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
@@ -796,7 +812,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -806,9 +822,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/simple.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -32,7 +33,8 @@ import Network.Wai.Middleware.RequestLogger
     )
 import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
 import Network.HTTP.Conduit (newManager, conduitManagerSettings)
-import System.Log.FastLogger (newLoggerSet, defaultBufSize)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
 import Network.Wai.Logger (clockDateCacher)
 import Data.Default (def)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
@@ -50,7 +52,7 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
 makeApplication conf = do
     foundation <- makeFoundation conf
 
@@ -65,7 +67,8 @@ makeApplication conf = do
 
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
-    return $ logWare app
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare app, logFunc)
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
@@ -74,8 +77,18 @@ makeFoundation conf = do
     manager <- newManager conduitManagerSettings
     s <- staticSite
 
-    loggerSet' <- newLoggerSet defaultBufSize Nothing
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            updateLoop
+    _ <- forkIO updateLoop
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App conf s manager logger
@@ -85,7 +98,7 @@ makeFoundation conf = do
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
-    defaultDevelApp loader makeApplication
+    defaultDevelApp loader (fmap fst . makeApplication)
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
@@ -321,7 +334,7 @@ library
                 DeriveDataTypeable
 
     build-depends: base                          >= 4          && < 5
-                 , yesod                         >= 1.2        && < 1.3
+                 , yesod                         >= 1.2.5      && < 1.3
                  , yesod-core                    >= 1.2        && < 1.3
                  , yesod-auth                    >= 1.2        && < 1.3
                  , yesod-static                  >= 1.2        && < 1.3
@@ -335,16 +348,16 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
-                 , fast-logger                   >= 2.1        && < 2.2
+                 , fast-logger                   >= 2.1.4      && < 2.2
                  , wai-logger                    >= 2.1        && < 2.2
 
 executable         PROJECTNAME
@@ -502,12 +515,12 @@ combineScripts = combineScripts' development combineSettings
 {-# START_FILE app/main.hs #-}
 import Prelude              (IO)
 import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main   (defaultMain)
+import Yesod.Default.Main   (defaultMainLog)
 import Settings             (parseExtra)
 import Application          (makeApplication)
 
 main :: IO ()
-main = defaultMain (fromArgs parseExtra) makeApplication
+main = defaultMainLog (fromArgs parseExtra) makeApplication
 
 {-# START_FILE BASE64 config/favicon.ico #-}
 AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
@@ -673,7 +686,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -683,9 +696,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/sqlite.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -37,7 +38,8 @@ import qualified Database.Persist
 import Database.Persist.Sql (runMigration)
 import Network.HTTP.Conduit (newManager, conduitManagerSettings)
 import Control.Monad.Logger (runLoggingT)
-import System.Log.FastLogger (newLoggerSet, defaultBufSize)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
 import Network.Wai.Logger (clockDateCacher)
 import Data.Default (def)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
@@ -55,7 +57,7 @@ mkYesodDispatch "App" resourcesApp
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
 makeApplication conf = do
     foundation <- makeFoundation conf
 
@@ -70,7 +72,8 @@ makeApplication conf = do
 
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
-    return $ logWare app
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare app, logFunc)
 
 -- | Loads up any necessary settings, creates your foundation datatype, and
 -- performs some initialization.
@@ -83,8 +86,18 @@ makeFoundation conf = do
               Database.Persist.applyEnv
     p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
 
-    loggerSet' <- newLoggerSet defaultBufSize Nothing
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
-    (getter, _) <- clockDateCacher
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            updateLoop
+    _ <- forkIO updateLoop
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App conf s p manager dbconf logger
@@ -99,7 +112,7 @@ makeFoundation conf = do
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
-    defaultDevelApp loader makeApplication
+    defaultDevelApp loader (fmap fst . makeApplication)
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
@@ -235,7 +248,10 @@ instance YesodAuth App where
         case x of
             Just (Entity uid _) -> return $ Just uid
             Nothing -> do
-                fmap Just $ insert $ User (credsIdent creds) Nothing
+                fmap Just $ insert User
+                    { userIdent = credsIdent creds
+                    , userPassword = Nothing
+                    }
 
     -- You can add other plugins like BrowserID, email or OAuth here
     authPlugins _ = [authBrowserId def, authGoogleEmail]
@@ -391,7 +407,7 @@ library
                 DeriveDataTypeable
 
     build-depends: base                          >= 4          && < 5
-                 , yesod                         >= 1.2        && < 1.3
+                 , yesod                         >= 1.2.5      && < 1.3
                  , yesod-core                    >= 1.2        && < 1.3
                  , yesod-auth                    >= 1.2        && < 1.3
                  , yesod-static                  >= 1.2        && < 1.3
@@ -408,16 +424,16 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
-                 , fast-logger                   >= 2.1        && < 2.2
+                 , fast-logger                   >= 2.1.4      && < 2.2
                  , wai-logger                    >= 2.1        && < 2.2
 
 executable         PROJECTNAME
@@ -584,12 +600,12 @@ combineScripts = combineScripts' development combineSettings
 {-# START_FILE app/main.hs #-}
 import Prelude              (IO)
 import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main   (defaultMain)
+import Yesod.Default.Main   (defaultMainLog)
 import Settings             (parseExtra)
 import Application          (makeApplication)
 
 main :: IO ()
-main = defaultMain (fromArgs parseExtra) makeApplication
+main = defaultMainLog (fromArgs parseExtra) makeApplication
 
 {-# START_FILE BASE64 config/favicon.ico #-}
 AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
@@ -792,7 +808,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -802,9 +818,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/input/done.cg

@@ -24,4 +24,4 @@ Take part in the community: http://yesodweb.com/page/community
 
 Start your project:
 
-   cd PROJECTNAME && cabal sandbox init && cabal install && yesod devel
+   cd PROJECTNAME && cabal sandbox init && cabal install --enable-tests . yesod-platform yesod-bin --max-backjumps=-1 --reorder-goals && yesod devel

yesod-bin/main.hs

@@ -21,6 +21,7 @@ import           Options.Applicative.Types (ReadM (ReadM))
 import           Options.Applicative.Builder.Internal (Mod, OptionFields)
 #endif
 
+import           HsFile                 (mkHsFile)
 #ifndef WINDOWS
 import           Build                  (touch)
 
@@ -47,6 +48,7 @@ data Options = Options
   deriving (Show, Eq)
 
 data Command = Init { _initBare :: Bool }
+             | HsFiles
              | Configure
              | Build { buildExtraArgs   :: [String] }
              | Touch
@@ -96,6 +98,7 @@ main = do
   let cabal = rawSystem' (cabalCommand o)
   case optCommand o of
     Init bare       -> scaffold bare
+    HsFiles         -> mkHsFile
     Configure       -> cabal ["configure"]
     Build es        -> touch' >> cabal ("build":es)
     Touch           -> touch'
@@ -124,8 +127,10 @@ optParser = Options
         <$> flag Cabal CabalDev ( long "dev"     <> short 'd' <> help "use cabal-dev" )
         <*> switch              ( long "verbose" <> short 'v' <> help "More verbose output" )
         <*> subparser ( command "init"
-                            (info (Init <$> switch (long "bare" <> help "Create files in current folder"))
+                            (info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
                             (progDesc "Scaffold a new site"))
+                      <> command "hsfiles" (info (pure HsFiles)
+                            (progDesc "Create a hsfiles file for the current folder"))
                       <> command "configure" (info (pure Configure)
                             (progDesc "Configure a project for building"))
                       <> command "build"     (info (Build <$> extraCabalArgs)

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.2.5.5
+version:         1.2.7.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -89,7 +89,7 @@ executable             yesod
                      , transformers
                      , warp               >= 1.3.7.5
                      , wai                >= 1.4
-                     , data-default
+                     , data-default-class
 
     ghc-options:       -Wall -threaded
     main-is:           main.hs
@@ -101,6 +101,7 @@ executable             yesod
                        AddHandler
                        Paths_yesod_bin
                        Options
+                       HsFile
 
 source-repository head
   type:     git

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -516,7 +516,7 @@ defaultErrorHandler (BadMethod m) = selectRep $ do
             <h1>Method Not Supported
             <p>Method <code>#{S8.unpack m}</code> not supported
         |]
-    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
+    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
 
 asyncHelper :: (url -> [x] -> Text)
          -> [Script (url)]

yesod-core/Yesod/Core/Dispatch.hs

@@ -41,7 +41,7 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Monoid (mappend)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
@@ -118,6 +118,10 @@ toWaiAppYre yre req =
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
     logger <- makeLogger site
+    toWaiAppLogger logger site
+
+toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
+toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
     let yre = YesodRunnerEnv
                 { yreLogger = logger
@@ -144,19 +148,29 @@ toWaiApp site = do
 --
 -- Since 1.2.0
 warp :: YesodDispatch site => Int -> site -> IO ()
-warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
+warp port site = do
-    Network.Wai.Handler.Warp.defaultSettings
+    logger <- makeLogger site
-        { Network.Wai.Handler.Warp.settingsPort = port
+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
-        {- FIXME
+        Network.Wai.Handler.Warp.defaultSettings
-        , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
+            { Network.Wai.Handler.Warp.settingsPort = port
-            [ "Warp/"
+            {- FIXME
-            , Network.Wai.Handler.Warp.warpVersion
+            , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
-            , " + Yesod/"
+                [ "Warp/"
-            , showVersion Paths_yesod_core.version
+                , Network.Wai.Handler.Warp.warpVersion
-            , " (core)"
+                , " + Yesod/"
-            ]
+                , showVersion Paths_yesod_core.version
-        -}
+                , " (core)"
-        }
+                ]
+            -}
+            , Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
+                messageLoggerSource
+                    site
+                    logger
+                    $(qLocation >>= liftLoc)
+                    "yesod-core"
+                    LevelError
+                    (toLogStr $ "Exception from Warp: " ++ show e)
+            }
 
 -- | A default set of middlewares.
 --

yesod-core/Yesod/Core/Handler.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -74,6 +75,7 @@ module Yesod.Core.Handler
     , redirect
     , redirectWith
     , redirectToPost
+    , Fragment(..)
       -- ** Errors
     , notFound
     , badMethod
@@ -89,6 +91,9 @@ module Yesod.Core.Handler
     , sendResponseStatus
     , sendResponseCreated
     , sendWaiResponse
+#if MIN_VERSION_wai(2, 1, 0)
+    , sendRawResponse
+#endif
       -- * Different representations
       -- $representations
     , selectRep
@@ -134,6 +139,7 @@ module Yesod.Core.Handler
     , newIdent
       -- * Lifting
     , handlerToIO
+    , forkHandler
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -146,18 +152,17 @@ import           Yesod.Core.Internal.Request   (langKey, mkFileInfoFile,
                                                 mkFileInfoLBS, mkFileInfoSource)
 
 import           Control.Applicative           ((<$>), (<|>))
-import           Control.Exception             (evaluate)
+import           Control.Exception             (evaluate, SomeException)
+import           Control.Exception.Lifted      (handle)
 
-import           Control.Monad                 (liftM)
+import           Control.Monad                 (liftM, void)
 import qualified Control.Monad.Trans.Writer    as Writer
 
 import           Control.Monad.IO.Class        (MonadIO, liftIO)
-import           Control.Monad.Trans.Resource  (MonadResource, liftResourceT, InternalState)
 
 import qualified Network.HTTP.Types            as H
 import qualified Network.Wai                   as W
 import Control.Monad.Trans.Class (lift)
-import Data.Conduit (transPipe, Flush (Flush), yield, Producer)
 
 import qualified Data.Text                     as T
 import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
@@ -170,10 +175,8 @@ import qualified Data.ByteString               as S
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map                      as Map
 
-import Data.Conduit (Source)
 import           Control.Arrow                 ((***))
 import qualified Data.ByteString.Char8         as S8
-import           Data.Maybe                    (mapMaybe)
 import           Data.Monoid                   (Endo (..), mappend, mempty)
 import           Data.Text                     (Text)
 import qualified Network.Wai.Parse             as NWP
@@ -183,11 +186,11 @@ import           Yesod.Core.Content            (ToTypedContent (..), simpleConte
 import           Yesod.Core.Internal.Util      (formatRFC1123)
 import           Text.Blaze.Html               (preEscapedToMarkup, toHtml)
 
-import           Control.Monad.Trans.Resource  (ResourceT, runResourceT, withInternalState, getInternalState, liftResourceT)
 import           Data.Dynamic                  (fromDynamic, toDyn)
 import qualified Data.IORef.Lifted             as I
-import           Data.Maybe                    (listToMaybe)
+import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable, typeOf)
+import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
@@ -195,9 +198,23 @@ import Control.Failure (failure)
 import Blaze.ByteString.Builder (Builder)
 import Safe (headMay)
 import Data.CaseInsensitive (CI)
+import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
+#if MIN_VERSION_wai(2, 0, 0)
+#else
+              , ResourceT
+#endif
+              )
 #if MIN_VERSION_wai(2, 0, 0)
 import qualified System.PosixCompat.Files as PC
 #endif
+#if MIN_VERSION_wai(2, 1, 0)
+import Control.Monad.Trans.Control (control, MonadBaseControl)
+#endif
+import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
+#if MIN_VERSION_wai(2, 1, 0)
+                    , Sink
+#endif
+                   )
 
 get :: MonadHandler m => m GHState
 get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -382,6 +399,18 @@ handlerToIO =
                 }
         liftIO (f newHandlerData)
 
+-- | forkIO for a Handler (run an action in the background)
+--
+-- Uses 'handlerToIO', liftResourceT, and resourceForkIO
+-- for correctness and efficiency
+--
+-- Since 1.2.8
+forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
+              -> HandlerT site IO ()
+              -> HandlerT site IO ()
+forkHandler onErr handler = do
+    yesRunner <- handlerToIO
+    void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
 
 -- | Redirect to the given route.
 -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@@ -547,6 +576,23 @@ sendResponseCreated url = do
 sendWaiResponse :: MonadHandler m => W.Response -> m b
 sendWaiResponse = handlerError . HCWai
 
+#if MIN_VERSION_wai(2, 1, 0)
+-- | Send a raw response. This is used for cases such as WebSockets. Requires
+-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
+-- Warp).
+--
+-- Since 1.2.7
+sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
+                => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
+                -> m a
+sendRawResponse raw = control $ \runInIO ->
+    runInIO $ sendWaiResponse $ flip W.responseRaw fallback
+    $ \src sink -> runInIO (raw src sink) >> return ()
+  where
+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
+        "sendRawResponse: backend does not support raw responses"
+#endif
+
 -- | Return a 404 not found page. Also denotes no handler available.
 notFound :: MonadHandler m => m a
 notFound = hcError NotFound
@@ -640,7 +686,12 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
 -- | Set the Expires header to some date in 2037. In other words, this content
 -- is never (realistically) expired.
 neverExpires :: MonadHandler m => m ()
-neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
+neverExpires = do
+    setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
+    cacheSeconds oneYear
+  where
+    oneYear :: Int
+    oneYear = 60 * 60 * 24 * 365
 
 -- | Set an Expires header in the past, meaning this content should not be
 -- cached.
@@ -710,6 +761,18 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va
 instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
     toTextUrl (url, params) = toTextUrl (url, Map.toList params)
 
+-- | Add a fragment identifier to a route to be used when
+-- redirecting.  For example:
+--
+-- > redirect (NewsfeedR :#: storyId)
+--
+-- Since 1.2.9.
+data Fragment a b = a :#: b deriving (Show, Typeable)
+
+instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
+  toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a
+
+
 -- | Lookup for session data.
 lookupSession :: MonadHandler m => Text -> m (Maybe Text)
 lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS

yesod-core/Yesod/Core/Internal/Response.hs

@@ -47,9 +47,20 @@ yarToResponse (YRWai a) _ _ _ is =
     case a of
         ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
             w f `finally` closeInternalState is
-        _ -> do
+        ResponseBuilder{} -> do
             closeInternalState is
             return a
+        ResponseFile{} -> do
+            closeInternalState is
+            return a
+#if MIN_VERSION_wai(2, 1, 0)
+        -- Ignore the fallback provided, in case it refers to a ResourceT state
+        -- in a ResponseSource.
+        ResponseRaw raw _ -> return $ ResponseRaw
+            (\f -> raw f `finally` closeInternalState is)
+            (responseLBS H.status500 [("Content-Type", "text/plain")]
+                "yarToResponse: backend does not support raw responses")
+#endif
 #else
 yarToResponse (YRWai a) _ _ _ = return a
 #endif
@@ -128,7 +139,9 @@ headerToPair (Header key value) = (CI.mk key, value)
 evaluateContent :: Content -> IO (Either ErrorResponse Content)
 evaluateContent (ContentBuilder b mlen) = handle f $ do
     let lbs = toLazyByteString b
-    L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
+        len = L.length lbs
+        mlen' = maybe (Just $ fromIntegral len) Just mlen
+    len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
   where
     f :: SomeException -> IO (Either ErrorResponse Content)
     f = return . Left . InternalError . T.pack . show

yesod-core/Yesod/Core/Internal/Run.hs

@@ -10,7 +10,8 @@ module Yesod.Core.Internal.Run where
 import Yesod.Core.Internal.Response
 import           Blaze.ByteString.Builder     (toByteString)
 import           Control.Applicative          ((<$>))
-import           Control.Exception            (fromException, bracketOnError)
+import           Control.Exception            (fromException, bracketOnError, evaluate)
+import qualified Control.Exception            as E
 import           Control.Exception.Lifted     (catch)
 import           Control.Monad.IO.Class       (MonadIO)
 import           Control.Monad.IO.Class       (liftIO)
@@ -94,7 +95,9 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
                 YRWai _ -> return yar
     let sendFile' ct fp p =
             return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
-    case contents of
+    contents1 <- evaluate contents `E.catch` \e -> return
+        (HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+    case contents1 of
         HCContent status (TypedContent ct c) -> do
             ec' <- liftIO $ evaluateContent c
             case ec' of

yesod-core/Yesod/Core/Json.hs

@@ -10,6 +10,7 @@ module Yesod.Core.Json
       -- * Convert to a JSON value
     , parseJsonBody
     , parseJsonBody_
+    , requireJsonBody
 
       -- * Produce JSON values
     , J.Value (..)
@@ -99,7 +100,13 @@ parseJsonBody = do
 -- | Same as 'parseJsonBody', but return an invalid args response on a parse
 -- error.
 parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
-parseJsonBody_ = do
+parseJsonBody_ = requireJsonBody
+{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}
+
+-- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- error.
+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireJsonBody = do
     ra <- parseJsonBody
     case ra of
         J.Error s -> invalidArgs [pack s]

yesod-core/bench/widget.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | BigTable benchmark implemented using Hamlet.
 --
 {-# LANGUAGE QuasiQuotes #-}
@@ -7,19 +8,22 @@ import Criterion.Main
 import Text.Hamlet
 import Numeric (showInt)
 import qualified Data.ByteString.Lazy as L
-import qualified Text.Blaze.Renderer.Utf8 as Utf8
+import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
 import Data.Monoid (mconcat)
 import Text.Blaze.Html5 (table, tr, td)
-import Yesod.Widget
+import Text.Blaze.Html (toHtml)
+import Yesod.Core.Widget
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.RWS
 import Data.Functor.Identity
-import Yesod.Internal
+import Yesod.Core.Types
+import Data.Monoid
+import Data.IORef
 
 main = defaultMain
     [ bench "bigTable html" $ nf bigTableHtml bigTableData
     , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
-    , bench "bigTable widget" $ nf bigTableWidget bigTableData
+    , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
     , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
     ]
   where
@@ -30,50 +34,35 @@ main = defaultMain
     bigTableData = replicate rows [1..10]
     {-# NOINLINE bigTableData #-}
 
-bigTableHtml rows = L.length $ renderHtml [$hamlet|
+bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
-<table
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
 |]
 
-bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
+bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
-<table
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
 |]
 
-bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
+bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
-<table
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
-|]) (\_ _ -> "foo")
+|])
   where
-  run (GWidget w) =
+  render _ _ = "foo"
-    let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0
+  run (WidgetT w) = do
-     in x
+    (_, GWData { gwdBody = Body x }) <- w undefined
-  {-
+    return x
-  run (GWidget w) = runIdentity $ do
-    w' <- flip evalStateT 0
-        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
-        $ runWriterT $ runWriterT $ runWriterT w
-    let ((((((((),
-         Body body),
-         _),
-         _),
-         _),
-         _),
-         _),
-         _) = w'
 
-    return body
+bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t
-    -}
-
-bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t
   where
-    row r = tr $ mconcat $ map (td . string . show) r
+    row r = tr $ mconcat $ map (td . toHtml . show) r

yesod-core/test/YesodCoreTest.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                        #-}
 module YesodCoreTest (specs) where 
 
 import YesodCoreTest.CleanPath
@@ -14,6 +15,9 @@ import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
 import qualified YesodCoreTest.Json as Json
+#if MIN_VERSION_wai(2, 1, 0)
+import qualified YesodCoreTest.RawResponse as RawResponse
+#endif
 import qualified YesodCoreTest.Streaming as Streaming
 import qualified YesodCoreTest.Reps as Reps
 import qualified YesodCoreTest.Auth as Auth
@@ -37,6 +41,9 @@ specs = do
       JsLoader.specs
       RequestBodySize.specs
       Json.specs
+#if MIN_VERSION_wai(2, 1, 0)
+      RawResponse.specs
+#endif
       Streaming.specs
       Reps.specs
       Auth.specs

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -13,6 +13,8 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
 import Control.Exception (SomeException, try)
 import Network.HTTP.Types (mkStatus)
+import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
+import Data.Monoid (mconcat)
 
 data App = App
 
@@ -24,6 +26,13 @@ mkYesod "App" [parseRoutes|
 /error-in-body ErrorInBodyR GET
 /error-in-body-noeval ErrorInBodyNoEvalR GET
 /override-status OverrideStatusR GET
+
+-- https://github.com/yesodweb/yesod/issues/658
+/builder BuilderR GET
+/file-bad-len FileBadLenR GET
+/file-bad-name FileBadNameR GET
+
+/good-builder GoodBuilderR GET
 |]
 
 overrideStatus = mkStatus 15 "OVERRIDE"
@@ -74,6 +83,21 @@ getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR
 getOverrideStatusR :: Handler ()
 getOverrideStatusR = invalidArgs ["OVERRIDE"]
 
+getBuilderR :: Handler TypedContent
+getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing
+
+getFileBadLenR :: Handler TypedContent
+getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen")
+
+getFileBadNameR :: Handler TypedContent
+getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
+
+goodBuilderContent :: Builder
+goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"
+
+getGoodBuilderR :: Handler TypedContent
+getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
+
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "says not found" caseNotFound
@@ -82,6 +106,10 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "error in body == 500" caseErrorInBody
       it "error in body, no eval == 200" caseErrorInBodyNoEval
       it "can override status code" caseOverrideStatus
+      it "builder" caseBuilder
+      it "file with bad len" caseFileBadLen
+      it "file with bad name" caseFileBadName
+      it "builder includes content-length" caseGoodBuilder
 
 runner :: Session () -> IO ()
 runner f = toWaiApp App >>= runSession f
@@ -140,3 +168,29 @@ caseOverrideStatus :: IO ()
 caseOverrideStatus = runner $ do
     res <- request defaultRequest { pathInfo = ["override-status"] }
     assertStatus 15 res
+
+caseBuilder :: IO ()
+caseBuilder = runner $ do
+    res <- request defaultRequest { pathInfo = ["builder"] }
+    assertStatus 500 res
+    assertBodyContains "builder-3.14159" res
+
+caseFileBadLen :: IO ()
+caseFileBadLen = runner $ do
+    res <- request defaultRequest { pathInfo = ["file-bad-len"] }
+    assertStatus 500 res
+    assertBodyContains "filebadlen" res
+
+caseFileBadName :: IO ()
+caseFileBadName = runner $ do
+    res <- request defaultRequest { pathInfo = ["file-bad-name"] }
+    assertStatus 500 res
+    assertBodyContains "filebadname" res
+
+caseGoodBuilder :: IO ()
+caseGoodBuilder = runner $ do
+    res <- request defaultRequest { pathInfo = ["good-builder"] }
+    assertStatus 200 res
+    let lbs = toLazyByteString goodBuilderContent
+    assertBody lbs res
+    assertHeader "content-length" (S8.pack $ show $ L.length lbs) res

yesod-core/test/YesodCoreTest/Json.hs

@@ -19,7 +19,7 @@ instance Yesod App
 
 getHomeR :: Handler RepPlain
 getHomeR = do
-    val <- parseJsonBody_
+    val <- requireJsonBody
     case Map.lookup ("foo" :: Text) val of
         Nothing -> invalidArgs ["foo not found"]
         Just foo -> return $ RepPlain $ toContent (foo :: Text)

yesod-core/test/YesodCoreTest/RawResponse.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-}
+module YesodCoreTest.RawResponse (specs, Widget) where
+
+import Yesod.Core
+import Test.Hspec
+import qualified Data.Map as Map
+import Network.Wai.Test
+import Data.Text (Text)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.Conduit.List as CL
+import qualified Data.ByteString.Char8 as S8
+import Data.Conduit
+import qualified Data.Conduit.Binary as CB
+import Data.Char (toUpper)
+import Control.Exception (try, IOException)
+import Data.Conduit.Network
+import Network.Socket (sClose)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (withAsync)
+import Control.Monad.Trans.Resource (register)
+import Data.IORef
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App
+
+getHomeR :: Handler ()
+getHomeR = do
+    ref <- liftIO $ newIORef 0
+    _ <- register $ writeIORef ref 1
+    sendRawResponse $ \src sink -> liftIO $ do
+        val <- readIORef ref
+        yield (S8.pack $ show val) $$ sink
+        src $$ CL.map (S8.map toUpper) =$ sink
+
+getFreePort :: IO Int
+getFreePort = do
+    loop 43124
+  where
+    loop port = do
+        esocket <- try $ bindPort port "*"
+        case esocket of
+            Left (_ :: IOException) -> loop (succ port)
+            Right socket -> do
+                sClose socket
+                return port
+
+specs :: Spec
+specs = describe "RawResponse" $ do
+    it "works" $ do
+        port <- getFreePort
+        withAsync (warp port App) $ \_ -> do
+            threadDelay 100000
+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad
+                (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")
+                yield "WORLd" $$ appSink ad
+                (appSource ad $$ await) >>= (`shouldBe` Just "WORLD")

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.2.6.4
+version:         1.2.9
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -122,9 +122,26 @@ test-suite tests
                   , containers
                   , lifted-base
                   , resourcet
+                  , network-conduit
+                  , network
+                  , async
     ghc-options:     -Wall
     extensions: TemplateHaskell
 
+benchmark widgets
+    type: exitcode-stdio-1.0
+    hs-source-dirs: bench
+    build-depends:  base
+                  , criterion
+                  , bytestring
+                  , text
+                  , hamlet
+                  , transformers
+                  , yesod-core
+                  , blaze-html
+    main-is:        widget.hs
+    ghc-options:    -Wall -O2
+
 source-repository head
   type:     git
   location: https://github.com/yesodweb/yesod

yesod-form/Yesod/Form/Bootstrap3.hs

@@ -0,0 +1,262 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Helper functions for creating forms when using Bootstrap v3.
+module Yesod.Form.Bootstrap3
+  ( -- * Rendering forms
+    renderBootstrap3
+  , BootstrapFormLayout(..)
+  , BootstrapGridOptions(..)
+    -- * Field settings
+  , bfs
+  , withPlaceholder
+  , withAutofocus
+  , withLargeInput
+  , withSmallInput
+    -- * Submit button
+  , bootstrapSubmit
+  , mbootstrapSubmit
+  , BootstrapSubmit(..)
+  ) where
+
+import Control.Arrow (second)
+import Control.Monad (liftM)
+import Data.Text (Text)
+import Data.String (IsString(..))
+import Yesod.Core
+
+import qualified Data.Text as T
+
+import Yesod.Form.Types
+import Yesod.Form.Functions
+
+-- | Create a new 'FieldSettings' with the classes that are
+-- required by Bootstrap v3.
+--
+-- Since: yesod-form 1.3.8
+bfs :: RenderMessage site msg => msg -> FieldSettings site
+bfs msg =
+    FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
+
+
+-- | Add a placeholder attribute to a field.  If you need i18n
+-- for the placeholder, currently you\'ll need to do a hack and
+-- use 'getMessageRender' manually.
+--
+-- Since: yesod-form 1.3.8
+withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
+withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("placeholder", placeholder) : fsAttrs fs
+
+
+-- | Add an autofocus attribute to a field.
+--
+-- Since: yesod-form 1.3.8
+withAutofocus :: FieldSettings site -> FieldSettings site
+withAutofocus fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
+
+
+-- | Add the @input-lg@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withLargeInput :: FieldSettings site -> FieldSettings site
+withLargeInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-lg" (fsAttrs fs)
+
+
+-- | Add the @input-sm@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withSmallInput :: FieldSettings site -> FieldSettings site
+withSmallInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-sm" (fsAttrs fs)
+
+
+addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
+addClass klass []                    = [("class", klass)]
+addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
+addClass klass (other         :rest) = other : addClass klass rest
+
+
+-- | How many bootstrap grid columns should be taken (see
+-- 'BootstrapFormLayout').
+--
+-- Since: yesod-form 1.3.8
+data BootstrapGridOptions =
+    ColXs !Int
+  | ColSm !Int
+  | ColMd !Int
+  | ColLg !Int
+    deriving (Eq, Ord, Show)
+
+toColumn :: BootstrapGridOptions -> String
+toColumn (ColXs 0) = ""
+toColumn (ColSm 0) = ""
+toColumn (ColMd 0) = ""
+toColumn (ColLg 0) = ""
+toColumn (ColXs columns) = "col-xs-" ++ show columns
+toColumn (ColSm columns) = "col-sm-" ++ show columns
+toColumn (ColMd columns) = "col-md-" ++ show columns
+toColumn (ColLg columns) = "col-lg-" ++ show columns
+
+toOffset :: BootstrapGridOptions -> String
+toOffset (ColXs 0) = ""
+toOffset (ColSm 0) = ""
+toOffset (ColMd 0) = ""
+toOffset (ColLg 0) = ""
+toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
+toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
+toOffset (ColMd columns) = "col-md-offset-" ++ show columns
+toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
+
+addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
+addGO (ColXs a) (ColXs b) = ColXs (a+b)
+addGO (ColSm a) (ColSm b) = ColSm (a+b)
+addGO (ColMd a) (ColMd b) = ColMd (a+b)
+addGO (ColLg a) (ColLg b) = ColLg (a+b)
+addGO a b     | a > b = addGO b a
+addGO (ColXs a) other = addGO (ColSm a) other
+addGO (ColSm a) other = addGO (ColMd a) other
+addGO (ColMd a) other = addGO (ColLg a) other
+addGO (ColLg _) _     = error "Yesod.Form.Bootstrap.addGO: never here"
+
+
+-- | The layout used for the bootstrap form.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapFormLayout =
+    BootstrapBasicForm
+  | BootstrapInlineForm
+  | BootstrapHorizontalForm
+      { bflLabelOffset :: !BootstrapGridOptions
+      , bflLabelSize   :: !BootstrapGridOptions
+      , bflInputOffset :: !BootstrapGridOptions
+      , bflInputSize   :: !BootstrapGridOptions
+      }
+    deriving (Show)
+
+
+-- | Render the given form using Bootstrap v3 conventions.
+--
+-- Sample Hamlet for 'BootstrapHorizontalForm':
+--
+-- >  <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
+-- >    ^{formWidget}
+-- >    ^{bootstrapSubmit MsgSubmit}
+--
+-- Since: yesod-form 1.3.8
+renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+renderBootstrap3 formLayout aform fragment = do
+    (res, views') <- aFormToForm aform
+    let views = views' []
+        has (Just _) = True
+        has Nothing  = False
+        widget = [whamlet|
+            $newline never
+            #{fragment}
+            $forall view <- views
+              <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
+                $case formLayout
+                  $of BootstrapBasicForm
+                    $if fvId view /= bootstrapSubmitId
+                      <label for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of BootstrapInlineForm
+                    $if fvId view /= bootstrapSubmitId
+                      <label .sr-only for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
+                    $if fvId view /= bootstrapSubmitId
+                      <label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
+                      <div .#{toOffset inputOffset} .#{toColumn inputSize}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                    $else
+                      <div .#{toOffset (addGO inputOffset (addGO labelOffset labelSize))} .#{toColumn inputSize}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                |]
+    return (res, widget)
+
+
+-- | (Internal) Render a help widget for tooltips and errors.
+helpWidget :: FieldView site -> WidgetT site IO ()
+helpWidget view = [whamlet|
+    $maybe tt <- fvTooltip view
+      <span .help-block>#{tt}
+    $maybe err <- fvErrors view
+      <span .help-block>#{err}
+|]
+
+
+-- | How the 'bootstrapSubmit' button should be rendered.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapSubmit msg =
+    BootstrapSubmit
+        { bsValue   :: msg
+          -- ^ The text of the submit button.
+        , bsClasses :: Text
+          -- ^ Classes added to the @<button>@.
+        , bsAttrs   :: [(Text, Text)]
+          -- ^ Attributes added to the @<button>@.
+        } deriving (Show)
+
+instance IsString msg => IsString (BootstrapSubmit msg) where
+    fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
+
+
+-- | A Bootstrap v3 submit button disguised as a field for
+-- convenience.  For example, if your form currently is:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+--
+-- Then just change it to:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+-- >        <*  bootstrapSubmit "Register"
+--
+-- (Note that @<*@ is not a typo.)
+--
+-- Alternatively, you may also just create the submit button
+-- manually as well in order to have more control over its
+-- layout.
+--
+-- Since: yesod-form 1.3.8
+bootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> AForm m ()
+bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
+
+
+-- | Same as 'bootstrapSubmit' but for monadic forms.  This isn't
+-- as useful since you're not going to use 'renderBootstrap3'
+-- anyway.
+--
+-- Since: yesod-form 1.3.8
+mbootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
+    let res = FormSuccess ()
+        widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
+        fv  = FieldView { fvLabel    = ""
+                        , fvTooltip  = Nothing
+                        , fvId       = bootstrapSubmitId
+                        , fvInput    = widget
+                        , fvErrors   = Nothing
+                        , fvRequired = False }
+    in return (res, fv)
+
+
+-- | A royal hack.  Magic id used to identify whether a field
+-- should have no label.  A valid HTML4 id which is probably not
+-- going to clash with any other id should someone use
+-- 'bootstrapSubmit' outside 'renderBootstrap3'.
+bootstrapSubmitId :: Text
+bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

yesod-form/Yesod/Form/Fields.hs

@@ -18,6 +18,7 @@ module Yesod.Form.Fields
     , timeField
     , htmlField
     , emailField
+    , multiEmailField
     , searchField
     , AutoFocus
     , urlField
@@ -68,6 +69,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..))
 import Database.Persist (Entity (..), SqlType (SqlString))
 import Text.HTML.SanitizeXSS (sanitizeBalance)
 import Control.Monad (when, unless)
+import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
 import qualified Blaze.ByteString.Builder.Html.Utf8 as B
@@ -78,7 +80,7 @@ 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 (Text, unpack, pack)
+import Data.Text as T (Text, concat, intercalate, unpack, pack, splitOn)
 import qualified Data.Text.Read
 
 import qualified Data.Map as Map
@@ -104,7 +106,7 @@ intField = Field
 
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
 $newline never
-<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
+<input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">
 |]
     , fieldEnctype = UrlEncoded
     }
@@ -121,7 +123,7 @@ doubleField = Field
 
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
 $newline never
-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
+<input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}">
 |]
     , fieldEnctype = UrlEncoded
     }
@@ -302,12 +304,37 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 
+-- |
+--
+-- Since 1.3.7
+multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
+multiEmailField = Field
+    { fieldParse = parseHelper $
+        \s ->
+            let addrs = map validate $ splitOn "," s
+            in case partitionEithers addrs of
+                ([], good) -> Right good
+                (bad, _) -> Left $ MsgInvalidEmail $ cat bad
+    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
+<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{either id cat val}">
+|]
+    , fieldEnctype = UrlEncoded
+    }
+    where
+        -- report offending address along with error
+        validate a = case Email.validate $ encodeUtf8 a of
+                        Left e -> Left $ T.concat [a, " (",  pack e, ")"]
+                        Right r -> Right $ emailToText r
+        cat = intercalate ", "
+        emailToText = decodeUtf8With lenientDecode . Email.toByteString
+
 type AutoFocus = Bool
 searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
 searchField autoFocus = Field
     { fieldParse = parseHelper Right
     , fieldView = \theId name attrs val isReq -> do
-        [whamlet|\
+        [whamlet|
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
 |]

yesod-form/Yesod/Form/Functions.hs

@@ -24,6 +24,8 @@ module Yesod.Form.Functions
       -- * Generate a blank form
     , generateFormPost
     , generateFormGet
+      -- * More than one form on a handler
+    , identifyForm
       -- * Rendering
     , FormRender
     , renderTable
@@ -39,15 +41,16 @@ module Yesod.Form.Functions
       -- * Utilities
     , fieldSettingsLabel
     , parseHelper
+    , parseHelperGen
     ) where
 
 import Yesod.Form.Types
 import Data.Text (Text, pack)
 import Control.Arrow (second)
-import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
+import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)
 import Control.Monad.Trans.Class
 import Control.Monad (liftM, join)
-import Crypto.Classes (constTimeEq)
+import Data.Byteable (constEqBytes)
 import Text.Blaze (Markup, toMarkup)
 #define Html Markup
 #define toHtml toMarkup
@@ -220,7 +223,7 @@ postHelper form env = do
                     | not (Map.lookup tokenKey params === reqToken req) ->
                         FormFailure [renderMessage m langs MsgCsrfWarning]
                 _ -> res
-            where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2
+            where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2
                   Nothing     === Nothing   = True   -- It's important to use constTimeEq
                   _           === _         = False  -- in order to avoid timing attacks.
     return ((res', xml), enctype)
@@ -284,6 +287,57 @@ getHelper form env = do
     m <- getYesod
     runFormGeneric (form fragment) m langs env
 
+
+-- | Creates a hidden field on the form that identifies it.  This
+-- identification is then used to distinguish between /missing/
+-- and /wrong/ form data when a single handler contains more than
+-- one form.
+--
+-- For instance, if you have the following code on your handler:
+--
+-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost fooForm
+-- > ((barRes, barWidget), barEnctype) <- runFormPost barForm
+--
+-- Then replace it with
+--
+-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost $ identifyForm "foo" fooForm
+-- > ((barRes, barWidget), barEnctype) <- runFormPost $ identifyForm "bar" barForm
+--
+-- Note that it's your responsibility to ensure that the
+-- identification strings are unique (using the same one twice on a
+-- single handler will not generate any errors).  This allows you
+-- to create a variable number of forms and still have them work
+-- even if their number or order change between the HTML
+-- generation and the form submission.
+identifyForm
+  :: Monad m
+  => Text -- ^ Form identification string.
+  -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+  -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+identifyForm identVal form = \fragment -> do
+    -- Create hidden <input>.
+    let fragment' =
+          [shamlet|
+            <input type=hidden name=#{identifyFormKey} value=#{identVal}>
+            #{fragment}
+          |]
+
+    -- Check if we got its value back.
+    mp <- askParams
+    let missing = (mp >>= Map.lookup identifyFormKey) /= Just [identVal]
+
+    -- Run the form proper (with our hidden <input>).  If the
+    -- data is missing, then do not provide any params to the
+    -- form, which will turn its result into FormMissing.  Also,
+    -- doing this avoids having lots of fields with red errors.
+    let eraseParams | missing   = local (\(_, h, l) -> (Nothing, h, l))
+                    | otherwise = id
+    eraseParams (form fragment')
+
+identifyFormKey :: Text
+identifyFormKey = "_formid"
+
+
 type FormRender m a =
        AForm m a
     -> Html
@@ -333,7 +387,9 @@ $forall view <- views
 |]
     return (res, widget)
 
--- | Render a form using Bootstrap-friendly shamlet syntax.
+-- | Render a form using Bootstrap v2-friendly shamlet syntax.
+-- If you're using Bootstrap v3, then you should use the
+-- functions from module "Yesod.Form.Bootstrap3".
 --
 -- Sample Hamlet:
 --
@@ -368,6 +424,7 @@ renderBootstrap aform fragment = do
                                 <span .help-block>#{err}
                 |]
     return (res, widget)
+{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
 
 check :: (Monad m, RenderMessage (HandlerSite m) msg)
       => (a -> Either msg a)
@@ -428,6 +485,15 @@ fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing
 parseHelper :: (Monad m, RenderMessage site FormMessage)
             => (Text -> Either FormMessage a)
             -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
-parseHelper _ [] _ = return $ Right Nothing
+parseHelper = parseHelperGen
-parseHelper _ ("":_) _ = return $ Right Nothing
+
-parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x
+-- | A generalized version of 'parseHelper', allowing any type for the message
+-- indicating a bad parse.
+--
+-- Since 1.3.6
+parseHelperGen :: (Monad m, RenderMessage site msg)
+               => (Text -> Either msg a)
+               -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
+parseHelperGen _ [] _ = return $ Right Nothing
+parseHelperGen _ ("":_) _ = return $ Right Nothing
+parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x

yesod-form/Yesod/Form/Input.hs

@@ -4,6 +4,7 @@ module Yesod.Form.Input
     ( FormInput (..)
     , runInputGet
     , runInputPost
+    , runInputPostResult
     , ireq
     , iopt
     ) where
@@ -66,11 +67,22 @@ toMap :: [(Text, a)] -> Map.Map Text [a]
 toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
 
 runInputPost :: MonadHandler m => FormInput m a -> m a
-runInputPost (FormInput f) = do
+runInputPost fi = do
+    emx <- runInputPostHelper fi
+    case emx of
+        Left errs -> invalidArgs errs
+        Right x -> return x
+
+runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)
+runInputPostResult fi = do
+    emx <- runInputPostHelper fi
+    case emx of
+        Left errs -> return $ FormFailure errs
+        Right x   -> return $ FormSuccess x
+
+runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
+runInputPostHelper (FormInput f) = do
     (env, fenv) <- liftM (toMap *** toMap) runRequestBody
     m <- getYesod
     l <- languages
-    emx <- f m l env fenv
+    fmap (either (Left . ($ [])) Right) $ f m l env fenv
-    case emx of
-        Left errs -> invalidArgs $ errs []
-        Right x -> return x

yesod-form/Yesod/Form/MassInput.hs

@@ -11,7 +11,7 @@ module Yesod.Form.MassInput
 
 import Yesod.Form.Types
 import Yesod.Form.Functions
-import Yesod.Form.Fields (boolField)
+import Yesod.Form.Fields (checkBoxField)
 import Yesod.Core
 import Control.Monad.Trans.RWS (get, put, ask)
 import Data.Maybe (fromMaybe)
@@ -97,7 +97,7 @@ $newline never
 <input type=hidden name=#{deleteName} value=yes>
 |]
         _ -> do
-            (_, xml2) <- aFormToForm $ areq boolField FieldSettings
+            (_, xml2) <- aFormToForm $ areq checkBoxField FieldSettings
                 { fsLabel = SomeMessage MsgDelete
                 , fsTooltip = Nothing
                 , fsName = Just deleteName

yesod-form/Yesod/Form/Types.hs

@@ -98,11 +98,11 @@ instance Monad m => Functor (AForm m) where
       where
         go (w, x, y, z) = (fmap f w, x, y, z)
 instance Monad m => Applicative (AForm m) where
-    pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
+    pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty)
     (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
         (a, b, ints', c) <- f mr env ints
         (x, y, ints'', z) <- g mr env ints'
-        return (a <*> x, b `mappend` y, ints'', c `mappend` z)
+        return (a <*> x, b . y, ints'', c `mappend` z)
 instance (Monad m, Monoid a) => Monoid (AForm m a) where
     mempty = pure mempty
     mappend a b = mappend <$> a <*> b

yesod-form/hello-forms.hs

@@ -23,7 +23,8 @@ mkYesod "HelloForms" [parseRoutes|
 /file FileR GET POST
 |]
 
-myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
+myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,,,)
+    <*> pure "pure works!"
     <*> areq boolField "Bool field" Nothing
     <*> aopt boolField "Opt bool field" Nothing
     <*> areq textField "Text field" Nothing
@@ -33,6 +34,7 @@ myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
     <*> aopt (multiSelectFieldList fruits) "Opt multi select field" Nothing
     <*> aopt intField "Opt int field" Nothing
     <*> aopt (radioFieldList fruits) "Opt radio" Nothing
+    <*> aopt multiEmailField "Opt multi email" Nothing
 
 data HelloForms = HelloForms
 

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         1.3.4.2
+version:         1.3.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -35,13 +35,14 @@ library
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.5.1
                    , attoparsec            >= 0.10
-                   , crypto-api            >= 0.8
+                   , byteable
                    , aeson
                    , resourcet
 
     exposed-modules: Yesod.Form
                      Yesod.Form.Types
                      Yesod.Form.Functions
+                     Yesod.Form.Bootstrap3
                      Yesod.Form.Input
                      Yesod.Form.Fields
                      Yesod.Form.Jquery

yesod-newsfeed/Yesod/AtomFeed.hs

@@ -62,7 +62,7 @@ template Feed {..} render =
         : Element "link" (Map.singleton "href" $ render feedLinkHome) []
         : Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
         : Element "id" Map.empty [NodeContent $ render feedLinkHome]
-        : Element "author" Map.empty [NodeContent feedAuthor]
+        : Element "author" Map.empty [NodeElement $ Element "name" Map.empty [NodeContent feedAuthor]]
         : map (flip entryTemplate render) feedEntries
 
 entryTemplate :: FeedEntry url -> (url -> Text) -> Element

yesod-newsfeed/yesod-newsfeed.cabal

@@ -1,5 +1,5 @@
 name:            yesod-newsfeed
-version:         1.2.0
+version:         1.2.0.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin

yesod-platform/make-cabal.sh

@@ -7,4 +7,4 @@ then
     cabal install cabal-nirvana -fgenerate
 fi
 
-cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text | runghc to-cabal.hs > yesod-platform.cabal
+cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text esqueleto warp-tls hjsmin http-reverse-proxy | runghc to-cabal.hs > yesod-platform.cabal

yesod-platform/yesod-platform.cabal

@@ -1,5 +1,5 @@
 name:            yesod-platform
-version:         1.2.5.3
+version:         1.2.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,112 +14,118 @@ homepage:        http://www.yesodweb.com/
 
 library
     build-depends: base >= 4 && < 5
-                 , SHA == 1.6.1
+                 , ReadArgs == 1.2.1
-                 , aeson == 0.6.2.1
+                 , SHA == 1.6.4
-                 , ansi-terminal == 0.6.1
+                 , aeson == 0.7.0.2
-                 , asn1-data == 0.7.1
+                 , ansi-terminal == 0.6.1.1
+                 , ansi-wl-pprint == 0.6.7.1
+                 , asn1-encoding == 0.8.1.3
+                 , asn1-parse == 0.8.1
                  , asn1-types == 0.2.3
-                 , attoparsec == 0.10.4.0
+                 , async == 2.0.1.5
+                 , attoparsec == 0.11.2.1
                  , attoparsec-conduit == 1.0.1.2
                  , authenticate == 1.3.2.6
                  , base-unicode-symbols == 0.2.2.4
                  , base64-bytestring == 1.0.0.1
+                 , basic-prelude == 0.3.6.0
                  , blaze-builder == 0.3.3.2
                  , blaze-builder-conduit == 1.0.0
-                 , blaze-html == 0.6.1.2
+                 , blaze-html == 0.7.0.1
-                 , blaze-markup == 0.5.1.6
+                 , blaze-markup == 0.6.0.0
                  , byteable == 0.1.1
                  , byteorder == 1.0.4
-                 , case-insensitive == 1.1.0.2
+                 , case-insensitive == 1.1.0.3
                  , cereal == 0.4.0.1
-                 , certificate == 1.3.9
+                 , cipher-aes == 0.2.7
-                 , cipher-aes == 0.2.6
                  , cipher-rc4 == 0.1.4
                  , clientsession == 0.9.0.3
-                 , conduit == 1.0.9.3
+                 , conduit == 1.0.15.1
-                 , connection == 0.1.3.1
+                 , connection == 0.2.0
                  , control-monad-loop == 0.1
                  , cookie == 0.4.0.1
                  , cprng-aes == 0.5.2
-                 , crypto-api == 0.12.2.2
+                 , crypto-api == 0.13
                  , crypto-cipher-types == 0.0.9
-                 , crypto-conduit == 0.5.2.1
                  , crypto-numbers == 0.2.3
                  , crypto-pubkey == 0.2.4
-                 , crypto-pubkey-types == 0.4.1
+                 , crypto-pubkey-types == 0.4.2.2
                  , crypto-random == 0.0.7
-                 , cryptohash == 0.11.1
+                 , cryptohash == 0.11.2
-                 , cryptohash-cryptoapi == 0.1.0
+                 , cryptohash-conduit == 0.1.0
-                 , css-text == 0.1.1
+                 , css-text == 0.1.2.1
                  , data-default == 0.5.3
                  , data-default-class == 0.0.1
                  , data-default-instances-base == 0.0.1
                  , data-default-instances-containers == 0.0.1
                  , data-default-instances-dlist == 0.0.1
                  , data-default-instances-old-locale == 0.0.1
-                 , dlist == 0.6.0.1
+                 , dlist == 0.7
-                 , email-validate == 1.0.0
+                 , email-validate == 2.0.1
                  , entropy == 0.2.2.4
+                 , esqueleto == 1.3.5
                  , failure == 0.2.0.1
-                 , fast-logger == 2.1.0
+                 , fast-logger == 2.1.5
                  , file-embed == 0.0.6
                  , filesystem-conduit == 1.0.0.1
-                 , hamlet == 1.1.7.6
+                 , hamlet == 1.1.9.2
-                 , hjsmin == 0.1.4.4
+                 , hjsmin == 0.1.4.5
-                 , hspec == 1.8.1.1
+                 , hspec == 1.8.3
                  , hspec-expectations == 0.5.0.1
                  , html-conduit == 1.1.0.1
-                 , http-attoparsec == 0.1.0
+                 , http-client == 0.2.2.2
-                 , http-client == 0.2.0.3
                  , http-client-conduit == 0.2.0.1
-                 , http-client-tls == 0.2.0.2
+                 , http-client-tls == 0.2.1.1
-                 , http-conduit == 2.0.0.3
+                 , http-conduit == 2.0.0.8
                  , http-date == 0.0.4
+                 , http-reverse-proxy == 0.3.1.1
                  , http-types == 0.8.3
-                 , language-javascript == 0.5.8
+                 , language-javascript == 0.5.9
-                 , lifted-base == 0.2.1.1
+                 , lifted-base == 0.2.2.1
-                 , mime-mail == 0.4.3
+                 , mime-mail == 0.4.4.1
                  , mime-types == 0.1.0.3
-                 , mmorph == 1.0.0
+                 , mmorph == 1.0.2
-                 , monad-control == 0.3.2.2
+                 , monad-control == 0.3.2.3
                  , monad-logger == 0.3.4.0
                  , monad-loops == 0.4.2
-                 , network-conduit == 1.0.0
+                 , network-conduit == 1.0.4
+                 , optparse-applicative == 0.7.0.2
                  , path-pieces == 0.1.3.1
                  , pem == 0.2.1
-                 , persistent == 1.3.0
+                 , persistent == 1.3.0.3
-                 , persistent-template == 1.3.0
+                 , persistent-template == 1.3.1.2
-                 , pool-conduit == 0.1.2
+                 , pool-conduit == 0.1.2.1
-                 , primitive == 0.5.1.0
+                 , primitive == 0.5.2.1
                  , process-conduit == 1.0.0.1
                  , publicsuffixlist == 0.1
                  , pureMD5 == 2.1.2.1
                  , pwstore-fast == 2.4.1
                  , quickcheck-io == 0.1.0
                  , resource-pool == 0.2.1.1
-                 , resourcet == 0.4.10
+                 , resourcet == 0.4.10.1
-                 , safe == 0.3.3
+                 , safe == 0.3.4
+                 , scientific == 0.2.0.2
                  , securemem == 0.1.3
-                 , semigroups == 0.12.1
+                 , semigroups == 0.12.2
-                 , setenv == 0.1.1
+                 , setenv == 0.1.1.1
-                 , shakespeare == 1.2.0.4
+                 , shakespeare == 1.2.1.1
-                 , shakespeare-css == 1.0.6.6
+                 , shakespeare-css == 1.0.7.1
                  , shakespeare-i18n == 1.0.0.5
-                 , shakespeare-js == 1.2.0.2
+                 , shakespeare-js == 1.2.0.4
-                 , shakespeare-text == 1.0.0.10
+                 , shakespeare-text == 1.0.2
                  , silently == 1.2.4.1
                  , simple-sendfile == 0.2.13
-                 , skein == 1.0.8
+                 , skein == 1.0.9
                  , socks == 0.5.4
                  , stm-chans == 3.0.0
                  , stringsearch == 0.3.6.5
-                 , system-fileio == 0.3.11
+                 , system-fileio == 0.3.12
-                 , system-filepath == 0.4.8
+                 , system-filepath == 0.4.9
-                 , tagged == 0.7
+                 , tagged == 0.7.1
-                 , tagsoup == 0.13
+                 , tagsoup == 0.13.1
-                 , tagstream-conduit == 0.5.4.1
+                 , tagstream-conduit == 0.5.5
-                 , tls == 1.1.5
+                 , text-stream-decode == 0.1.0.4
-                 , tls-extra == 0.6.6
+                 , tls == 1.2.2
                  , transformers-base == 0.4.1
                  , unix-compat == 0.4.1.1
                  , unordered-containers == 0.2.3.3
@@ -127,24 +133,29 @@ library
                  , utf8-string == 0.3.7
                  , vector == 0.10.9.1
                  , void == 0.6.1
-                 , wai == 2.0.0
+                 , wai == 2.1.0
-                 , wai-app-static == 2.0.0.2
+                 , wai-app-static == 2.0.0.4
-                 , wai-extra == 2.0.1.2
+                 , wai-extra == 2.1.0.1
-                 , wai-logger == 2.1.0
+                 , wai-logger == 2.1.1
-                 , wai-test == 2.0.0.1
+                 , wai-test == 2.0.0.2
-                 , warp == 2.0.1
+                 , warp == 2.1.1.2
+                 , warp-tls == 2.0.3.1
                  , word8 == 0.0.4
+                 , x509 == 1.4.11
+                 , x509-store == 1.4.4
+                 , x509-system == 1.4.2
+                 , x509-validation == 1.5.0
                  , xml-conduit == 1.1.0.9
                  , xml-types == 0.3.4
-                 , xss-sanitize == 0.3.4.1
+                 , xss-sanitize == 0.3.5
-                 , yaml == 0.8.5.2
+                 , yaml == 0.8.7.2
-                 , yesod == 1.2.4
+                 , yesod == 1.2.5
-                 , yesod-auth == 1.2.5.2
+                 , yesod-auth == 1.2.7
-                 , yesod-core == 1.2.6.4
+                 , yesod-core == 1.2.8
-                 , yesod-form == 1.3.4.2
+                 , yesod-form == 1.3.8
                  , yesod-persistent == 1.2.2.1
-                 , yesod-routes == 1.2.0.5
+                 , yesod-routes == 1.2.0.6
-                 , yesod-static == 1.2.2.1
+                 , yesod-static == 1.2.2.2
                  , yesod-test == 1.2.1
                  , zlib-bindings == 0.1.1.3
                  , zlib-conduit == 1.0.0

yesod-routes/Yesod/Routes/Parse.hs

@@ -184,6 +184,7 @@ ttToType (TTList t) = ListT `AppT` ttToType t
 
 pieceFromString :: String -> Either String (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
+pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
 pieceFromString ('#':x) = Right $ (True, Dynamic x)
 pieceFromString ('*':x) = Left x
 pieceFromString ('+':x) = Left x

yesod-routes/test/Hierarchy.hs

@@ -77,6 +77,8 @@ do
     let resources = [parseRoutes|
 / HomeR GET
 
+/!#Int BackwardsR GET
+
 /admin/#Int AdminR:
     /            AdminRootR GET
     /login       LoginR     GET POST
@@ -141,6 +143,9 @@ getAfter   :: Handler site String; getAfter = "after"
 getHomeR :: Handler site String
 getHomeR = "home"
 
+getBackwardsR :: Int -> Handler site Text
+getBackwardsR _ = pack "backwards"
+
 getAdminRootR :: Int -> Handler site Text
 getAdminRootR i = pack $ "admin root: " ++ show i
 

yesod-routes/yesod-routes.cabal

@@ -1,5 +1,5 @@
 name:            yesod-routes
-version:         1.2.0.5
+version:         1.2.0.6
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

yesod-static/Yesod/Static.hs

@@ -73,14 +73,14 @@ import Data.List (intercalate)
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax as TH
 
-import Crypto.Conduit (hashFile, sinkHash)
+import Crypto.Hash.Conduit (hashFile, sinkHash)
-import Crypto.Hash.CryptoAPI (MD5)
+import Crypto.Hash (MD5, Digest)
 import Control.Monad.Trans.State
 
+import qualified Data.Byteable as Byteable
 import qualified Data.ByteString.Base64
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
-import qualified Data.Serialize
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -359,7 +359,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
 
 base64md5File :: Prelude.FilePath -> IO String
 base64md5File = fmap (base64 . encode) . hashFile
-    where encode d = Data.Serialize.encode (d :: MD5)
+    where encode d = Byteable.toBytes (d :: Digest MD5)
 
 base64md5 :: L.ByteString -> String
 base64md5 lbs =
@@ -367,7 +367,7 @@ base64md5 lbs =
           $ runIdentity
           $ sourceList (L.toChunks lbs) $$ sinkHash
   where
-    encode d = Data.Serialize.encode (d :: MD5)
+    encode d = Byteable.toBytes (d :: Digest MD5)
 
 base64 :: S.ByteString -> String
 base64 = map tr

yesod-static/yesod-static.cabal

@@ -1,5 +1,5 @@
 name:            yesod-static
-version:         1.2.2.1
+version:         1.2.2.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -29,7 +29,7 @@ library
                    , old-time              >= 1.0
                    , yesod-core            >= 1.2      && < 1.3
                    , base64-bytestring     >= 0.1.0.1
-                   , cereal                >= 0.3
+                   , byteable              >= 0.1
                    , bytestring            >= 0.9.1.4
                    , template-haskell
                    , directory             >= 1.0
@@ -41,8 +41,8 @@ library
                    , http-types            >= 0.7
                    , unix-compat           >= 0.2
                    , conduit               >= 0.5
-                   , crypto-conduit        >= 0.4
+                   , cryptohash-conduit    >= 0.1
-                   , cryptohash-cryptoapi  >= 0.1.0
+                   , cryptohash            >= 0.11
                    , system-filepath       >= 0.4.6    && < 0.5
                    , system-fileio         >= 0.3
                    , data-default
@@ -80,8 +80,8 @@ test-suite tests
                    , old-time
                    , yesod-core
                    , base64-bytestring
-                   , cereal
                    , bytestring
+                   , byteable
                    , template-haskell
                    , directory
                    , transformers
@@ -92,8 +92,8 @@ test-suite tests
                    , http-types
                    , unix-compat
                    , conduit
-                   , crypto-conduit
+                   , cryptohash-conduit
-                   , cryptohash-cryptoapi
+                   , cryptohash
                    , system-filepath
                    , system-fileio
                    , data-default

yesod-websockets/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2014 Michael Snoyman, http://www.yesodweb.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-websockets/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

yesod-websockets/Yesod/WebSockets.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.WebSockets
+    ( -- * Core API
+      WebSocketsT
+    , webSockets
+    , receiveData
+    , sendTextData
+    , sendBinaryData
+      -- * Conduit API
+    , sourceWS
+    , sinkWSText
+    , sinkWSBinary
+      -- * Async helpers
+    , race
+    , race_
+    , concurrently
+    , concurrently_
+    ) where
+
+import qualified Control.Concurrent.Async       as A
+import           Control.Monad                  (forever, void, when)
+import           Control.Monad.IO.Class         (MonadIO (liftIO))
+import           Control.Monad.Trans.Control    (control)
+import           Control.Monad.Trans.Control    (MonadBaseControl (liftBaseWith, restoreM))
+import           Control.Monad.Trans.Reader     (ReaderT (ReaderT, runReaderT))
+import qualified Data.Conduit                   as C
+import qualified Data.Conduit.List              as CL
+import qualified Network.Wai.Handler.WebSockets as WaiWS
+import qualified Network.WebSockets             as WS
+import qualified Yesod.Core                     as Y
+
+-- | A transformer for a WebSockets handler.
+--
+-- Since 0.1.0
+type WebSocketsT = ReaderT WS.Connection
+
+-- | Attempt to run a WebSockets handler. This function first checks if the
+-- client initiated a WebSockets connection and, if so, runs the provided
+-- application, short-circuiting the rest of your handler. If the client did
+-- not request a WebSockets connection, the rest of your handler will be called
+-- instead.
+--
+-- Since 0.1.0
+webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
+webSockets inner = do
+    req <- Y.waiRequest
+    when (WaiWS.isWebSocketsReq req) $
+        Y.sendRawResponse $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
+            WS.defaultConnectionOptions
+            (WaiWS.getRequestHead req)
+            (\pconn -> do
+                conn <- WS.acceptRequest pconn
+                runInIO $ runReaderT inner conn)
+            src
+            sink
+
+-- | Receive a piece of data from the client.
+--
+-- Since 0.1.0
+receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
+receiveData = ReaderT $ liftIO . WS.receiveData
+
+-- | Send a textual messsage to the client.
+--
+-- Since 0.1.0
+sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x
+
+-- | Send a binary messsage to the client.
+--
+-- Since 0.1.0
+sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x
+
+-- | A @Source@ of WebSockets data from the user.
+--
+-- Since 0.1.0
+sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
+sourceWS = forever $ Y.lift receiveData >>= C.yield
+
+-- | A @Sink@ for sending textual data to the user.
+--
+-- Since 0.1.0
+sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
+sinkWSText = CL.mapM_ sendTextData
+
+-- | A @Sink@ for sending binary data to the user.
+--
+-- Since 0.1.0
+sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
+sinkWSBinary = CL.mapM_ sendBinaryData
+
+-- | Generalized version of 'A.race'.
+--
+-- Since 0.1.0
+race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)
+race x y = liftBaseWith (\run -> A.race (run x) (run y))
+    >>= either (fmap Left . restoreM) (fmap Right . restoreM)
+
+-- | Generalized version of 'A.race_'.
+--
+-- Since 0.1.0
+race_ :: MonadBaseControl IO m => m a -> m b -> m ()
+race_ x y = void $ race x y
+
+-- | Generalized version of 'A.concurrently'. Note that if your underlying
+-- monad has some kind of mutable state, the state from the second action will
+-- overwrite the state from the first.
+--
+-- Since 0.1.0
+concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)
+concurrently x y = do
+    (resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y)
+    x' <- restoreM resX
+    y' <- restoreM resY
+    return (x', y')
+
+-- | Run two actions concurrently (like 'A.concurrently'), but discard their
+-- results and any modified monadic state.
+--
+-- Since 0.1.0
+concurrently_ :: MonadBaseControl IO m => m a -> m b -> m ()
+concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y)

yesod-websockets/chat.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+import Yesod.Core
+import Yesod.WebSockets
+import qualified Data.Text.Lazy as TL
+import Control.Monad (forever)
+import Control.Monad.Trans.Reader
+import Control.Concurrent (threadDelay)
+import Data.Time
+import Conduit
+import Data.Monoid ((<>))
+import Control.Concurrent.STM.Lifted
+import Data.Text (Text)
+
+data App = App (TChan Text)
+
+instance Yesod App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+chatApp :: WebSocketsT Handler ()
+chatApp = do
+    sendTextData ("Welcome to the chat server, please enter your name." :: Text)
+    name <- receiveData
+    sendTextData $ "Welcome, " <> name
+    App writeChan <- getYesod
+    readChan <- atomically $ do
+        writeTChan writeChan $ name <> " has joined the chat"
+        dupTChan writeChan
+    race_
+        (forever $ atomically (readTChan readChan) >>= sendTextData)
+        (sourceWS $$ mapM_C (\msg ->
+            atomically $ writeTChan writeChan $ name <> ": " <> msg))
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets chatApp
+    defaultLayout $ do
+        [whamlet|
+            <div #output>
+            <form #form>
+                <input #input autofocus>
+        |]
+        toWidget [lucius|
+            \#output {
+                width: 600px;
+                height: 400px;
+                border: 1px solid black;
+                margin-bottom: 1em;
+                p {
+                    margin: 0 0 0.5em 0;
+                    padding: 0 0 0.5em 0;
+                    border-bottom: 1px dashed #99aa99;
+                }
+            }
+            \#input {
+                width: 600px;
+                display: block;
+            }
+        |]
+        toWidget [julius|
+            var url = document.URL,
+                output = document.getElementById("output"),
+                form = document.getElementById("form"),
+                input = document.getElementById("input"),
+                conn;
+
+            url = url.replace("http:", "ws:").replace("https:", "wss:");
+            conn = new WebSocket(url);
+
+            conn.onmessage = function(e) {
+                var p = document.createElement("p");
+                p.appendChild(document.createTextNode(e.data));
+                output.appendChild(p);
+            };
+
+            form.addEventListener("submit", function(e){
+                conn.send(input.value);
+                input.value = "";
+                e.preventDefault();
+            });
+        |]
+
+main :: IO ()
+main = do
+    chan <- atomically newBroadcastTChan
+    warp 3000 $ App chan

yesod-websockets/sample.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+import Yesod.Core
+import Yesod.WebSockets
+import qualified Data.Text.Lazy as TL
+import Control.Monad (forever)
+import Control.Monad.Trans.Reader
+import Control.Concurrent (threadDelay)
+import Data.Time
+import Conduit
+
+data App = App
+
+instance Yesod App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+timeSource :: MonadIO m => Source m TL.Text
+timeSource = forever $ do
+    now <- liftIO getCurrentTime
+    yield $ TL.pack $ show now
+    liftIO $ threadDelay 5000000
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets $ race_
+        (sourceWS $$ mapC TL.toUpper =$ sinkWSText)
+        (timeSource $$ sinkWSText)
+    defaultLayout $
+        toWidget
+            [julius|
+                var conn = new WebSocket("ws://localhost:3000/");
+                conn.onopen = function() {
+                    document.write("<p>open!</p>");
+                    document.write("<button id=button>Send another message</button>")
+                    document.getElementById("button").addEventListener("click", function(){
+                        var msg = prompt("Enter a message for the server");
+                        conn.send(msg);
+                    });
+                    conn.send("hello world");
+                };
+                conn.onmessage = function(e) {
+                    document.write("<p>" + e.data + "</p>");
+                };
+            |]
+
+main :: IO ()
+main = warp 3000 App

yesod-websockets/yesod-websockets.cabal

@@ -0,0 +1,30 @@
+-- Initial yesod-websockets.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                yesod-websockets
+version:             0.1.0.0
+synopsis:            WebSockets support for Yesod
+description:         WebSockets support for Yesod
+homepage:            https://github.com/yesodweb/yesod
+license:             MIT
+license-file:        LICENSE
+author:              Michael Snoyman
+maintainer:          michael@snoyman.com
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Yesod.WebSockets
+  build-depends:       base              >= 4.5 && < 5
+                     , wai-websockets    >= 2.1
+                     , websockets        >= 0.8
+                     , transformers      >= 0.2
+                     , yesod-core        >= 1.2.7
+                     , monad-control     >= 0.3
+                     , conduit           >= 1.0.15.1
+                     , async             >= 2.0.1.5
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod

yesod/Yesod/Default/Main.hs

@@ -1,15 +1,19 @@
 {-# LANGUAGE CPP                #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE TemplateHaskell    #-}
 module Yesod.Default.Main
     ( defaultMain
+    , defaultMainLog
     , defaultRunner
     , defaultDevelApp
+    , LogFunc
     ) where
 
 import Yesod.Default.Config
 import Network.Wai (Application)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort, settingsHost)
+    (runSettings, defaultSettings, settingsPort, settingsHost, settingsOnException)
 import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
 import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles, def)
 import Network.Wai.Middleware.Autohead (autohead)
@@ -18,6 +22,9 @@ import Control.Monad (when)
 import System.Environment (getEnvironment)
 import Data.Maybe (fromMaybe)
 import Safe (readMay)
+import Control.Monad.Logger (Loc, LogSource, LogLevel (LevelError), liftLoc)
+import System.Log.FastLogger (LogStr, toLogStr)
+import Language.Haskell.TH.Syntax (qLocation)
 
 #ifndef WINDOWS
 import qualified System.Posix.Signals as Signal
@@ -45,6 +52,29 @@ defaultMain load getApp = do
         , settingsHost = appHost config
         } app
 
+type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+
+-- | Same as @defaultMain@, but gets a logging function back as well as an
+-- @Application@ to install Warp exception handlers.
+--
+-- Since 1.2.5
+defaultMainLog :: (Show env, Read env)
+               => IO (AppConfig env extra)
+               -> (AppConfig env extra -> IO (Application, LogFunc))
+               -> IO ()
+defaultMainLog load getApp = do
+    config <- load
+    (app, logFunc) <- getApp config
+    runSettings defaultSettings
+        { settingsPort = appPort config
+        , settingsHost = appHost config
+        , settingsOnException = const $ \e -> logFunc
+            $(qLocation >>= liftLoc)
+            "yesod"
+            LevelError
+            (toLogStr $ "Exception from Warp: " ++ show e)
+        } app
+
 -- | Run your application continously, listening for SIGINT and exiting
 --   when received
 --

yesod/yesod.cabal

@@ -1,5 +1,5 @@
 name:            yesod
-version:         1.2.4
+version:         1.2.5
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -46,6 +46,8 @@ library
                    , directory
                    , template-haskell
                    , bytestring
+                   , monad-logger
+                   , fast-logger
 
     exposed-modules: Yesod
                    , Yesod.Default.Config