Merge remote-tracking branch 'origin/simpler-dispatch' into persistent2-simpler-dispatch
This commit is contained in:
Michael Snoyman
commit
84baab6fb5
3
.gitignore
vendored
3
.gitignore
vendored
@ -12,3 +12,6 @@ cabal.sandbox.config
|
||||
/vendor/
|
||||
/.shelly/
|
||||
/tarballs/
|
||||
*.swp
|
||||
dist
|
||||
client_session_key.aes
|
||||
|
||||
@ -9,3 +9,7 @@ script:
|
||||
- echo Done
|
||||
- cabal-meta install --enable-tests
|
||||
- mega-sdist --test
|
||||
- cabal install mega-sdist hspec cabal-meta cabal-src
|
||||
- cabal-meta install --force-reinstalls
|
||||
|
||||
script: mega-sdist --test
|
||||
|
||||
15
README
Normal file
15
README
Normal 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
6
authenticate-oauth/.gitignore
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
.DS_Store
|
||||
*.hi
|
||||
*.o
|
||||
dist
|
||||
*~
|
||||
cabal-dev
|
||||
25
authenticate-oauth/LICENSE
Normal file
25
authenticate-oauth/LICENSE
Normal 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
7
authenticate-oauth/Setup.lhs
Executable 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
455
authenticate-oauth/Web/Authenticate/OAuth.hs
Normal 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
95
authenticate-oauth/Web/Authenticate/OAuth/IO.hs
Normal 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
39
authenticate-oauth/authenticate-oauth.cabal
Normal 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
25
authenticate/LICENSE
Normal 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
159
authenticate/OpenId2/Discovery.hs
Normal 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
69
authenticate/OpenId2/Normalization.hs
Normal 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
34
authenticate/OpenId2/Types.hs
Normal 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
77
authenticate/OpenId2/XRDS.hs
Normal 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
7
authenticate/Setup.lhs
Executable 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
40
authenticate/Web/Authenticate/BrowserId.hs
Normal 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
15
authenticate/Web/Authenticate/Internal.hs
Normal 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
164
authenticate/Web/Authenticate/OpenId.hs
Normal 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
44
authenticate/Web/Authenticate/OpenId/Providers.hs
Normal 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
103
authenticate/Web/Authenticate/Rpxnow.hs
Normal 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
48
authenticate/authenticate.cabal
Normal 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
45
authenticate/browserid.hs
Normal 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
91
authenticate/openid2.hs
Normal 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
38
authenticate/rpxnow.hs
Normal 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
|
||||
@ -9,3 +9,5 @@
|
||||
./yesod-test
|
||||
./yesod-bin
|
||||
./yesod
|
||||
./authenticate
|
||||
./yesod-eventsource
|
||||
|
||||
@ -3,7 +3,7 @@ version: 1.2.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Hiromi Ishii
|
||||
maintainer: Hiromi Ishii
|
||||
maintainer: Michael Litchard
|
||||
synopsis: OAuth Authentication for Yesod.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
@ -24,7 +24,7 @@ library
|
||||
, bytestring >= 0.9.1.4
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, text >= 0.7 && < 0.12
|
||||
, text >= 0.7 && < 1.1
|
||||
, yesod-form >= 1.3 && < 1.4
|
||||
, transformers >= 0.2.2 && < 0.4
|
||||
, lifted-base >= 0.2 && < 0.3
|
||||
|
||||
@ -18,6 +18,11 @@
|
||||
-- Stability : Stable
|
||||
-- Portability : Portable
|
||||
--
|
||||
-- /WARNING/: This module was /not/ designed with security in mind, and is not
|
||||
-- suitable for production sites. In the near future, it will likely be either
|
||||
-- deprecated or rewritten to have a more secure implementation. For more
|
||||
-- information, see: <https://github.com/yesodweb/yesod/issues/668>.
|
||||
--
|
||||
-- A yesod-auth AuthPlugin designed to look users up in Persist where
|
||||
-- their user id's and a salted SHA1 hash of their password is stored.
|
||||
--
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-auth
|
||||
version: 1.2.5.2
|
||||
version: 1.2.5.3
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
|
||||
@ -42,7 +42,11 @@ import MonadUtils (liftIO)
|
||||
import Panic (throwGhcException, panic)
|
||||
import SrcLoc (Located, mkGeneralLocated)
|
||||
import qualified StaticFlags
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
import DynFlags (ldInputs)
|
||||
#else
|
||||
import StaticFlags (v_Ld_inputs)
|
||||
#endif
|
||||
import System.FilePath (normalise, (</>))
|
||||
import Util (consIORef, looksLikeModuleName)
|
||||
|
||||
@ -162,7 +166,15 @@ buildPackage' argv2 ld ar = do
|
||||
o_files <- mapM (\x -> compileFile hsc_env StopLn x)
|
||||
#endif
|
||||
non_hs_srcs
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
let dflags4 = dflags3
|
||||
{ ldInputs = map (DF.FileOption "") (reverse o_files)
|
||||
++ ldInputs dflags3
|
||||
}
|
||||
GHC.setSessionDynFlags dflags4
|
||||
#else
|
||||
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
|
||||
#endif
|
||||
targets <- mapM (uncurry GHC.guessTarget) hs_srcs
|
||||
GHC.setTargets targets
|
||||
ok_flag <- GHC.load GHC.LoadAllTargets
|
||||
|
||||
@ -35,7 +35,8 @@ import Network.Wai.Middleware.RequestLogger
|
||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||
import qualified Database.Persist
|
||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
||||
import System.Log.FastLogger (newLoggerSet, defaultBufSize)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
||||
import Network.Wai.Logger (clockDateCacher)
|
||||
import Data.Default (def)
|
||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||
@ -53,7 +54,7 @@ mkYesodDispatch "App" resourcesApp
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
|
||||
makeApplication conf = do
|
||||
foundation <- makeFoundation conf
|
||||
|
||||
@ -68,7 +69,8 @@ makeApplication conf = do
|
||||
|
||||
-- Create the WAI application and apply middlewares
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
let logFunc = messageLoggerSource foundation (appLogger foundation)
|
||||
return (logWare app, logFunc)
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
@ -81,8 +83,18 @@ makeFoundation conf = do
|
||||
Database.Persist.applyEnv
|
||||
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
|
||||
|
||||
loggerSet' <- newLoggerSet defaultBufSize Nothing
|
||||
(getter, _) <- clockDateCacher
|
||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||
(getter, updater) <- clockDateCacher
|
||||
|
||||
-- If the Yesod logger (as opposed to the request logger middleware) is
|
||||
-- used less than once a second on average, you may prefer to omit this
|
||||
-- thread and use "(updater >> getter)" in place of "getter" below. That
|
||||
-- would update the cache every time it is used, instead of every second.
|
||||
let updateLoop = do
|
||||
threadDelay 1000000
|
||||
updater
|
||||
updateLoop
|
||||
_ <- forkIO updateLoop
|
||||
|
||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||
foundation = App conf s p manager dbconf logger
|
||||
@ -92,7 +104,7 @@ makeFoundation conf = do
|
||||
-- for yesod devel
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev =
|
||||
defaultDevelApp loader makeApplication
|
||||
defaultDevelApp loader (fmap fst . makeApplication)
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
@ -226,7 +238,10 @@ instance YesodAuth App where
|
||||
case x of
|
||||
Just (Entity uid _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
fmap Just $ insert User
|
||||
{ userIdent = credsIdent creds
|
||||
, userPassword = Nothing
|
||||
}
|
||||
|
||||
-- You can add other plugins like BrowserID, email or OAuth here
|
||||
authPlugins _ = [authBrowserId def, authGoogleEmail]
|
||||
@ -387,7 +402,7 @@ library
|
||||
DeriveDataTypeable
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.2 && < 1.3
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
@ -413,7 +428,7 @@ library
|
||||
, aeson >= 0.6 && < 0.8
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.1 && < 2.2
|
||||
, fast-logger >= 2.1.4 && < 2.2
|
||||
, wai-logger >= 2.1 && < 2.2
|
||||
|
||||
executable PROJECTNAME
|
||||
@ -580,12 +595,12 @@ combineScripts = combineScripts' development combineSettings
|
||||
{-# START_FILE app/main.hs #-}
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Default.Main (defaultMainLog)
|
||||
import Settings (parseExtra)
|
||||
import Application (makeApplication)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain (fromArgs parseExtra) makeApplication
|
||||
main = defaultMainLog (fromArgs parseExtra) makeApplication
|
||||
|
||||
{-# START_FILE BASE64 config/favicon.ico #-}
|
||||
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
|
||||
|
||||
@ -37,7 +37,8 @@ import qualified Database.Persist
|
||||
import Database.Persist.Sql (runMigration)
|
||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
||||
import Control.Monad.Logger (runLoggingT)
|
||||
import System.Log.FastLogger (newLoggerSet, defaultBufSize)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
||||
import Network.Wai.Logger (clockDateCacher)
|
||||
import Data.Default (def)
|
||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||
@ -55,7 +56,7 @@ mkYesodDispatch "App" resourcesApp
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
|
||||
makeApplication conf = do
|
||||
foundation <- makeFoundation conf
|
||||
|
||||
@ -70,7 +71,8 @@ makeApplication conf = do
|
||||
|
||||
-- Create the WAI application and apply middlewares
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
let logFunc = messageLoggerSource foundation (appLogger foundation)
|
||||
return (logWare app, logFunc)
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
@ -83,8 +85,18 @@ makeFoundation conf = do
|
||||
Database.Persist.applyEnv
|
||||
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
|
||||
|
||||
loggerSet' <- newLoggerSet defaultBufSize Nothing
|
||||
(getter, _) <- clockDateCacher
|
||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||
(getter, updater) <- clockDateCacher
|
||||
|
||||
-- If the Yesod logger (as opposed to the request logger middleware) is
|
||||
-- used less than once a second on average, you may prefer to omit this
|
||||
-- thread and use "(updater >> getter)" in place of "getter" below. That
|
||||
-- would update the cache every time it is used, instead of every second.
|
||||
let updateLoop = do
|
||||
threadDelay 1000000
|
||||
updater
|
||||
updateLoop
|
||||
_ <- forkIO updateLoop
|
||||
|
||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||
foundation = App conf s p manager dbconf logger
|
||||
@ -99,7 +111,7 @@ makeFoundation conf = do
|
||||
-- for yesod devel
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev =
|
||||
defaultDevelApp loader makeApplication
|
||||
defaultDevelApp loader (fmap fst . makeApplication)
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
@ -235,7 +247,10 @@ instance YesodAuth App where
|
||||
case x of
|
||||
Just (Entity uid _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
fmap Just $ insert User
|
||||
{ userIdent = credsIdent creds
|
||||
, userPassword = Nothing
|
||||
}
|
||||
|
||||
-- You can add other plugins like BrowserID, email or OAuth here
|
||||
authPlugins _ = [authBrowserId def, authGoogleEmail]
|
||||
@ -391,7 +406,7 @@ library
|
||||
DeriveDataTypeable
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.2 && < 1.3
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
@ -417,7 +432,7 @@ library
|
||||
, aeson >= 0.6 && < 0.8
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.1 && < 2.2
|
||||
, fast-logger >= 2.1.4 && < 2.2
|
||||
, wai-logger >= 2.1 && < 2.2
|
||||
|
||||
executable PROJECTNAME
|
||||
@ -584,12 +599,12 @@ combineScripts = combineScripts' development combineSettings
|
||||
{-# START_FILE app/main.hs #-}
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Default.Main (defaultMainLog)
|
||||
import Settings (parseExtra)
|
||||
import Application (makeApplication)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain (fromArgs parseExtra) makeApplication
|
||||
main = defaultMainLog (fromArgs parseExtra) makeApplication
|
||||
|
||||
{-# START_FILE BASE64 config/favicon.ico #-}
|
||||
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
|
||||
|
||||
@ -39,7 +39,8 @@ import Database.Persist.Sql (runMigration)
|
||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
||||
import Yesod.Fay (getFaySite)
|
||||
import Control.Monad.Logger (runLoggingT)
|
||||
import System.Log.FastLogger (newLoggerSet, defaultBufSize)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
||||
import Network.Wai.Logger (clockDateCacher)
|
||||
import Data.Default (def)
|
||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||
@ -58,7 +59,7 @@ mkYesodDispatch "App" resourcesApp
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
|
||||
makeApplication conf = do
|
||||
foundation <- makeFoundation conf
|
||||
|
||||
@ -73,7 +74,8 @@ makeApplication conf = do
|
||||
|
||||
-- Create the WAI application and apply middlewares
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
let logFunc = messageLoggerSource foundation (appLogger foundation)
|
||||
return (logWare app, logFunc)
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
@ -86,8 +88,18 @@ makeFoundation conf = do
|
||||
Database.Persist.applyEnv
|
||||
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
|
||||
|
||||
loggerSet' <- newLoggerSet defaultBufSize Nothing
|
||||
(getter, _) <- clockDateCacher
|
||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||
(getter, updater) <- clockDateCacher
|
||||
|
||||
-- If the Yesod logger (as opposed to the request logger middleware) is
|
||||
-- used less than once a second on average, you may prefer to omit this
|
||||
-- thread and use "(updater >> getter)" in place of "getter" below. That
|
||||
-- would update the cache every time it is used, instead of every second.
|
||||
let updateLoop = do
|
||||
threadDelay 1000000
|
||||
updater
|
||||
updateLoop
|
||||
_ <- forkIO updateLoop
|
||||
|
||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||
foundation = App conf s p manager dbconf onCommand logger
|
||||
@ -102,7 +114,7 @@ makeFoundation conf = do
|
||||
-- for yesod devel
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev =
|
||||
defaultDevelApp loader makeApplication
|
||||
defaultDevelApp loader (fmap fst . makeApplication)
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
@ -248,7 +260,10 @@ instance YesodAuth App where
|
||||
case x of
|
||||
Just (Entity uid _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
fmap Just $ insert User
|
||||
{ userIdent = credsIdent creds
|
||||
, userPassword = Nothing
|
||||
}
|
||||
|
||||
-- You can add other plugins like BrowserID, email or OAuth here
|
||||
authPlugins _ = [authBrowserId def, authGoogleEmail]
|
||||
@ -427,7 +442,7 @@ library
|
||||
DeriveDataTypeable
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.2 && < 1.3
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
@ -454,7 +469,7 @@ library
|
||||
, aeson >= 0.6 && < 0.8
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.1 && < 2.2
|
||||
, fast-logger >= 2.1.4 && < 2.2
|
||||
, wai-logger >= 2.1 && < 2.2
|
||||
|
||||
executable PROJECTNAME
|
||||
@ -633,12 +648,12 @@ combineScripts = combineScripts' development combineSettings
|
||||
{-# START_FILE app/main.hs #-}
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Default.Main (defaultMainLog)
|
||||
import Settings (parseExtra)
|
||||
import Application (makeApplication)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain (fromArgs parseExtra) makeApplication
|
||||
main = defaultMainLog (fromArgs parseExtra) makeApplication
|
||||
|
||||
{-# START_FILE BASE64 config/favicon.ico #-}
|
||||
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
|
||||
|
||||
@ -37,7 +37,8 @@ import qualified Database.Persist
|
||||
import Database.Persist.Sql (runMigration)
|
||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
||||
import Control.Monad.Logger (runLoggingT)
|
||||
import System.Log.FastLogger (newLoggerSet, defaultBufSize)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
||||
import Network.Wai.Logger (clockDateCacher)
|
||||
import Data.Default (def)
|
||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||
@ -55,7 +56,7 @@ mkYesodDispatch "App" resourcesApp
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
|
||||
makeApplication conf = do
|
||||
foundation <- makeFoundation conf
|
||||
|
||||
@ -70,7 +71,8 @@ makeApplication conf = do
|
||||
|
||||
-- Create the WAI application and apply middlewares
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
let logFunc = messageLoggerSource foundation (appLogger foundation)
|
||||
return (logWare app, logFunc)
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
@ -83,8 +85,18 @@ makeFoundation conf = do
|
||||
Database.Persist.applyEnv
|
||||
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
|
||||
|
||||
loggerSet' <- newLoggerSet defaultBufSize Nothing
|
||||
(getter, _) <- clockDateCacher
|
||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||
(getter, updater) <- clockDateCacher
|
||||
|
||||
-- If the Yesod logger (as opposed to the request logger middleware) is
|
||||
-- used less than once a second on average, you may prefer to omit this
|
||||
-- thread and use "(updater >> getter)" in place of "getter" below. That
|
||||
-- would update the cache every time it is used, instead of every second.
|
||||
let updateLoop = do
|
||||
threadDelay 1000000
|
||||
updater
|
||||
updateLoop
|
||||
_ <- forkIO updateLoop
|
||||
|
||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||
foundation = App conf s p manager dbconf logger
|
||||
@ -99,7 +111,7 @@ makeFoundation conf = do
|
||||
-- for yesod devel
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev =
|
||||
defaultDevelApp loader makeApplication
|
||||
defaultDevelApp loader (fmap fst . makeApplication)
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
@ -235,7 +247,10 @@ instance YesodAuth App where
|
||||
case x of
|
||||
Just (Entity uid _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
fmap Just $ insert User
|
||||
{ userIdent = credsIdent creds
|
||||
, userPassword = Nothing
|
||||
}
|
||||
|
||||
-- You can add other plugins like BrowserID, email or OAuth here
|
||||
authPlugins _ = [authBrowserId def, authGoogleEmail]
|
||||
@ -391,7 +406,7 @@ library
|
||||
DeriveDataTypeable
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.2 && < 1.3
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
@ -417,7 +432,7 @@ library
|
||||
, aeson >= 0.6 && < 0.8
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.1 && < 2.2
|
||||
, fast-logger >= 2.1.4 && < 2.2
|
||||
, wai-logger >= 2.1 && < 2.2
|
||||
|
||||
executable PROJECTNAME
|
||||
@ -584,12 +599,12 @@ combineScripts = combineScripts' development combineSettings
|
||||
{-# START_FILE app/main.hs #-}
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Default.Main (defaultMainLog)
|
||||
import Settings (parseExtra)
|
||||
import Application (makeApplication)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain (fromArgs parseExtra) makeApplication
|
||||
main = defaultMainLog (fromArgs parseExtra) makeApplication
|
||||
|
||||
{-# START_FILE BASE64 config/favicon.ico #-}
|
||||
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
|
||||
|
||||
@ -32,7 +32,8 @@ import Network.Wai.Middleware.RequestLogger
|
||||
)
|
||||
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
||||
import System.Log.FastLogger (newLoggerSet, defaultBufSize)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
||||
import Network.Wai.Logger (clockDateCacher)
|
||||
import Data.Default (def)
|
||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||
@ -50,7 +51,7 @@ mkYesodDispatch "App" resourcesApp
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
|
||||
makeApplication conf = do
|
||||
foundation <- makeFoundation conf
|
||||
|
||||
@ -65,7 +66,8 @@ makeApplication conf = do
|
||||
|
||||
-- Create the WAI application and apply middlewares
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
let logFunc = messageLoggerSource foundation (appLogger foundation)
|
||||
return (logWare app, logFunc)
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
@ -74,8 +76,18 @@ makeFoundation conf = do
|
||||
manager <- newManager conduitManagerSettings
|
||||
s <- staticSite
|
||||
|
||||
loggerSet' <- newLoggerSet defaultBufSize Nothing
|
||||
(getter, _) <- clockDateCacher
|
||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||
(getter, updater) <- clockDateCacher
|
||||
|
||||
-- If the Yesod logger (as opposed to the request logger middleware) is
|
||||
-- used less than once a second on average, you may prefer to omit this
|
||||
-- thread and use "(updater >> getter)" in place of "getter" below. That
|
||||
-- would update the cache every time it is used, instead of every second.
|
||||
let updateLoop = do
|
||||
threadDelay 1000000
|
||||
updater
|
||||
updateLoop
|
||||
_ <- forkIO updateLoop
|
||||
|
||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||
foundation = App conf s manager logger
|
||||
@ -85,7 +97,7 @@ makeFoundation conf = do
|
||||
-- for yesod devel
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev =
|
||||
defaultDevelApp loader makeApplication
|
||||
defaultDevelApp loader (fmap fst . makeApplication)
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
@ -321,7 +333,7 @@ library
|
||||
DeriveDataTypeable
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.2 && < 1.3
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
@ -344,7 +356,7 @@ library
|
||||
, aeson >= 0.6 && < 0.8
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.1 && < 2.2
|
||||
, fast-logger >= 2.1.4 && < 2.2
|
||||
, wai-logger >= 2.1 && < 2.2
|
||||
|
||||
executable PROJECTNAME
|
||||
@ -502,12 +514,12 @@ combineScripts = combineScripts' development combineSettings
|
||||
{-# START_FILE app/main.hs #-}
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Default.Main (defaultMainLog)
|
||||
import Settings (parseExtra)
|
||||
import Application (makeApplication)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain (fromArgs parseExtra) makeApplication
|
||||
main = defaultMainLog (fromArgs parseExtra) makeApplication
|
||||
|
||||
{-# START_FILE BASE64 config/favicon.ico #-}
|
||||
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
|
||||
|
||||
@ -37,7 +37,8 @@ import qualified Database.Persist
|
||||
import Database.Persist.Sql (runMigration)
|
||||
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
|
||||
import Control.Monad.Logger (runLoggingT)
|
||||
import System.Log.FastLogger (newLoggerSet, defaultBufSize)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
|
||||
import Network.Wai.Logger (clockDateCacher)
|
||||
import Data.Default (def)
|
||||
import Yesod.Core.Types (loggerSet, Logger (Logger))
|
||||
@ -55,7 +56,7 @@ mkYesodDispatch "App" resourcesApp
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
|
||||
makeApplication conf = do
|
||||
foundation <- makeFoundation conf
|
||||
|
||||
@ -70,7 +71,8 @@ makeApplication conf = do
|
||||
|
||||
-- Create the WAI application and apply middlewares
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
let logFunc = messageLoggerSource foundation (appLogger foundation)
|
||||
return (logWare app, logFunc)
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
@ -83,8 +85,18 @@ makeFoundation conf = do
|
||||
Database.Persist.applyEnv
|
||||
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
|
||||
|
||||
loggerSet' <- newLoggerSet defaultBufSize Nothing
|
||||
(getter, _) <- clockDateCacher
|
||||
loggerSet' <- newStdoutLoggerSet defaultBufSize
|
||||
(getter, updater) <- clockDateCacher
|
||||
|
||||
-- If the Yesod logger (as opposed to the request logger middleware) is
|
||||
-- used less than once a second on average, you may prefer to omit this
|
||||
-- thread and use "(updater >> getter)" in place of "getter" below. That
|
||||
-- would update the cache every time it is used, instead of every second.
|
||||
let updateLoop = do
|
||||
threadDelay 1000000
|
||||
updater
|
||||
updateLoop
|
||||
_ <- forkIO updateLoop
|
||||
|
||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||
foundation = App conf s p manager dbconf logger
|
||||
@ -99,7 +111,7 @@ makeFoundation conf = do
|
||||
-- for yesod devel
|
||||
getApplicationDev :: IO (Int, Application)
|
||||
getApplicationDev =
|
||||
defaultDevelApp loader makeApplication
|
||||
defaultDevelApp loader (fmap fst . makeApplication)
|
||||
where
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
@ -235,7 +247,10 @@ instance YesodAuth App where
|
||||
case x of
|
||||
Just (Entity uid _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
fmap Just $ insert User
|
||||
{ userIdent = credsIdent creds
|
||||
, userPassword = Nothing
|
||||
}
|
||||
|
||||
-- You can add other plugins like BrowserID, email or OAuth here
|
||||
authPlugins _ = [authBrowserId def, authGoogleEmail]
|
||||
@ -391,7 +406,7 @@ library
|
||||
DeriveDataTypeable
|
||||
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod >= 1.2 && < 1.3
|
||||
, yesod >= 1.2.5 && < 1.3
|
||||
, yesod-core >= 1.2 && < 1.3
|
||||
, yesod-auth >= 1.2 && < 1.3
|
||||
, yesod-static >= 1.2 && < 1.3
|
||||
@ -417,7 +432,7 @@ library
|
||||
, aeson >= 0.6 && < 0.8
|
||||
, conduit >= 1.0 && < 2.0
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, fast-logger >= 2.1 && < 2.2
|
||||
, fast-logger >= 2.1.4 && < 2.2
|
||||
, wai-logger >= 2.1 && < 2.2
|
||||
|
||||
executable PROJECTNAME
|
||||
@ -584,12 +599,12 @@ combineScripts = combineScripts' development combineSettings
|
||||
{-# START_FILE app/main.hs #-}
|
||||
import Prelude (IO)
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Default.Main (defaultMainLog)
|
||||
import Settings (parseExtra)
|
||||
import Application (makeApplication)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain (fromArgs parseExtra) makeApplication
|
||||
main = defaultMainLog (fromArgs parseExtra) makeApplication
|
||||
|
||||
{-# START_FILE BASE64 config/favicon.ico #-}
|
||||
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
|
||||
|
||||
@ -24,4 +24,4 @@ Take part in the community: http://yesodweb.com/page/community
|
||||
|
||||
Start your project:
|
||||
|
||||
cd PROJECTNAME && cabal sandbox init && cabal install && yesod devel
|
||||
cd PROJECTNAME && cabal sandbox init && cabal install --enable-tests . yesod-platform yesod-bin --max-backjumps=-1 --reorder-goals && yesod devel
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-bin
|
||||
version: 1.2.5.6
|
||||
version: 1.2.6
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
|
||||
@ -516,7 +516,7 @@ defaultErrorHandler (BadMethod m) = selectRep $ do
|
||||
<h1>Method Not Supported
|
||||
<p>Method <code>#{S8.unpack m}</code> not supported
|
||||
|]
|
||||
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
|
||||
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
|
||||
@ -41,7 +41,7 @@ import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Monoid (mappend)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
@ -118,6 +118,10 @@ toWaiAppYre yre req =
|
||||
toWaiApp :: YesodDispatch site => site -> IO W.Application
|
||||
toWaiApp site = do
|
||||
logger <- makeLogger site
|
||||
toWaiAppLogger logger site
|
||||
|
||||
toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
|
||||
toWaiAppLogger logger site = do
|
||||
sb <- makeSessionBackend site
|
||||
let yre = YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
@ -144,19 +148,29 @@ toWaiApp site = do
|
||||
--
|
||||
-- Since 1.2.0
|
||||
warp :: YesodDispatch site => Int -> site -> IO ()
|
||||
warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
|
||||
Network.Wai.Handler.Warp.defaultSettings
|
||||
{ Network.Wai.Handler.Warp.settingsPort = port
|
||||
{- FIXME
|
||||
, Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
|
||||
[ "Warp/"
|
||||
, Network.Wai.Handler.Warp.warpVersion
|
||||
, " + Yesod/"
|
||||
, showVersion Paths_yesod_core.version
|
||||
, " (core)"
|
||||
]
|
||||
-}
|
||||
}
|
||||
warp port site = do
|
||||
logger <- makeLogger site
|
||||
toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
|
||||
Network.Wai.Handler.Warp.defaultSettings
|
||||
{ Network.Wai.Handler.Warp.settingsPort = port
|
||||
{- FIXME
|
||||
, Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
|
||||
[ "Warp/"
|
||||
, Network.Wai.Handler.Warp.warpVersion
|
||||
, " + 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.
|
||||
--
|
||||
|
||||
@ -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
|
||||
-- is never (realistically) expired.
|
||||
neverExpires :: MonadHandler m => m ()
|
||||
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
|
||||
neverExpires = do
|
||||
setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
|
||||
cacheSeconds oneYear
|
||||
where
|
||||
oneYear :: Int
|
||||
oneYear = 60 * 60 * 24 * 365
|
||||
|
||||
-- | Set an Expires header in the past, meaning this content should not be
|
||||
-- cached.
|
||||
|
||||
@ -10,7 +10,8 @@ module Yesod.Core.Internal.Run where
|
||||
import Yesod.Core.Internal.Response
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (fromException, bracketOnError)
|
||||
import Control.Exception (fromException, bracketOnError, evaluate)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
@ -94,7 +95,9 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
|
||||
YRWai _ -> return yar
|
||||
let sendFile' ct fp p =
|
||||
return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
|
||||
case contents of
|
||||
contents1 <- evaluate contents `E.catch` \e -> return
|
||||
(HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
|
||||
case contents1 of
|
||||
HCContent status (TypedContent ct c) -> do
|
||||
ec' <- liftIO $ evaluateContent c
|
||||
case ec' of
|
||||
|
||||
@ -17,6 +17,7 @@ import Data.ByteString.Lazy.Char8 ()
|
||||
import Data.List (foldl')
|
||||
|
||||
import Yesod.Routes.TH
|
||||
import Yesod.Routes.TH.Simple (mkSimpleDispatchClause)
|
||||
import Yesod.Routes.Parse
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Content
|
||||
@ -115,7 +116,7 @@ mkDispatchInstance :: Type -- ^ The master site type
|
||||
-> [ResourceTree a] -- ^ The resource
|
||||
-> DecsQ
|
||||
mkDispatchInstance master res = do
|
||||
clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
|
||||
clause' <- mkSimpleDispatchClause (mkMDS [|yesodRunner|]) res
|
||||
let thisDispatch = FunD 'yesodDispatch [clause']
|
||||
return [InstanceD [] yDispatch [thisDispatch]]
|
||||
where
|
||||
@ -123,7 +124,7 @@ mkDispatchInstance master res = do
|
||||
|
||||
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
|
||||
mkYesodSubDispatch res = do
|
||||
clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
|
||||
clause' <- mkSimpleDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
|
||||
inner <- newName "inner"
|
||||
let innerFun = FunD inner [clause']
|
||||
helper <- newName "helper"
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||
module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -24,6 +24,11 @@ mkYesod "App" [parseRoutes|
|
||||
/error-in-body ErrorInBodyR GET
|
||||
/error-in-body-noeval ErrorInBodyNoEvalR GET
|
||||
/override-status OverrideStatusR GET
|
||||
|
||||
-- https://github.com/yesodweb/yesod/issues/658
|
||||
/builder BuilderR GET
|
||||
/file-bad-len FileBadLenR GET
|
||||
/file-bad-name FileBadNameR GET
|
||||
|]
|
||||
|
||||
overrideStatus = mkStatus 15 "OVERRIDE"
|
||||
@ -74,6 +79,15 @@ getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR
|
||||
getOverrideStatusR :: Handler ()
|
||||
getOverrideStatusR = invalidArgs ["OVERRIDE"]
|
||||
|
||||
getBuilderR :: Handler TypedContent
|
||||
getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing
|
||||
|
||||
getFileBadLenR :: Handler TypedContent
|
||||
getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen")
|
||||
|
||||
getFileBadNameR :: Handler TypedContent
|
||||
getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
|
||||
|
||||
errorHandlingTest :: Spec
|
||||
errorHandlingTest = describe "Test.ErrorHandling" $ do
|
||||
it "says not found" caseNotFound
|
||||
@ -82,6 +96,9 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
|
||||
it "error in body == 500" caseErrorInBody
|
||||
it "error in body, no eval == 200" caseErrorInBodyNoEval
|
||||
it "can override status code" caseOverrideStatus
|
||||
it "builder" caseBuilder
|
||||
it "file with bad len" caseFileBadLen
|
||||
it "file with bad name" caseFileBadName
|
||||
|
||||
runner :: Session () -> IO ()
|
||||
runner f = toWaiApp App >>= runSession f
|
||||
@ -140,3 +157,21 @@ caseOverrideStatus :: IO ()
|
||||
caseOverrideStatus = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["override-status"] }
|
||||
assertStatus 15 res
|
||||
|
||||
caseBuilder :: IO ()
|
||||
caseBuilder = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["builder"] }
|
||||
assertStatus 500 res
|
||||
assertBodyContains "builder-3.14159" res
|
||||
|
||||
caseFileBadLen :: IO ()
|
||||
caseFileBadLen = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["file-bad-len"] }
|
||||
assertStatus 500 res
|
||||
assertBodyContains "filebadlen" res
|
||||
|
||||
caseFileBadName :: IO ()
|
||||
caseFileBadName = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["file-bad-name"] }
|
||||
assertStatus 500 res
|
||||
assertBodyContains "filebadname" res
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
|
||||
module YesodCoreTest.Json (specs, Widget) where
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||
module YesodCoreTest.Links (linksTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module YesodCoreTest.Media (mediaTest, Widget) where
|
||||
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
|
||||
module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
|
||||
module YesodCoreTest.Reps (specs, Widget) where
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||
module YesodCoreTest.Widget (widgetTest) where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-core
|
||||
version: 1.2.6.4
|
||||
version: 1.2.7
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
|
||||
@ -108,7 +108,7 @@ intField = Field
|
||||
|
||||
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
@ -125,7 +125,7 @@ doubleField = Field
|
||||
|
||||
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@ -4,6 +4,7 @@ module Yesod.Form.Input
|
||||
( FormInput (..)
|
||||
, runInputGet
|
||||
, runInputPost
|
||||
, runInputPostResult
|
||||
, ireq
|
||||
, iopt
|
||||
) where
|
||||
@ -66,11 +67,22 @@ toMap :: [(Text, a)] -> Map.Map Text [a]
|
||||
toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
|
||||
|
||||
runInputPost :: MonadHandler m => FormInput m a -> m a
|
||||
runInputPost (FormInput f) = do
|
||||
runInputPost fi = do
|
||||
emx <- runInputPostHelper fi
|
||||
case emx of
|
||||
Left errs -> invalidArgs errs
|
||||
Right x -> return x
|
||||
|
||||
runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)
|
||||
runInputPostResult fi = do
|
||||
emx <- runInputPostHelper fi
|
||||
case emx of
|
||||
Left errs -> return $ FormFailure errs
|
||||
Right x -> return $ FormSuccess x
|
||||
|
||||
runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
|
||||
runInputPostHelper (FormInput f) = do
|
||||
(env, fenv) <- liftM (toMap *** toMap) runRequestBody
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
emx <- f m l env fenv
|
||||
case emx of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
fmap (either (Left . ($ [])) Right) $ f m l env fenv
|
||||
|
||||
@ -11,7 +11,7 @@ module Yesod.Form.MassInput
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Functions
|
||||
import Yesod.Form.Fields (boolField)
|
||||
import Yesod.Form.Fields (checkBoxField)
|
||||
import Yesod.Core
|
||||
import Control.Monad.Trans.RWS (get, put, ask)
|
||||
import Data.Maybe (fromMaybe)
|
||||
@ -97,7 +97,7 @@ $newline never
|
||||
<input type=hidden name=#{deleteName} value=yes>
|
||||
|]
|
||||
_ -> do
|
||||
(_, xml2) <- aFormToForm $ areq boolField FieldSettings
|
||||
(_, xml2) <- aFormToForm $ areq checkBoxField FieldSettings
|
||||
{ fsLabel = SomeMessage MsgDelete
|
||||
, fsTooltip = Nothing
|
||||
, fsName = Just deleteName
|
||||
|
||||
@ -102,7 +102,7 @@ instance Monad m => Applicative (AForm m) where
|
||||
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
|
||||
(a, b, ints', c) <- f mr env ints
|
||||
(x, y, ints'', z) <- g mr env ints'
|
||||
return (a <*> x, b `mappend` y, ints'', c `mappend` z)
|
||||
return (a <*> x, b . y, ints'', c `mappend` z)
|
||||
instance (Monad m, Monoid a) => Monoid (AForm m a) where
|
||||
mempty = pure mempty
|
||||
mappend a b = mappend <$> a <*> b
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-form
|
||||
version: 1.3.4.2
|
||||
version: 1.3.5.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
|
||||
@ -62,7 +62,7 @@ template Feed {..} render =
|
||||
: Element "link" (Map.singleton "href" $ render feedLinkHome) []
|
||||
: Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
|
||||
: Element "id" Map.empty [NodeContent $ render feedLinkHome]
|
||||
: Element "author" Map.empty [NodeContent feedAuthor]
|
||||
: Element "author" Map.empty [NodeElement $ Element "name" Map.empty [NodeContent feedAuthor]]
|
||||
: map (flip entryTemplate render) feedEntries
|
||||
|
||||
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-newsfeed
|
||||
version: 1.2.0
|
||||
version: 1.2.0.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
|
||||
@ -7,4 +7,4 @@ then
|
||||
cabal install cabal-nirvana -fgenerate
|
||||
fi
|
||||
|
||||
cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text | runghc to-cabal.hs > yesod-platform.cabal
|
||||
cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text esqueleto warp-tls hjsmin | runghc to-cabal.hs > yesod-platform.cabal
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-platform
|
||||
version: 1.2.5.3
|
||||
version: 1.2.7.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,41 +14,41 @@ homepage: http://www.yesodweb.com/
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, SHA == 1.6.1
|
||||
, aeson == 0.6.2.1
|
||||
, ansi-terminal == 0.6.1
|
||||
, asn1-data == 0.7.1
|
||||
, SHA == 1.6.4
|
||||
, aeson == 0.7.0.1
|
||||
, ansi-terminal == 0.6.1.1
|
||||
, asn1-encoding == 0.8.1.2
|
||||
, asn1-parse == 0.8.1
|
||||
, asn1-types == 0.2.3
|
||||
, attoparsec == 0.10.4.0
|
||||
, attoparsec == 0.11.1.0
|
||||
, attoparsec-conduit == 1.0.1.2
|
||||
, authenticate == 1.3.2.6
|
||||
, base-unicode-symbols == 0.2.2.4
|
||||
, base64-bytestring == 1.0.0.1
|
||||
, blaze-builder == 0.3.3.2
|
||||
, blaze-builder-conduit == 1.0.0
|
||||
, blaze-html == 0.6.1.2
|
||||
, blaze-markup == 0.5.1.6
|
||||
, blaze-html == 0.7.0.1
|
||||
, blaze-markup == 0.6.0.0
|
||||
, byteable == 0.1.1
|
||||
, byteorder == 1.0.4
|
||||
, case-insensitive == 1.1.0.2
|
||||
, case-insensitive == 1.1.0.3
|
||||
, cereal == 0.4.0.1
|
||||
, certificate == 1.3.9
|
||||
, cipher-aes == 0.2.6
|
||||
, cipher-rc4 == 0.1.4
|
||||
, clientsession == 0.9.0.3
|
||||
, conduit == 1.0.9.3
|
||||
, connection == 0.1.3.1
|
||||
, conduit == 1.0.14
|
||||
, connection == 0.2.0
|
||||
, control-monad-loop == 0.1
|
||||
, cookie == 0.4.0.1
|
||||
, cprng-aes == 0.5.2
|
||||
, crypto-api == 0.12.2.2
|
||||
, crypto-api == 0.13
|
||||
, crypto-cipher-types == 0.0.9
|
||||
, crypto-conduit == 0.5.2.1
|
||||
, crypto-conduit == 0.5.2.2
|
||||
, crypto-numbers == 0.2.3
|
||||
, crypto-pubkey == 0.2.4
|
||||
, crypto-pubkey-types == 0.4.1
|
||||
, crypto-random == 0.0.7
|
||||
, cryptohash == 0.11.1
|
||||
, cryptohash == 0.11.2
|
||||
, cryptohash-cryptoapi == 0.1.0
|
||||
, css-text == 0.1.1
|
||||
, data-default == 0.5.3
|
||||
@ -58,37 +58,38 @@ library
|
||||
, data-default-instances-dlist == 0.0.1
|
||||
, data-default-instances-old-locale == 0.0.1
|
||||
, dlist == 0.6.0.1
|
||||
, email-validate == 1.0.0
|
||||
, email-validate == 2.0.1
|
||||
, entropy == 0.2.2.4
|
||||
, esqueleto == 1.3.4.5
|
||||
, failure == 0.2.0.1
|
||||
, fast-logger == 2.1.0
|
||||
, fast-logger == 2.1.5
|
||||
, file-embed == 0.0.6
|
||||
, filesystem-conduit == 1.0.0.1
|
||||
, hamlet == 1.1.7.6
|
||||
, hjsmin == 0.1.4.4
|
||||
, hspec == 1.8.1.1
|
||||
, hamlet == 1.1.7.7
|
||||
, hjsmin == 0.1.4.5
|
||||
, hspec == 1.8.3
|
||||
, hspec-expectations == 0.5.0.1
|
||||
, html-conduit == 1.1.0.1
|
||||
, http-attoparsec == 0.1.0
|
||||
, http-client == 0.2.0.3
|
||||
, http-client == 0.2.2.2
|
||||
, http-client-conduit == 0.2.0.1
|
||||
, http-client-tls == 0.2.0.2
|
||||
, http-conduit == 2.0.0.3
|
||||
, http-client-tls == 0.2.1.1
|
||||
, http-conduit == 2.0.0.5
|
||||
, http-date == 0.0.4
|
||||
, http-types == 0.8.3
|
||||
, language-javascript == 0.5.8
|
||||
, lifted-base == 0.2.1.1
|
||||
, mime-mail == 0.4.3
|
||||
, lifted-base == 0.2.2.0
|
||||
, mime-mail == 0.4.4
|
||||
, mime-types == 0.1.0.3
|
||||
, mmorph == 1.0.0
|
||||
, monad-control == 0.3.2.2
|
||||
, mmorph == 1.0.2
|
||||
, monad-control == 0.3.2.3
|
||||
, monad-logger == 0.3.4.0
|
||||
, monad-loops == 0.4.2
|
||||
, network-conduit == 1.0.0
|
||||
, network-conduit == 1.0.2.2
|
||||
, optparse-applicative == 0.7.0.2
|
||||
, path-pieces == 0.1.3.1
|
||||
, pem == 0.2.1
|
||||
, persistent == 1.3.0
|
||||
, persistent-template == 1.3.0
|
||||
, persistent == 1.3.0.2
|
||||
, persistent-template == 1.3.1.1
|
||||
, pool-conduit == 0.1.2
|
||||
, primitive == 0.5.1.0
|
||||
, process-conduit == 1.0.0.1
|
||||
@ -98,28 +99,29 @@ library
|
||||
, quickcheck-io == 0.1.0
|
||||
, resource-pool == 0.2.1.1
|
||||
, resourcet == 0.4.10
|
||||
, safe == 0.3.3
|
||||
, safe == 0.3.4
|
||||
, scientific == 0.2.0.1
|
||||
, securemem == 0.1.3
|
||||
, semigroups == 0.12.1
|
||||
, setenv == 0.1.1
|
||||
, semigroups == 0.12.2
|
||||
, setenv == 0.1.1.1
|
||||
, shakespeare == 1.2.0.4
|
||||
, shakespeare-css == 1.0.6.6
|
||||
, shakespeare-i18n == 1.0.0.5
|
||||
, shakespeare-js == 1.2.0.2
|
||||
, shakespeare-text == 1.0.0.10
|
||||
, shakespeare-js == 1.2.0.3
|
||||
, shakespeare-text == 1.0.1
|
||||
, silently == 1.2.4.1
|
||||
, simple-sendfile == 0.2.13
|
||||
, skein == 1.0.8
|
||||
, skein == 1.0.8.1
|
||||
, socks == 0.5.4
|
||||
, stm-chans == 3.0.0
|
||||
, stringsearch == 0.3.6.5
|
||||
, system-fileio == 0.3.11
|
||||
, system-filepath == 0.4.8
|
||||
, system-fileio == 0.3.12
|
||||
, system-filepath == 0.4.9
|
||||
, tagged == 0.7
|
||||
, tagsoup == 0.13
|
||||
, tagstream-conduit == 0.5.4.1
|
||||
, tls == 1.1.5
|
||||
, tls-extra == 0.6.6
|
||||
, tagsoup == 0.13.1
|
||||
, tagstream-conduit == 0.5.5
|
||||
, text-stream-decode == 0.1.0.3
|
||||
, tls == 1.2.2
|
||||
, transformers-base == 0.4.1
|
||||
, unix-compat == 0.4.1.1
|
||||
, unordered-containers == 0.2.3.3
|
||||
@ -129,21 +131,26 @@ library
|
||||
, void == 0.6.1
|
||||
, wai == 2.0.0
|
||||
, wai-app-static == 2.0.0.2
|
||||
, wai-extra == 2.0.1.2
|
||||
, wai-logger == 2.1.0
|
||||
, wai-extra == 2.0.3.3
|
||||
, wai-logger == 2.1.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
|
||||
, 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-types == 0.3.4
|
||||
, xss-sanitize == 0.3.4.1
|
||||
, yaml == 0.8.5.2
|
||||
, yesod == 1.2.4
|
||||
, yesod-auth == 1.2.5.2
|
||||
, yesod-core == 1.2.6.4
|
||||
, yesod-form == 1.3.4.2
|
||||
, xss-sanitize == 0.3.4.2
|
||||
, yaml == 0.8.7.2
|
||||
, yesod == 1.2.5
|
||||
, yesod-auth == 1.2.5.3
|
||||
, yesod-core == 1.2.6.7
|
||||
, yesod-form == 1.3.5.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-test == 1.2.1
|
||||
, zlib-bindings == 0.1.1.3
|
||||
|
||||
178
yesod-routes/Yesod/Routes/TH/Simple.hs
Normal file
178
yesod-routes/Yesod/Routes/TH/Simple.hs
Normal 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) []
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
@ -6,6 +7,7 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Hierarchy
|
||||
( hierarchy
|
||||
, Dispatcher (..)
|
||||
@ -27,6 +29,9 @@ import qualified Yesod.Routes.Class as YRC
|
||||
import Data.Text (Text, pack, unpack, append)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
#if SIMPLE_DISPATCH
|
||||
import Yesod.Routes.TH.Simple
|
||||
#endif
|
||||
|
||||
class ToText a where
|
||||
toText :: a -> Text
|
||||
@ -108,7 +113,11 @@ do
|
||||
|
||||
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
#if SIMPLE_DISPATCH
|
||||
dispatch <- mkSimpleDispatchClause MkDispatchSettings
|
||||
#else
|
||||
dispatch <- mkDispatchClause MkDispatchSettings
|
||||
#endif
|
||||
{ mdsRunHandler = [|runHandler|]
|
||||
, mdsSubDispatcher = [|subDispatch|]
|
||||
, mdsGetPathInfo = [|fst|]
|
||||
|
||||
@ -10,6 +10,8 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -ddump-splices #-}
|
||||
import Test.Hspec
|
||||
import Test.HUnit ((@?=))
|
||||
import Data.Text (Text, pack, unpack, singleton)
|
||||
@ -24,6 +26,9 @@ import Language.Haskell.TH.Syntax
|
||||
import Hierarchy
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.Set as Set
|
||||
#if SIMPLE_DISPATCH
|
||||
import Yesod.Routes.TH.Simple
|
||||
#endif
|
||||
|
||||
result :: ([Text] -> Maybe Int) -> Dispatch Int
|
||||
result f ts = f ts
|
||||
@ -125,7 +130,11 @@ do
|
||||
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
|
||||
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
|
||||
prinst <- mkParseRouteInstance (ConT ''MyApp) ress
|
||||
#if SIMPLE_DISPATCH
|
||||
dispatch <- mkSimpleDispatchClause MkDispatchSettings
|
||||
#else
|
||||
dispatch <- mkDispatchClause MkDispatchSettings
|
||||
#endif
|
||||
{ mdsRunHandler = [|runHandler|]
|
||||
, mdsSubDispatcher = [|subDispatch dispatcher|]
|
||||
, mdsGetPathInfo = [|fst|]
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-routes
|
||||
version: 1.2.0.6
|
||||
version: 1.2.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -21,9 +21,11 @@ library
|
||||
, containers >= 0.2
|
||||
, template-haskell
|
||||
, path-pieces >= 0.1 && < 0.2
|
||||
, bytestring
|
||||
|
||||
exposed-modules: Yesod.Routes.Dispatch
|
||||
Yesod.Routes.TH
|
||||
Yesod.Routes.TH.Simple
|
||||
Yesod.Routes.Class
|
||||
Yesod.Routes.Parse
|
||||
Yesod.Routes.Overlap
|
||||
|
||||
@ -1,15 +1,19 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Default.Main
|
||||
( defaultMain
|
||||
, defaultMainLog
|
||||
, defaultRunner
|
||||
, defaultDevelApp
|
||||
, LogFunc
|
||||
) where
|
||||
|
||||
import Yesod.Default.Config
|
||||
import Network.Wai (Application)
|
||||
import Network.Wai.Handler.Warp
|
||||
(runSettings, defaultSettings, settingsPort, settingsHost)
|
||||
(runSettings, defaultSettings, settingsPort, settingsHost, settingsOnException)
|
||||
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
|
||||
import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles, def)
|
||||
import Network.Wai.Middleware.Autohead (autohead)
|
||||
@ -18,6 +22,9 @@ import Control.Monad (when)
|
||||
import System.Environment (getEnvironment)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Safe (readMay)
|
||||
import Control.Monad.Logger (Loc, LogSource, LogLevel (LevelError), liftLoc)
|
||||
import System.Log.FastLogger (LogStr, toLogStr)
|
||||
import Language.Haskell.TH.Syntax (qLocation)
|
||||
|
||||
#ifndef WINDOWS
|
||||
import qualified System.Posix.Signals as Signal
|
||||
@ -45,6 +52,29 @@ defaultMain load getApp = do
|
||||
, settingsHost = appHost config
|
||||
} app
|
||||
|
||||
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
|
||||
-- | Same as @defaultMain@, but gets a logging function back as well as an
|
||||
-- @Application@ to install Warp exception handlers.
|
||||
--
|
||||
-- Since 1.2.5
|
||||
defaultMainLog :: (Show env, Read env)
|
||||
=> IO (AppConfig env extra)
|
||||
-> (AppConfig env extra -> IO (Application, LogFunc))
|
||||
-> IO ()
|
||||
defaultMainLog load getApp = do
|
||||
config <- load
|
||||
(app, logFunc) <- getApp config
|
||||
runSettings defaultSettings
|
||||
{ settingsPort = appPort config
|
||||
, settingsHost = appHost config
|
||||
, settingsOnException = const $ \e -> logFunc
|
||||
$(qLocation >>= liftLoc)
|
||||
"yesod"
|
||||
LevelError
|
||||
(toLogStr $ "Exception from Warp: " ++ show e)
|
||||
} app
|
||||
|
||||
-- | Run your application continously, listening for SIGINT and exiting
|
||||
-- when received
|
||||
--
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod
|
||||
version: 1.2.4
|
||||
version: 1.2.5
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -46,6 +46,8 @@ library
|
||||
, directory
|
||||
, template-haskell
|
||||
, bytestring
|
||||
, monad-logger
|
||||
, fast-logger
|
||||
|
||||
exposed-modules: Yesod
|
||||
, Yesod.Default.Config
|
||||
|
||||
Loading…
Reference in New Issue
Block a user