Merge remote-tracking branch 'origin/master' into yesod-1.4
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
commit
fe622d5345
3
.gitmodules
vendored
3
.gitmodules
vendored
@ -1,3 +0,0 @@
|
|||||||
[submodule "scripts"]
|
|
||||||
path = scripts
|
|
||||||
url = git://github.com/yesodweb/scripts.git
|
|
||||||
@ -2,12 +2,12 @@ language: haskell
|
|||||||
|
|
||||||
install:
|
install:
|
||||||
- cabal update
|
- 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
|
- cabal-meta install --force-reinstalls
|
||||||
|
|
||||||
script:
|
script:
|
||||||
- echo Done
|
- echo Done
|
||||||
- cabal-meta install --enable-tests
|
- cabal-meta install --enable-tests
|
||||||
- mega-sdist --test
|
- mega-sdist --test
|
||||||
- cabal install mega-sdist hspec cabal-meta cabal-src
|
- cabal install hspec cabal-meta cabal-src
|
||||||
- cabal-meta install --force-reinstalls
|
- cabal-meta install --force-reinstalls
|
||||||
|
|||||||
6
authenticate-oauth/.gitignore
vendored
6
authenticate-oauth/.gitignore
vendored
@ -1,6 +0,0 @@
|
|||||||
.DS_Store
|
|
||||||
*.hi
|
|
||||||
*.o
|
|
||||||
dist
|
|
||||||
*~
|
|
||||||
cabal-dev
|
|
||||||
@ -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.
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
#!/usr/bin/env runhaskell
|
|
||||||
|
|
||||||
> module Main where
|
|
||||||
> import Distribution.Simple
|
|
||||||
|
|
||||||
> main :: IO ()
|
|
||||||
> main = defaultMain
|
|
||||||
@ -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 }
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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.
|
|
||||||
@ -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
|
|
||||||
@ -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 []
|
|
||||||
@ -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)
|
|
||||||
@ -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
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
#!/usr/bin/env runhaskell
|
|
||||||
|
|
||||||
> module Main where
|
|
||||||
> import Distribution.Simple
|
|
||||||
|
|
||||||
> main :: IO ()
|
|
||||||
> main = defaultMain
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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/"
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
scripts
@ -1 +0,0 @@
|
|||||||
Subproject commit 9902ff808afbcb417c6ad125941343878e3afe11
|
|
||||||
@ -9,6 +9,5 @@
|
|||||||
./yesod-test
|
./yesod-test
|
||||||
./yesod-bin
|
./yesod-bin
|
||||||
./yesod
|
./yesod
|
||||||
./authenticate
|
|
||||||
./yesod-eventsource
|
./yesod-eventsource
|
||||||
./yesod-websockets
|
./yesod-websockets
|
||||||
|
|||||||
@ -34,10 +34,13 @@ module Yesod.Auth.Email
|
|||||||
import Network.Mail.Mime (randomString)
|
import Network.Mail.Mime (randomString)
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import System.Random
|
import System.Random
|
||||||
import Data.Digest.Pure.MD5
|
|
||||||
import qualified Data.Text as TS
|
import qualified Data.Text as TS
|
||||||
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Lazy as TL
|
import qualified Data.Text.Lazy as TL
|
||||||
|
import qualified Data.Text.Encoding as TE
|
||||||
import qualified Data.Text.Lazy.Encoding as TLE
|
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 (encodeUtf8, decodeUtf8With)
|
||||||
import Data.Text.Encoding.Error (lenientDecode)
|
import Data.Text.Encoding.Error (lenientDecode)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
@ -526,7 +529,8 @@ saltPass = fmap (decodeUtf8With lenientDecode)
|
|||||||
. encodeUtf8
|
. encodeUtf8
|
||||||
|
|
||||||
saltPass' :: String -> String -> String
|
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
|
isValidPass :: Text -- ^ cleartext password
|
||||||
-> SaltedPass -- ^ salted password
|
-> SaltedPass -- ^ salted password
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-auth
|
name: yesod-auth
|
||||||
version: 1.3.0.0
|
version: 1.3.0.4
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman, Patrick Brisbin
|
author: Michael Snoyman, Patrick Brisbin
|
||||||
@ -15,7 +15,9 @@ description:
|
|||||||
.
|
.
|
||||||
* <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
|
* <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
|
extra-source-files: persona_sign_in_blue.png
|
||||||
|
|
||||||
library
|
library
|
||||||
@ -25,21 +27,22 @@ library
|
|||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2 && < 1.3
|
||||||
, wai >= 1.4
|
, wai >= 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, pureMD5 >= 2.0
|
, base16-bytestring
|
||||||
|
, cryptohash
|
||||||
, random >= 1.0.0.2
|
, random >= 1.0.0.2
|
||||||
, text >= 0.7
|
, text >= 0.7
|
||||||
, mime-mail >= 0.3
|
, mime-mail >= 0.3
|
||||||
, yesod-persistent >= 1.2
|
, yesod-persistent >= 1.2
|
||||||
, hamlet >= 1.1 && < 1.2
|
, hamlet >= 1.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
, shakespeare
|
||||||
, shakespeare-js >= 1.0.2 && < 1.3
|
, shakespeare-css >= 1.0
|
||||||
|
, shakespeare-js >= 1.0.2
|
||||||
, containers
|
, containers
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, transformers >= 0.2.2
|
, transformers >= 0.2.2
|
||||||
, persistent >= 1.2 && < 2.1
|
, persistent >= 1.2 && < 2.1
|
||||||
, persistent-template >= 1.2 && < 2.1
|
, persistent-template >= 1.2 && < 2.1
|
||||||
, SHA >= 1.4.1.3
|
|
||||||
, http-conduit >= 1.5
|
, http-conduit >= 1.5
|
||||||
, aeson >= 0.5
|
, aeson >= 0.5
|
||||||
, pwstore-fast >= 2.2
|
, pwstore-fast >= 2.2
|
||||||
|
|||||||
@ -64,8 +64,7 @@ import GhcBuild (buildPackage,
|
|||||||
getBuildFlags, getPackageArgs)
|
getBuildFlags, getPackageArgs)
|
||||||
|
|
||||||
import qualified Config as GHC
|
import qualified Config as GHC
|
||||||
import Data.Conduit.Network (HostPreference (HostIPv4),
|
import Data.Streaming.Network (bindPortTCP)
|
||||||
bindPort)
|
|
||||||
import Network (withSocketsDo)
|
import Network (withSocketsDo)
|
||||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||||
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
|
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
|
||||||
@ -171,7 +170,7 @@ reverseProxy opts iappPort = do
|
|||||||
|
|
||||||
checkPort :: Int -> IO Bool
|
checkPort :: Int -> IO Bool
|
||||||
checkPort p = do
|
checkPort p = do
|
||||||
es <- Ex.try $ bindPort p HostIPv4
|
es <- Ex.try $ bindPortTCP p "*4"
|
||||||
case es of
|
case es of
|
||||||
Left (_ :: Ex.IOException) -> return False
|
Left (_ :: Ex.IOException) -> return False
|
||||||
Right s -> do
|
Right s -> do
|
||||||
|
|||||||
@ -2,7 +2,8 @@
|
|||||||
module HsFile (mkHsFile) where
|
module HsFile (mkHsFile) where
|
||||||
import Text.ProjectTemplate (createTemplate)
|
import Text.ProjectTemplate (createTemplate)
|
||||||
import Data.Conduit
|
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 qualified Data.Conduit.List as CL
|
||||||
import Prelude hiding (FilePath)
|
import Prelude hiding (FilePath)
|
||||||
import Filesystem.Path ( FilePath )
|
import Filesystem.Path ( FilePath )
|
||||||
|
|||||||
@ -4,7 +4,8 @@ module Scaffolding.Scaffolder (scaffold) where
|
|||||||
|
|
||||||
import Control.Arrow ((&&&))
|
import Control.Arrow ((&&&))
|
||||||
import qualified Data.ByteString.Char8 as S
|
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.FileEmbed (embedFile)
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
{-# START_FILE .gitignore #-}
|
{-# START_FILE .gitignore #-}
|
||||||
dist*
|
dist*
|
||||||
static/tmp/
|
static/tmp/
|
||||||
|
static/combined/
|
||||||
config/client_session_key.aes
|
config/client_session_key.aes
|
||||||
*.hi
|
*.hi
|
||||||
*.o
|
*.o
|
||||||
@ -15,6 +16,7 @@ yesod-devel/
|
|||||||
.cabal-sandbox
|
.cabal-sandbox
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.DS_Store
|
.DS_Store
|
||||||
|
*.swp
|
||||||
|
|
||||||
{-# START_FILE Application.hs #-}
|
{-# START_FILE Application.hs #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -35,9 +37,9 @@ import Network.Wai.Middleware.RequestLogger
|
|||||||
)
|
)
|
||||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
import Network.HTTP.Client.Conduit (newManager)
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
|
||||||
import Network.Wai.Logger (clockDateCacher)
|
import Network.Wai.Logger (clockDateCacher)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||||
@ -71,13 +73,13 @@ makeApplication conf = do
|
|||||||
-- Create the WAI application and apply middlewares
|
-- Create the WAI application and apply middlewares
|
||||||
app <- toWaiAppPlain foundation
|
app <- toWaiAppPlain foundation
|
||||||
let logFunc = messageLoggerSource foundation (appLogger 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
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||||
-- performs some initialization.
|
-- performs some initialization.
|
||||||
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
||||||
makeFoundation conf = do
|
makeFoundation conf = do
|
||||||
manager <- newManager conduitManagerSettings
|
manager <- newManager
|
||||||
s <- staticSite
|
s <- staticSite
|
||||||
dbconf <- withYamlEnvironment "config/mongoDB.yml" (appEnv conf)
|
dbconf <- withYamlEnvironment "config/mongoDB.yml" (appEnv conf)
|
||||||
Database.Persist.loadConfig >>=
|
Database.Persist.loadConfig >>=
|
||||||
@ -94,6 +96,7 @@ makeFoundation conf = do
|
|||||||
let updateLoop = do
|
let updateLoop = do
|
||||||
threadDelay 1000000
|
threadDelay 1000000
|
||||||
updater
|
updater
|
||||||
|
flushLogStr loggerSet'
|
||||||
updateLoop
|
updateLoop
|
||||||
_ <- forkIO updateLoop
|
_ <- forkIO updateLoop
|
||||||
|
|
||||||
@ -122,7 +125,7 @@ import Yesod.Auth.BrowserId
|
|||||||
import Yesod.Auth.GoogleEmail
|
import Yesod.Auth.GoogleEmail
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
||||||
import qualified Settings
|
import qualified Settings
|
||||||
import Settings.Development (development)
|
import Settings.Development (development)
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
@ -147,6 +150,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance HasHttpManager App where
|
||||||
|
getHttpManager = httpManager
|
||||||
|
|
||||||
-- Set up i18n messages. See the message folder.
|
-- Set up i18n messages. See the message folder.
|
||||||
mkMessage "App" "messages" "en"
|
mkMessage "App" "messages" "en"
|
||||||
|
|
||||||
@ -404,8 +410,8 @@ library
|
|||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5 && < 1.3
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.12 && < 1.3
|
||||||
, yesod-auth >= 1.2 && < 1.3
|
, yesod-auth >= 1.3 && < 1.4
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2 && < 1.3
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9 && < 0.11
|
||||||
@ -414,15 +420,12 @@ library
|
|||||||
, persistent-mongoDB >= 1.3 && < 1.4
|
, persistent-mongoDB >= 1.3 && < 1.4
|
||||||
, persistent-template >= 1.3 && < 1.4
|
, persistent-template >= 1.3 && < 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, hamlet >= 1.1 && < 1.2
|
, shakespeare >= 2.0 && < 2.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
|
||||||
, shakespeare-js >= 1.2 && < 1.3
|
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
|
||||||
, hjsmin >= 0.1 && < 0.2
|
, hjsmin >= 0.1 && < 0.2
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, wai-extra >= 2.1 && < 2.2
|
, wai-extra >= 2.1 && < 2.2
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8 && < 0.9
|
||||||
, http-conduit >= 2.0 && < 2.1
|
, http-conduit >= 2.1 && < 2.2
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1 && < 1.3
|
||||||
, warp >= 2.1 && < 2.2
|
, warp >= 2.1 && < 2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
{-# START_FILE .gitignore #-}
|
{-# START_FILE .gitignore #-}
|
||||||
dist*
|
dist*
|
||||||
static/tmp/
|
static/tmp/
|
||||||
|
static/combined/
|
||||||
config/client_session_key.aes
|
config/client_session_key.aes
|
||||||
*.hi
|
*.hi
|
||||||
*.o
|
*.o
|
||||||
@ -15,6 +16,7 @@ yesod-devel/
|
|||||||
.cabal-sandbox
|
.cabal-sandbox
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.DS_Store
|
.DS_Store
|
||||||
|
*.swp
|
||||||
|
|
||||||
{-# START_FILE Application.hs #-}
|
{-# START_FILE Application.hs #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -36,10 +38,10 @@ import Network.Wai.Middleware.RequestLogger
|
|||||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
import Database.Persist.Sql (runMigration)
|
import Database.Persist.Sql (runMigration)
|
||||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
import Network.HTTP.Client.Conduit (newManager)
|
||||||
import Control.Monad.Logger (runLoggingT)
|
import Control.Monad.Logger (runLoggingT)
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
|
||||||
import Network.Wai.Logger (clockDateCacher)
|
import Network.Wai.Logger (clockDateCacher)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||||
@ -73,13 +75,13 @@ makeApplication conf = do
|
|||||||
-- Create the WAI application and apply middlewares
|
-- Create the WAI application and apply middlewares
|
||||||
app <- toWaiAppPlain foundation
|
app <- toWaiAppPlain foundation
|
||||||
let logFunc = messageLoggerSource foundation (appLogger 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
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||||
-- performs some initialization.
|
-- performs some initialization.
|
||||||
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
||||||
makeFoundation conf = do
|
makeFoundation conf = do
|
||||||
manager <- newManager conduitManagerSettings
|
manager <- newManager
|
||||||
s <- staticSite
|
s <- staticSite
|
||||||
dbconf <- withYamlEnvironment "config/mysql.yml" (appEnv conf)
|
dbconf <- withYamlEnvironment "config/mysql.yml" (appEnv conf)
|
||||||
Database.Persist.loadConfig >>=
|
Database.Persist.loadConfig >>=
|
||||||
@ -96,6 +98,7 @@ makeFoundation conf = do
|
|||||||
let updateLoop = do
|
let updateLoop = do
|
||||||
threadDelay 1000000
|
threadDelay 1000000
|
||||||
updater
|
updater
|
||||||
|
flushLogStr loggerSet'
|
||||||
updateLoop
|
updateLoop
|
||||||
_ <- forkIO updateLoop
|
_ <- forkIO updateLoop
|
||||||
|
|
||||||
@ -129,7 +132,7 @@ import Yesod.Auth.BrowserId
|
|||||||
import Yesod.Auth.GoogleEmail
|
import Yesod.Auth.GoogleEmail
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
||||||
import qualified Settings
|
import qualified Settings
|
||||||
import Settings.Development (development)
|
import Settings.Development (development)
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
@ -154,6 +157,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance HasHttpManager App where
|
||||||
|
getHttpManager = httpManager
|
||||||
|
|
||||||
-- Set up i18n messages. See the message folder.
|
-- Set up i18n messages. See the message folder.
|
||||||
mkMessage "App" "messages" "en"
|
mkMessage "App" "messages" "en"
|
||||||
|
|
||||||
@ -408,8 +414,8 @@ library
|
|||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5 && < 1.3
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.12 && < 1.3
|
||||||
, yesod-auth >= 1.2 && < 1.3
|
, yesod-auth >= 1.3 && < 1.4
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2 && < 1.3
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9 && < 0.11
|
||||||
@ -418,15 +424,12 @@ library
|
|||||||
, persistent-mysql >= 1.3 && < 1.4
|
, persistent-mysql >= 1.3 && < 1.4
|
||||||
, persistent-template >= 1.3 && < 1.4
|
, persistent-template >= 1.3 && < 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, hamlet >= 1.1 && < 1.2
|
, shakespeare >= 2.0 && < 2.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
|
||||||
, shakespeare-js >= 1.2 && < 1.3
|
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
|
||||||
, hjsmin >= 0.1 && < 0.2
|
, hjsmin >= 0.1 && < 0.2
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, wai-extra >= 2.1 && < 2.2
|
, wai-extra >= 2.1 && < 2.2
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8 && < 0.9
|
||||||
, http-conduit >= 2.0 && < 2.1
|
, http-conduit >= 2.1 && < 2.2
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1 && < 1.3
|
||||||
, warp >= 2.1 && < 2.2
|
, warp >= 2.1 && < 2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
{-# START_FILE .gitignore #-}
|
{-# START_FILE .gitignore #-}
|
||||||
dist*
|
dist*
|
||||||
static/tmp/
|
static/tmp/
|
||||||
|
static/combined/
|
||||||
config/client_session_key.aes
|
config/client_session_key.aes
|
||||||
*.hi
|
*.hi
|
||||||
*.o
|
*.o
|
||||||
@ -16,6 +17,7 @@ yesod-devel/
|
|||||||
.cabal-sandbox
|
.cabal-sandbox
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.DS_Store
|
.DS_Store
|
||||||
|
*.swp
|
||||||
|
|
||||||
{-# START_FILE Application.hs #-}
|
{-# START_FILE Application.hs #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -37,11 +39,11 @@ import Network.Wai.Middleware.RequestLogger
|
|||||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
import Database.Persist.Sql (runMigration)
|
import Database.Persist.Sql (runMigration)
|
||||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
import Network.HTTP.Client.Conduit (newManager)
|
||||||
import Yesod.Fay (getFaySite)
|
import Yesod.Fay (getFaySite)
|
||||||
import Control.Monad.Logger (runLoggingT)
|
import Control.Monad.Logger (runLoggingT)
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
|
||||||
import Network.Wai.Logger (clockDateCacher)
|
import Network.Wai.Logger (clockDateCacher)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||||
@ -76,13 +78,13 @@ makeApplication conf = do
|
|||||||
-- Create the WAI application and apply middlewares
|
-- Create the WAI application and apply middlewares
|
||||||
app <- toWaiAppPlain foundation
|
app <- toWaiAppPlain foundation
|
||||||
let logFunc = messageLoggerSource foundation (appLogger 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
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||||
-- performs some initialization.
|
-- performs some initialization.
|
||||||
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
||||||
makeFoundation conf = do
|
makeFoundation conf = do
|
||||||
manager <- newManager conduitManagerSettings
|
manager <- newManager
|
||||||
s <- staticSite
|
s <- staticSite
|
||||||
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
|
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
|
||||||
Database.Persist.loadConfig >>=
|
Database.Persist.loadConfig >>=
|
||||||
@ -99,6 +101,7 @@ makeFoundation conf = do
|
|||||||
let updateLoop = do
|
let updateLoop = do
|
||||||
threadDelay 1000000
|
threadDelay 1000000
|
||||||
updater
|
updater
|
||||||
|
flushLogStr loggerSet'
|
||||||
updateLoop
|
updateLoop
|
||||||
_ <- forkIO updateLoop
|
_ <- forkIO updateLoop
|
||||||
|
|
||||||
@ -132,7 +135,7 @@ import Yesod.Auth.BrowserId
|
|||||||
import Yesod.Auth.GoogleEmail
|
import Yesod.Auth.GoogleEmail
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
||||||
import qualified Settings
|
import qualified Settings
|
||||||
import Settings.Development (development)
|
import Settings.Development (development)
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
@ -158,6 +161,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance HasHttpManager App where
|
||||||
|
getHttpManager = httpManager
|
||||||
|
|
||||||
-- Set up i18n messages. See the message folder.
|
-- Set up i18n messages. See the message folder.
|
||||||
mkMessage "App" "messages" "en"
|
mkMessage "App" "messages" "en"
|
||||||
|
|
||||||
@ -444,11 +450,11 @@ library
|
|||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5 && < 1.3
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.12 && < 1.3
|
||||||
, yesod-auth >= 1.2 && < 1.3
|
, yesod-auth >= 1.3 && < 1.4
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2 && < 1.3
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, yesod-fay >= 0.4
|
, yesod-fay >= 0.5.0.1
|
||||||
, fay >= 0.16
|
, fay >= 0.16
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9 && < 0.11
|
||||||
, text >= 0.11 && < 2.0
|
, text >= 0.11 && < 2.0
|
||||||
@ -456,14 +462,11 @@ library
|
|||||||
, persistent-postgresql >= 1.3 && < 1.4
|
, persistent-postgresql >= 1.3 && < 1.4
|
||||||
, persistent-template >= 1.3 && < 1.4
|
, persistent-template >= 1.3 && < 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, hamlet >= 1.1 && < 1.2
|
, shakespeare >= 2.0 && < 2.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
|
||||||
, shakespeare-js >= 1.2 && < 1.3
|
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, wai-extra >= 2.1 && < 2.2
|
, wai-extra >= 2.1 && < 2.2
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8 && < 0.9
|
||||||
, http-conduit >= 2.0 && < 2.1
|
, http-conduit >= 2.1 && < 2.2
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1 && < 1.3
|
||||||
, warp >= 2.1 && < 2.2
|
, warp >= 2.1 && < 2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
{-# START_FILE .gitignore #-}
|
{-# START_FILE .gitignore #-}
|
||||||
dist*
|
dist*
|
||||||
static/tmp/
|
static/tmp/
|
||||||
|
static/combined/
|
||||||
config/client_session_key.aes
|
config/client_session_key.aes
|
||||||
*.hi
|
*.hi
|
||||||
*.o
|
*.o
|
||||||
@ -15,6 +16,7 @@ yesod-devel/
|
|||||||
.cabal-sandbox
|
.cabal-sandbox
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.DS_Store
|
.DS_Store
|
||||||
|
*.swp
|
||||||
|
|
||||||
{-# START_FILE Application.hs #-}
|
{-# START_FILE Application.hs #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -36,10 +38,10 @@ import Network.Wai.Middleware.RequestLogger
|
|||||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
import Database.Persist.Sql (runMigration)
|
import Database.Persist.Sql (runMigration)
|
||||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
import Network.HTTP.Client.Conduit (newManager)
|
||||||
import Control.Monad.Logger (runLoggingT)
|
import Control.Monad.Logger (runLoggingT)
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
|
||||||
import Network.Wai.Logger (clockDateCacher)
|
import Network.Wai.Logger (clockDateCacher)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||||
@ -73,13 +75,13 @@ makeApplication conf = do
|
|||||||
-- Create the WAI application and apply middlewares
|
-- Create the WAI application and apply middlewares
|
||||||
app <- toWaiAppPlain foundation
|
app <- toWaiAppPlain foundation
|
||||||
let logFunc = messageLoggerSource foundation (appLogger 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
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||||
-- performs some initialization.
|
-- performs some initialization.
|
||||||
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
||||||
makeFoundation conf = do
|
makeFoundation conf = do
|
||||||
manager <- newManager conduitManagerSettings
|
manager <- newManager
|
||||||
s <- staticSite
|
s <- staticSite
|
||||||
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
|
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
|
||||||
Database.Persist.loadConfig >>=
|
Database.Persist.loadConfig >>=
|
||||||
@ -96,6 +98,7 @@ makeFoundation conf = do
|
|||||||
let updateLoop = do
|
let updateLoop = do
|
||||||
threadDelay 1000000
|
threadDelay 1000000
|
||||||
updater
|
updater
|
||||||
|
flushLogStr loggerSet'
|
||||||
updateLoop
|
updateLoop
|
||||||
_ <- forkIO updateLoop
|
_ <- forkIO updateLoop
|
||||||
|
|
||||||
@ -129,7 +132,7 @@ import Yesod.Auth.BrowserId
|
|||||||
import Yesod.Auth.GoogleEmail
|
import Yesod.Auth.GoogleEmail
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
||||||
import qualified Settings
|
import qualified Settings
|
||||||
import Settings.Development (development)
|
import Settings.Development (development)
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
@ -154,6 +157,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance HasHttpManager App where
|
||||||
|
getHttpManager = httpManager
|
||||||
|
|
||||||
-- Set up i18n messages. See the message folder.
|
-- Set up i18n messages. See the message folder.
|
||||||
mkMessage "App" "messages" "en"
|
mkMessage "App" "messages" "en"
|
||||||
|
|
||||||
@ -408,8 +414,8 @@ library
|
|||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5 && < 1.3
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.12 && < 1.3
|
||||||
, yesod-auth >= 1.2 && < 1.3
|
, yesod-auth >= 1.3 && < 1.4
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2 && < 1.3
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9 && < 0.11
|
||||||
@ -418,15 +424,12 @@ library
|
|||||||
, persistent-postgresql >= 1.3 && < 1.4
|
, persistent-postgresql >= 1.3 && < 1.4
|
||||||
, persistent-template >= 1.3 && < 1.4
|
, persistent-template >= 1.3 && < 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, hamlet >= 1.1 && < 1.2
|
, shakespeare >= 2.0 && < 2.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
|
||||||
, shakespeare-js >= 1.2 && < 1.3
|
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
|
||||||
, hjsmin >= 0.1 && < 0.2
|
, hjsmin >= 0.1 && < 0.2
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, wai-extra >= 2.1 && < 2.2
|
, wai-extra >= 2.1 && < 2.2
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8 && < 0.9
|
||||||
, http-conduit >= 2.0 && < 2.1
|
, http-conduit >= 2.1 && < 2.2
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1 && < 1.3
|
||||||
, warp >= 2.1 && < 2.2
|
, warp >= 2.1 && < 2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
{-# START_FILE .gitignore #-}
|
{-# START_FILE .gitignore #-}
|
||||||
dist*
|
dist*
|
||||||
static/tmp/
|
static/tmp/
|
||||||
|
static/combined/
|
||||||
config/client_session_key.aes
|
config/client_session_key.aes
|
||||||
*.hi
|
*.hi
|
||||||
*.o
|
*.o
|
||||||
@ -15,6 +16,7 @@ yesod-devel/
|
|||||||
.cabal-sandbox
|
.cabal-sandbox
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.DS_Store
|
.DS_Store
|
||||||
|
*.swp
|
||||||
|
|
||||||
{-# START_FILE Application.hs #-}
|
{-# START_FILE Application.hs #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -32,9 +34,9 @@ import Network.Wai.Middleware.RequestLogger
|
|||||||
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
|
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
|
||||||
)
|
)
|
||||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
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 Control.Concurrent (forkIO, threadDelay)
|
||||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
|
||||||
import Network.Wai.Logger (clockDateCacher)
|
import Network.Wai.Logger (clockDateCacher)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||||
@ -68,13 +70,13 @@ makeApplication conf = do
|
|||||||
-- Create the WAI application and apply middlewares
|
-- Create the WAI application and apply middlewares
|
||||||
app <- toWaiAppPlain foundation
|
app <- toWaiAppPlain foundation
|
||||||
let logFunc = messageLoggerSource foundation (appLogger 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
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||||
-- performs some initialization.
|
-- performs some initialization.
|
||||||
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
||||||
makeFoundation conf = do
|
makeFoundation conf = do
|
||||||
manager <- newManager conduitManagerSettings
|
manager <- newManager
|
||||||
s <- staticSite
|
s <- staticSite
|
||||||
|
|
||||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||||
@ -87,6 +89,7 @@ makeFoundation conf = do
|
|||||||
let updateLoop = do
|
let updateLoop = do
|
||||||
threadDelay 1000000
|
threadDelay 1000000
|
||||||
updater
|
updater
|
||||||
|
flushLogStr loggerSet'
|
||||||
updateLoop
|
updateLoop
|
||||||
_ <- forkIO updateLoop
|
_ <- forkIO updateLoop
|
||||||
|
|
||||||
@ -112,7 +115,7 @@ import Yesod
|
|||||||
import Yesod.Static
|
import Yesod.Static
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
||||||
import qualified Settings
|
import qualified Settings
|
||||||
import Settings.Development (development)
|
import Settings.Development (development)
|
||||||
import Settings.StaticFiles
|
import Settings.StaticFiles
|
||||||
@ -132,6 +135,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance HasHttpManager App where
|
||||||
|
getHttpManager = httpManager
|
||||||
|
|
||||||
-- Set up i18n messages. See the message folder.
|
-- Set up i18n messages. See the message folder.
|
||||||
mkMessage "App" "messages" "en"
|
mkMessage "App" "messages" "en"
|
||||||
|
|
||||||
@ -335,22 +341,19 @@ library
|
|||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5 && < 1.3
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.12 && < 1.3
|
||||||
, yesod-auth >= 1.2 && < 1.3
|
, yesod-auth >= 1.3 && < 1.4
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2 && < 1.3
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9 && < 0.11
|
||||||
, text >= 0.11 && < 2.0
|
, text >= 0.11 && < 2.0
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, hamlet >= 1.1 && < 1.2
|
, shakespeare >= 2.0 && < 2.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
|
||||||
, shakespeare-js >= 1.2 && < 1.3
|
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
|
||||||
, hjsmin >= 0.1 && < 0.2
|
, hjsmin >= 0.1 && < 0.2
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, wai-extra >= 2.1 && < 2.2
|
, wai-extra >= 2.1 && < 2.2
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8 && < 0.9
|
||||||
, http-conduit >= 2.0 && < 2.1
|
, http-conduit >= 2.1 && < 2.2
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1 && < 1.3
|
||||||
, warp >= 2.1 && < 2.2
|
, warp >= 2.1 && < 2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
{-# START_FILE .gitignore #-}
|
{-# START_FILE .gitignore #-}
|
||||||
dist*
|
dist*
|
||||||
static/tmp/
|
static/tmp/
|
||||||
|
static/combined/
|
||||||
config/client_session_key.aes
|
config/client_session_key.aes
|
||||||
*.hi
|
*.hi
|
||||||
*.o
|
*.o
|
||||||
@ -15,6 +16,7 @@ yesod-devel/
|
|||||||
.cabal-sandbox
|
.cabal-sandbox
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.DS_Store
|
.DS_Store
|
||||||
|
*.swp
|
||||||
|
|
||||||
{-# START_FILE Application.hs #-}
|
{-# START_FILE Application.hs #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
@ -36,10 +38,10 @@ import Network.Wai.Middleware.RequestLogger
|
|||||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
import Database.Persist.Sql (runMigration)
|
import Database.Persist.Sql (runMigration)
|
||||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
import Network.HTTP.Client.Conduit (newManager)
|
||||||
import Control.Monad.Logger (runLoggingT)
|
import Control.Monad.Logger (runLoggingT)
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
|
||||||
import Network.Wai.Logger (clockDateCacher)
|
import Network.Wai.Logger (clockDateCacher)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||||
@ -73,13 +75,13 @@ makeApplication conf = do
|
|||||||
-- Create the WAI application and apply middlewares
|
-- Create the WAI application and apply middlewares
|
||||||
app <- toWaiAppPlain foundation
|
app <- toWaiAppPlain foundation
|
||||||
let logFunc = messageLoggerSource foundation (appLogger 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
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||||
-- performs some initialization.
|
-- performs some initialization.
|
||||||
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
|
||||||
makeFoundation conf = do
|
makeFoundation conf = do
|
||||||
manager <- newManager conduitManagerSettings
|
manager <- newManager
|
||||||
s <- staticSite
|
s <- staticSite
|
||||||
dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
|
dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
|
||||||
Database.Persist.loadConfig >>=
|
Database.Persist.loadConfig >>=
|
||||||
@ -96,6 +98,7 @@ makeFoundation conf = do
|
|||||||
let updateLoop = do
|
let updateLoop = do
|
||||||
threadDelay 1000000
|
threadDelay 1000000
|
||||||
updater
|
updater
|
||||||
|
flushLogStr loggerSet'
|
||||||
updateLoop
|
updateLoop
|
||||||
_ <- forkIO updateLoop
|
_ <- forkIO updateLoop
|
||||||
|
|
||||||
@ -129,7 +132,7 @@ import Yesod.Auth.BrowserId
|
|||||||
import Yesod.Auth.GoogleEmail
|
import Yesod.Auth.GoogleEmail
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
||||||
import qualified Settings
|
import qualified Settings
|
||||||
import Settings.Development (development)
|
import Settings.Development (development)
|
||||||
import qualified Database.Persist
|
import qualified Database.Persist
|
||||||
@ -154,6 +157,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance HasHttpManager App where
|
||||||
|
getHttpManager = httpManager
|
||||||
|
|
||||||
-- Set up i18n messages. See the message folder.
|
-- Set up i18n messages. See the message folder.
|
||||||
mkMessage "App" "messages" "en"
|
mkMessage "App" "messages" "en"
|
||||||
|
|
||||||
@ -408,8 +414,8 @@ library
|
|||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5 && < 1.3
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.12 && < 1.3
|
||||||
, yesod-auth >= 1.2 && < 1.3
|
, yesod-auth >= 1.3 && < 1.4
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2 && < 1.3
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3 && < 1.4
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9 && < 0.11
|
||||||
@ -418,15 +424,12 @@ library
|
|||||||
, persistent-sqlite >= 1.3 && < 1.4
|
, persistent-sqlite >= 1.3 && < 1.4
|
||||||
, persistent-template >= 1.3 && < 1.4
|
, persistent-template >= 1.3 && < 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, hamlet >= 1.1 && < 1.2
|
, shakespeare >= 2.0 && < 2.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
|
||||||
, shakespeare-js >= 1.2 && < 1.3
|
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
|
||||||
, hjsmin >= 0.1 && < 0.2
|
, hjsmin >= 0.1 && < 0.2
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, wai-extra >= 2.1 && < 2.2
|
, wai-extra >= 2.1 && < 2.2
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8 && < 0.9
|
||||||
, http-conduit >= 2.0 && < 2.1
|
, http-conduit >= 2.1 && < 2.2
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1 && < 1.3
|
||||||
, warp >= 2.1 && < 2.2
|
, warp >= 2.1 && < 2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-bin
|
name: yesod-bin
|
||||||
version: 1.2.7.3
|
version: 1.2.8.1
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -47,14 +47,15 @@ executable yesod
|
|||||||
cpp-options: -DWINDOWS
|
cpp-options: -DWINDOWS
|
||||||
|
|
||||||
build-depends: base >= 4.3 && < 5
|
build-depends: base >= 4.3 && < 5
|
||||||
, ghc >= 7.0.3 && < 7.8
|
, ghc >= 7.0.3
|
||||||
, ghc-paths >= 0.1
|
, ghc-paths >= 0.1
|
||||||
, parsec >= 2.1 && < 4
|
, parsec >= 2.1 && < 4
|
||||||
, text >= 0.11
|
, text >= 0.11
|
||||||
, shakespeare-text >= 1.0 && < 1.1
|
, shakespeare
|
||||||
, shakespeare >= 1.0.2 && < 1.3
|
, shakespeare-text >= 1.0
|
||||||
, shakespeare-js >= 1.0.2 && < 1.3
|
, shakespeare >= 1.0.2 && < 2.1
|
||||||
, shakespeare-css >= 1.0.2 && < 1.1
|
, shakespeare-js >= 1.0.2
|
||||||
|
, shakespeare-css >= 1.0.2
|
||||||
, bytestring >= 0.9.1.4
|
, bytestring >= 0.9.1.4
|
||||||
, time >= 1.1.4
|
, time >= 1.1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
@ -77,8 +78,9 @@ executable yesod
|
|||||||
, fsnotify >= 0.0 && < 0.1
|
, fsnotify >= 0.0 && < 0.1
|
||||||
, split >= 0.2 && < 0.3
|
, split >= 0.2 && < 0.3
|
||||||
, file-embed
|
, file-embed
|
||||||
, conduit >= 0.5 && < 1.1
|
, conduit >= 0.5 && < 1.2
|
||||||
, resourcet >= 0.3 && < 0.5
|
, conduit-extra
|
||||||
|
, resourcet >= 0.3 && < 1.2
|
||||||
, base64-bytestring
|
, base64-bytestring
|
||||||
, lifted-base
|
, lifted-base
|
||||||
, http-reverse-proxy >= 0.1.1
|
, http-reverse-proxy >= 0.1.1
|
||||||
@ -90,6 +92,7 @@ executable yesod
|
|||||||
, warp >= 1.3.7.5
|
, warp >= 1.3.7.5
|
||||||
, wai >= 1.4
|
, wai >= 1.4
|
||||||
, data-default-class
|
, data-default-class
|
||||||
|
, streaming-commons
|
||||||
|
|
||||||
ghc-options: -Wall -threaded
|
ghc-options: -Wall -threaded
|
||||||
main-is: main.hs
|
main-is: main.hs
|
||||||
|
|||||||
@ -24,6 +24,8 @@ module Yesod.Core
|
|||||||
, widgetToPageContent
|
, widgetToPageContent
|
||||||
-- * Defaults
|
-- * Defaults
|
||||||
, defaultErrorHandler
|
, defaultErrorHandler
|
||||||
|
, defaultYesodMiddleware
|
||||||
|
, authorizationCheck
|
||||||
-- * Data types
|
-- * Data types
|
||||||
, AuthResult (..)
|
, AuthResult (..)
|
||||||
, unauthorizedI
|
, unauthorizedI
|
||||||
|
|||||||
@ -61,7 +61,9 @@ GOX(Monoid w, RWST r w s)
|
|||||||
GOX(Monoid w, Strict.RWST r w s)
|
GOX(Monoid w, Strict.RWST r w s)
|
||||||
GO(Strict.StateT s)
|
GO(Strict.StateT s)
|
||||||
GOX(Monoid w, Strict.WriterT w)
|
GOX(Monoid w, Strict.WriterT w)
|
||||||
|
#if !MIN_VERSION_resourcet(1,1,0)
|
||||||
GO(ExceptionT)
|
GO(ExceptionT)
|
||||||
|
#endif
|
||||||
GO(Pipe l i o u)
|
GO(Pipe l i o u)
|
||||||
GO(ConduitM i o)
|
GO(ConduitM i o)
|
||||||
#undef GO
|
#undef GO
|
||||||
@ -85,7 +87,9 @@ GOX(Monoid w, RWST r w s)
|
|||||||
GOX(Monoid w, Strict.RWST r w s)
|
GOX(Monoid w, Strict.RWST r w s)
|
||||||
GO(Strict.StateT s)
|
GO(Strict.StateT s)
|
||||||
GOX(Monoid w, Strict.WriterT w)
|
GOX(Monoid w, Strict.WriterT w)
|
||||||
|
#if !MIN_VERSION_resourcet(1,1,0)
|
||||||
GO(ExceptionT)
|
GO(ExceptionT)
|
||||||
|
#endif
|
||||||
GO(Pipe l i o u)
|
GO(Pipe l i o u)
|
||||||
GO(ConduitM i o)
|
GO(ConduitM i o)
|
||||||
#undef GO
|
#undef GO
|
||||||
|
|||||||
@ -60,7 +60,8 @@ import Data.Monoid (mempty)
|
|||||||
|
|
||||||
import Text.Hamlet (Html)
|
import Text.Hamlet (Html)
|
||||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
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 Data.Conduit.Internal (ResumableSource (ResumableSource))
|
||||||
|
|
||||||
import qualified Data.Aeson as J
|
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 qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
|
||||||
import Data.Text.Lazy.Builder (toLazyText)
|
import Data.Text.Lazy.Builder (toLazyText)
|
||||||
import Yesod.Core.Types
|
import Yesod.Core.Types
|
||||||
|
import Text.Lucius (Css, renderCss)
|
||||||
|
import Text.Julius (Javascript, unJavascript)
|
||||||
|
|
||||||
-- | Zero-length enumerator.
|
-- | Zero-length enumerator.
|
||||||
emptyContent :: Content
|
emptyContent :: Content
|
||||||
@ -107,6 +110,11 @@ instance ToContent (ContentType, Content) where
|
|||||||
instance ToContent TypedContent where
|
instance ToContent TypedContent where
|
||||||
toContent (TypedContent _ c) = c
|
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
|
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
|
||||||
toContent src = ContentSource $ mapOutput toFlushBuilder src
|
toContent src = ContentSource $ mapOutput toFlushBuilder src
|
||||||
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
|
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
|
||||||
@ -244,6 +252,12 @@ instance HasContentType Text where
|
|||||||
instance HasContentType T.Text where
|
instance HasContentType T.Text where
|
||||||
getContentType _ = typePlain
|
getContentType _ = typePlain
|
||||||
|
|
||||||
|
instance HasContentType Css where
|
||||||
|
getContentType _ = typeCss
|
||||||
|
|
||||||
|
instance HasContentType Javascript where
|
||||||
|
getContentType _ = typeJavascript
|
||||||
|
|
||||||
-- | Any type which can be converted to 'TypedContent'.
|
-- | Any type which can be converted to 'TypedContent'.
|
||||||
--
|
--
|
||||||
-- Since 1.2.0
|
-- Since 1.2.0
|
||||||
@ -276,3 +290,8 @@ instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
|
|||||||
toTypedContent (DontFullyEvaluate a) =
|
toTypedContent (DontFullyEvaluate a) =
|
||||||
let TypedContent ct c = toTypedContent a
|
let TypedContent ct c = toTypedContent a
|
||||||
in TypedContent ct (ContentDontEvaluate c)
|
in TypedContent ct (ContentDontEvaluate c)
|
||||||
|
|
||||||
|
instance ToTypedContent Css where
|
||||||
|
toTypedContent = TypedContent typeCss . toContent
|
||||||
|
instance ToTypedContent Javascript where
|
||||||
|
toTypedContent = TypedContent typeJavascript . toContent
|
||||||
|
|||||||
@ -27,6 +27,7 @@ module Yesod.Core.Dispatch
|
|||||||
, warpDebug
|
, warpDebug
|
||||||
, warpEnv
|
, warpEnv
|
||||||
, mkDefaultMiddlewares
|
, mkDefaultMiddlewares
|
||||||
|
, defaultMiddlewaresNoLogging
|
||||||
-- * WAI subsites
|
-- * WAI subsites
|
||||||
, WaiSubsite (..)
|
, WaiSubsite (..)
|
||||||
) where
|
) where
|
||||||
@ -64,6 +65,7 @@ import Network.Wai.Middleware.MethodOverride
|
|||||||
import qualified Network.Wai.Handler.Warp
|
import qualified Network.Wai.Handler.Warp
|
||||||
import System.Log.FastLogger
|
import System.Log.FastLogger
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
|
import Control.Monad (when)
|
||||||
import qualified Paths_yesod_core
|
import qualified Paths_yesod_core
|
||||||
import Data.Version (showVersion)
|
import Data.Version (showVersion)
|
||||||
|
|
||||||
@ -163,6 +165,7 @@ warp port site = do
|
|||||||
]
|
]
|
||||||
-}
|
-}
|
||||||
, Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
|
, Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
|
||||||
|
when (shouldLog' e) $
|
||||||
messageLoggerSource
|
messageLoggerSource
|
||||||
site
|
site
|
||||||
logger
|
logger
|
||||||
@ -171,6 +174,13 @@ warp port site = do
|
|||||||
LevelError
|
LevelError
|
||||||
(toLogStr $ "Exception from Warp: " ++ show e)
|
(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.
|
-- | A default set of middlewares.
|
||||||
--
|
--
|
||||||
@ -185,11 +195,13 @@ mkDefaultMiddlewares logger = do
|
|||||||
#endif
|
#endif
|
||||||
, outputFormat = Apache FromSocket
|
, outputFormat = Apache FromSocket
|
||||||
}
|
}
|
||||||
return $ logWare
|
return $ logWare . defaultMiddlewaresNoLogging
|
||||||
. acceptOverride
|
|
||||||
. autohead
|
-- | All of the default middlewares, excluding logging.
|
||||||
. gzip def
|
--
|
||||||
. methodOverride
|
-- Since 1.2.12
|
||||||
|
defaultMiddlewaresNoLogging :: W.Middleware
|
||||||
|
defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride
|
||||||
|
|
||||||
-- | Deprecated synonym for 'warp'.
|
-- | Deprecated synonym for 'warp'.
|
||||||
warpDebug :: YesodDispatch site => Int -> site -> IO ()
|
warpDebug :: YesodDispatch site => Int -> site -> IO ()
|
||||||
|
|||||||
@ -194,7 +194,7 @@ import Web.PathPieces (PathPiece(..))
|
|||||||
import Yesod.Core.Class.Handler
|
import Yesod.Core.Class.Handler
|
||||||
import Yesod.Core.Types
|
import Yesod.Core.Types
|
||||||
import Yesod.Routes.Class (Route)
|
import Yesod.Routes.Class (Route)
|
||||||
import Control.Failure (failure)
|
import Control.Exception (throwIO)
|
||||||
import Blaze.ByteString.Builder (Builder)
|
import Blaze.ByteString.Builder (Builder)
|
||||||
import Safe (headMay)
|
import Safe (headMay)
|
||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
@ -229,7 +229,7 @@ tell :: MonadHandler m => Endo [Header] -> m ()
|
|||||||
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
|
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
|
||||||
|
|
||||||
handlerError :: MonadHandler m => HandlerContents -> m a
|
handlerError :: MonadHandler m => HandlerContents -> m a
|
||||||
handlerError = liftHandlerT . failure
|
handlerError = liftIO . throwIO
|
||||||
|
|
||||||
hcError :: MonadHandler m => ErrorResponse -> m a
|
hcError :: MonadHandler m => ErrorResponse -> m a
|
||||||
hcError = handlerError . HCError
|
hcError = handlerError . HCError
|
||||||
|
|||||||
@ -40,6 +40,7 @@ import Data.Conduit.List (sourceList)
|
|||||||
import Data.Conduit.Binary (sourceFile, sinkFile)
|
import Data.Conduit.Binary (sourceFile, sinkFile)
|
||||||
import Data.Word (Word64)
|
import Data.Word (Word64)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
|
||||||
import Control.Exception (throwIO)
|
import Control.Exception (throwIO)
|
||||||
import Yesod.Core.Types
|
import Yesod.Core.Types
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|||||||
@ -13,6 +13,7 @@ import Control.Applicative ((<$>))
|
|||||||
import Control.Exception (fromException, bracketOnError, evaluate)
|
import Control.Exception (fromException, bracketOnError, evaluate)
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import Control.Exception.Lifted (catch)
|
import Control.Exception.Lifted (catch)
|
||||||
|
import Control.Monad (mplus)
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
|
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
|
||||||
@ -48,6 +49,19 @@ import Yesod.Core.Types
|
|||||||
import Yesod.Core.Internal.Request (parseWaiRequest,
|
import Yesod.Core.Internal.Request (parseWaiRequest,
|
||||||
tooLargeResponse)
|
tooLargeResponse)
|
||||||
import Yesod.Routes.Class (Route, renderRoute)
|
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
|
-- | Function used internally by Yesod in the process of converting a
|
||||||
-- 'HandlerT' into an 'Application'. Should not be needed by users.
|
-- '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
|
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
||||||
$ fromException e)
|
$ fromException e)
|
||||||
state <- liftIO $ I.readIORef istate
|
state <- liftIO $ I.readIORef istate
|
||||||
let finalSession = ghsSession state
|
|
||||||
let headers = ghsHeaders state
|
(finalSession, mcontents1) <- (do
|
||||||
let contents = either id (HCContent defaultStatus . toTypedContent) contents'
|
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
|
let handleError e = flip runInternalState resState $ do
|
||||||
yar <- rheOnError e yreq
|
yar <- rheOnError e yreq
|
||||||
{ reqSession = finalSession
|
{ reqSession = finalSession
|
||||||
}
|
}
|
||||||
case yar of
|
case yar of
|
||||||
YRPlain status' hs ct c sess ->
|
YRPlain status' hs ct c sess ->
|
||||||
let hs' = appEndo headers hs
|
let hs' = headers ++ hs
|
||||||
status
|
status
|
||||||
| status' == defaultStatus = getStatus e
|
| status' == defaultStatus = getStatus e
|
||||||
| otherwise = status'
|
| otherwise = status'
|
||||||
in return $ YRPlain status hs' ct c sess
|
in return $ YRPlain status hs' ct c sess
|
||||||
YRWai _ -> return yar
|
YRWai _ -> return yar
|
||||||
let sendFile' ct fp p =
|
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
|
contents1 <- evaluate contents `E.catch` \e -> return
|
||||||
(HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
|
(HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
|
||||||
case contents1 of
|
case contents1 of
|
||||||
@ -102,7 +128,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
|
|||||||
ec' <- liftIO $ evaluateContent c
|
ec' <- liftIO $ evaluateContent c
|
||||||
case ec' of
|
case ec' of
|
||||||
Left e -> handleError e
|
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
|
HCError e -> handleError e
|
||||||
HCRedirect status loc -> do
|
HCRedirect status loc -> do
|
||||||
let disable_caching x =
|
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"
|
: Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
|
||||||
: x
|
: x
|
||||||
hs = (if status /= H.movedPermanently301 then disable_caching else id)
|
hs = (if status /= H.movedPermanently301 then disable_caching else id)
|
||||||
$ Header "Location" (encodeUtf8 loc) : appEndo headers []
|
$ Header "Location" (encodeUtf8 loc) : headers
|
||||||
return $ YRPlain
|
return $ YRPlain
|
||||||
status hs typePlain emptyContent
|
status hs typePlain emptyContent
|
||||||
finalSession
|
finalSession
|
||||||
@ -118,7 +144,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
|
|||||||
(sendFile' ct fp p)
|
(sendFile' ct fp p)
|
||||||
(handleError . toErrorHandler)
|
(handleError . toErrorHandler)
|
||||||
HCCreated loc -> do
|
HCCreated loc -> do
|
||||||
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
|
let hs = Header "Location" (encodeUtf8 loc) : headers
|
||||||
return $ YRPlain
|
return $ YRPlain
|
||||||
H.status201
|
H.status201
|
||||||
hs
|
hs
|
||||||
|
|||||||
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
|
{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Yesod.Core.Json
|
module Yesod.Core.Json
|
||||||
( -- * Convert from a JSON value
|
( -- * 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 Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
|
||||||
import Control.Monad.Trans.Writer (Writer)
|
import Control.Monad.Trans.Writer (Writer)
|
||||||
|
import Control.Monad.Trans.Resource (runExceptionT)
|
||||||
import Data.Monoid (Endo)
|
import Data.Monoid (Endo)
|
||||||
import Yesod.Core.Content (TypedContent)
|
import Yesod.Core.Content (TypedContent)
|
||||||
import Yesod.Core.Types (reqAccept)
|
import Yesod.Core.Types (reqAccept)
|
||||||
@ -42,6 +44,7 @@ import Data.Conduit.Attoparsec (sinkParser)
|
|||||||
import Data.Text (pack)
|
import Data.Text (pack)
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
|
import Data.Conduit.Lift
|
||||||
import qualified Data.ByteString.Char8 as B8
|
import qualified Data.ByteString.Char8 as B8
|
||||||
import Data.Maybe (listToMaybe)
|
import Data.Maybe (listToMaybe)
|
||||||
import Control.Monad (liftM)
|
import Control.Monad (liftM)
|
||||||
@ -92,7 +95,11 @@ provideJson = provideRep . return . J.toJSON
|
|||||||
-- /Since: 0.3.0/
|
-- /Since: 0.3.0/
|
||||||
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
|
||||||
parseJsonBody = do
|
parseJsonBody = do
|
||||||
|
#if MIN_VERSION_resourcet(1,1,0)
|
||||||
|
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
|
||||||
|
#else
|
||||||
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
|
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
|
||||||
|
#endif
|
||||||
return $ case eValue of
|
return $ case eValue of
|
||||||
Left e -> J.Error $ show e
|
Left e -> J.Error $ show e
|
||||||
Right value -> J.fromJSON value
|
Right value -> J.fromJSON value
|
||||||
|
|||||||
@ -16,16 +16,18 @@ import Control.Arrow (first)
|
|||||||
import Control.Exception (Exception)
|
import Control.Exception (Exception)
|
||||||
import Control.Monad (liftM, ap)
|
import Control.Monad (liftM, ap)
|
||||||
import Control.Monad.Base (MonadBase (liftBase))
|
import Control.Monad.Base (MonadBase (liftBase))
|
||||||
|
import Control.Monad.Catch (MonadCatch (..))
|
||||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||||
import Control.Monad.Logger (LogLevel, LogSource,
|
import Control.Monad.Logger (LogLevel, LogSource,
|
||||||
MonadLogger (..))
|
MonadLogger (..))
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
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 Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import Data.Conduit (Flush, MonadThrow (..),
|
import Data.Conduit (Flush, Source)
|
||||||
MonadUnsafeIO (..),
|
|
||||||
ResourceT, Source)
|
|
||||||
import Data.Dynamic (Dynamic)
|
import Data.Dynamic (Dynamic)
|
||||||
import Data.IORef (IORef)
|
import Data.IORef (IORef)
|
||||||
import Data.Map (Map, unionWith)
|
import Data.Map (Map, unionWith)
|
||||||
@ -60,6 +62,9 @@ import Web.Cookie (SetCookie)
|
|||||||
import Yesod.Core.Internal.Util (getTime, putTime)
|
import Yesod.Core.Internal.Util (getTime, putTime)
|
||||||
import Control.Monad.Trans.Class (MonadTrans (..))
|
import Control.Monad.Trans.Class (MonadTrans (..))
|
||||||
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
|
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
|
||||||
|
import Control.Monad.Reader (MonadReader (..))
|
||||||
|
import Prelude hiding (catch)
|
||||||
|
import Control.DeepSeq (NFData (rnf))
|
||||||
|
|
||||||
-- Sessions
|
-- Sessions
|
||||||
type SessionMap = Map Text ByteString
|
type SessionMap = Map Text ByteString
|
||||||
@ -308,6 +313,14 @@ data Header =
|
|||||||
| Header ByteString ByteString
|
| Header ByteString ByteString
|
||||||
deriving (Eq, Show)
|
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
|
data Location url = Local url | Remote Text
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
@ -385,17 +398,48 @@ instance MonadBase b m => MonadBase b (WidgetT site m) where
|
|||||||
liftBase = WidgetT . const . liftBase . fmap (, mempty)
|
liftBase = WidgetT . const . liftBase . fmap (, mempty)
|
||||||
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
|
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
|
||||||
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
|
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
|
||||||
liftBaseWith f = WidgetT $ \reader ->
|
liftBaseWith f = WidgetT $ \reader' ->
|
||||||
liftBaseWith $ \runInBase ->
|
liftBaseWith $ \runInBase ->
|
||||||
liftM (\x -> (x, mempty))
|
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
|
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
|
instance MonadTrans (WidgetT site) where
|
||||||
lift = WidgetT . const . liftM (, mempty)
|
lift = WidgetT . const . liftM (, mempty)
|
||||||
instance MonadThrow m => MonadThrow (WidgetT site m) where
|
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
|
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
|
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)
|
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
|
||||||
|
|
||||||
instance MonadIO m => MonadLogger (WidgetT site m) where
|
instance MonadIO m => MonadLogger (WidgetT site m) where
|
||||||
@ -418,6 +462,13 @@ instance MonadIO m => MonadIO (HandlerT site m) where
|
|||||||
liftIO = lift . liftIO
|
liftIO = lift . liftIO
|
||||||
instance MonadBase b m => MonadBase b (HandlerT site m) where
|
instance MonadBase b m => MonadBase b (HandlerT site m) where
|
||||||
liftBase = lift . liftBase
|
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
|
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
|
||||||
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
|
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
|
||||||
-- Instead, if you must fork a separate thread, you should use
|
-- 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.\"
|
-- after cleanup. Please contact the maintainers.\"
|
||||||
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
|
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
|
||||||
data StM (HandlerT site m) a = StH (StM m a)
|
data StM (HandlerT site m) a = StH (StM m a)
|
||||||
liftBaseWith f = HandlerT $ \reader ->
|
liftBaseWith f = HandlerT $ \reader' ->
|
||||||
liftBaseWith $ \runInBase ->
|
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
|
restoreM (StH base) = HandlerT $ const $ restoreM base
|
||||||
|
|
||||||
instance MonadThrow m => MonadThrow (HandlerT site m) where
|
instance MonadThrow m => MonadThrow (HandlerT site m) where
|
||||||
|
#if MIN_VERSION_resourcet(1,1,0)
|
||||||
|
throwM = lift . monadThrow
|
||||||
|
#else
|
||||||
monadThrow = lift . monadThrow
|
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
|
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
|
||||||
|
#endif
|
||||||
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
|
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
|
||||||
|
|
||||||
instance MonadIO m => MonadLogger (HandlerT site m) where
|
instance MonadIO m => MonadLogger (HandlerT site m) where
|
||||||
|
|||||||
@ -15,6 +15,9 @@ import Control.Exception (SomeException, try)
|
|||||||
import Network.HTTP.Types (mkStatus)
|
import Network.HTTP.Types (mkStatus)
|
||||||
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
|
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
|
||||||
import Data.Monoid (mconcat)
|
import Data.Monoid (mconcat)
|
||||||
|
import Data.Text (Text, pack)
|
||||||
|
import Control.Monad (forM_)
|
||||||
|
import qualified Control.Exception.Lifted as E
|
||||||
|
|
||||||
data App = App
|
data App = App
|
||||||
|
|
||||||
@ -26,6 +29,7 @@ mkYesod "App" [parseRoutes|
|
|||||||
/error-in-body ErrorInBodyR GET
|
/error-in-body ErrorInBodyR GET
|
||||||
/error-in-body-noeval ErrorInBodyNoEvalR GET
|
/error-in-body-noeval ErrorInBodyNoEvalR GET
|
||||||
/override-status OverrideStatusR GET
|
/override-status OverrideStatusR GET
|
||||||
|
/error/#Int ErrorR GET
|
||||||
|
|
||||||
-- https://github.com/yesodweb/yesod/issues/658
|
-- https://github.com/yesodweb/yesod/issues/658
|
||||||
/builder BuilderR GET
|
/builder BuilderR GET
|
||||||
@ -98,6 +102,18 @@ goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"
|
|||||||
getGoodBuilderR :: Handler TypedContent
|
getGoodBuilderR :: Handler TypedContent
|
||||||
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
|
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 :: Spec
|
||||||
errorHandlingTest = describe "Test.ErrorHandling" $ do
|
errorHandlingTest = describe "Test.ErrorHandling" $ do
|
||||||
it "says not found" caseNotFound
|
it "says not found" caseNotFound
|
||||||
@ -110,6 +126,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
|
|||||||
it "file with bad len" caseFileBadLen
|
it "file with bad len" caseFileBadLen
|
||||||
it "file with bad name" caseFileBadName
|
it "file with bad name" caseFileBadName
|
||||||
it "builder includes content-length" caseGoodBuilder
|
it "builder includes content-length" caseGoodBuilder
|
||||||
|
forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
|
||||||
|
|
||||||
runner :: Session () -> IO ()
|
runner :: Session () -> IO ()
|
||||||
runner f = toWaiApp App >>= runSession f
|
runner f = toWaiApp App >>= runSession f
|
||||||
@ -194,3 +211,10 @@ caseGoodBuilder = runner $ do
|
|||||||
let lbs = toLazyByteString goodBuilderContent
|
let lbs = toLazyByteString goodBuilderContent
|
||||||
assertBody lbs res
|
assertBody lbs res
|
||||||
assertHeader "content-length" (S8.pack $ show $ L.length 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)
|
||||||
|
|||||||
@ -19,6 +19,7 @@ import Control.Concurrent (threadDelay)
|
|||||||
import Control.Concurrent.Async (withAsync)
|
import Control.Concurrent.Async (withAsync)
|
||||||
import Control.Monad.Trans.Resource (register)
|
import Control.Monad.Trans.Resource (register)
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
import Data.Streaming.Network (bindPortTCP)
|
||||||
|
|
||||||
data App = App
|
data App = App
|
||||||
|
|
||||||
@ -42,7 +43,7 @@ getFreePort = do
|
|||||||
loop 43124
|
loop 43124
|
||||||
where
|
where
|
||||||
loop port = do
|
loop port = do
|
||||||
esocket <- try $ bindPort port "*"
|
esocket <- try $ bindPortTCP port "*"
|
||||||
case esocket of
|
case esocket of
|
||||||
Left (_ :: IOException) -> loop (succ port)
|
Left (_ :: IOException) -> loop (succ port)
|
||||||
Right socket -> do
|
Right socket -> do
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-core
|
name: yesod-core
|
||||||
version: 1.2.9
|
version: 1.2.14
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -32,22 +32,22 @@ library
|
|||||||
, text >= 0.7
|
, text >= 0.7
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, path-pieces >= 0.1.2 && < 0.2
|
, path-pieces >= 0.1.2 && < 0.2
|
||||||
, hamlet >= 1.1 && < 1.2
|
, hamlet >= 1.1
|
||||||
, shakespeare >= 1.0 && < 1.3
|
, shakespeare >= 1.0 && < 2.1
|
||||||
, shakespeare-js >= 1.0.2 && < 1.3
|
, shakespeare-js >= 1.0.2
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
, shakespeare-css >= 1.0
|
||||||
, shakespeare-i18n >= 1.0 && < 1.1
|
, shakespeare-i18n >= 1.0
|
||||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||||
, transformers >= 0.2.2 && < 0.4
|
, transformers >= 0.2.2 && < 0.4
|
||||||
|
, mtl
|
||||||
, clientsession >= 0.9 && < 0.10
|
, clientsession >= 0.9 && < 0.10
|
||||||
, random >= 1.0.0.2 && < 1.1
|
, random >= 1.0.0.2 && < 1.1
|
||||||
, cereal >= 0.3
|
, cereal >= 0.3
|
||||||
, old-locale >= 1.0.0.2 && < 1.1
|
, old-locale >= 1.0.0.2 && < 1.1
|
||||||
, failure >= 0.2 && < 0.3
|
|
||||||
, containers >= 0.2
|
, containers >= 0.2
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3 && < 0.4
|
||||||
, transformers-base >= 0.4
|
, transformers-base >= 0.4
|
||||||
, cookie >= 0.4 && < 0.5
|
, cookie >= 0.4.1 && < 0.5
|
||||||
, http-types >= 0.7
|
, http-types >= 0.7
|
||||||
, case-insensitive >= 0.2
|
, case-insensitive >= 0.2
|
||||||
, parsec >= 2 && < 3.2
|
, parsec >= 2 && < 3.2
|
||||||
@ -58,7 +58,7 @@ library
|
|||||||
, wai-logger >= 0.2
|
, wai-logger >= 0.2
|
||||||
, monad-logger >= 0.3.1 && < 0.4
|
, monad-logger >= 0.3.1 && < 0.4
|
||||||
, conduit >= 0.5
|
, conduit >= 0.5
|
||||||
, resourcet >= 0.4.9 && < 0.5
|
, resourcet >= 0.4.9 && < 1.2
|
||||||
, lifted-base >= 0.1.2
|
, lifted-base >= 0.1.2
|
||||||
, attoparsec-conduit
|
, attoparsec-conduit
|
||||||
, blaze-html >= 0.5
|
, blaze-html >= 0.5
|
||||||
@ -67,6 +67,9 @@ library
|
|||||||
, safe
|
, safe
|
||||||
, warp >= 1.3.8
|
, warp >= 1.3.8
|
||||||
, unix-compat
|
, unix-compat
|
||||||
|
, conduit-extra
|
||||||
|
, exceptions
|
||||||
|
, deepseq
|
||||||
|
|
||||||
exposed-modules: Yesod.Core
|
exposed-modules: Yesod.Core
|
||||||
Yesod.Core.Content
|
Yesod.Core.Content
|
||||||
@ -125,6 +128,9 @@ test-suite tests
|
|||||||
, network-conduit
|
, network-conduit
|
||||||
, network
|
, network
|
||||||
, async
|
, async
|
||||||
|
, conduit-extra
|
||||||
|
, shakespeare
|
||||||
|
, streaming-commons
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
extensions: TemplateHaskell
|
extensions: TemplateHaskell
|
||||||
|
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-eventsource
|
name: yesod-eventsource
|
||||||
version: 1.1.0.1
|
version: 1.1.0.2
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Felipe Lessa <felipe.lessa@gmail.com>
|
author: Felipe Lessa <felipe.lessa@gmail.com>
|
||||||
@ -29,7 +29,7 @@ description:
|
|||||||
library
|
library
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod-core == 1.2.*
|
, yesod-core == 1.2.*
|
||||||
, conduit >= 0.5 && < 1.1
|
, conduit >= 0.5 && < 1.2
|
||||||
, wai >= 1.3
|
, wai >= 1.3
|
||||||
, wai-eventsource >= 1.3
|
, wai-eventsource >= 1.3
|
||||||
, blaze-builder
|
, blaze-builder
|
||||||
|
|||||||
@ -88,7 +88,7 @@ import Data.Text as T (Text, concat, intercalate, unpack, pack, splitOn)
|
|||||||
import qualified Data.Text.Read
|
import qualified Data.Text.Read
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
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.Arrow ((&&&))
|
||||||
|
|
||||||
import Control.Applicative ((<$>), (<|>))
|
import Control.Applicative ((<$>), (<|>))
|
||||||
@ -565,9 +565,9 @@ optionsPersist :: ( YesodPersist site, PersistEntity a
|
|||||||
)
|
)
|
||||||
#else
|
#else
|
||||||
optionsPersist :: ( YesodPersist site, PersistEntity a
|
optionsPersist :: ( YesodPersist site, PersistEntity a
|
||||||
, PersistQuery (YesodDB site)
|
, PersistQuery (YesodPersistBackend site (HandlerT site IO))
|
||||||
, PathPiece (Key a)
|
, PathPiece (Key a)
|
||||||
, PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)
|
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))
|
||||||
, RenderMessage site msg
|
, RenderMessage site msg
|
||||||
)
|
)
|
||||||
#endif
|
#endif
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-form
|
name: yesod-form
|
||||||
version: 1.3.8
|
version: 1.3.8.2
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -17,10 +17,11 @@ library
|
|||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2 && < 1.3
|
||||||
, yesod-persistent >= 1.2 && < 1.3
|
, yesod-persistent >= 1.2 && < 1.3
|
||||||
, time >= 1.1.4
|
, time >= 1.1.4
|
||||||
, hamlet >= 1.1 && < 1.2
|
, hamlet >= 1.1
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
, shakespeare
|
||||||
, shakespeare-js >= 1.0.2 && < 1.3
|
, shakespeare-css >= 1.0
|
||||||
, persistent >= 1.2 && < 2.1
|
, shakespeare-js >= 1.0.2
|
||||||
|
, persistent >= 1.2 && < 1.4
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, transformers >= 0.2.2
|
, transformers >= 0.2.2
|
||||||
, data-default
|
, data-default
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-newsfeed
|
name: yesod-newsfeed
|
||||||
version: 1.2.0.1
|
version: 1.2.0.2
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman, Patrick Brisbin
|
author: Michael Snoyman, Patrick Brisbin
|
||||||
@ -16,7 +16,8 @@ library
|
|||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2 && < 1.3
|
||||||
, time >= 1.1.4
|
, time >= 1.1.4
|
||||||
, hamlet >= 1.1 && < 1.2
|
, hamlet >= 1.1
|
||||||
|
, shakespeare
|
||||||
, bytestring >= 0.9.1.4
|
, bytestring >= 0.9.1.4
|
||||||
, text >= 0.9
|
, text >= 0.9
|
||||||
, xml-conduit >= 1.0
|
, xml-conduit >= 1.0
|
||||||
|
|||||||
@ -88,7 +88,7 @@ class YesodPersist site => YesodPersistRunner site where
|
|||||||
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
|
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||||
|
|
||||||
newtype DBRunner site = DBRunner
|
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'.
|
-- | Helper for implementing 'getDBRunner'.
|
||||||
@ -127,7 +127,7 @@ defaultGetDBRunner getPool = do
|
|||||||
--
|
--
|
||||||
-- Since 1.2.0
|
-- Since 1.2.0
|
||||||
runDBSource :: YesodPersistRunner site
|
runDBSource :: YesodPersistRunner site
|
||||||
=> Source (YesodDB site) a
|
=> Source (YesodPersistBackend site (HandlerT site IO)) a
|
||||||
-> Source (HandlerT site IO) a
|
-> Source (HandlerT site IO) a
|
||||||
runDBSource src = do
|
runDBSource src = do
|
||||||
(dbrunner, cleanup) <- lift getDBRunner
|
(dbrunner, cleanup) <- lift getDBRunner
|
||||||
@ -137,7 +137,7 @@ runDBSource src = do
|
|||||||
-- | Extends 'respondSource' to create a streaming database response body.
|
-- | Extends 'respondSource' to create a streaming database response body.
|
||||||
respondSourceDB :: YesodPersistRunner site
|
respondSourceDB :: YesodPersistRunner site
|
||||||
=> ContentType
|
=> ContentType
|
||||||
-> Source (YesodDB site) (Flush Builder)
|
-> Source (YesodPersistBackend site (HandlerT site IO)) (Flush Builder)
|
||||||
-> HandlerT site IO TypedContent
|
-> HandlerT site IO TypedContent
|
||||||
respondSourceDB ctype = respondSource ctype . runDBSource
|
respondSourceDB ctype = respondSource ctype . runDBSource
|
||||||
|
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-persistent
|
name: yesod-persistent
|
||||||
version: 1.2.2.2
|
version: 1.2.2.3
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
|
|||||||
@ -7,4 +7,16 @@ then
|
|||||||
cabal install cabal-nirvana -fgenerate
|
cabal install cabal-nirvana -fgenerate
|
||||||
fi
|
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
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-platform
|
name: yesod-platform
|
||||||
version: 1.2.8.2
|
version: 1.2.10
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -14,9 +14,8 @@ homepage: http://www.yesodweb.com/
|
|||||||
|
|
||||||
library
|
library
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, ReadArgs == 1.2.1
|
|
||||||
, SHA == 1.6.4
|
, SHA == 1.6.4
|
||||||
, aeson == 0.7.0.2
|
, aeson == 0.7.0.3
|
||||||
, ansi-terminal == 0.6.1.1
|
, ansi-terminal == 0.6.1.1
|
||||||
, ansi-wl-pprint == 0.6.7.1
|
, ansi-wl-pprint == 0.6.7.1
|
||||||
, asn1-encoding == 0.8.1.3
|
, asn1-encoding == 0.8.1.3
|
||||||
@ -24,26 +23,26 @@ library
|
|||||||
, asn1-types == 0.2.3
|
, asn1-types == 0.2.3
|
||||||
, async == 2.0.1.5
|
, async == 2.0.1.5
|
||||||
, attoparsec == 0.11.2.1
|
, attoparsec == 0.11.2.1
|
||||||
, attoparsec-conduit == 1.0.1.2
|
, attoparsec-conduit == 1.1.0
|
||||||
, authenticate == 1.3.2.6
|
, authenticate == 1.3.2.8
|
||||||
, base-unicode-symbols == 0.2.2.4
|
, base-unicode-symbols == 0.2.2.4
|
||||||
|
, base16-bytestring == 0.1.1.6
|
||||||
, base64-bytestring == 1.0.0.1
|
, base64-bytestring == 1.0.0.1
|
||||||
, basic-prelude == 0.3.6.0
|
|
||||||
, blaze-builder == 0.3.3.2
|
, 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-html == 0.7.0.1
|
||||||
, blaze-markup == 0.6.0.0
|
, blaze-markup == 0.6.0.0
|
||||||
, byteable == 0.1.1
|
, byteable == 0.1.1
|
||||||
, byteorder == 1.0.4
|
, byteorder == 1.0.4
|
||||||
, case-insensitive == 1.1.0.3
|
, case-insensitive == 1.2.0.0
|
||||||
, cereal == 0.4.0.1
|
, cereal == 0.4.0.1
|
||||||
, cipher-aes == 0.2.7
|
, cipher-aes == 0.2.7
|
||||||
, cipher-rc4 == 0.1.4
|
, cipher-rc4 == 0.1.4
|
||||||
, clientsession == 0.9.0.3
|
, clientsession == 0.9.0.3
|
||||||
, conduit == 1.0.15.1
|
, conduit == 1.1.0.2
|
||||||
, connection == 0.2.0
|
, conduit-extra == 1.1.0.1
|
||||||
, control-monad-loop == 0.1
|
, connection == 0.2.1
|
||||||
, cookie == 0.4.0.1
|
, cookie == 0.4.1.1
|
||||||
, cprng-aes == 0.5.2
|
, cprng-aes == 0.5.2
|
||||||
, crypto-api == 0.13
|
, crypto-api == 0.13
|
||||||
, crypto-cipher-types == 0.0.9
|
, crypto-cipher-types == 0.0.9
|
||||||
@ -51,8 +50,8 @@ library
|
|||||||
, crypto-pubkey == 0.2.4
|
, crypto-pubkey == 0.2.4
|
||||||
, crypto-pubkey-types == 0.4.2.2
|
, crypto-pubkey-types == 0.4.2.2
|
||||||
, crypto-random == 0.0.7
|
, crypto-random == 0.0.7
|
||||||
, cryptohash == 0.11.2
|
, cryptohash == 0.11.4
|
||||||
, cryptohash-conduit == 0.1.0
|
, cryptohash-conduit == 0.1.1
|
||||||
, css-text == 0.1.2.1
|
, css-text == 0.1.2.1
|
||||||
, data-default == 0.5.3
|
, data-default == 0.5.3
|
||||||
, data-default-class == 0.0.1
|
, data-default-class == 0.0.1
|
||||||
@ -60,105 +59,100 @@ library
|
|||||||
, data-default-instances-containers == 0.0.1
|
, data-default-instances-containers == 0.0.1
|
||||||
, data-default-instances-dlist == 0.0.1
|
, data-default-instances-dlist == 0.0.1
|
||||||
, data-default-instances-old-locale == 0.0.1
|
, data-default-instances-old-locale == 0.0.1
|
||||||
, dlist == 0.7
|
, dlist == 0.7.0.1
|
||||||
, email-validate == 2.0.1
|
, email-validate == 2.0.1
|
||||||
, entropy == 0.2.2.4
|
, entropy == 0.2.2.4
|
||||||
, esqueleto == 1.3.5
|
, esqueleto == 1.3.12
|
||||||
, failure == 0.2.0.1
|
, exceptions == 0.5
|
||||||
, fast-logger == 2.1.5
|
, fast-logger == 2.1.5
|
||||||
, file-embed == 0.0.6
|
, file-embed == 0.0.6
|
||||||
, filesystem-conduit == 1.0.0.1
|
, hamlet == 1.2.0
|
||||||
, hamlet == 1.1.9.2
|
, hjsmin == 0.1.4.6
|
||||||
, hjsmin == 0.1.4.5
|
, hspec == 1.9.2
|
||||||
, hspec == 1.9.0
|
|
||||||
, hspec-expectations == 0.5.0.1
|
, hspec-expectations == 0.5.0.1
|
||||||
, html-conduit == 1.1.0.1
|
, html-conduit == 1.1.0.4
|
||||||
, http-client == 0.2.2.2
|
, http-client == 0.3.1.1
|
||||||
, http-client-conduit == 0.2.0.1
|
|
||||||
, http-client-tls == 0.2.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-date == 0.0.4
|
||||||
, http-reverse-proxy == 0.3.1.1
|
, http-reverse-proxy == 0.3.1.5
|
||||||
, http-types == 0.8.3
|
, http-types == 0.8.4
|
||||||
, language-javascript == 0.5.9
|
, language-javascript == 0.5.12
|
||||||
, lifted-base == 0.2.2.1
|
, lifted-base == 0.2.2.1
|
||||||
, mime-mail == 0.4.4.1
|
, mime-mail == 0.4.5.1
|
||||||
, mime-types == 0.1.0.3
|
, mime-types == 0.1.0.4
|
||||||
, mmorph == 1.0.2
|
, mmorph == 1.0.2
|
||||||
, monad-control == 0.3.2.3
|
, monad-control == 0.3.2.3
|
||||||
, monad-logger == 0.3.4.0
|
, monad-logger == 0.3.6
|
||||||
, monad-loops == 0.4.2
|
, monad-loops == 0.4.2
|
||||||
, network-conduit == 1.0.4
|
, network-conduit == 1.1.0
|
||||||
, optparse-applicative == 0.7.0.2
|
, optparse-applicative == 0.8.0.1
|
||||||
, path-pieces == 0.1.3.1
|
, path-pieces == 0.1.3.1
|
||||||
, pem == 0.2.1
|
, pem == 0.2.2
|
||||||
, persistent == 1.3.0.3
|
, persistent == 1.3.0.6
|
||||||
, persistent-template == 1.3.1.2
|
, persistent-template == 1.3.1.3
|
||||||
, pool-conduit == 0.1.2.1
|
|
||||||
, primitive == 0.5.2.1
|
, primitive == 0.5.2.1
|
||||||
, process-conduit == 1.0.0.1
|
|
||||||
, publicsuffixlist == 0.1
|
, publicsuffixlist == 0.1
|
||||||
, pureMD5 == 2.1.2.1
|
|
||||||
, pwstore-fast == 2.4.1
|
, pwstore-fast == 2.4.1
|
||||||
, quickcheck-io == 0.1.0
|
, quickcheck-io == 0.1.1
|
||||||
, resource-pool == 0.2.1.1
|
, resource-pool == 0.2.1.1
|
||||||
, resourcet == 0.4.10.1
|
, resourcet == 1.1.2
|
||||||
, safe == 0.3.4
|
, safe == 0.3.4
|
||||||
, scientific == 0.2.0.2
|
, scientific == 0.2.0.2
|
||||||
, securemem == 0.1.3
|
, securemem == 0.1.3
|
||||||
, semigroups == 0.12.2
|
, semigroups == 0.13.0.1
|
||||||
, setenv == 0.1.1.1
|
, setenv == 0.1.1.1
|
||||||
, shakespeare == 1.2.1.1
|
, shakespeare == 2.0.0.3
|
||||||
, shakespeare-css == 1.0.7.1
|
, shakespeare-css == 1.1.0
|
||||||
, shakespeare-i18n == 1.0.0.5
|
, shakespeare-i18n == 1.1.0
|
||||||
, shakespeare-js == 1.2.0.4
|
, shakespeare-js == 1.3.0
|
||||||
, shakespeare-text == 1.0.2
|
, shakespeare-text == 1.1.0
|
||||||
, silently == 1.2.4.1
|
, silently == 1.2.4.1
|
||||||
, simple-sendfile == 0.2.13
|
, simple-sendfile == 0.2.14
|
||||||
, skein == 1.0.9
|
, skein == 1.0.9
|
||||||
, socks == 0.5.4
|
, 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
|
, stringsearch == 0.3.6.5
|
||||||
, system-fileio == 0.3.12
|
, system-fileio == 0.3.12
|
||||||
, system-filepath == 0.4.9
|
, system-filepath == 0.4.10
|
||||||
, tagged == 0.7.1
|
, tagged == 0.7.1
|
||||||
, tagsoup == 0.13.1
|
, tagsoup == 0.13.1
|
||||||
, tagstream-conduit == 0.5.5
|
, tagstream-conduit == 0.5.5.1
|
||||||
, text-stream-decode == 0.1.0.4
|
, tf-random == 0.5
|
||||||
, tls == 1.2.2
|
, tls == 1.2.6
|
||||||
, transformers-base == 0.4.1
|
, transformers-base == 0.4.1
|
||||||
, unix-compat == 0.4.1.1
|
, unix-compat == 0.4.1.1
|
||||||
, unordered-containers == 0.2.3.3
|
, unordered-containers == 0.2.4.0
|
||||||
, utf8-light == 0.4.2
|
|
||||||
, utf8-string == 0.3.7
|
, utf8-string == 0.3.7
|
||||||
, vector == 0.10.9.1
|
, vector == 0.10.9.1
|
||||||
, void == 0.6.1
|
, void == 0.6.1
|
||||||
, wai == 2.1.0
|
, wai == 2.1.0.2
|
||||||
, wai-app-static == 2.0.0.4
|
, wai-app-static == 2.0.1
|
||||||
, wai-extra == 2.1.0.1
|
, wai-extra == 2.1.1.1
|
||||||
, wai-logger == 2.1.1
|
, wai-logger == 2.1.1
|
||||||
, wai-test == 2.0.0.2
|
, wai-test == 2.0.1.1
|
||||||
, warp == 2.1.1.2
|
, warp == 2.1.4
|
||||||
, warp-tls == 2.0.3.1
|
, warp-tls == 2.0.3.3
|
||||||
, word8 == 0.0.4
|
, word8 == 0.0.4
|
||||||
, x509 == 1.4.11
|
, x509 == 1.4.11
|
||||||
, x509-store == 1.4.4
|
, x509-store == 1.4.4
|
||||||
, x509-system == 1.4.2
|
, x509-system == 1.4.2
|
||||||
, x509-validation == 1.5.0
|
, x509-validation == 1.5.0
|
||||||
, xml-conduit == 1.1.0.9
|
, xml-conduit == 1.2.0.1
|
||||||
, xml-types == 0.3.4
|
, xml-types == 0.3.4
|
||||||
, xss-sanitize == 0.3.5
|
, xss-sanitize == 0.3.5.2
|
||||||
, yaml == 0.8.7.2
|
, yaml == 0.8.8.2
|
||||||
, yesod == 1.2.5
|
, yesod == 1.2.5.2
|
||||||
, yesod-auth == 1.2.7
|
, yesod-auth == 1.3.0.4
|
||||||
, yesod-core == 1.2.8
|
, yesod-auth-hashdb == 1.3.0.1
|
||||||
, yesod-form == 1.3.8
|
, yesod-core == 1.2.14
|
||||||
, yesod-persistent == 1.2.2.1
|
, yesod-form == 1.3.8.2
|
||||||
|
, yesod-persistent == 1.2.2.3
|
||||||
, yesod-routes == 1.2.0.6
|
, yesod-routes == 1.2.0.6
|
||||||
, yesod-static == 1.2.2.2
|
, yesod-static == 1.2.2.5
|
||||||
, yesod-test == 1.2.1
|
, yesod-test == 1.2.1.2
|
||||||
, zlib-bindings == 0.1.1.3
|
, zlib-conduit == 1.1.0
|
||||||
, zlib-conduit == 1.0.0
|
|
||||||
|
|
||||||
exposed-modules: Yesod.Platform
|
exposed-modules: Yesod.Platform
|
||||||
|
|
||||||
|
|||||||
@ -30,13 +30,12 @@ module Yesod.EmbeddedStatic.Generators (
|
|||||||
-- $example
|
-- $example
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>), (<*>))
|
||||||
import Control.Exception (try, SomeException)
|
import Control.Exception (try, SomeException)
|
||||||
import Control.Monad (forM, when)
|
import Control.Monad (forM, when)
|
||||||
import Control.Monad.Trans.Resource (runResourceT)
|
import Control.Monad.Trans.Resource (runResourceT)
|
||||||
import Data.Char (isDigit, isLower)
|
import Data.Char (isDigit, isLower)
|
||||||
import Data.Conduit (($$), (=$))
|
import Data.Conduit (($$))
|
||||||
import Data.Conduit.Process (proc, conduitProcess)
|
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Data.Maybe (isNothing)
|
import Data.Maybe (isNothing)
|
||||||
import Language.Haskell.TH
|
import Language.Haskell.TH
|
||||||
@ -46,7 +45,12 @@ import System.FilePath ((</>))
|
|||||||
import Text.Jasmine (minifym)
|
import Text.Jasmine (minifym)
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import qualified Data.Conduit.List as C
|
import qualified Data.Conduit.List as C
|
||||||
|
import Data.Conduit.Binary (sourceHandle)
|
||||||
import qualified Data.Text as T
|
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
|
import Yesod.EmbeddedStatic.Types
|
||||||
|
|
||||||
@ -197,12 +201,20 @@ compressTool f opts ct = do
|
|||||||
mpath <- findExecutable f
|
mpath <- findExecutable f
|
||||||
when (isNothing mpath) $
|
when (isNothing mpath) $
|
||||||
fail $ "Unable to find " ++ f
|
fail $ "Unable to find " ++ f
|
||||||
let src = C.sourceList $ BL.toChunks ct
|
let p = (Proc.proc f opts)
|
||||||
p = proc f opts
|
{ Proc.std_in = Proc.CreatePipe
|
||||||
sink = C.consume
|
, Proc.std_out = Proc.CreatePipe
|
||||||
compressed <- runResourceT (src $$ conduitProcess p =$ sink)
|
}
|
||||||
putStrLn $ "Compressed successfully with " ++ f
|
(Just hin, Just hout, _, ph) <- Proc.createProcess p
|
||||||
return $ BL.fromChunks compressed
|
(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
|
-- | Try a list of processing functions (like the compressions above) one by one until
|
||||||
|
|||||||
@ -66,6 +66,7 @@ import System.Directory
|
|||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.FileEmbed (embedDir)
|
import Data.FileEmbed (embedDir)
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Resource (runResourceT)
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Yesod.Core.Types
|
import Yesod.Core.Types
|
||||||
|
|
||||||
@ -446,7 +447,7 @@ data CombineSettings = CombineSettings
|
|||||||
, csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
|
, csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
|
||||||
-- ^ Post processing to be performed on CSS files.
|
-- ^ Post processing to be performed on CSS files.
|
||||||
--
|
--
|
||||||
-- Default: Use Lucius to minify.
|
-- Default: Pass-through.
|
||||||
--
|
--
|
||||||
-- Since 1.2.0
|
-- Since 1.2.0
|
||||||
, csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
|
, csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-static
|
name: yesod-static
|
||||||
version: 1.2.2.2
|
version: 1.2.2.5
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -41,6 +41,7 @@ library
|
|||||||
, http-types >= 0.7
|
, http-types >= 0.7
|
||||||
, unix-compat >= 0.2
|
, unix-compat >= 0.2
|
||||||
, conduit >= 0.5
|
, conduit >= 0.5
|
||||||
|
, conduit-extra
|
||||||
, cryptohash-conduit >= 0.1
|
, cryptohash-conduit >= 0.1
|
||||||
, cryptohash >= 0.11
|
, cryptohash >= 0.11
|
||||||
, system-filepath >= 0.4.6 && < 0.5
|
, system-filepath >= 0.4.6 && < 0.5
|
||||||
@ -49,10 +50,11 @@ library
|
|||||||
, shakespeare-css >= 1.0.3
|
, shakespeare-css >= 1.0.3
|
||||||
, mime-types >= 0.1
|
, mime-types >= 0.1
|
||||||
, hjsmin
|
, hjsmin
|
||||||
, process-conduit >= 1.0 && < 1.1
|
|
||||||
, filepath >= 1.3
|
, filepath >= 1.3
|
||||||
, resourcet >= 0.4
|
, resourcet >= 0.4
|
||||||
, unordered-containers >= 0.2
|
, unordered-containers >= 0.2
|
||||||
|
, process
|
||||||
|
, async
|
||||||
|
|
||||||
exposed-modules: Yesod.Static
|
exposed-modules: Yesod.Static
|
||||||
Yesod.EmbeddedStatic
|
Yesod.EmbeddedStatic
|
||||||
@ -100,12 +102,14 @@ test-suite tests
|
|||||||
, shakespeare-css
|
, shakespeare-css
|
||||||
, mime-types
|
, mime-types
|
||||||
, hjsmin
|
, hjsmin
|
||||||
, process-conduit
|
|
||||||
, filepath
|
, filepath
|
||||||
, resourcet
|
, resourcet
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
|
, async
|
||||||
|
, process
|
||||||
|
, conduit-extra
|
||||||
|
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall -threaded
|
||||||
extensions: TemplateHaskell
|
extensions: TemplateHaskell
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-test
|
name: yesod-test
|
||||||
version: 1.2.1.1
|
version: 1.2.1.2
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Nubis <nubis@woobiz.com.ar>
|
author: Nubis <nubis@woobiz.com.ar>
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod
|
name: yesod
|
||||||
version: 1.2.5.1
|
version: 1.2.5.2
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -30,9 +30,9 @@ library
|
|||||||
, transformers >= 0.2.2 && < 0.4
|
, transformers >= 0.2.2 && < 0.4
|
||||||
, wai >= 1.3
|
, wai >= 1.3
|
||||||
, wai-extra >= 1.3
|
, wai-extra >= 1.3
|
||||||
, hamlet >= 1.1 && < 1.2
|
, hamlet >= 1.1
|
||||||
, shakespeare-js >= 1.0.2 && < 1.3
|
, shakespeare-js >= 1.0.2
|
||||||
, shakespeare-css >= 1.0 && < 1.1
|
, shakespeare-css >= 1.0
|
||||||
, warp >= 1.3
|
, warp >= 1.3
|
||||||
, blaze-html >= 0.5
|
, blaze-html >= 0.5
|
||||||
, blaze-markup >= 0.5.1
|
, blaze-markup >= 0.5.1
|
||||||
@ -48,6 +48,8 @@ library
|
|||||||
, bytestring
|
, bytestring
|
||||||
, monad-logger
|
, monad-logger
|
||||||
, fast-logger
|
, fast-logger
|
||||||
|
, conduit-extra
|
||||||
|
, shakespeare
|
||||||
|
|
||||||
exposed-modules: Yesod
|
exposed-modules: Yesod
|
||||||
, Yesod.Default.Config
|
, Yesod.Default.Config
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user