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

All functions take Manager (where relevant)

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-09 16:07:30 +02:00
parent 36d811c582
commit 2a903feca1
8 changed files with 131 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
OpenId2/Discovery.hs
View File

@ -27,11 +27,11 @@ import Debug.Trace
import Data.Char import Data.Char
import Data.Maybe import Data.Maybe
import Network.HTTP.Conduit import Network.HTTP.Conduit
import Data.Conduit (ResourceT, ResourceIO)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Control.Arrow (first) import Control.Arrow (first)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Failure (Failure (failure)) import Control.Monad (mplus)
import Control.Monad (mplus, liftM)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Text.Lazy (toStrict) import Data.Text.Lazy (toStrict)
@ -41,36 +41,39 @@ import Data.Text.Encoding.Error (lenientDecode)
import Text.HTML.TagSoup (parseTags, Tag (TagOpen)) import Text.HTML.TagSoup (parseTags, Tag (TagOpen))
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Network.HTTP.Types (status200) import Network.HTTP.Types (status200)
import Control.Exception (throwIO)
data Discovery = Discovery1 Text (Maybe Text) data Discovery = Discovery1 Text (Maybe Text)
| Discovery2 Provider Identifier IdentType | Discovery2 Provider Identifier IdentType
deriving Show deriving Show
-- | Attempt to resolve an OpenID endpoint, and user identifier. -- | Attempt to resolve an OpenID endpoint, and user identifier.
discover :: Identifier -> IO Discovery discover :: ResourceIO m => Identifier -> Manager -> ResourceT m Discovery
discover ident@(Identifier i) = do discover ident@(Identifier i) manager = do
res1 <- discoverYADIS ident Nothing 10 res1 <- discoverYADIS ident Nothing 10 manager
case res1 of case res1 of
Just (x, y, z) -> return $ Discovery2 x y z Just (x, y, z) -> return $ Discovery2 x y z
Nothing -> do Nothing -> do
res2 <- discoverHTML ident res2 <- discoverHTML ident manager
case res2 of case res2 of
Just x -> return x Just x -> return x
Nothing -> failure $ DiscoveryException $ unpack i Nothing -> liftIO $ throwIO $ DiscoveryException $ unpack i
-- YADIS-Based Discovery ------------------------------------------------------- -- YADIS-Based Discovery -------------------------------------------------------
-- | Attempt a YADIS based discovery, given a valid identifier. The result is -- | Attempt a YADIS based discovery, given a valid identifier. The result is
-- an OpenID endpoint, and the actual identifier for the user. -- an OpenID endpoint, and the actual identifier for the user.
discoverYADIS :: Identifier discoverYADIS :: ResourceIO m
=> Identifier
-> Maybe String -> Maybe String
-> Int -- ^ remaining redirects -> Int -- ^ remaining redirects
-> IO (Maybe (Provider, Identifier, IdentType)) -> Manager
discoverYADIS _ _ 0 = failure TooManyRedirects -> ResourceT m (Maybe (Provider, Identifier, IdentType))
discoverYADIS ident mb_loc redirects = do discoverYADIS _ _ 0 _ = liftIO $ throwIO TooManyRedirects
discoverYADIS ident mb_loc redirects manager = do
let uri = fromMaybe (unpack $ identifier ident) mb_loc let uri = fromMaybe (unpack $ identifier ident) mb_loc
req <- parseUrl uri req <- liftIO $ parseUrl uri
res <- liftIO $ withManager $ httpLbs req { checkStatus = \_ _ -> Nothing } res <- httpLbs req { checkStatus = \_ _ -> Nothing } manager
let mloc = fmap S8.unpack let mloc = fmap S8.unpack
$ lookup "x-xrds-location" $ lookup "x-xrds-location"
$ map (first $ map toLower . S8.unpack . CI.original) $ map (first $ map toLower . S8.unpack . CI.original)
@ -79,7 +82,7 @@ discoverYADIS ident mb_loc redirects = do
if statusCode res == status200 if statusCode res == status200
then then
case mloc' of case mloc' of
Just loc -> discoverYADIS ident (Just loc) (redirects - 1) Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager
Nothing -> do Nothing -> do
let mdoc = parseXRDS $ responseBody res let mdoc = parseXRDS $ responseBody res
case mdoc of case mdoc of
@ -113,9 +116,11 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
-- | Attempt to discover an OpenID endpoint, from an HTML document. The result -- | 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. -- will be an endpoint on success, and the actual identifier of the user.
discoverHTML :: Identifier -> IO (Maybe Discovery) discoverHTML :: ResourceIO m => Identifier -> Manager -> ResourceT m (Maybe Discovery)
discoverHTML ident'@(Identifier ident) = discoverHTML ident'@(Identifier ident) manager = do
(parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident) req <- liftIO $ parseUrl $ unpack ident
Response _ _ lbs <- httpLbs req manager
return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs
-- | Parse out an OpenID endpoint and an actual identifier from an HTML -- | Parse out an OpenID endpoint and an actual identifier from an HTML
-- document. -- document.

7
OpenId2/Normalization.hs
View File

@ -21,18 +21,19 @@ import OpenId2.Types
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Data.List import Data.List
import Control.Failure (Failure (..))
import Network.URI import Network.URI
( uriToString, normalizeCase, normalizeEscape ( uriToString, normalizeCase, normalizeEscape
, normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment
) )
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
import Control.Monad.IO.Class
import Control.Exception (throwIO)
normalize :: Failure AuthenticateException m => Text -> m Identifier normalize :: MonadIO m => Text -> m Identifier
normalize ident = normalize ident =
case normalizeIdentifier $ Identifier ident of case normalizeIdentifier $ Identifier ident of
Just i -> return i Just i -> return i
Nothing -> failure $ NormalizationException $ unpack ident Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident
-- | Normalize an identifier, discarding XRIs. -- | Normalize an identifier, discarding XRIs.
normalizeIdentifier :: Identifier -> Maybe Identifier normalizeIdentifier :: Identifier -> Maybe Identifier

16
Web/Authenticate/BrowserId.hs
View File

@ -5,26 +5,30 @@ module Web.Authenticate.BrowserId
) where ) where
import Data.Text (Text) import Data.Text (Text)
import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody) import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, Manager, method, urlEncodedBody)
import Data.Conduit (ResourceT, ResourceIO)
import Data.Aeson (json, Value (Object, String)) import Data.Aeson (json, Value (Object, String))
import Data.Attoparsec.Lazy (parse, maybeResult) import Data.Attoparsec.Lazy (parse, maybeResult)
import qualified Data.HashMap.Lazy as Map import qualified Data.HashMap.Lazy as Map
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Control.Monad.IO.Class (liftIO)
-- | Location of the Javascript file hosted by browserid.org -- | Location of the Javascript file hosted by browserid.org
browserIdJs :: Text browserIdJs :: Text
browserIdJs = "https://browserid.org/include.js" browserIdJs = "https://browserid.org/include.js"
checkAssertion :: Text -- ^ audience checkAssertion :: ResourceIO m
=> Text -- ^ audience
-> Text -- ^ assertion -> Text -- ^ assertion
-> IO (Maybe Text) -> Manager
checkAssertion audience assertion = do -> ResourceT m (Maybe Text)
req' <- parseUrl "https://browserid.org/verify" checkAssertion audience assertion manager = do
req' <- liftIO $ parseUrl "https://browserid.org/verify"
let req = urlEncodedBody let req = urlEncodedBody
[ ("audience", encodeUtf8 audience) [ ("audience", encodeUtf8 audience)
, ("assertion", encodeUtf8 assertion) , ("assertion", encodeUtf8 assertion)
] req' { method = "POST" } ] req' { method = "POST" }
res <- withManager $ httpLbs req res <- httpLbs req manager
let lbs = responseBody res let lbs = responseBody res
return $ maybeResult (parse json lbs) >>= getEmail return $ maybeResult (parse json lbs) >>= getEmail
where where

20
Web/Authenticate/Facebook.hs
View File

@ -14,6 +14,8 @@ module Web.Authenticate.Facebook
) where ) where
import Network.HTTP.Conduit import Network.HTTP.Conduit
import Data.Conduit (ResourceT)
import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Types (parseSimpleQuery) import Network.HTTP.Types (parseSimpleQuery)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
@ -76,10 +78,11 @@ accessTokenUrl fb code =
, ("client_secret", Just $ facebookClientSecret fb) , ("client_secret", Just $ facebookClientSecret fb)
] ]
getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken :: Facebook -> Text -> Manager -> ResourceT IO AccessToken
getAccessToken fb code = do getAccessToken fb code manager = do
let url = accessTokenUrl fb code let url = accessTokenUrl fb code
b <- simpleHttp $ S8.unpack url req <- liftIO $ parseUrl $ S8.unpack url
Response _ _ b <- httpLbs req manager
let params = parseSimpleQuery $ S8.concat $ L8.toChunks b let params = parseSimpleQuery $ S8.concat $ L8.toChunks b
case lookup "access_token" params of case lookup "access_token" params of
Just x -> return $ AccessToken $ T.pack $ S8.unpack x Just x -> return $ AccessToken $ T.pack $ S8.unpack x
@ -92,14 +95,15 @@ graphUrl (AccessToken s) func =
`mappend` fromText func `mappend` fromText func
`mappend` renderQueryText True [("access_token", Just s)] `mappend` renderQueryText True [("access_token", Just s)]
getGraphData :: AccessToken -> Text -> IO (Either String Value) getGraphData :: AccessToken -> Text -> Manager -> ResourceT IO (Either String Value)
getGraphData at func = do getGraphData at func manager = do
let url = graphUrl at func let url = graphUrl at func
b <- simpleHttp $ S8.unpack url req <- liftIO $ parseUrl $ S8.unpack url
Response _ _ b <- httpLbs req manager
return $ eitherResult $ parse json b return $ eitherResult $ parse json b
getGraphData_ :: AccessToken -> Text -> IO Value getGraphData_ :: AccessToken -> Text -> Manager -> ResourceT IO Value
getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return getGraphData_ a b m = getGraphData a b m >>= either (liftIO . throwIO . InvalidJsonException) return
data InvalidJsonException = InvalidJsonException String data InvalidJsonException = InvalidJsonException String
deriving (Show, Typeable) deriving (Show, Typeable)

88
Web/Authenticate/OAuth.hs
View File

@ -37,10 +37,11 @@ import Network.HTTP.Types (Header)
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Network.HTTP.Types (renderSimpleQuery, status200) import Network.HTTP.Types (renderSimpleQuery, status200)
import Data.Conduit (ResourceIO, runResourceT, ($$), ($=), Source) import Data.Conduit (ResourceT, ResourceIO, ($$), ($=), Source)
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.Conduit.Blaze (builderToByteString) import Data.Conduit.Blaze (builderToByteString)
import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder (Builder)
import Control.Monad.IO.Class (liftIO)
-- | Data type for OAuth client (consumer). -- | Data type for OAuth client (consumer).
-- The default values apply when you use 'newOAuth' -- The default values apply when you use 'newOAuth'
@ -105,39 +106,47 @@ fromStrict :: BS.ByteString -> BSL.ByteString
fromStrict = BSL.fromChunks . return fromStrict = BSL.fromChunks . return
-- | Get temporary credential for requesting acces token. -- | Get temporary credential for requesting acces token.
getTemporaryCredential :: OAuth -- ^ OAuth Application getTemporaryCredential :: ResourceIO m
-> IO Credential -- ^ Temporary Credential (Request Token & Secret). => OAuth -- ^ OAuth Application
-> Manager
-> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredential = getTemporaryCredential' id getTemporaryCredential = getTemporaryCredential' id
-- | Get temporary credential for requesting access token with Scope parameter. -- | Get temporary credential for requesting access token with Scope parameter.
getTemporaryCredentialWithScope :: BS.ByteString -- ^ Scope parameter string getTemporaryCredentialWithScope :: ResourceIO m
=> BS.ByteString -- ^ Scope parameter string
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> IO Credential -- ^ Temporay Credential (Request Token & Secret). -> Manager
getTemporaryCredentialWithScope = getTemporaryCredential' . addScope -> ResourceT m Credential -- ^ Temporay Credential (Request Token & Secret).
getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs)
addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m
addScope scope req | BS.null scope = req addScope scope req | BS.null scope = req
| otherwise = urlEncodedBody [("scope", scope)] req | otherwise = urlEncodedBody [("scope", scope)] req
-- | Get temporary credential for requesting access token via the proxy. -- | Get temporary credential for requesting access token via the proxy.
getTemporaryCredentialProxy :: Maybe Proxy -- ^ Proxy getTemporaryCredentialProxy :: ResourceIO m
=> Maybe Proxy -- ^ Proxy
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> IO Credential -- ^ Temporary Credential (Request Token & Secret). -> Manager
getTemporaryCredentialProxy p = getTemporaryCredential' $ addMaybeProxy p -> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m
getTemporaryCredential' :: (Request IO -> Request IO) -- ^ Request Hook getTemporaryCredential' :: ResourceIO m
=> (Request m -> Request m) -- ^ Request Hook
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> IO Credential -- ^ Temporary Credential (Request Token & Secret). -> Manager
getTemporaryCredential' hook oa = do -> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredential' hook oa manager = do
let req = fromJust $ parseUrl $ oauthRequestUri oa let req = fromJust $ parseUrl $ oauthRequestUri oa
crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential
req' <- signOAuth oa crd $ hook (req { method = "POST" }) req' <- signOAuth oa crd $ hook (req { method = "POST" })
rsp <- withManager . httpLbs $ req' rsp <- httpLbs req' manager
if statusCode rsp == status200 if statusCode rsp == status200
then do then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic return $ Credential dic
else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) else liftIO . throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)
-- | URL to obtain OAuth verifier. -- | URL to obtain OAuth verifier.
authorizeUrl :: OAuth -- ^ OAuth Application authorizeUrl :: OAuth -- ^ OAuth Application
@ -150,31 +159,37 @@ authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True q
-- | Get Access token. -- | Get Access token.
getAccessToken, getTokenCredential getAccessToken, getTokenCredential
:: OAuth -- ^ OAuth Application :: ResourceIO m
=> OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential with oauth_verifier -> Credential -- ^ Temporary Credential with oauth_verifier
-> IO Credential -- ^ Token Credential (Access Token & Secret) -> Manager
-> ResourceT m Credential -- ^ Token Credential (Access Token & Secret)
getAccessToken = getAccessToken' id getAccessToken = getAccessToken' id
-- | Get Access token via the proxy. -- | Get Access token via the proxy.
getAccessTokenProxy, getTokenCredentialProxy getAccessTokenProxy, getTokenCredentialProxy
:: Maybe Proxy -- ^ Proxy :: ResourceIO m
=> Maybe Proxy -- ^ Proxy
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential with oauth_verifier -> Credential -- ^ Temporary Credential with oauth_verifier
-> IO Credential -- ^ Token Credential (Access Token & Secret) -> Manager
-> ResourceT m Credential -- ^ Token Credential (Access Token & Secret)
getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p
getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook getAccessToken' :: ResourceIO m
=> (Request m -> Request m) -- ^ Request Hook
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential with oauth_verifier -> Credential -- ^ Temporary Credential with oauth_verifier
-> IO Credential -- ^ Token Credential (Access Token & Secret) -> Manager
getAccessToken' hook oa cr = do -> ResourceT m Credential -- ^ Token Credential (Access Token & Secret)
getAccessToken' hook oa cr manager = do
let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
rsp <- withManager . httpLbs =<< signOAuth oa cr req rsp <- flip httpLbs manager =<< signOAuth oa cr req
if statusCode rsp == status200 if statusCode rsp == status200
then do then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic return $ Credential dic
else throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp) else liftIO . throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp)
getTokenCredential = getAccessToken getTokenCredential = getAccessToken
@ -204,10 +219,11 @@ delete :: BS.ByteString -- ^ Parameter name
delete key = Credential . deleteMap key . unCredential delete key = Credential . deleteMap key . unCredential
-- | Add OAuth headers & sign to 'Request'. -- | Add OAuth headers & sign to 'Request'.
signOAuth :: OAuth -- ^ OAuth Application signOAuth :: ResourceIO m
=> OAuth -- ^ OAuth Application
-> Credential -- ^ Credential -> Credential -- ^ Credential
-> Request IO -- ^ Original Request -> Request m -- ^ Original Request
-> IO (Request IO) -- ^ Signed OAuth Request -> ResourceT m (Request m) -- ^ Signed OAuth Request
signOAuth oa crd req = do signOAuth oa crd req = do
crd' <- addTimeStamp =<< addNonce crd crd' <- addTimeStamp =<< addNonce crd
let tok = injectOAuthToCred oa crd' let tok = injectOAuthToCred oa crd'
@ -228,15 +244,15 @@ showSigMtd PLAINTEXT = "PLAINTEXT"
showSigMtd HMACSHA1 = "HMAC-SHA1" showSigMtd HMACSHA1 = "HMAC-SHA1"
showSigMtd (RSASHA1 _) = "RSA-SHA1" showSigMtd (RSASHA1 _) = "RSA-SHA1"
addNonce :: Credential -> IO Credential addNonce :: ResourceIO m => Credential -> ResourceT m Credential
addNonce cred = do addNonce cred = do
nonce <- replicateM 10 (randomRIO ('a','z')) nonce <- liftIO $ replicateM 10 (randomRIO ('a','z')) -- FIXME very inefficient
return $ insert "oauth_nonce" (BS.pack nonce) cred return $ insert "oauth_nonce" (BS.pack nonce) cred
addTimeStamp :: Credential -> IO Credential addTimeStamp :: ResourceIO m => Credential -> ResourceT m Credential
addTimeStamp cred = do addTimeStamp cred = do
stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer stamp <- floor . (`diffUTCTime` baseTime) <$> liftIO getCurrentTime
return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred
injectOAuthToCred :: OAuth -> Credential -> Credential injectOAuthToCred :: OAuth -> Credential -> Credential
injectOAuthToCred oa cred = injectOAuthToCred oa cred =
@ -245,7 +261,7 @@ injectOAuthToCred oa cred =
, ("oauth_version", "1.0") , ("oauth_version", "1.0")
] cred ] cred
genSign :: ResourceIO m => OAuth -> Credential -> Request m -> m BS.ByteString genSign :: ResourceIO m => OAuth -> Credential -> Request m -> ResourceT m BS.ByteString
genSign oa tok req = genSign oa tok req =
case oauthSignatureMethod oa of case oauthSignatureMethod oa of
HMACSHA1 -> do HMACSHA1 -> do
@ -273,7 +289,7 @@ paramEncode = BS.concatMap escape
oct = '%' : replicate (2 - length num) '0' ++ num oct = '%' : replicate (2 - length num) '0' ++ num
in BS.pack oct in BS.pack oct
getBaseString :: ResourceIO m => Credential -> Request m -> m BSL.ByteString getBaseString :: ResourceIO m => Credential -> Request m -> ResourceT m BSL.ByteString
getBaseString tok req = do getBaseString tok req = do
let bsMtd = BS.map toUpper $ method req let bsMtd = BS.map toUpper $ method req
isHttps = secure req isHttps = secure req
@ -293,15 +309,15 @@ getBaseString tok req = do
-- So this is OK. -- So this is OK.
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
toLBS :: ResourceIO m => RequestBody m -> m BS.ByteString toLBS :: ResourceIO m => RequestBody m -> ResourceT m BS.ByteString
toLBS (RequestBodyLBS l) = return $ toStrict l toLBS (RequestBodyLBS l) = return $ toStrict l
toLBS (RequestBodyBS s) = return s toLBS (RequestBodyBS s) = return s
toLBS (RequestBodyBuilder _ b) = return $ toByteString b toLBS (RequestBodyBuilder _ b) = return $ toByteString b
toLBS (RequestBodySource _ src) = toLBS' src toLBS (RequestBodySource _ src) = toLBS' src
toLBS (RequestBodySourceChunked src) = toLBS' src toLBS (RequestBodySourceChunked src) = toLBS' src
toLBS' :: ResourceIO m => Source m Builder -> m BS.ByteString toLBS' :: ResourceIO m => Source m Builder -> ResourceT m BS.ByteString
toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume toLBS' src = fmap BS.concat $ src $= builderToByteString $$ CL.consume
isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded :: [Header] -> Bool
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type" isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"

39
Web/Authenticate/OpenId.hs
View File

@ -10,7 +10,6 @@ module Web.Authenticate.OpenId
import Control.Monad.IO.Class import Control.Monad.IO.Class
import OpenId2.Normalization (normalize) import OpenId2.Normalization (normalize)
import OpenId2.Discovery (discover, Discovery (..)) import OpenId2.Discovery (discover, Discovery (..))
import Control.Failure (Failure (failure))
import OpenId2.Types import OpenId2.Types
import Control.Monad (unless) import Control.Monad (unless)
import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Lazy.Encoding (decodeUtf8With)
@ -18,8 +17,9 @@ import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy (toStrict) import Data.Text.Lazy (toStrict)
import Network.HTTP.Conduit import Network.HTTP.Conduit
( parseUrl, urlEncodedBody, responseBody, httpLbs ( parseUrl, urlEncodedBody, responseBody, httpLbs
, HttpException, withManager , HttpException, Manager
) )
import Data.Conduit (ResourceT, ResourceIO)
import Control.Arrow ((***), second) import Control.Arrow ((***), second)
import Data.List (unfoldr) import Data.List (unfoldr)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -28,20 +28,19 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Network.HTTP.Types (renderQueryText) import Network.HTTP.Types (renderQueryText)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import Control.Exception (throwIO)
getForwardUrl getForwardUrl
:: ( MonadIO m :: ResourceIO m
, Failure AuthenticateException m
, Failure HttpException m
)
=> Text -- ^ The openid the user provided. => Text -- ^ The openid the user provided.
-> Text -- ^ The URL for this application\'s complete page. -> Text -- ^ The URL for this application\'s complete page.
-> Maybe Text -- ^ Optional realm -> Maybe Text -- ^ Optional realm
-> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions. -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
-> m Text -- ^ URL to send the user to. -> Manager
getForwardUrl openid' complete mrealm params = do -> ResourceT m Text -- ^ URL to send the user to.
getForwardUrl openid' complete mrealm params manager = do
let realm = fromMaybe complete mrealm let realm = fromMaybe complete mrealm
disc <- liftIO $ normalize openid' >>= discover disc <- normalize openid' >>= flip discover manager
let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q) let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q)
case disc of case disc of
Discovery1 server mdelegate -> helper server Discovery1 server mdelegate -> helper server
@ -66,15 +65,13 @@ getForwardUrl openid' complete mrealm params = do
: params : params
authenticate authenticate
:: ( MonadIO m :: ResourceIO m
, Failure AuthenticateException m
, Failure HttpException m
)
=> [(Text, Text)] => [(Text, Text)]
-> m (Identifier, [(Text, Text)]) -> Manager
authenticate params = do -> ResourceT m (Identifier, [(Text, Text)])
authenticate params manager = do
unless (lookup "openid.mode" params == Just "id_res") unless (lookup "openid.mode" params == Just "id_res")
$ failure $ case lookup "openid.mode" params of $ liftIO $ throwIO $ case lookup "openid.mode" params of
Nothing -> AuthenticationException "openid.mode was not found in the params." Nothing -> AuthenticationException "openid.mode was not found in the params."
(Just m) (Just m)
| m == "error" -> | m == "error" ->
@ -85,21 +82,21 @@ authenticate params = do
ident <- case lookup "openid.identity" params of ident <- case lookup "openid.identity" params of
Just i -> return i Just i -> return i
Nothing -> Nothing ->
failure $ AuthenticationException "Missing identity" liftIO $ throwIO $ AuthenticationException "Missing identity"
disc <- liftIO $ normalize ident >>= discover disc <- normalize ident >>= flip discover manager
let endpoint = case disc of let endpoint = case disc of
Discovery1 p _ -> p Discovery1 p _ -> p
Discovery2 (Provider p) _ _ -> p Discovery2 (Provider p) _ _ -> p
let params' = map (encodeUtf8 *** encodeUtf8) let params' = map (encodeUtf8 *** encodeUtf8)
$ ("openid.mode", "check_authentication") $ ("openid.mode", "check_authentication")
: filter (\(k, _) -> k /= "openid.mode") params : filter (\(k, _) -> k /= "openid.mode") params
req' <- parseUrl $ unpack endpoint req' <- liftIO $ parseUrl $ unpack endpoint
let req = urlEncodedBody params' req' let req = urlEncodedBody params' req'
rsp <- liftIO $ withManager $ httpLbs req rsp <- httpLbs req manager
let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp
case lookup "is_valid" rps of case lookup "is_valid" rps of
Just "true" -> return (Identifier ident, rps) Just "true" -> return (Identifier ident, rps)
_ -> failure $ AuthenticationException "OpenID provider did not validate" _ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate"
-- | Turn a response body into a list of parameters. -- | Turn a response body into a list of parameters.
parseDirectResponse :: Text -> [(Text, Text)] parseDirectResponse :: Text -> [(Text, Text)]

30
Web/Authenticate/Rpxnow.hs
View File

@ -23,8 +23,8 @@ module Web.Authenticate.Rpxnow
import Data.Aeson import Data.Aeson
import Network.HTTP.Conduit import Network.HTTP.Conduit
import Data.Conduit (ResourceT, ResourceIO)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Failure
import Data.Maybe import Data.Maybe
import Control.Monad import Control.Monad
import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Char8 as S
@ -36,12 +36,9 @@ import Data.Attoparsec.Lazy (parse)
import qualified Data.Attoparsec.Lazy as AT import qualified Data.Attoparsec.Lazy as AT
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Aeson.Types import qualified Data.Aeson.Types
#if MIN_VERSION_aeson(0, 4, 0)
import qualified Data.HashMap.Lazy as Map import qualified Data.HashMap.Lazy as Map
#else
import qualified Data.Map as Map
#endif
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Control.Exception (throwIO)
-- | Information received from Rpxnow after a valid login. -- | Information received from Rpxnow after a valid login.
data Identifier = Identifier data Identifier = Identifier
@ -51,20 +48,19 @@ data Identifier = Identifier
deriving (Eq, Ord, Read, Show, Data, Typeable) deriving (Eq, Ord, Read, Show, Data, Typeable)
-- | Attempt to log a user in. -- | Attempt to log a user in.
authenticate :: (MonadIO m, authenticate :: ResourceIO m
Failure HttpException m,
Failure AuthenticateException m)
=> String -- ^ API key given by RPXNOW. => String -- ^ API key given by RPXNOW.
-> String -- ^ Token passed by client. -> String -- ^ Token passed by client.
-> m Identifier -> Manager
authenticate apiKey token = do -> ResourceT m Identifier
authenticate apiKey token manager = do
let body = L.fromChunks let body = L.fromChunks
[ "apiKey=" [ "apiKey="
, S.pack apiKey , S.pack apiKey
, "&token=" , "&token="
, S.pack token , S.pack token
] ]
req' <- parseUrl "https://rpxnow.com" req' <- liftIO $ parseUrl "https://rpxnow.com"
let req = let req =
req' req'
{ method = "POST" { method = "POST"
@ -74,7 +70,7 @@ authenticate apiKey token = do
] ]
, requestBody = RequestBodyLBS body , requestBody = RequestBodyLBS body
} }
res <- liftIO $ withManager $ httpLbs req res <- httpLbs req manager
let b = responseBody res let b = responseBody res
o <- unResult $ parse json b o <- unResult $ parse json b
--m <- fromMapping o --m <- fromMapping o
@ -84,15 +80,15 @@ authenticate apiKey token = do
_ -> mzero _ -> mzero
case mstat of case mstat of
Success "ok" -> return () Success "ok" -> return ()
Success stat -> failure $ RpxnowException $ Success stat -> liftIO $ throwIO $ RpxnowException $
"Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
_ -> failure $ RpxnowException "Now stat value found on Rpxnow response" _ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response"
case Data.Aeson.Types.parse parseProfile o of case Data.Aeson.Types.parse parseProfile o of
Success x -> return x Success x -> return x
Error e -> failure $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e
unResult :: Failure AuthenticateException m => AT.Result a -> m a unResult :: MonadIO m => AT.Result a -> m a
unResult = either (failure . RpxnowException) return . AT.eitherResult unResult = either (liftIO . throwIO . RpxnowException) return . AT.eitherResult
parseProfile :: Value -> Data.Aeson.Types.Parser Identifier parseProfile :: Value -> Data.Aeson.Types.Parser Identifier
parseProfile (Object m) = do parseProfile (Object m) = do

1
authenticate.cabal
View File

@ -18,7 +18,6 @@ library
, aeson >= 0.5 , aeson >= 0.5
, http-conduit >= 1.1 && < 1.2 , http-conduit >= 1.1 && < 1.2
, tagsoup >= 0.12 && < 0.13 , tagsoup >= 0.12 && < 0.13
, failure >= 0.0.0 && < 0.2
, transformers >= 0.1 && < 0.3 , transformers >= 0.1 && < 0.3
, bytestring >= 0.9 , bytestring >= 0.9
, network , network