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

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

Browse Source 
Conflicts:
	yesod-auth/yesod-auth.cabal
	yesod-form/Yesod/Form/Fields.hs
	yesod-form/yesod-form.cabal
	yesod-persistent/Yesod/Persist/Core.hs
This commit is contained in:
Michael Snoyman 2014-04-18 14:33:54 +03:00
commit fe622d5345
63 changed files with 458 additions and 1846 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored
View File

@ -1,3 +0,0 @@
[submodule "scripts"]
path = scripts
url = git://github.com/yesodweb/scripts.git

4
.travis.yml
View File

@ -2,12 +2,12 @@ language: haskell
install:
- cabal update
- cabal install --force-reinstalls mega-sdist hspec cabal-meta cabal-src
- cabal install --force-reinstalls hspec cabal-meta cabal-src alex
- cabal-meta install --force-reinstalls
script:
- echo Done
- cabal-meta install --enable-tests
- mega-sdist --test
- cabal install mega-sdist hspec cabal-meta cabal-src
- cabal install hspec cabal-meta cabal-src
- cabal-meta install --force-reinstalls

6
authenticate-oauth/.gitignore vendored
View File

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

25
authenticate-oauth/LICENSE
View File

@ -1,25 +0,0 @@
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.

7
authenticate-oauth/Setup.lhs
View File

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

455
authenticate-oauth/Web/Authenticate/OAuth.hs
View File

@ -1,455 +0,0 @@
{-# 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 }

95
authenticate-oauth/Web/Authenticate/OAuth/IO.hs
View File

@ -1,95 +0,0 @@
{-# 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

39
authenticate-oauth/authenticate-oauth.cabal
View File

@ -1,39 +0,0 @@
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

25
authenticate/LICENSE
View File

@ -1,25 +0,0 @@
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.

159
authenticate/OpenId2/Discovery.hs
View File

@ -1,159 +0,0 @@
{-# 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

69
authenticate/OpenId2/Normalization.hs
View File

@ -1,69 +0,0 @@
{-# 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 []

34
authenticate/OpenId2/Types.hs
View File

@ -1,34 +0,0 @@
{-# 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)

77
authenticate/OpenId2/XRDS.hs
View File

@ -1,77 +0,0 @@
{-# 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

7
authenticate/Setup.lhs
View File

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

40
authenticate/Web/Authenticate/BrowserId.hs
View File

@ -1,40 +0,0 @@
{-# 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

15
authenticate/Web/Authenticate/Internal.hs
View File

@ -1,15 +0,0 @@
{-# 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

164
authenticate/Web/Authenticate/OpenId.hs
View File

@ -1,164 +0,0 @@
{-# 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

44
authenticate/Web/Authenticate/OpenId/Providers.hs
View File

@ -1,44 +0,0 @@
-- | 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/"

103
authenticate/Web/Authenticate/Rpxnow.hs
View File

@ -1,103 +0,0 @@
{-# 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

48
authenticate/authenticate.cabal
View File

@ -1,48 +0,0 @@
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

45
authenticate/browserid.hs
View File

@ -1,45 +0,0 @@
{-# 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

91
authenticate/openid2.hs
View File

@ -1,91 +0,0 @@
{-# 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

38
authenticate/rpxnow.hs
View File

@ -1,38 +0,0 @@
{-# 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

15
package-list.sh
View File

@ -1,15 +0,0 @@
#!/bin/bash
pkgs=( ./yesod-routes
./yesod-core
./yesod-json
./cryptohash-conduit
./authenticate/authenticate
./yesod-static
./yesod-persistent
./yesod-newsfeed
./yesod-form
./yesod-auth
./yesod-sitemap
./yesod-default
./yesod )

1
scripts

@ -1 +0,0 @@
Subproject commit 9902ff808afbcb417c6ad125941343878e3afe11

1
sources.txt
View File

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

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

@ -34,10 +34,13 @@ module Yesod.Auth.Email
import Network.Mail.Mime (randomString)
import Yesod.Auth
import System.Random
import Data.Digest.Pure.MD5
import qualified Data.Text as TS
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Crypto.Hash.MD5 as H
import Data.ByteString.Base16 as B16
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text (Text)
@ -526,7 +529,8 @@ saltPass = fmap (decodeUtf8With lenientDecode)
. encodeUtf8
saltPass' :: String -> String -> String
saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass)
saltPass' salt pass =
salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ H.hash $ TE.encodeUtf8 $ T.pack $ salt ++ pass)
isValidPass :: Text -- ^ cleartext password
-> SaltedPass -- ^ salted password

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

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.3.0.0
version: 1.3.0.4
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -15,7 +15,9 @@ description:
.
* <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
.
* <https://github.com/ollieh/yesod-auth-bcrypt/>: A replacement for the previously provided HashDB module, which has been removed.
* <http://hackage.haskell.org/package/yesod-auth-hashdb>: The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
.
* <https://github.com/ollieh/yesod-auth-bcrypt/>: An alternative to the HashDB module.
extra-source-files: persona_sign_in_blue.png
library
@ -25,21 +27,22 @@ library
, yesod-core >= 1.2 && < 1.3
, wai >= 1.4
, template-haskell
, pureMD5 >= 2.0
, base16-bytestring
, cryptohash
, random >= 1.0.0.2
, text >= 0.7
, mime-mail >= 0.3
, yesod-persistent >= 1.2
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.3
, hamlet >= 1.1
, shakespeare
, shakespeare-css >= 1.0
, shakespeare-js >= 1.0.2
, containers
, unordered-containers
, yesod-form >= 1.3 && < 1.4
, transformers >= 0.2.2
, persistent >= 1.2 && < 2.1
, persistent-template >= 1.2 && < 2.1
, SHA >= 1.4.1.3
, http-conduit >= 1.5
, aeson >= 0.5
, pwstore-fast >= 2.2

5
yesod-bin/Devel.hs
View File

@ -64,8 +64,7 @@ import GhcBuild (buildPackage,
getBuildFlags, getPackageArgs)
import qualified Config as GHC
import Data.Conduit.Network (HostPreference (HostIPv4),
bindPort)
import Data.Streaming.Network (bindPortTCP)
import Network (withSocketsDo)
#if MIN_VERSION_http_conduit(2, 0, 0)
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
@ -171,7 +170,7 @@ reverseProxy opts iappPort = do
checkPort :: Int -> IO Bool
checkPort p = do
es <- Ex.try $ bindPort p HostIPv4
es <- Ex.try $ bindPortTCP p "*4"
case es of
Left (_ :: Ex.IOException) -> return False
Right s -> do

3
yesod-bin/HsFile.hs
View File

@ -2,7 +2,8 @@
module HsFile (mkHsFile) where
import Text.ProjectTemplate (createTemplate)
import Data.Conduit
( ($$), (=$), runResourceT, ResourceT, ConduitM, awaitForever, yield, Source )
( ($$), (=$), ConduitM, awaitForever, yield, Source )
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import qualified Data.Conduit.List as CL
import Prelude hiding (FilePath)
import Filesystem.Path ( FilePath )

3
yesod-bin/Scaffolding/Scaffolder.hs
View File

@ -4,7 +4,8 @@ module Scaffolding.Scaffolder (scaffold) where
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as S
import Data.Conduit (runResourceT, yield, ($$), ($$+-))
import Data.Conduit (yield, ($$), ($$+-))
import Control.Monad.Trans.Resource (runResourceT)
import Data.FileEmbed (embedFile)
import Data.String (fromString)
import qualified Data.Text as T

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

@ -5,6 +5,7 @@
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
@ -15,6 +16,7 @@ yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -35,9 +37,9 @@ import Network.Wai.Middleware.RequestLogger
)
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Database.Persist
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Network.HTTP.Client.Conduit (newManager)
import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
@ -71,13 +73,13 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager conduitManagerSettings
manager <- newManager
s <- staticSite
dbconf <- withYamlEnvironment "config/mongoDB.yml" (appEnv conf)
Database.Persist.loadConfig >>=
@ -94,6 +96,7 @@ makeFoundation conf = do
let updateLoop = do
threadDelay 1000000
updater
flushLogStr loggerSet'
updateLoop
_ <- forkIO updateLoop
@ -122,7 +125,7 @@ import Yesod.Auth.BrowserId
import Yesod.Auth.GoogleEmail
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
@ -147,6 +150,9 @@ data App = App
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@ -404,8 +410,8 @@ library
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
@ -414,15 +420,12 @@ library
, persistent-mongoDB >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
, template-haskell
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 2.1 && < 2.2
, data-default

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

@ -5,6 +5,7 @@
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
@ -15,6 +16,7 @@ yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -36,10 +38,10 @@ import Network.Wai.Middleware.RequestLogger
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Database.Persist
import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Network.HTTP.Client.Conduit (newManager)
import Control.Monad.Logger (runLoggingT)
import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
@ -73,13 +75,13 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager conduitManagerSettings
manager <- newManager
s <- staticSite
dbconf <- withYamlEnvironment "config/mysql.yml" (appEnv conf)
Database.Persist.loadConfig >>=
@ -96,6 +98,7 @@ makeFoundation conf = do
let updateLoop = do
threadDelay 1000000
updater
flushLogStr loggerSet'
updateLoop
_ <- forkIO updateLoop
@ -129,7 +132,7 @@ import Yesod.Auth.BrowserId
import Yesod.Auth.GoogleEmail
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
@ -154,6 +157,9 @@ data App = App
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@ -408,8 +414,8 @@ library
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
@ -418,15 +424,12 @@ library
, persistent-mysql >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
, template-haskell
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 2.1 && < 2.2
, data-default

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

@ -5,6 +5,7 @@
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
@ -16,6 +17,7 @@ yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -37,11 +39,11 @@ import Network.Wai.Middleware.RequestLogger
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Database.Persist
import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Network.HTTP.Client.Conduit (newManager)
import Yesod.Fay (getFaySite)
import Control.Monad.Logger (runLoggingT)
import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
@ -76,13 +78,13 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager conduitManagerSettings
manager <- newManager
s <- staticSite
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
Database.Persist.loadConfig >>=
@ -99,6 +101,7 @@ makeFoundation conf = do
let updateLoop = do
threadDelay 1000000
updater
flushLogStr loggerSet'
updateLoop
_ <- forkIO updateLoop
@ -132,7 +135,7 @@ import Yesod.Auth.BrowserId
import Yesod.Auth.GoogleEmail
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
@ -158,6 +161,9 @@ data App = App
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@ -444,11 +450,11 @@ library
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, yesod-fay >= 0.4
, yesod-fay >= 0.5.0.1
, fay >= 0.16
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
@ -456,14 +462,11 @@ library
, persistent-postgresql >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
, template-haskell
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 2.0 && < 2.1
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 2.1 && < 2.2
, data-default

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

@ -5,6 +5,7 @@
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
@ -15,6 +16,7 @@ yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -36,10 +38,10 @@ import Network.Wai.Middleware.RequestLogger
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Database.Persist
import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Network.HTTP.Client.Conduit (newManager)
import Control.Monad.Logger (runLoggingT)
import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
@ -73,13 +75,13 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager conduitManagerSettings
manager <- newManager
s <- staticSite
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
Database.Persist.loadConfig >>=
@ -96,6 +98,7 @@ makeFoundation conf = do
let updateLoop = do
threadDelay 1000000
updater
flushLogStr loggerSet'
updateLoop
_ <- forkIO updateLoop
@ -129,7 +132,7 @@ import Yesod.Auth.BrowserId
import Yesod.Auth.GoogleEmail
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
@ -154,6 +157,9 @@ data App = App
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@ -408,8 +414,8 @@ library
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
@ -418,15 +424,12 @@ library
, persistent-postgresql >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
, template-haskell
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 2.1 && < 2.2
, data-default

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

@ -5,6 +5,7 @@
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
@ -15,6 +16,7 @@ yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -32,9 +34,9 @@ import Network.Wai.Middleware.RequestLogger
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
)
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Network.HTTP.Client.Conduit (newManager)
import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
@ -68,13 +70,13 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager conduitManagerSettings
manager <- newManager
s <- staticSite
loggerSet' <- newStdoutLoggerSet defaultBufSize
@ -87,6 +89,7 @@ makeFoundation conf = do
let updateLoop = do
threadDelay 1000000
updater
flushLogStr loggerSet'
updateLoop
_ <- forkIO updateLoop
@ -112,7 +115,7 @@ import Yesod
import Yesod.Static
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import Settings.StaticFiles
@ -132,6 +135,9 @@ data App = App
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@ -335,22 +341,19 @@ library
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
, template-haskell
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 2.1 && < 2.2
, data-default

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

@ -5,6 +5,7 @@
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
@ -15,6 +16,7 @@ yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -36,10 +38,10 @@ import Network.Wai.Middleware.RequestLogger
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Database.Persist
import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Network.HTTP.Client.Conduit (newManager)
import Control.Monad.Logger (runLoggingT)
import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
@ -73,13 +75,13 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager conduitManagerSettings
manager <- newManager
s <- staticSite
dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
Database.Persist.loadConfig >>=
@ -96,6 +98,7 @@ makeFoundation conf = do
let updateLoop = do
threadDelay 1000000
updater
flushLogStr loggerSet'
updateLoop
_ <- forkIO updateLoop
@ -129,7 +132,7 @@ import Yesod.Auth.BrowserId
import Yesod.Auth.GoogleEmail
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
@ -154,6 +157,9 @@ data App = App
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@ -408,8 +414,8 @@ library
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
@ -418,15 +424,12 @@ library
, persistent-sqlite >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
, template-haskell
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 2.1 && < 2.2
, data-default

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

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.2.7.3
version: 1.2.8.1
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -47,14 +47,15 @@ executable yesod
cpp-options: -DWINDOWS
build-depends: base >= 4.3 && < 5
, ghc >= 7.0.3 && < 7.8
, ghc >= 7.0.3
, ghc-paths >= 0.1
, parsec >= 2.1 && < 4
, text >= 0.11
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 1.0.2 && < 1.3
, shakespeare-js >= 1.0.2 && < 1.3
, shakespeare-css >= 1.0.2 && < 1.1
, shakespeare
, shakespeare-text >= 1.0
, shakespeare >= 1.0.2 && < 2.1
, shakespeare-js >= 1.0.2
, shakespeare-css >= 1.0.2
, bytestring >= 0.9.1.4
, time >= 1.1.4
, template-haskell
@ -77,8 +78,9 @@ executable yesod
, fsnotify >= 0.0 && < 0.1
, split >= 0.2 && < 0.3
, file-embed
, conduit >= 0.5 && < 1.1
, resourcet >= 0.3 && < 0.5
, conduit >= 0.5 && < 1.2
, conduit-extra
, resourcet >= 0.3 && < 1.2
, base64-bytestring
, lifted-base
, http-reverse-proxy >= 0.1.1
@ -90,6 +92,7 @@ executable yesod
, warp >= 1.3.7.5
, wai >= 1.4
, data-default-class
, streaming-commons
ghc-options: -Wall -threaded
main-is: main.hs

2
yesod-core/Yesod/Core.hs
View File

@ -24,6 +24,8 @@ module Yesod.Core
, widgetToPageContent
-- * Defaults
, defaultErrorHandler
, defaultYesodMiddleware
, authorizationCheck
-- * Data types
, AuthResult (..)
, unauthorizedI

4
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -61,7 +61,9 @@ GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#if !MIN_VERSION_resourcet(1,1,0)
GO(ExceptionT)
#endif
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
@ -85,7 +87,9 @@ GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#if !MIN_VERSION_resourcet(1,1,0)
GO(ExceptionT)
#endif
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO

21
yesod-core/Yesod/Core/Content.hs
View File

@ -60,7 +60,8 @@ import Data.Monoid (mempty)
import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput)
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Aeson as J
@ -68,6 +69,8 @@ import Data.Aeson.Encode (fromValue)
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import Data.Text.Lazy.Builder (toLazyText)
import Yesod.Core.Types
import Text.Lucius (Css, renderCss)
import Text.Julius (Javascript, unJavascript)
-- | Zero-length enumerator.
emptyContent :: Content
@ -107,6 +110,11 @@ instance ToContent (ContentType, Content) where
instance ToContent TypedContent where
toContent (TypedContent _ c) = c
instance ToContent Css where
toContent = toContent . renderCss
instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
toContent src = ContentSource $ mapOutput toFlushBuilder src
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
@ -244,6 +252,12 @@ instance HasContentType Text where
instance HasContentType T.Text where
getContentType _ = typePlain
instance HasContentType Css where
getContentType _ = typeCss
instance HasContentType Javascript where
getContentType _ = typeJavascript
-- | Any type which can be converted to 'TypedContent'.
--
-- Since 1.2.0
@ -276,3 +290,8 @@ instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
toTypedContent (DontFullyEvaluate a) =
let TypedContent ct c = toTypedContent a
in TypedContent ct (ContentDontEvaluate c)
instance ToTypedContent Css where
toTypedContent = TypedContent typeCss . toContent
instance ToTypedContent Javascript where
toTypedContent = TypedContent typeJavascript . toContent

22
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -27,6 +27,7 @@ module Yesod.Core.Dispatch
, warpDebug
, warpEnv
, mkDefaultMiddlewares
, defaultMiddlewaresNoLogging
-- * WAI subsites
, WaiSubsite (..)
) where
@ -64,6 +65,7 @@ import Network.Wai.Middleware.MethodOverride
import qualified Network.Wai.Handler.Warp
import System.Log.FastLogger
import Control.Monad.Logger
import Control.Monad (when)
import qualified Paths_yesod_core
import Data.Version (showVersion)
@ -163,6 +165,7 @@ warp port site = do
]
-}
, Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
when (shouldLog' e) $
messageLoggerSource
site
logger
@ -171,6 +174,13 @@ warp port site = do
LevelError
(toLogStr $ "Exception from Warp: " ++ show e)
}
where
shouldLog' =
#if MIN_VERSION_warp(2,1,3)
Network.Wai.Handler.Warp.defaultShouldDisplayException
#else
const True
#endif
-- | A default set of middlewares.
--
@ -185,11 +195,13 @@ mkDefaultMiddlewares logger = do
#endif
, outputFormat = Apache FromSocket
}
return $ logWare
. acceptOverride
. autohead
. gzip def
. methodOverride
return $ logWare . defaultMiddlewaresNoLogging
-- | All of the default middlewares, excluding logging.
--
-- Since 1.2.12
defaultMiddlewaresNoLogging :: W.Middleware
defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride
-- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO ()

4
yesod-core/Yesod/Core/Handler.hs
View File

@ -194,7 +194,7 @@ import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Routes.Class (Route)
import Control.Failure (failure)
import Control.Exception (throwIO)
import Blaze.ByteString.Builder (Builder)
import Safe (headMay)
import Data.CaseInsensitive (CI)
@ -229,7 +229,7 @@ tell :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
handlerError :: MonadHandler m => HandlerContents -> m a
handlerError = liftHandlerT . failure
handlerError = liftIO . throwIO
hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError

1
yesod-core/Yesod/Core/Internal/Request.hs
View File

@ -40,6 +40,7 @@ import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile)
import Data.Word (Word64)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO)
import Yesod.Core.Types
import qualified Data.Map as Map

42
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -13,6 +13,7 @@ import Control.Applicative ((<$>))
import Control.Exception (fromException, bracketOnError, evaluate)
import qualified Control.Exception as E
import Control.Exception.Lifted (catch)
import Control.Monad (mplus)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
@ -48,6 +49,19 @@ import Yesod.Core.Types
import Yesod.Core.Internal.Request (parseWaiRequest,
tooLargeResponse)
import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData)
import Control.Monad (liftM)
returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
#if MIN_VERSION_bytestring(0, 10, 0)
returnDeepSessionMap sm = return $!! sm
#else
returnDeepSessionMap sm = fmap unWrappedBS `liftM` (return $!! fmap WrappedBS sm)
-- | Work around missing NFData instance for bytestring 0.9.
newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }
instance NFData WrappedBS
#endif
-- | Function used internally by Yesod in the process of converting a
-- 'HandlerT' into an 'Application'. Should not be needed by users.
@ -78,23 +92,35 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e)
state <- liftIO $ I.readIORef istate
let finalSession = ghsSession state
let headers = ghsHeaders state
let contents = either id (HCContent defaultStatus . toTypedContent) contents'
(finalSession, mcontents1) <- (do
finalSession <- returnDeepSessionMap (ghsSession state)
return (finalSession, Nothing)) `E.catch` \e -> return
(Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
(headers, mcontents2) <- (do
headers <- return $!! appEndo (ghsHeaders state) []
return (headers, Nothing)) `E.catch` \e -> return
([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
let contents =
case mcontents1 `mplus` mcontents2 of
Just x -> x
Nothing -> either id (HCContent defaultStatus . toTypedContent) contents'
let handleError e = flip runInternalState resState $ do
yar <- rheOnError e yreq
{ reqSession = finalSession
}
case yar of
YRPlain status' hs ct c sess ->
let hs' = appEndo headers hs
let hs' = headers ++ hs
status
| status' == defaultStatus = getStatus e
| otherwise = status'
in return $ YRPlain status hs' ct c sess
YRWai _ -> return yar
let sendFile' ct fp p =
return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession
contents1 <- evaluate contents `E.catch` \e -> return
(HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
case contents1 of
@ -102,7 +128,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
ec' <- liftIO $ evaluateContent c
case ec' of
Left e -> handleError e
Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession
Right c' -> return $ YRPlain status headers ct c' finalSession
HCError e -> handleError e
HCRedirect status loc -> do
let disable_caching x =
@ -110,7 +136,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
: Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
: x
hs = (if status /= H.movedPermanently301 then disable_caching else id)
$ Header "Location" (encodeUtf8 loc) : appEndo headers []
$ Header "Location" (encodeUtf8 loc) : headers
return $ YRPlain
status hs typePlain emptyContent
finalSession
@ -118,7 +144,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
(sendFile' ct fp p)
(handleError . toErrorHandler)
HCCreated loc -> do
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
let hs = Header "Location" (encodeUtf8 loc) : headers
return $ YRPlain
H.status201
hs

7
yesod-core/Yesod/Core/Json.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Core.Json
( -- * Convert from a JSON value
@ -28,6 +29,7 @@ module Yesod.Core.Json
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
import Control.Monad.Trans.Writer (Writer)
import Control.Monad.Trans.Resource (runExceptionT)
import Data.Monoid (Endo)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept)
@ -42,6 +44,7 @@ import Data.Conduit.Attoparsec (sinkParser)
import Data.Text (pack)
import qualified Data.Vector as V
import Data.Conduit
import Data.Conduit.Lift
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad (liftM)
@ -92,7 +95,11 @@ provideJson = provideRep . return . J.toJSON
-- /Since: 0.3.0/
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
#if MIN_VERSION_resourcet(1,1,0)
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
#else
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
#endif
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value

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

@ -16,16 +16,18 @@ import Control.Arrow (first)
import Control.Exception (Exception)
import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadCatch (..))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState)
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
#if !MIN_VERSION_resourcet(1,1,0)
import Control.Monad.Trans.Resource (MonadUnsafeIO (..))
#endif
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, MonadThrow (..),
MonadUnsafeIO (..),
ResourceT, Source)
import Data.Conduit (Flush, Source)
import Data.Dynamic (Dynamic)
import Data.IORef (IORef)
import Data.Map (Map, unionWith)
@ -60,6 +62,9 @@ import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
import Control.Monad.Reader (MonadReader (..))
import Prelude hiding (catch)
import Control.DeepSeq (NFData (rnf))
-- Sessions
type SessionMap = Map Text ByteString
@ -308,6 +313,14 @@ data Header =
| Header ByteString ByteString
deriving (Eq, Show)
-- FIXME In the next major version bump, let's just add strictness annotations
-- to Header (and probably everywhere else). We can also add strictness
-- annotations to SetCookie in the cookie package.
instance NFData Header where
rnf (AddCookie x) = rnf x
rnf (DeleteCookie x y) = x `seq` y `seq` ()
rnf (Header x y) = x `seq` y `seq` ()
data Location url = Local url | Remote Text
deriving (Show, Eq)
@ -385,17 +398,48 @@ instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader ->
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . flip unWidgetT reader)
(f $ liftM StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base
instance Monad m => MonadReader site (WidgetT site m) where
ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
local f (WidgetT g) = WidgetT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty)
instance MonadThrow m => MonadThrow (WidgetT site m) where
#if MIN_VERSION_resourcet(1,1,0)
throwM = lift . throwM
instance MonadCatch m => MonadCatch (HandlerT site m) where
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
uninterruptibleMask a =
HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
instance MonadCatch m => MonadCatch (WidgetT site m) where
catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
uninterruptibleMask a =
WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
#else
monadThrow = lift . monadThrow
#endif
#if MIN_VERSION_resourcet(1,1,0)
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#else
instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
#endif
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where
@ -418,6 +462,13 @@ instance MonadIO m => MonadIO (HandlerT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (HandlerT site m) where
liftBase = lift . liftBase
instance Monad m => MonadReader site (HandlerT site m) where
ask = HandlerT $ return . rheSite . handlerEnv
local f (HandlerT g) = HandlerT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use
@ -428,14 +479,23 @@ instance MonadBase b m => MonadBase b (HandlerT site m) where
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader ->
liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader')
restoreM (StH base) = HandlerT $ const $ restoreM base
instance MonadThrow m => MonadThrow (HandlerT site m) where
#if MIN_VERSION_resourcet(1,1,0)
throwM = lift . monadThrow
#else
monadThrow = lift . monadThrow
#endif
#if MIN_VERSION_resourcet(1,1,0)
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
#else
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
#endif
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (HandlerT site m) where

24
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -15,6 +15,9 @@ import Control.Exception (SomeException, try)
import Network.HTTP.Types (mkStatus)
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
import Data.Monoid (mconcat)
import Data.Text (Text, pack)
import Control.Monad (forM_)
import qualified Control.Exception.Lifted as E
data App = App
@ -26,6 +29,7 @@ mkYesod "App" [parseRoutes|
/error-in-body ErrorInBodyR GET
/error-in-body-noeval ErrorInBodyNoEvalR GET
/override-status OverrideStatusR GET
/error/#Int ErrorR GET
-- https://github.com/yesodweb/yesod/issues/658
/builder BuilderR GET
@ -98,6 +102,18 @@ goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"
getGoodBuilderR :: Handler TypedContent
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
getErrorR :: Int -> Handler ()
getErrorR 1 = setSession undefined "foo"
getErrorR 2 = setSession "foo" undefined
getErrorR 3 = deleteSession undefined
getErrorR 4 = addHeader undefined "foo"
getErrorR 5 = addHeader "foo" undefined
getErrorR 6 = expiresAt undefined
getErrorR 7 = setLanguage undefined
getErrorR 8 = cacheSeconds undefined
getErrorR 9 = setUltDest (undefined :: Text)
getErrorR 10 = setMessage undefined
errorHandlingTest :: Spec
errorHandlingTest = describe "Test.ErrorHandling" $ do
it "says not found" caseNotFound
@ -110,6 +126,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
it "file with bad len" caseFileBadLen
it "file with bad name" caseFileBadName
it "builder includes content-length" caseGoodBuilder
forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
runner :: Session () -> IO ()
runner f = toWaiApp App >>= runSession f
@ -194,3 +211,10 @@ caseGoodBuilder = runner $ do
let lbs = toLazyByteString goodBuilderContent
assertBody lbs res
assertHeader "content-length" (S8.pack $ show $ L.length lbs) res
caseError :: Int -> IO ()
caseError i = runner $ do
res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
assertStatus 500 res `E.catch` \e -> do
liftIO $ print res
E.throwIO (e :: E.SomeException)

3
yesod-core/test/YesodCoreTest/RawResponse.hs
View File

@ -19,6 +19,7 @@ import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Monad.Trans.Resource (register)
import Data.IORef
import Data.Streaming.Network (bindPortTCP)
data App = App
@ -42,7 +43,7 @@ getFreePort = do
loop 43124
where
loop port = do
esocket <- try $ bindPort port "*"
esocket <- try $ bindPortTCP port "*"
case esocket of
Left (_ :: IOException) -> loop (succ port)
Right socket -> do

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

@ -1,5 +1,5 @@
name: yesod-core
version: 1.2.9
version: 1.2.14
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -32,22 +32,22 @@ library
, text >= 0.7
, template-haskell
, path-pieces >= 0.1.2 && < 0.2
, hamlet >= 1.1 && < 1.2
, shakespeare >= 1.0 && < 1.3
, shakespeare-js >= 1.0.2 && < 1.3
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-i18n >= 1.0 && < 1.1
, hamlet >= 1.1
, shakespeare >= 1.0 && < 2.1
, shakespeare-js >= 1.0.2
, shakespeare-css >= 1.0
, shakespeare-i18n >= 1.0
, blaze-builder >= 0.2.1.4 && < 0.4
, transformers >= 0.2.2 && < 0.4
, mtl
, clientsession >= 0.9 && < 0.10
, random >= 1.0.0.2 && < 1.1
, cereal >= 0.3
, old-locale >= 1.0.0.2 && < 1.1
, failure >= 0.2 && < 0.3
, containers >= 0.2
, monad-control >= 0.3 && < 0.4
, transformers-base >= 0.4
, cookie >= 0.4 && < 0.5
, cookie >= 0.4.1 && < 0.5
, http-types >= 0.7
, case-insensitive >= 0.2
, parsec >= 2 && < 3.2
@ -58,7 +58,7 @@ library
, wai-logger >= 0.2
, monad-logger >= 0.3.1 && < 0.4
, conduit >= 0.5
, resourcet >= 0.4.9 && < 0.5
, resourcet >= 0.4.9 && < 1.2
, lifted-base >= 0.1.2
, attoparsec-conduit
, blaze-html >= 0.5
@ -67,6 +67,9 @@ library
, safe
, warp >= 1.3.8
, unix-compat
, conduit-extra
, exceptions
, deepseq
exposed-modules: Yesod.Core
Yesod.Core.Content
@ -125,6 +128,9 @@ test-suite tests
, network-conduit
, network
, async
, conduit-extra
, shakespeare
, streaming-commons
ghc-options: -Wall
extensions: TemplateHaskell

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

@ -1,5 +1,5 @@
name: yesod-eventsource
version: 1.1.0.1
version: 1.1.0.2
license: MIT
license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com>
@ -29,7 +29,7 @@ description:
library
build-depends: base >= 4 && < 5
, yesod-core == 1.2.*
, conduit >= 0.5 && < 1.1
, conduit >= 0.5 && < 1.2
, wai >= 1.3
, wai-eventsource >= 1.3
, blaze-builder

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

@ -88,7 +88,7 @@ import Data.Text as T (Text, concat, intercalate, unpack, pack, splitOn)
import qualified Data.Text.Read
import qualified Data.Map as Map
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&))
import Control.Applicative ((<$>), (<|>))
@ -565,9 +565,9 @@ optionsPersist :: ( YesodPersist site, PersistEntity a
)
#else
optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (YesodDB site)
, PersistQuery (YesodPersistBackend site (HandlerT site IO))
, PathPiece (Key a)
, PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))
, RenderMessage site msg
)
#endif

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

@ -1,5 +1,5 @@
name: yesod-form
version: 1.3.8
version: 1.3.8.2
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -17,10 +17,11 @@ library
, yesod-core >= 1.2 && < 1.3
, yesod-persistent >= 1.2 && < 1.3
, time >= 1.1.4
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.3
, persistent >= 1.2 && < 2.1
, hamlet >= 1.1
, shakespeare
, shakespeare-css >= 1.0
, shakespeare-js >= 1.0.2
, persistent >= 1.2 && < 1.4
, template-haskell
, transformers >= 0.2.2
, data-default

5
yesod-newsfeed/yesod-newsfeed.cabal
View File

@ -1,5 +1,5 @@
name: yesod-newsfeed
version: 1.2.0.1
version: 1.2.0.2
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -16,7 +16,8 @@ library
build-depends: base >= 4 && < 5
, yesod-core >= 1.2 && < 1.3
, time >= 1.1.4
, hamlet >= 1.1 && < 1.2
, hamlet >= 1.1
, shakespeare
, bytestring >= 0.9.1.4
, text >= 0.9
, xml-conduit >= 1.0

6
yesod-persistent/Yesod/Persist/Core.hs
View File

@ -88,7 +88,7 @@ class YesodPersist site => YesodPersistRunner site where
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
newtype DBRunner site = DBRunner
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
{ runDBRunner :: forall a. YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a
}
-- | Helper for implementing 'getDBRunner'.
@ -127,7 +127,7 @@ defaultGetDBRunner getPool = do
--
-- Since 1.2.0
runDBSource :: YesodPersistRunner site
=> Source (YesodDB site) a
=> Source (YesodPersistBackend site (HandlerT site IO)) a
-> Source (HandlerT site IO) a
runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner
@ -137,7 +137,7 @@ runDBSource src = do
-- | Extends 'respondSource' to create a streaming database response body.
respondSourceDB :: YesodPersistRunner site
=> ContentType
-> Source (YesodDB site) (Flush Builder)
-> Source (YesodPersistBackend site (HandlerT site IO)) (Flush Builder)
-> HandlerT site IO TypedContent
respondSourceDB ctype = respondSource ctype . runDBSource

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

@ -1,5 +1,5 @@
name: yesod-persistent
version: 1.2.2.2
version: 1.2.2.3
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

14
yesod-platform/make-cabal.sh
View File

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

140
yesod-platform/yesod-platform.cabal
View File

@ -1,5 +1,5 @@
name: yesod-platform
version: 1.2.8.2
version: 1.2.10
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -14,9 +14,8 @@ homepage: http://www.yesodweb.com/
library
build-depends: base >= 4 && < 5
, ReadArgs == 1.2.1
, SHA == 1.6.4
, aeson == 0.7.0.2
, aeson == 0.7.0.3
, ansi-terminal == 0.6.1.1
, ansi-wl-pprint == 0.6.7.1
, asn1-encoding == 0.8.1.3
@ -24,26 +23,26 @@ library
, asn1-types == 0.2.3
, async == 2.0.1.5
, attoparsec == 0.11.2.1
, attoparsec-conduit == 1.0.1.2
, authenticate == 1.3.2.6
, attoparsec-conduit == 1.1.0
, authenticate == 1.3.2.8
, base-unicode-symbols == 0.2.2.4
, base16-bytestring == 0.1.1.6
, 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-builder-conduit == 1.1.0
, blaze-html == 0.7.0.1
, blaze-markup == 0.6.0.0
, byteable == 0.1.1
, byteorder == 1.0.4
, case-insensitive == 1.1.0.3
, case-insensitive == 1.2.0.0
, cereal == 0.4.0.1
, cipher-aes == 0.2.7
, cipher-rc4 == 0.1.4
, clientsession == 0.9.0.3
, conduit == 1.0.15.1
, connection == 0.2.0
, control-monad-loop == 0.1
, cookie == 0.4.0.1
, conduit == 1.1.0.2
, conduit-extra == 1.1.0.1
, connection == 0.2.1
, cookie == 0.4.1.1
, cprng-aes == 0.5.2
, crypto-api == 0.13
, crypto-cipher-types == 0.0.9
@ -51,8 +50,8 @@ library
, crypto-pubkey == 0.2.4
, crypto-pubkey-types == 0.4.2.2
, crypto-random == 0.0.7
, cryptohash == 0.11.2
, cryptohash-conduit == 0.1.0
, cryptohash == 0.11.4
, cryptohash-conduit == 0.1.1
, css-text == 0.1.2.1
, data-default == 0.5.3
, data-default-class == 0.0.1
@ -60,105 +59,100 @@ library
, data-default-instances-containers == 0.0.1
, data-default-instances-dlist == 0.0.1
, data-default-instances-old-locale == 0.0.1
, dlist == 0.7
, dlist == 0.7.0.1
, email-validate == 2.0.1
, entropy == 0.2.2.4
, esqueleto == 1.3.5
, failure == 0.2.0.1
, esqueleto == 1.3.12
, exceptions == 0.5
, fast-logger == 2.1.5
, file-embed == 0.0.6
, filesystem-conduit == 1.0.0.1
, hamlet == 1.1.9.2
, hjsmin == 0.1.4.5
, hspec == 1.9.0
, hamlet == 1.2.0
, hjsmin == 0.1.4.6
, hspec == 1.9.2
, hspec-expectations == 0.5.0.1
, html-conduit == 1.1.0.1
, http-client == 0.2.2.2
, http-client-conduit == 0.2.0.1
, html-conduit == 1.1.0.4
, http-client == 0.3.1.1
, http-client-tls == 0.2.1.1
, http-conduit == 2.0.0.8
, http-conduit == 2.1.1
, http-date == 0.0.4
, http-reverse-proxy == 0.3.1.1
, http-types == 0.8.3
, language-javascript == 0.5.9
, http-reverse-proxy == 0.3.1.5
, http-types == 0.8.4
, language-javascript == 0.5.12
, lifted-base == 0.2.2.1
, mime-mail == 0.4.4.1
, mime-types == 0.1.0.3
, mime-mail == 0.4.5.1
, mime-types == 0.1.0.4
, mmorph == 1.0.2
, monad-control == 0.3.2.3
, monad-logger == 0.3.4.0
, monad-logger == 0.3.6
, monad-loops == 0.4.2
, network-conduit == 1.0.4
, optparse-applicative == 0.7.0.2
, network-conduit == 1.1.0
, optparse-applicative == 0.8.0.1
, path-pieces == 0.1.3.1
, pem == 0.2.1
, persistent == 1.3.0.3
, persistent-template == 1.3.1.2
, pool-conduit == 0.1.2.1
, pem == 0.2.2
, persistent == 1.3.0.6
, persistent-template == 1.3.1.3
, 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
, quickcheck-io == 0.1.1
, resource-pool == 0.2.1.1
, resourcet == 0.4.10.1
, resourcet == 1.1.2
, safe == 0.3.4
, scientific == 0.2.0.2
, securemem == 0.1.3
, semigroups == 0.12.2
, semigroups == 0.13.0.1
, setenv == 0.1.1.1
, shakespeare == 1.2.1.1
, shakespeare-css == 1.0.7.1
, shakespeare-i18n == 1.0.0.5
, shakespeare-js == 1.2.0.4
, shakespeare-text == 1.0.2
, shakespeare == 2.0.0.3
, shakespeare-css == 1.1.0
, shakespeare-i18n == 1.1.0
, shakespeare-js == 1.3.0
, shakespeare-text == 1.1.0
, silently == 1.2.4.1
, simple-sendfile == 0.2.13
, simple-sendfile == 0.2.14
, skein == 1.0.9
, socks == 0.5.4
, stm-chans == 3.0.0
, stm-chans == 3.0.0.2
, streaming-commons == 0.1.1
, stringsearch == 0.3.6.5
, system-fileio == 0.3.12
, system-filepath == 0.4.9
, system-filepath == 0.4.10
, tagged == 0.7.1
, tagsoup == 0.13.1
, tagstream-conduit == 0.5.5
, text-stream-decode == 0.1.0.4
, tls == 1.2.2
, tagstream-conduit == 0.5.5.1
, tf-random == 0.5
, tls == 1.2.6
, transformers-base == 0.4.1
, unix-compat == 0.4.1.1
, unordered-containers == 0.2.3.3
, utf8-light == 0.4.2
, unordered-containers == 0.2.4.0
, utf8-string == 0.3.7
, vector == 0.10.9.1
, void == 0.6.1
, wai == 2.1.0
, wai-app-static == 2.0.0.4
, wai-extra == 2.1.0.1
, wai == 2.1.0.2
, wai-app-static == 2.0.1
, wai-extra == 2.1.1.1
, wai-logger == 2.1.1
, wai-test == 2.0.0.2
, warp == 2.1.1.2
, warp-tls == 2.0.3.1
, wai-test == 2.0.1.1
, warp == 2.1.4
, warp-tls == 2.0.3.3
, 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-conduit == 1.2.0.1
, xml-types == 0.3.4
, xss-sanitize == 0.3.5
, yaml == 0.8.7.2
, yesod == 1.2.5
, yesod-auth == 1.2.7
, yesod-core == 1.2.8
, yesod-form == 1.3.8
, yesod-persistent == 1.2.2.1
, xss-sanitize == 0.3.5.2
, yaml == 0.8.8.2
, yesod == 1.2.5.2
, yesod-auth == 1.3.0.4
, yesod-auth-hashdb == 1.3.0.1
, yesod-core == 1.2.14
, yesod-form == 1.3.8.2
, yesod-persistent == 1.2.2.3
, yesod-routes == 1.2.0.6
, yesod-static == 1.2.2.2
, yesod-test == 1.2.1
, zlib-bindings == 0.1.1.3
, zlib-conduit == 1.0.0
, yesod-static == 1.2.2.5
, yesod-test == 1.2.1.2
, zlib-conduit == 1.1.0
exposed-modules: Yesod.Platform

30
yesod-static/Yesod/EmbeddedStatic/Generators.hs
View File

@ -30,13 +30,12 @@ module Yesod.EmbeddedStatic.Generators (
-- $example
) where
import Control.Applicative ((<$>))
import Control.Applicative ((<$>), (<*>))
import Control.Exception (try, SomeException)
import Control.Monad (forM, when)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Char (isDigit, isLower)
import Data.Conduit (($$), (=$))
import Data.Conduit.Process (proc, conduitProcess)
import Data.Conduit (($$))
import Data.Default (def)
import Data.Maybe (isNothing)
import Language.Haskell.TH
@ -46,7 +45,12 @@ import System.FilePath ((</>))
import Text.Jasmine (minifym)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C
import Data.Conduit.Binary (sourceHandle)
import qualified Data.Text as T
import qualified System.Process as Proc
import System.Exit (ExitCode (ExitSuccess))
import Control.Concurrent.Async (Concurrently (..))
import System.IO (hClose)
import Yesod.EmbeddedStatic.Types
@ -197,12 +201,20 @@ compressTool f opts ct = do
mpath <- findExecutable f
when (isNothing mpath) $
fail $ "Unable to find " ++ f
let src = C.sourceList $ BL.toChunks ct
p = proc f opts
sink = C.consume
compressed <- runResourceT (src $$ conduitProcess p =$ sink)
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
let p = (Proc.proc f opts)
{ Proc.std_in = Proc.CreatePipe
, Proc.std_out = Proc.CreatePipe
}
(Just hin, Just hout, _, ph) <- Proc.createProcess p
(compressed, (), code) <- runConcurrently $ (,,)
<$> Concurrently (sourceHandle hout $$ C.consume)
<*> Concurrently (BL.hPut hin ct >> hClose hin)
<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess
then do
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
else error $ "compressTool: compression failed with " ++ f
-- | Try a list of processing functions (like the compressions above) one by one until

3
yesod-static/Yesod/Static.hs
View File

@ -66,6 +66,7 @@ import System.Directory
import Control.Monad
import Data.FileEmbed (embedDir)
import Control.Monad.Trans.Resource (runResourceT)
import Yesod.Core
import Yesod.Core.Types
@ -446,7 +447,7 @@ data CombineSettings = CombineSettings
, csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
-- ^ Post processing to be performed on CSS files.
--
-- Default: Use Lucius to minify.
-- Default: Pass-through.
--
-- Since 1.2.0
, csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString

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

@ -1,5 +1,5 @@
name: yesod-static
version: 1.2.2.2
version: 1.2.2.5
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -41,6 +41,7 @@ library
, http-types >= 0.7
, unix-compat >= 0.2
, conduit >= 0.5
, conduit-extra
, cryptohash-conduit >= 0.1
, cryptohash >= 0.11
, system-filepath >= 0.4.6 && < 0.5
@ -49,10 +50,11 @@ library
, shakespeare-css >= 1.0.3
, mime-types >= 0.1
, hjsmin
, process-conduit >= 1.0 && < 1.1
, filepath >= 1.3
, resourcet >= 0.4
, unordered-containers >= 0.2
, process
, async
exposed-modules: Yesod.Static
Yesod.EmbeddedStatic
@ -100,12 +102,14 @@ test-suite tests
, shakespeare-css
, mime-types
, hjsmin
, process-conduit
, filepath
, resourcet
, unordered-containers
, async
, process
, conduit-extra
ghc-options: -Wall
ghc-options: -Wall -threaded
extensions: TemplateHaskell
source-repository head

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

@ -1,5 +1,5 @@
name: yesod-test
version: 1.2.1.1
version: 1.2.1.2
license: MIT
license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar>

10
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod
version: 1.2.5.1
version: 1.2.5.2
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -30,9 +30,9 @@ library
, transformers >= 0.2.2 && < 0.4
, wai >= 1.3
, wai-extra >= 1.3
, hamlet >= 1.1 && < 1.2
, shakespeare-js >= 1.0.2 && < 1.3
, shakespeare-css >= 1.0 && < 1.1
, hamlet >= 1.1
, shakespeare-js >= 1.0.2
, shakespeare-css >= 1.0
, warp >= 1.3
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
@ -48,6 +48,8 @@ library
, bytestring
, monad-logger
, fast-logger
, conduit-extra
, shakespeare
exposed-modules: Yesod
, Yesod.Default.Config