http-enumerator 0.5
This commit is contained in:
Michael Snoyman
parent
fb9ec3c412
commit
572df52d03
@ -29,10 +29,10 @@ import Network.HTTP.Enumerator
|
||||
import qualified Data.ByteString.Lazy.UTF8 as BSLU
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Control.Arrow (first, (***))
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Failure (Failure (failure))
|
||||
import Control.Monad (mplus, liftM)
|
||||
import Network.Wai (ciOriginal)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
data Discovery = Discovery1 String (Maybe String)
|
||||
| Discovery2 Provider Identifier IdentType
|
||||
@ -69,11 +69,11 @@ discoverYADIS :: ( MonadIO m
|
||||
discoverYADIS _ _ 0 = failure TooManyRedirects
|
||||
discoverYADIS ident mb_loc redirects = do
|
||||
let uri = fromMaybe (identifier ident) mb_loc
|
||||
req <- parseUrl uri
|
||||
res <- httpLbs req
|
||||
req <- parseUrl $ S8.pack uri
|
||||
res <- liftIO $ withManager $ httpLbs req
|
||||
let mloc = fmap S8.unpack
|
||||
$ lookup "x-xrds-location"
|
||||
$ map (first $ map toLower . S8.unpack . ciOriginal)
|
||||
$ map (first $ map toLower . S8.unpack . CI.original)
|
||||
$ responseHeaders res
|
||||
let mloc' = if mloc == mb_loc then Nothing else mloc
|
||||
case statusCode res of
|
||||
@ -117,7 +117,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m)
|
||||
=> Identifier
|
||||
-> m (Maybe Discovery)
|
||||
discoverHTML ident'@(Identifier ident) =
|
||||
(parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident
|
||||
(parseHTML ident' . BSLU.toString) `liftM` simpleHttp (S8.pack ident)
|
||||
|
||||
-- | Parse out an OpenID endpoint and an actual identifier from an HTML
|
||||
-- document.
|
||||
|
||||
@ -11,6 +11,7 @@ import Data.Data (Data)
|
||||
import Data.Typeable (Typeable)
|
||||
import Control.Exception (Exception, throwIO)
|
||||
import Data.Attoparsec.Lazy (parse, eitherResult)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
||||
data Facebook = Facebook
|
||||
{ facebookClientId :: String
|
||||
@ -48,7 +49,7 @@ accessTokenUrl fb code = concat
|
||||
getAccessToken :: Facebook -> String -> IO AccessToken
|
||||
getAccessToken fb code = do
|
||||
let url = accessTokenUrl fb code
|
||||
b <- simpleHttp url
|
||||
b <- simpleHttp $ S8.pack url
|
||||
let (front, back) = splitAt 13 $ L8.unpack b
|
||||
case front of
|
||||
"access_token=" -> return $ AccessToken back
|
||||
@ -65,7 +66,7 @@ graphUrl (AccessToken s) func = concat
|
||||
getGraphData :: AccessToken -> String -> IO (Either String Value)
|
||||
getGraphData at func = do
|
||||
let url = graphUrl at func
|
||||
b <- simpleHttp url
|
||||
b <- simpleHttp $ S8.pack url
|
||||
return $ eitherResult $ parse json b
|
||||
|
||||
getGraphData' :: AccessToken -> String -> IO Value
|
||||
|
||||
@ -30,9 +30,15 @@ import Data.Digest.Pure.SHA
|
||||
import Data.ByteString.Base64
|
||||
import Data.Time
|
||||
import Numeric
|
||||
import Network.Wai (ResponseHeader)
|
||||
import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))
|
||||
|
||||
import Network.HTTP.Types (Header)
|
||||
import Control.Arrow (second)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Data.Enumerator (($$), run_, Stream (..), continue)
|
||||
import Data.Monoid (mconcat)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Data.IORef (newIORef, readIORef, atomicModifyIORef)
|
||||
|
||||
-- | Data type for OAuth client (consumer).
|
||||
data OAuth = OAuth { oauthServerName :: String -- ^ Service name
|
||||
@ -85,9 +91,9 @@ fromStrict = BSL.fromChunks . return
|
||||
getTemporaryCredential :: OAuth -- ^ OAuth Application
|
||||
-> IO Credential -- ^ Temporary Credential (Request Token & Secret).
|
||||
getTemporaryCredential oa = do
|
||||
let req = fromJust $ parseUrl (oauthRequestUri oa)
|
||||
let req = fromJust $ parseUrl $ S8.pack $ oauthRequestUri oa
|
||||
req' <- signOAuth oa emptyCredential (req { method = "POST" })
|
||||
rsp <- httpLbs req'
|
||||
rsp <- withManager $ httpLbs req'
|
||||
let dic = parseQueryString . toStrict . responseBody $ rsp
|
||||
return $ Credential dic
|
||||
|
||||
@ -103,8 +109,8 @@ getAccessToken, getTokenCredential
|
||||
-> Credential -- ^ Temporary Credential with oauth_verifier
|
||||
-> IO Credential -- ^ Token Credential (Access Token & Secret)
|
||||
getAccessToken oa cr = do
|
||||
let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
|
||||
rsp <- signOAuth oa cr req >>= httpLbs
|
||||
let req = (fromJust $ parseUrl $ S8.pack $ oauthAccessTokenUri oa) { method = "POST" }
|
||||
rsp <- signOAuth oa cr req >>= withManager . httpLbs
|
||||
let dic = parseQueryString . toStrict . responseBody $ rsp
|
||||
return $ Credential dic
|
||||
|
||||
@ -136,12 +142,12 @@ delete key = Credential . deleteMap key . unCredential
|
||||
-- | Add OAuth headers & sign to 'Request'.
|
||||
signOAuth :: OAuth -- ^ OAuth Application
|
||||
-> Credential -- ^ Credential
|
||||
-> Request -- ^ Original Request
|
||||
-> IO Request -- ^ Signed OAuth Request
|
||||
-> Request IO -- ^ Original Request
|
||||
-> IO (Request IO) -- ^ Signed OAuth Request
|
||||
signOAuth oa crd req = do
|
||||
crd' <- addTimeStamp =<< addNonce crd
|
||||
let tok = injectOAuthToCred oa crd'
|
||||
sign = genSign oa tok req
|
||||
sign <- genSign oa tok req
|
||||
return $ addAuthHeader (insert "oauth_signature" sign tok) req
|
||||
|
||||
baseTime :: UTCTime
|
||||
@ -171,19 +177,19 @@ injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa
|
||||
, ("oauth_version", "1.0")
|
||||
] cred
|
||||
|
||||
genSign :: OAuth -> Credential -> Request -> BS.ByteString
|
||||
genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString
|
||||
genSign oa tok req =
|
||||
case oauthSignatureMethod oa of
|
||||
HMACSHA1 ->
|
||||
let text = getBaseString tok req
|
||||
key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
|
||||
in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text
|
||||
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 ->
|
||||
BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
|
||||
return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
|
||||
RSASHA1 pr ->
|
||||
encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req)
|
||||
liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)
|
||||
|
||||
addAuthHeader :: Credential -> Request -> Request
|
||||
addAuthHeader :: Credential -> Request a -> Request a
|
||||
addAuthHeader (Credential cred) req =
|
||||
req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req }
|
||||
|
||||
@ -199,24 +205,44 @@ paramEncode = BS.concatMap escape
|
||||
oct = '%' : replicate (2 - length num) '0' ++ num
|
||||
in BS.pack oct
|
||||
|
||||
getBaseString :: Credential -> Request -> BSL.ByteString
|
||||
getBaseString tok req =
|
||||
getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString
|
||||
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 = queryString req
|
||||
bsBodyQ = if isBodyFormEncoded $ requestHeaders req
|
||||
then parseQueryString (toStrict $ requestBody req) else []
|
||||
bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok
|
||||
bsQuery = map (second $ fromMaybe "") $ queryString req
|
||||
bsBodyQ <- if isBodyFormEncoded $ requestHeaders req
|
||||
then liftM parseQueryString $ toLBS (requestBody req)
|
||||
else return []
|
||||
let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).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
|
||||
in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
|
||||
-- FIXME it would be much better to use http-types functions here
|
||||
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
|
||||
|
||||
isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> Bool
|
||||
toLBS :: MonadIO m => RequestBody m -> m BS.ByteString
|
||||
toLBS (RequestBodyLBS l) = return $ toStrict l
|
||||
toLBS (RequestBodyBS s) = return s
|
||||
toLBS (RequestBodyBuilder _ b) = return $ toByteString b
|
||||
toLBS (RequestBodyEnum _ enum) = do
|
||||
i <- liftIO $ newIORef id
|
||||
run_ $ enum $$ go i
|
||||
liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i
|
||||
where
|
||||
go i =
|
||||
continue go'
|
||||
where
|
||||
go' (Chunks []) = continue go'
|
||||
go' (Chunks x) = do
|
||||
liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ()))
|
||||
continue go'
|
||||
go' EOF = return ()
|
||||
|
||||
isBodyFormEncoded :: [Header] -> Bool
|
||||
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"
|
||||
|
||||
compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering
|
||||
|
||||
@ -14,10 +14,11 @@ import OpenId2.Types
|
||||
import Web.Authenticate.Internal (qsUrl)
|
||||
import Control.Monad (unless)
|
||||
import qualified Data.ByteString.UTF8 as BSU
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy.UTF8 as BSLU
|
||||
import Network.HTTP.Enumerator
|
||||
( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
|
||||
, HttpException
|
||||
, HttpException, withManager
|
||||
)
|
||||
import Control.Arrow ((***))
|
||||
import Data.List (unfoldr)
|
||||
@ -87,9 +88,9 @@ authenticate params = do
|
||||
let params' = map (BSU.fromString *** BSU.fromString)
|
||||
$ ("openid.mode", "check_authentication")
|
||||
: filter (\(k, _) -> k /= "openid.mode") params
|
||||
req' <- parseUrl endpoint
|
||||
req' <- parseUrl $ S8.pack endpoint
|
||||
let req = urlEncodedBody params' req'
|
||||
rsp <- httpLbsRedirect req
|
||||
rsp <- liftIO $ withManager $ httpLbsRedirect req
|
||||
let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
|
||||
case lookup "is_valid" rps of
|
||||
Just "true" -> return (Identifier ident, rps)
|
||||
|
||||
@ -71,9 +71,10 @@ authenticate apiKey token = do
|
||||
, requestHeaders =
|
||||
[ ("Content-Type", "application/x-www-form-urlencoded")
|
||||
]
|
||||
, requestBody = body
|
||||
, requestBody = RequestBodyLBS body
|
||||
, checkCerts = const $ return True
|
||||
}
|
||||
res <- httpLbsRedirect req
|
||||
res <- liftIO $ withManager $ httpLbsRedirect req
|
||||
let b = responseBody res
|
||||
unless (200 <= statusCode res && statusCode res < 300) $
|
||||
liftIO $ throwIO $ StatusCodeException (statusCode res) b
|
||||
|
||||
@ -16,7 +16,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master
|
||||
library
|
||||
build-depends: base >= 4 && < 5,
|
||||
aeson >= 0.3.1.1 && < 0.4,
|
||||
http-enumerator >= 0.3.0 && < 0.4,
|
||||
http-enumerator >= 0.5.1 && < 0.6,
|
||||
tagsoup >= 0.6 && < 0.13,
|
||||
failure >= 0.0.0 && < 0.2,
|
||||
transformers >= 0.1 && < 0.3,
|
||||
@ -24,7 +24,7 @@ library
|
||||
utf8-string >= 0.3 && < 0.4,
|
||||
network >= 2.2.1 && < 2.4,
|
||||
xml >= 1.3.7 && < 1.4,
|
||||
wai >= 0.3 && < 0.4,
|
||||
case-insensitive >= 0.2 && < 0.3,
|
||||
RSA >= 1.0 && < 1.1,
|
||||
time >= 1.1 && < 1.3,
|
||||
base64-bytestring >= 0.1 && < 0.2,
|
||||
@ -32,6 +32,9 @@ library
|
||||
random >= 1.0 && < 1.1,
|
||||
wai-extra >= 0.3 && < 0.4,
|
||||
text >= 0.5 && < 1.0,
|
||||
http-types >= 0.6 && < 0.7,
|
||||
enumerator >= 0.4.7 && < 0.5,
|
||||
blaze-builder >= 0.2 && < 0.4,
|
||||
attoparsec >= 0.8.5 && < 0.9
|
||||
exposed-modules: Web.Authenticate.Rpxnow,
|
||||
Web.Authenticate.OpenId,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user