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

Merge remote-tracking branch 'origin/simpler-dispatch' into persistent2-simpler-dispatch

Browse Source
This commit is contained in:
Michael Snoyman 2014-03-04 13:47:21 +02:00
commit 84baab6fb5
66 changed files with 2190 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -12,3 +12,6 @@ cabal.sandbox.config
/vendor/ /vendor/
/.shelly/ /.shelly/
/tarballs/ /tarballs/
*.swp
dist
client_session_key.aes

4
.travis.yml
View File

@ -9,3 +9,7 @@ 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-meta install --force-reinstalls
script: mega-sdist --test

15
README Normal file
View File

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

6
authenticate-oauth/.gitignore vendored Normal file
View File

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

25
authenticate-oauth/LICENSE Normal file
View File

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

7
authenticate-oauth/Setup.lhs Executable file
View File

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

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

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

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

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

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

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

25
authenticate/LICENSE Normal file
View File

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

159
authenticate/OpenId2/Discovery.hs Normal file
View File

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

69
authenticate/OpenId2/Normalization.hs Normal file
View File

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

34
authenticate/OpenId2/Types.hs Normal file
View File

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

77
authenticate/OpenId2/XRDS.hs Normal file
View File

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

7
authenticate/Setup.lhs Executable file
View File

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

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

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

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

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

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

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

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

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

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

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

48
authenticate/authenticate.cabal Normal file
View File

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

45
authenticate/browserid.hs Normal file
View File

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

91
authenticate/openid2.hs Normal file
View File

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

38
authenticate/rpxnow.hs Normal file
View File

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

2
sources.txt
View File

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

4
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

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

5
yesod-auth/Yesod/Auth/HashDB.hs
View File

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

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

@ -1,5 +1,5 @@
name: yesod-auth name: yesod-auth
version: 1.2.5.2 version: 1.2.5.3
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin

12
yesod-bin/GhcBuild.hs
View File

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

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

@ -35,7 +35,8 @@ 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.Conduit (newManager, conduitManagerSettings)
import System.Log.FastLogger (newLoggerSet, defaultBufSize) import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher) import 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))
@ -53,7 +54,7 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do makeApplication conf = do
foundation <- makeFoundation conf foundation <- makeFoundation conf
@ -68,7 +69,8 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
return $ logWare app let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
@ -81,8 +83,18 @@ makeFoundation conf = do
Database.Persist.applyEnv Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
loggerSet' <- newLoggerSet defaultBufSize Nothing loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher (getter, updater) <- clockDateCacher
-- If the Yesod logger (as opposed to the request logger middleware) is
-- used less than once a second on average, you may prefer to omit this
-- thread and use "(updater >> getter)" in place of "getter" below. That
-- would update the cache every time it is used, instead of every second.
let updateLoop = do
threadDelay 1000000
updater
updateLoop
_ <- forkIO updateLoop
let logger = Yesod.Core.Types.Logger loggerSet' getter let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger foundation = App conf s p manager dbconf logger
@ -92,7 +104,7 @@ makeFoundation conf = do
-- for yesod devel -- for yesod devel
getApplicationDev :: IO (Int, Application) getApplicationDev :: IO (Int, Application)
getApplicationDev = getApplicationDev =
defaultDevelApp loader makeApplication defaultDevelApp loader (fmap fst . makeApplication)
where where
loader = Yesod.Default.Config.loadConfig (configSettings Development) loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra { csParseExtra = parseExtra
@ -226,7 +238,10 @@ instance YesodAuth App where
case x of case x of
Just (Entity uid _) -> return $ Just uid Just (Entity uid _) -> return $ Just uid
Nothing -> do Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing fmap Just $ insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authBrowserId def, authGoogleEmail] authPlugins _ = [authBrowserId def, authGoogleEmail]
@ -387,7 +402,7 @@ library
DeriveDataTypeable DeriveDataTypeable
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.2 && < 1.3 , yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3
, yesod-static >= 1.2 && < 1.3 , yesod-static >= 1.2 && < 1.3
@ -413,7 +428,7 @@ library
, aeson >= 0.6 && < 0.8 , aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
executable PROJECTNAME executable PROJECTNAME
@ -580,12 +595,12 @@ combineScripts = combineScripts' development combineSettings
{-# START_FILE app/main.hs #-} {-# START_FILE app/main.hs #-}
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain) import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra) import Settings (parseExtra)
import Application (makeApplication) import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMain (fromArgs parseExtra) makeApplication main = defaultMainLog (fromArgs parseExtra) makeApplication
{-# START_FILE BASE64 config/favicon.ico #-} {-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA

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

@ -37,7 +37,8 @@ import qualified Database.Persist
import Database.Persist.Sql (runMigration) import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings) import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Control.Monad.Logger (runLoggingT) import Control.Monad.Logger (runLoggingT)
import System.Log.FastLogger (newLoggerSet, defaultBufSize) import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher) import 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))
@ -55,7 +56,7 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do makeApplication conf = do
foundation <- makeFoundation conf foundation <- makeFoundation conf
@ -70,7 +71,8 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
return $ logWare app let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
@ -83,8 +85,18 @@ makeFoundation conf = do
Database.Persist.applyEnv Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
loggerSet' <- newLoggerSet defaultBufSize Nothing loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher (getter, updater) <- clockDateCacher
-- If the Yesod logger (as opposed to the request logger middleware) is
-- used less than once a second on average, you may prefer to omit this
-- thread and use "(updater >> getter)" in place of "getter" below. That
-- would update the cache every time it is used, instead of every second.
let updateLoop = do
threadDelay 1000000
updater
updateLoop
_ <- forkIO updateLoop
let logger = Yesod.Core.Types.Logger loggerSet' getter let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger foundation = App conf s p manager dbconf logger
@ -99,7 +111,7 @@ makeFoundation conf = do
-- for yesod devel -- for yesod devel
getApplicationDev :: IO (Int, Application) getApplicationDev :: IO (Int, Application)
getApplicationDev = getApplicationDev =
defaultDevelApp loader makeApplication defaultDevelApp loader (fmap fst . makeApplication)
where where
loader = Yesod.Default.Config.loadConfig (configSettings Development) loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra { csParseExtra = parseExtra
@ -235,7 +247,10 @@ instance YesodAuth App where
case x of case x of
Just (Entity uid _) -> return $ Just uid Just (Entity uid _) -> return $ Just uid
Nothing -> do Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing fmap Just $ insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authBrowserId def, authGoogleEmail] authPlugins _ = [authBrowserId def, authGoogleEmail]
@ -391,7 +406,7 @@ library
DeriveDataTypeable DeriveDataTypeable
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.2 && < 1.3 , yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3
, yesod-static >= 1.2 && < 1.3 , yesod-static >= 1.2 && < 1.3
@ -417,7 +432,7 @@ library
, aeson >= 0.6 && < 0.8 , aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
executable PROJECTNAME executable PROJECTNAME
@ -584,12 +599,12 @@ combineScripts = combineScripts' development combineSettings
{-# START_FILE app/main.hs #-} {-# START_FILE app/main.hs #-}
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain) import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra) import Settings (parseExtra)
import Application (makeApplication) import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMain (fromArgs parseExtra) makeApplication main = defaultMainLog (fromArgs parseExtra) makeApplication
{-# START_FILE BASE64 config/favicon.ico #-} {-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA

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

@ -39,7 +39,8 @@ import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings) import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Yesod.Fay (getFaySite) import Yesod.Fay (getFaySite)
import Control.Monad.Logger (runLoggingT) import Control.Monad.Logger (runLoggingT)
import System.Log.FastLogger (newLoggerSet, defaultBufSize) import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher) import 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))
@ -58,7 +59,7 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do makeApplication conf = do
foundation <- makeFoundation conf foundation <- makeFoundation conf
@ -73,7 +74,8 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
return $ logWare app let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
@ -86,8 +88,18 @@ makeFoundation conf = do
Database.Persist.applyEnv Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
loggerSet' <- newLoggerSet defaultBufSize Nothing loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher (getter, updater) <- clockDateCacher
-- If the Yesod logger (as opposed to the request logger middleware) is
-- used less than once a second on average, you may prefer to omit this
-- thread and use "(updater >> getter)" in place of "getter" below. That
-- would update the cache every time it is used, instead of every second.
let updateLoop = do
threadDelay 1000000
updater
updateLoop
_ <- forkIO updateLoop
let logger = Yesod.Core.Types.Logger loggerSet' getter let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf onCommand logger foundation = App conf s p manager dbconf onCommand logger
@ -102,7 +114,7 @@ makeFoundation conf = do
-- for yesod devel -- for yesod devel
getApplicationDev :: IO (Int, Application) getApplicationDev :: IO (Int, Application)
getApplicationDev = getApplicationDev =
defaultDevelApp loader makeApplication defaultDevelApp loader (fmap fst . makeApplication)
where where
loader = Yesod.Default.Config.loadConfig (configSettings Development) loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra { csParseExtra = parseExtra
@ -248,7 +260,10 @@ instance YesodAuth App where
case x of case x of
Just (Entity uid _) -> return $ Just uid Just (Entity uid _) -> return $ Just uid
Nothing -> do Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing fmap Just $ insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authBrowserId def, authGoogleEmail] authPlugins _ = [authBrowserId def, authGoogleEmail]
@ -427,7 +442,7 @@ library
DeriveDataTypeable DeriveDataTypeable
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.2 && < 1.3 , yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3
, yesod-static >= 1.2 && < 1.3 , yesod-static >= 1.2 && < 1.3
@ -454,7 +469,7 @@ library
, aeson >= 0.6 && < 0.8 , aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
executable PROJECTNAME executable PROJECTNAME
@ -633,12 +648,12 @@ combineScripts = combineScripts' development combineSettings
{-# START_FILE app/main.hs #-} {-# START_FILE app/main.hs #-}
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain) import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra) import Settings (parseExtra)
import Application (makeApplication) import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMain (fromArgs parseExtra) makeApplication main = defaultMainLog (fromArgs parseExtra) makeApplication
{-# START_FILE BASE64 config/favicon.ico #-} {-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA

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

@ -37,7 +37,8 @@ import qualified Database.Persist
import Database.Persist.Sql (runMigration) import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings) import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Control.Monad.Logger (runLoggingT) import Control.Monad.Logger (runLoggingT)
import System.Log.FastLogger (newLoggerSet, defaultBufSize) import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher) import 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))
@ -55,7 +56,7 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do makeApplication conf = do
foundation <- makeFoundation conf foundation <- makeFoundation conf
@ -70,7 +71,8 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
return $ logWare app let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
@ -83,8 +85,18 @@ makeFoundation conf = do
Database.Persist.applyEnv Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
loggerSet' <- newLoggerSet defaultBufSize Nothing loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher (getter, updater) <- clockDateCacher
-- If the Yesod logger (as opposed to the request logger middleware) is
-- used less than once a second on average, you may prefer to omit this
-- thread and use "(updater >> getter)" in place of "getter" below. That
-- would update the cache every time it is used, instead of every second.
let updateLoop = do
threadDelay 1000000
updater
updateLoop
_ <- forkIO updateLoop
let logger = Yesod.Core.Types.Logger loggerSet' getter let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger foundation = App conf s p manager dbconf logger
@ -99,7 +111,7 @@ makeFoundation conf = do
-- for yesod devel -- for yesod devel
getApplicationDev :: IO (Int, Application) getApplicationDev :: IO (Int, Application)
getApplicationDev = getApplicationDev =
defaultDevelApp loader makeApplication defaultDevelApp loader (fmap fst . makeApplication)
where where
loader = Yesod.Default.Config.loadConfig (configSettings Development) loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra { csParseExtra = parseExtra
@ -235,7 +247,10 @@ instance YesodAuth App where
case x of case x of
Just (Entity uid _) -> return $ Just uid Just (Entity uid _) -> return $ Just uid
Nothing -> do Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing fmap Just $ insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authBrowserId def, authGoogleEmail] authPlugins _ = [authBrowserId def, authGoogleEmail]
@ -391,7 +406,7 @@ library
DeriveDataTypeable DeriveDataTypeable
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.2 && < 1.3 , yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3
, yesod-static >= 1.2 && < 1.3 , yesod-static >= 1.2 && < 1.3
@ -417,7 +432,7 @@ library
, aeson >= 0.6 && < 0.8 , aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
executable PROJECTNAME executable PROJECTNAME
@ -584,12 +599,12 @@ combineScripts = combineScripts' development combineSettings
{-# START_FILE app/main.hs #-} {-# START_FILE app/main.hs #-}
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain) import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra) import Settings (parseExtra)
import Application (makeApplication) import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMain (fromArgs parseExtra) makeApplication main = defaultMainLog (fromArgs parseExtra) makeApplication
{-# START_FILE BASE64 config/favicon.ico #-} {-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA

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

@ -32,7 +32,8 @@ import Network.Wai.Middleware.RequestLogger
) )
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.Conduit (newManager, conduitManagerSettings)
import System.Log.FastLogger (newLoggerSet, defaultBufSize) import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher) import 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))
@ -50,7 +51,7 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do makeApplication conf = do
foundation <- makeFoundation conf foundation <- makeFoundation conf
@ -65,7 +66,8 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
return $ logWare app let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
@ -74,8 +76,18 @@ makeFoundation conf = do
manager <- newManager conduitManagerSettings manager <- newManager conduitManagerSettings
s <- staticSite s <- staticSite
loggerSet' <- newLoggerSet defaultBufSize Nothing loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher (getter, updater) <- clockDateCacher
-- If the Yesod logger (as opposed to the request logger middleware) is
-- used less than once a second on average, you may prefer to omit this
-- thread and use "(updater >> getter)" in place of "getter" below. That
-- would update the cache every time it is used, instead of every second.
let updateLoop = do
threadDelay 1000000
updater
updateLoop
_ <- forkIO updateLoop
let logger = Yesod.Core.Types.Logger loggerSet' getter let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s manager logger foundation = App conf s manager logger
@ -85,7 +97,7 @@ makeFoundation conf = do
-- for yesod devel -- for yesod devel
getApplicationDev :: IO (Int, Application) getApplicationDev :: IO (Int, Application)
getApplicationDev = getApplicationDev =
defaultDevelApp loader makeApplication defaultDevelApp loader (fmap fst . makeApplication)
where where
loader = Yesod.Default.Config.loadConfig (configSettings Development) loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra { csParseExtra = parseExtra
@ -321,7 +333,7 @@ library
DeriveDataTypeable DeriveDataTypeable
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.2 && < 1.3 , yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3
, yesod-static >= 1.2 && < 1.3 , yesod-static >= 1.2 && < 1.3
@ -344,7 +356,7 @@ library
, aeson >= 0.6 && < 0.8 , aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
executable PROJECTNAME executable PROJECTNAME
@ -502,12 +514,12 @@ combineScripts = combineScripts' development combineSettings
{-# START_FILE app/main.hs #-} {-# START_FILE app/main.hs #-}
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain) import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra) import Settings (parseExtra)
import Application (makeApplication) import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMain (fromArgs parseExtra) makeApplication main = defaultMainLog (fromArgs parseExtra) makeApplication
{-# START_FILE BASE64 config/favicon.ico #-} {-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA

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

@ -37,7 +37,8 @@ import qualified Database.Persist
import Database.Persist.Sql (runMigration) import Database.Persist.Sql (runMigration)
import Network.HTTP.Conduit (newManager, conduitManagerSettings) import Network.HTTP.Conduit (newManager, conduitManagerSettings)
import Control.Monad.Logger (runLoggingT) import Control.Monad.Logger (runLoggingT)
import System.Log.FastLogger (newLoggerSet, defaultBufSize) import Control.Concurrent (forkIO, threadDelay)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher) import 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))
@ -55,7 +56,7 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do makeApplication conf = do
foundation <- makeFoundation conf foundation <- makeFoundation conf
@ -70,7 +71,8 @@ makeApplication conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
return $ logWare app let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
@ -83,8 +85,18 @@ makeFoundation conf = do
Database.Persist.applyEnv Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
loggerSet' <- newLoggerSet defaultBufSize Nothing loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher (getter, updater) <- clockDateCacher
-- If the Yesod logger (as opposed to the request logger middleware) is
-- used less than once a second on average, you may prefer to omit this
-- thread and use "(updater >> getter)" in place of "getter" below. That
-- would update the cache every time it is used, instead of every second.
let updateLoop = do
threadDelay 1000000
updater
updateLoop
_ <- forkIO updateLoop
let logger = Yesod.Core.Types.Logger loggerSet' getter let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger foundation = App conf s p manager dbconf logger
@ -99,7 +111,7 @@ makeFoundation conf = do
-- for yesod devel -- for yesod devel
getApplicationDev :: IO (Int, Application) getApplicationDev :: IO (Int, Application)
getApplicationDev = getApplicationDev =
defaultDevelApp loader makeApplication defaultDevelApp loader (fmap fst . makeApplication)
where where
loader = Yesod.Default.Config.loadConfig (configSettings Development) loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra { csParseExtra = parseExtra
@ -235,7 +247,10 @@ instance YesodAuth App where
case x of case x of
Just (Entity uid _) -> return $ Just uid Just (Entity uid _) -> return $ Just uid
Nothing -> do Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing fmap Just $ insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authBrowserId def, authGoogleEmail] authPlugins _ = [authBrowserId def, authGoogleEmail]
@ -391,7 +406,7 @@ library
DeriveDataTypeable DeriveDataTypeable
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.2 && < 1.3 , yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3
, yesod-static >= 1.2 && < 1.3 , yesod-static >= 1.2 && < 1.3
@ -417,7 +432,7 @@ library
, aeson >= 0.6 && < 0.8 , aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
executable PROJECTNAME executable PROJECTNAME
@ -584,12 +599,12 @@ combineScripts = combineScripts' development combineSettings
{-# START_FILE app/main.hs #-} {-# START_FILE app/main.hs #-}
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain) import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra) import Settings (parseExtra)
import Application (makeApplication) import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMain (fromArgs parseExtra) makeApplication main = defaultMainLog (fromArgs parseExtra) makeApplication
{-# START_FILE BASE64 config/favicon.ico #-} {-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA

2
yesod-bin/input/done.cg
View File

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

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

@ -1,5 +1,5 @@
name: yesod-bin name: yesod-bin
version: 1.2.5.6 version: 1.2.6
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>

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

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

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

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

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

@ -640,7 +640,12 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
-- | Set the Expires header to some date in 2037. In other words, this content -- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired. -- is never (realistically) expired.
neverExpires :: MonadHandler m => m () neverExpires :: MonadHandler m => m ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" neverExpires = do
setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
cacheSeconds oneYear
where
oneYear :: Int
oneYear = 60 * 60 * 24 * 365
-- | Set an Expires header in the past, meaning this content should not be -- | Set an Expires header in the past, meaning this content should not be
-- cached. -- cached.

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

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

5
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -17,6 +17,7 @@ import Data.ByteString.Lazy.Char8 ()
import Data.List (foldl') import Data.List (foldl')
import Yesod.Routes.TH import Yesod.Routes.TH
import Yesod.Routes.TH.Simple (mkSimpleDispatchClause)
import Yesod.Routes.Parse import Yesod.Routes.Parse
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Content import Yesod.Core.Content
@ -115,7 +116,7 @@ mkDispatchInstance :: Type -- ^ The master site type
-> [ResourceTree a] -- ^ The resource -> [ResourceTree a] -- ^ The resource
-> DecsQ -> DecsQ
mkDispatchInstance master res = do mkDispatchInstance master res = do
clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res clause' <- mkSimpleDispatchClause (mkMDS [|yesodRunner|]) res
let thisDispatch = FunD 'yesodDispatch [clause'] let thisDispatch = FunD 'yesodDispatch [clause']
return [InstanceD [] yDispatch [thisDispatch]] return [InstanceD [] yDispatch [thisDispatch]]
where where
@ -123,7 +124,7 @@ mkDispatchInstance master res = do
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch res = do mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res clause' <- mkSimpleDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
inner <- newName "inner" inner <- newName "inner"
let innerFun = FunD inner [clause'] let innerFun = FunD inner [clause']
helper <- newName "helper" helper <- newName "helper"

2
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
module YesodCoreTest.CleanPath (cleanPathTest, Widget) where module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
import Test.Hspec import Test.Hspec

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

@ -24,6 +24,11 @@ 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
-- https://github.com/yesodweb/yesod/issues/658
/builder BuilderR GET
/file-bad-len FileBadLenR GET
/file-bad-name FileBadNameR GET
|] |]
overrideStatus = mkStatus 15 "OVERRIDE" overrideStatus = mkStatus 15 "OVERRIDE"
@ -74,6 +79,15 @@ getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR
getOverrideStatusR :: Handler () getOverrideStatusR :: Handler ()
getOverrideStatusR = invalidArgs ["OVERRIDE"] getOverrideStatusR = invalidArgs ["OVERRIDE"]
getBuilderR :: Handler TypedContent
getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing
getFileBadLenR :: Handler TypedContent
getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen")
getFileBadNameR :: Handler TypedContent
getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
errorHandlingTest :: Spec errorHandlingTest :: Spec
errorHandlingTest = describe "Test.ErrorHandling" $ do errorHandlingTest = describe "Test.ErrorHandling" $ do
it "says not found" caseNotFound it "says not found" caseNotFound
@ -82,6 +96,9 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
it "error in body == 500" caseErrorInBody it "error in body == 500" caseErrorInBody
it "error in body, no eval == 200" caseErrorInBodyNoEval it "error in body, no eval == 200" caseErrorInBodyNoEval
it "can override status code" caseOverrideStatus it "can override status code" caseOverrideStatus
it "builder" caseBuilder
it "file with bad len" caseFileBadLen
it "file with bad name" caseFileBadName
runner :: Session () -> IO () runner :: Session () -> IO ()
runner f = toWaiApp App >>= runSession f runner f = toWaiApp App >>= runSession f
@ -140,3 +157,21 @@ caseOverrideStatus :: IO ()
caseOverrideStatus = runner $ do caseOverrideStatus = runner $ do
res <- request defaultRequest { pathInfo = ["override-status"] } res <- request defaultRequest { pathInfo = ["override-status"] }
assertStatus 15 res assertStatus 15 res
caseBuilder :: IO ()
caseBuilder = runner $ do
res <- request defaultRequest { pathInfo = ["builder"] }
assertStatus 500 res
assertBodyContains "builder-3.14159" res
caseFileBadLen :: IO ()
caseFileBadLen = runner $ do
res <- request defaultRequest { pathInfo = ["file-bad-len"] }
assertStatus 500 res
assertBodyContains "filebadlen" res
caseFileBadName :: IO ()
caseFileBadName = runner $ do
res <- request defaultRequest { pathInfo = ["file-bad-name"] }
assertStatus 500 res
assertBodyContains "filebadname" res

2
yesod-core/test/YesodCoreTest/Json.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
module YesodCoreTest.Json (specs, Widget) where module YesodCoreTest.Json (specs, Widget) where
import Yesod.Core import Yesod.Core

2
yesod-core/test/YesodCoreTest/Links.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
module YesodCoreTest.Links (linksTest, Widget) where module YesodCoreTest.Links (linksTest, Widget) where
import Test.Hspec import Test.Hspec

2
yesod-core/test/YesodCoreTest/Media.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module YesodCoreTest.Media (mediaTest, Widget) where module YesodCoreTest.Media (mediaTest, Widget) where

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

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
import Test.Hspec import Test.Hspec

2
yesod-core/test/YesodCoreTest/Reps.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
module YesodCoreTest.Reps (specs, Widget) where module YesodCoreTest.Reps (specs, Widget) where
import Yesod.Core import Yesod.Core

2
yesod-core/test/YesodCoreTest/Widget.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
module YesodCoreTest.Widget (widgetTest) where module YesodCoreTest.Widget (widgetTest) where
import Test.Hspec import Test.Hspec

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

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

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

@ -108,7 +108,7 @@ intField = Field
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never $newline never
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">
|] |]
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@ -125,7 +125,7 @@ doubleField = Field
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never $newline never
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}"> <input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}">
|] |]
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }

22
yesod-form/Yesod/Form/Input.hs
View File

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

4
yesod-form/Yesod/Form/MassInput.hs
View File

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

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

@ -102,7 +102,7 @@ instance Monad m => Applicative (AForm m) where
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
(a, b, ints', c) <- f mr env ints (a, b, ints', c) <- f mr env ints
(x, y, ints'', z) <- g mr env ints' (x, y, ints'', z) <- g mr env ints'
return (a <*> x, b `mappend` y, ints'', c `mappend` z) return (a <*> x, b . y, ints'', c `mappend` z)
instance (Monad m, Monoid a) => Monoid (AForm m a) where instance (Monad m, Monoid a) => Monoid (AForm m a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b

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

@ -1,5 +1,5 @@
name: yesod-form name: yesod-form
version: 1.3.4.2 version: 1.3.5.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>

2
yesod-newsfeed/Yesod/AtomFeed.hs
View File

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

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

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

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

@ -7,4 +7,4 @@ 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 | runghc to-cabal.hs > yesod-platform.cabal cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text esqueleto warp-tls hjsmin | runghc to-cabal.hs > yesod-platform.cabal

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

@ -1,5 +1,5 @@
name: yesod-platform name: yesod-platform
version: 1.2.5.3 version: 1.2.7.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -14,41 +14,41 @@ homepage: http://www.yesodweb.com/
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, SHA == 1.6.1 , SHA == 1.6.4
, aeson == 0.6.2.1 , aeson == 0.7.0.1
, ansi-terminal == 0.6.1 , ansi-terminal == 0.6.1.1
, asn1-data == 0.7.1 , asn1-encoding == 0.8.1.2
, asn1-parse == 0.8.1
, asn1-types == 0.2.3 , asn1-types == 0.2.3
, attoparsec == 0.10.4.0 , attoparsec == 0.11.1.0
, attoparsec-conduit == 1.0.1.2 , attoparsec-conduit == 1.0.1.2
, authenticate == 1.3.2.6 , authenticate == 1.3.2.6
, base-unicode-symbols == 0.2.2.4 , base-unicode-symbols == 0.2.2.4
, base64-bytestring == 1.0.0.1 , base64-bytestring == 1.0.0.1
, blaze-builder == 0.3.3.2 , blaze-builder == 0.3.3.2
, blaze-builder-conduit == 1.0.0 , blaze-builder-conduit == 1.0.0
, blaze-html == 0.6.1.2 , blaze-html == 0.7.0.1
, blaze-markup == 0.5.1.6 , blaze-markup == 0.6.0.0
, byteable == 0.1.1 , byteable == 0.1.1
, byteorder == 1.0.4 , byteorder == 1.0.4
, case-insensitive == 1.1.0.2 , case-insensitive == 1.1.0.3
, cereal == 0.4.0.1 , cereal == 0.4.0.1
, certificate == 1.3.9
, cipher-aes == 0.2.6 , cipher-aes == 0.2.6
, cipher-rc4 == 0.1.4 , cipher-rc4 == 0.1.4
, clientsession == 0.9.0.3 , clientsession == 0.9.0.3
, conduit == 1.0.9.3 , conduit == 1.0.14
, connection == 0.1.3.1 , connection == 0.2.0
, control-monad-loop == 0.1 , control-monad-loop == 0.1
, cookie == 0.4.0.1 , cookie == 0.4.0.1
, cprng-aes == 0.5.2 , cprng-aes == 0.5.2
, crypto-api == 0.12.2.2 , crypto-api == 0.13
, crypto-cipher-types == 0.0.9 , crypto-cipher-types == 0.0.9
, crypto-conduit == 0.5.2.1 , crypto-conduit == 0.5.2.2
, crypto-numbers == 0.2.3 , crypto-numbers == 0.2.3
, crypto-pubkey == 0.2.4 , crypto-pubkey == 0.2.4
, crypto-pubkey-types == 0.4.1 , crypto-pubkey-types == 0.4.1
, crypto-random == 0.0.7 , crypto-random == 0.0.7
, cryptohash == 0.11.1 , cryptohash == 0.11.2
, cryptohash-cryptoapi == 0.1.0 , cryptohash-cryptoapi == 0.1.0
, css-text == 0.1.1 , css-text == 0.1.1
, data-default == 0.5.3 , data-default == 0.5.3
@ -58,37 +58,38 @@ library
, 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.6.0.1 , dlist == 0.6.0.1
, email-validate == 1.0.0 , email-validate == 2.0.1
, entropy == 0.2.2.4 , entropy == 0.2.2.4
, esqueleto == 1.3.4.5
, failure == 0.2.0.1 , failure == 0.2.0.1
, fast-logger == 2.1.0 , fast-logger == 2.1.5
, file-embed == 0.0.6 , file-embed == 0.0.6
, filesystem-conduit == 1.0.0.1 , filesystem-conduit == 1.0.0.1
, hamlet == 1.1.7.6 , hamlet == 1.1.7.7
, hjsmin == 0.1.4.4 , hjsmin == 0.1.4.5
, hspec == 1.8.1.1 , hspec == 1.8.3
, hspec-expectations == 0.5.0.1 , hspec-expectations == 0.5.0.1
, html-conduit == 1.1.0.1 , html-conduit == 1.1.0.1
, http-attoparsec == 0.1.0 , http-client == 0.2.2.2
, http-client == 0.2.0.3
, http-client-conduit == 0.2.0.1 , http-client-conduit == 0.2.0.1
, http-client-tls == 0.2.0.2 , http-client-tls == 0.2.1.1
, http-conduit == 2.0.0.3 , http-conduit == 2.0.0.5
, http-date == 0.0.4 , http-date == 0.0.4
, http-types == 0.8.3 , http-types == 0.8.3
, language-javascript == 0.5.8 , language-javascript == 0.5.8
, lifted-base == 0.2.1.1 , lifted-base == 0.2.2.0
, mime-mail == 0.4.3 , mime-mail == 0.4.4
, mime-types == 0.1.0.3 , mime-types == 0.1.0.3
, mmorph == 1.0.0 , mmorph == 1.0.2
, monad-control == 0.3.2.2 , monad-control == 0.3.2.3
, monad-logger == 0.3.4.0 , monad-logger == 0.3.4.0
, monad-loops == 0.4.2 , monad-loops == 0.4.2
, network-conduit == 1.0.0 , network-conduit == 1.0.2.2
, optparse-applicative == 0.7.0.2
, path-pieces == 0.1.3.1 , path-pieces == 0.1.3.1
, pem == 0.2.1 , pem == 0.2.1
, persistent == 1.3.0 , persistent == 1.3.0.2
, persistent-template == 1.3.0 , persistent-template == 1.3.1.1
, pool-conduit == 0.1.2 , pool-conduit == 0.1.2
, primitive == 0.5.1.0 , primitive == 0.5.1.0
, process-conduit == 1.0.0.1 , process-conduit == 1.0.0.1
@ -98,28 +99,29 @@ library
, quickcheck-io == 0.1.0 , quickcheck-io == 0.1.0
, resource-pool == 0.2.1.1 , resource-pool == 0.2.1.1
, resourcet == 0.4.10 , resourcet == 0.4.10
, safe == 0.3.3 , safe == 0.3.4
, scientific == 0.2.0.1
, securemem == 0.1.3 , securemem == 0.1.3
, semigroups == 0.12.1 , semigroups == 0.12.2
, setenv == 0.1.1 , setenv == 0.1.1.1
, shakespeare == 1.2.0.4 , shakespeare == 1.2.0.4
, shakespeare-css == 1.0.6.6 , shakespeare-css == 1.0.6.6
, shakespeare-i18n == 1.0.0.5 , shakespeare-i18n == 1.0.0.5
, shakespeare-js == 1.2.0.2 , shakespeare-js == 1.2.0.3
, shakespeare-text == 1.0.0.10 , shakespeare-text == 1.0.1
, silently == 1.2.4.1 , silently == 1.2.4.1
, simple-sendfile == 0.2.13 , simple-sendfile == 0.2.13
, skein == 1.0.8 , skein == 1.0.8.1
, socks == 0.5.4 , socks == 0.5.4
, stm-chans == 3.0.0 , stm-chans == 3.0.0
, stringsearch == 0.3.6.5 , stringsearch == 0.3.6.5
, system-fileio == 0.3.11 , system-fileio == 0.3.12
, system-filepath == 0.4.8 , system-filepath == 0.4.9
, tagged == 0.7 , tagged == 0.7
, tagsoup == 0.13 , tagsoup == 0.13.1
, tagstream-conduit == 0.5.4.1 , tagstream-conduit == 0.5.5
, tls == 1.1.5 , text-stream-decode == 0.1.0.3
, tls-extra == 0.6.6 , tls == 1.2.2
, 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.3.3
@ -129,21 +131,26 @@ library
, void == 0.6.1 , void == 0.6.1
, wai == 2.0.0 , wai == 2.0.0
, wai-app-static == 2.0.0.2 , wai-app-static == 2.0.0.2
, wai-extra == 2.0.1.2 , wai-extra == 2.0.3.3
, wai-logger == 2.1.0 , wai-logger == 2.1.1
, wai-test == 2.0.0.1 , wai-test == 2.0.0.1
, warp == 2.0.1 , warp == 2.0.3.2
, warp-tls == 2.0.2
, word8 == 0.0.4 , word8 == 0.0.4
, x509 == 1.4.7
, x509-store == 1.4.4
, x509-system == 1.4.2
, x509-validation == 1.5.0
, xml-conduit == 1.1.0.9 , xml-conduit == 1.1.0.9
, xml-types == 0.3.4 , xml-types == 0.3.4
, xss-sanitize == 0.3.4.1 , xss-sanitize == 0.3.4.2
, yaml == 0.8.5.2 , yaml == 0.8.7.2
, yesod == 1.2.4 , yesod == 1.2.5
, yesod-auth == 1.2.5.2 , yesod-auth == 1.2.5.3
, yesod-core == 1.2.6.4 , yesod-core == 1.2.6.7
, yesod-form == 1.3.4.2 , yesod-form == 1.3.5.1
, yesod-persistent == 1.2.2.1 , yesod-persistent == 1.2.2.1
, yesod-routes == 1.2.0.5 , yesod-routes == 1.2.0.6
, yesod-static == 1.2.2.1 , yesod-static == 1.2.2.1
, yesod-test == 1.2.1 , yesod-test == 1.2.1
, zlib-bindings == 0.1.1.3 , zlib-bindings == 0.1.1.3

178
yesod-routes/Yesod/Routes/TH/Simple.hs Normal file
View File

@ -0,0 +1,178 @@
{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
module Yesod.Routes.TH.Simple where
import Prelude hiding (exp)
import Yesod.Routes.TH
import Language.Haskell.TH.Syntax
import Web.PathPieces
import Data.Maybe (mapMaybe, catMaybes)
import Control.Monad (forM)
import Data.List (foldl')
import Data.ByteString (ByteString)
import Control.Arrow (second)
data SDC = SDC
{ clause404 :: Clause
, extraParams :: [Exp]
, extraCons :: [Exp]
, envExp :: Exp
, reqExp :: Exp
}
-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on
-- view patterns.
--
-- Since 1.2.1
mkSimpleDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause
mkSimpleDispatchClause MkDispatchSettings {..} resources = do
envName <- newName "env"
reqName <- newName "req"
helperName <- newName "helper"
let envE = VarE envName
reqE = VarE reqName
helperE = VarE helperName
clause404' <- mkClause404 envE reqE
getPathInfo <- mdsGetPathInfo
let pathInfo = getPathInfo `AppE` reqE
let sdc = SDC
{ clause404 = clause404'
, extraParams = []
, extraCons = []
, envExp = envE
, reqExp = reqE
}
clauses <- mapM (go sdc) resources
return $ Clause
[VarP envName, VarP reqName]
(NormalB $ helperE `AppE` pathInfo)
[FunD helperName $ clauses ++ [clause404']]
where
handlePiece :: (CheckOverlap, Piece a) -> Q (Pat, Maybe Exp)
handlePiece (_, Static str) = return (LitP $ StringL str, Nothing)
handlePiece (_, Dynamic _) = do
x <- newName "dyn"
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
return (pat, Just $ VarE x)
handlePieces :: [(CheckOverlap, Piece a)] -> Q ([Pat], [Exp])
handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece
mkCon :: String -> [Exp] -> Exp
mkCon name = foldl' AppE (ConE $ mkName name)
mkPathPat :: Pat -> [Pat] -> Pat
mkPathPat final =
foldr addPat final
where
addPat x y = ConP '(:) [x, y]
go :: SDC -> ResourceTree a -> Q Clause
go sdc (ResourceParent name pieces children) = do
(pats, dyns) <- handlePieces pieces
let sdc' = sdc
{ extraParams = extraParams sdc ++ dyns
, extraCons = extraCons sdc ++ [mkCon name dyns]
}
childClauses <- mapM (go sdc') children
restName <- newName "rest"
let restE = VarE restName
restP = VarP restName
helperName <- newName "helper"
let helperE = VarE helperName
return $ Clause
[mkPathPat restP pats]
(NormalB $ helperE `AppE` restE)
[FunD helperName $ childClauses ++ [clause404 sdc]]
go SDC {..} (ResourceLeaf (Resource name pieces dispatch _)) = do
(pats, dyns) <- handlePieces pieces
(chooseMethod, finalPat) <- handleDispatch dispatch dyns
return $ Clause
[mkPathPat finalPat pats]
(NormalB chooseMethod)
[]
where
handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat)
handleDispatch dispatch dyns =
case dispatch of
Methods multi methods -> do
(finalPat, mfinalE) <-
case multi of
Nothing -> return (ConP '[] [], Nothing)
Just _ -> do
multiName <- newName "multi"
let pat = ViewP (VarE 'fromPathMultiPiece)
(ConP 'Just [VarP multiName])
return (pat, Just $ VarE multiName)
let dynsMulti =
case mfinalE of
Nothing -> dyns
Just e -> dyns ++ [e]
route' = foldl' AppE (ConE (mkName name)) dynsMulti
route = foldr AppE route' extraCons
jroute = ConE 'Just `AppE` route
allDyns = extraParams ++ dynsMulti
mkRunExp mmethod = do
runHandlerE <- mdsRunHandler
handlerE' <- mdsGetHandler mmethod name
let handlerE = foldl' AppE handlerE' allDyns
return $ runHandlerE
`AppE` handlerE
`AppE` envExp
`AppE` jroute
`AppE` reqExp
func <-
case methods of
[] -> mkRunExp Nothing
_ -> do
getMethod <- mdsMethod
let methodE = getMethod `AppE` reqExp
matches <- forM methods $ \method -> do
exp <- mkRunExp (Just method)
return $ Match (LitP $ StringL method) (NormalB exp) []
match405 <- do
runHandlerE <- mdsRunHandler
handlerE <- mds405
let exp = runHandlerE
`AppE` handlerE
`AppE` envExp
`AppE` jroute
`AppE` reqExp
return $ Match WildP (NormalB exp) []
return $ CaseE methodE $ matches ++ [match405]
return (func, finalPat)
Subsite _ getSub -> do
restPath <- newName "restPath"
setPathInfoE <- mdsSetPathInfo
subDispatcherE <- mdsSubDispatcher
runHandlerE <- mdsRunHandler
sub <- newName "sub"
let sub2 = LamE [VarP sub]
(foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns)
let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp
route' = foldl' AppE (ConE (mkName name)) dyns
route = foldr AppE route' extraCons
exp = subDispatcherE
`AppE` runHandlerE
`AppE` sub2
`AppE` route
`AppE` envExp
`AppE` reqExp'
return (exp, VarP restPath)
mkClause404 envE reqE = do
handler <- mds404
runHandler <- mdsRunHandler
let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE
return $ Clause [WildP] (NormalB exp) []

9
yesod-routes/test/Hierarchy.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -6,6 +7,7 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hierarchy module Hierarchy
( hierarchy ( hierarchy
, Dispatcher (..) , Dispatcher (..)
@ -27,6 +29,9 @@ import qualified Yesod.Routes.Class as YRC
import Data.Text (Text, pack, unpack, append) import Data.Text (Text, pack, unpack, append)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
#if SIMPLE_DISPATCH
import Yesod.Routes.TH.Simple
#endif
class ToText a where class ToText a where
toText :: a -> Text toText :: a -> Text
@ -108,7 +113,11 @@ do
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
#if SIMPLE_DISPATCH
dispatch <- mkSimpleDispatchClause MkDispatchSettings
#else
dispatch <- mkDispatchClause MkDispatchSettings dispatch <- mkDispatchClause MkDispatchSettings
#endif
{ mdsRunHandler = [|runHandler|] { mdsRunHandler = [|runHandler|]
, mdsSubDispatcher = [|subDispatch|] , mdsSubDispatcher = [|subDispatch|]
, mdsGetPathInfo = [|fst|] , mdsGetPathInfo = [|fst|]

9
yesod-routes/test/main.hs
View File

@ -10,6 +10,8 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -ddump-splices #-}
import Test.Hspec import Test.Hspec
import Test.HUnit ((@?=)) import Test.HUnit ((@?=))
import Data.Text (Text, pack, unpack, singleton) import Data.Text (Text, pack, unpack, singleton)
@ -24,6 +26,9 @@ import Language.Haskell.TH.Syntax
import Hierarchy import Hierarchy
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.Set as Set import qualified Data.Set as Set
#if SIMPLE_DISPATCH
import Yesod.Routes.TH.Simple
#endif
result :: ([Text] -> Maybe Int) -> Dispatch Int result :: ([Text] -> Maybe Int) -> Dispatch Int
result f ts = f ts result f ts = f ts
@ -125,7 +130,11 @@ do
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
prinst <- mkParseRouteInstance (ConT ''MyApp) ress prinst <- mkParseRouteInstance (ConT ''MyApp) ress
#if SIMPLE_DISPATCH
dispatch <- mkSimpleDispatchClause MkDispatchSettings
#else
dispatch <- mkDispatchClause MkDispatchSettings dispatch <- mkDispatchClause MkDispatchSettings
#endif
{ mdsRunHandler = [|runHandler|] { mdsRunHandler = [|runHandler|]
, mdsSubDispatcher = [|subDispatch dispatcher|] , mdsSubDispatcher = [|subDispatch dispatcher|]
, mdsGetPathInfo = [|fst|] , mdsGetPathInfo = [|fst|]

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

@ -1,5 +1,5 @@
name: yesod-routes name: yesod-routes
version: 1.2.0.6 version: 1.2.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -21,9 +21,11 @@ library
, containers >= 0.2 , containers >= 0.2
, template-haskell , template-haskell
, path-pieces >= 0.1 && < 0.2 , path-pieces >= 0.1 && < 0.2
, bytestring
exposed-modules: Yesod.Routes.Dispatch exposed-modules: Yesod.Routes.Dispatch
Yesod.Routes.TH Yesod.Routes.TH
Yesod.Routes.TH.Simple
Yesod.Routes.Class Yesod.Routes.Class
Yesod.Routes.Parse Yesod.Routes.Parse
Yesod.Routes.Overlap Yesod.Routes.Overlap

32
yesod/Yesod/Default/Main.hs
View File

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

4
yesod/yesod.cabal
View File

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