From 2a903feca1644fbef9c1c01bd5ae293f312f0b12 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Jan 2012 16:07:30 +0200 Subject: [PATCH] All functions take Manager (where relevant) --- OpenId2/Discovery.hs | 39 +++++++++------- OpenId2/Normalization.hs | 7 +-- Web/Authenticate/BrowserId.hs | 16 ++++--- Web/Authenticate/Facebook.hs | 20 ++++---- Web/Authenticate/OAuth.hs | 88 +++++++++++++++++++++-------------- Web/Authenticate/OpenId.hs | 39 +++++++--------- Web/Authenticate/Rpxnow.hs | 30 ++++++------ authenticate.cabal | 1 - 8 files changed, 131 insertions(+), 109 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index dd6a63ac..25b64753 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -27,11 +27,11 @@ import Debug.Trace import Data.Char import Data.Maybe import Network.HTTP.Conduit +import Data.Conduit (ResourceT, ResourceIO) import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Failure (Failure (failure)) -import Control.Monad (mplus, liftM) +import Control.Monad (mplus) import qualified Data.CaseInsensitive as CI import Data.Text (Text, unpack) import Data.Text.Lazy (toStrict) @@ -41,36 +41,39 @@ 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) data Discovery = Discovery1 Text (Maybe Text) | Discovery2 Provider Identifier IdentType deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier. -discover :: Identifier -> IO Discovery -discover ident@(Identifier i) = do - res1 <- discoverYADIS ident Nothing 10 +discover :: ResourceIO m => Identifier -> Manager -> ResourceT 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 + res2 <- discoverHTML ident manager case res2 of Just x -> return x - Nothing -> failure $ DiscoveryException $ unpack i + 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 :: Identifier +discoverYADIS :: ResourceIO m + => Identifier -> Maybe String -> Int -- ^ remaining redirects - -> IO (Maybe (Provider, Identifier, IdentType)) -discoverYADIS _ _ 0 = failure TooManyRedirects -discoverYADIS ident mb_loc redirects = do + -> Manager + -> ResourceT m (Maybe (Provider, Identifier, IdentType)) +discoverYADIS _ _ 0 _ = liftIO $ throwIO TooManyRedirects +discoverYADIS ident mb_loc redirects manager = do let uri = fromMaybe (unpack $ identifier ident) mb_loc - req <- parseUrl uri - res <- liftIO $ withManager $ httpLbs req { checkStatus = \_ _ -> Nothing } + req <- liftIO $ parseUrl uri + res <- httpLbs req { checkStatus = \_ _ -> Nothing } manager let mloc = fmap S8.unpack $ lookup "x-xrds-location" $ map (first $ map toLower . S8.unpack . CI.original) @@ -79,7 +82,7 @@ discoverYADIS ident mb_loc redirects = do if statusCode res == status200 then case mloc' of - Just loc -> discoverYADIS ident (Just loc) (redirects - 1) + Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager Nothing -> do let mdoc = parseXRDS $ responseBody res 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 -- will be an endpoint on success, and the actual identifier of the user. -discoverHTML :: Identifier -> IO (Maybe Discovery) -discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident) +discoverHTML :: ResourceIO m => Identifier -> Manager -> ResourceT m (Maybe Discovery) +discoverHTML ident'@(Identifier ident) manager = do + 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 -- document. diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 21dbfc82..9534a18a 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -21,18 +21,19 @@ import OpenId2.Types import Control.Applicative import Control.Monad import Data.List -import Control.Failure (Failure (..)) 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 :: Failure AuthenticateException m => Text -> m Identifier +normalize :: MonadIO m => Text -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i - Nothing -> failure $ NormalizationException $ unpack ident + Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident -- | Normalize an identifier, discarding XRIs. normalizeIdentifier :: Identifier -> Maybe Identifier diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs index b978a33e..3abf5dde 100644 --- a/Web/Authenticate/BrowserId.hs +++ b/Web/Authenticate/BrowserId.hs @@ -5,26 +5,30 @@ module Web.Authenticate.BrowserId ) where 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.Attoparsec.Lazy (parse, maybeResult) import qualified Data.HashMap.Lazy as Map import Data.Text.Encoding (encodeUtf8) +import Control.Monad.IO.Class (liftIO) -- | Location of the Javascript file hosted by browserid.org browserIdJs :: Text browserIdJs = "https://browserid.org/include.js" -checkAssertion :: Text -- ^ audience +checkAssertion :: ResourceIO m + => Text -- ^ audience -> Text -- ^ assertion - -> IO (Maybe Text) -checkAssertion audience assertion = do - req' <- parseUrl "https://browserid.org/verify" + -> Manager + -> ResourceT m (Maybe Text) +checkAssertion audience assertion manager = do + req' <- liftIO $ parseUrl "https://browserid.org/verify" let req = urlEncodedBody [ ("audience", encodeUtf8 audience) , ("assertion", encodeUtf8 assertion) ] req' { method = "POST" } - res <- withManager $ httpLbs req + res <- httpLbs req manager let lbs = responseBody res return $ maybeResult (parse json lbs) >>= getEmail where diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index f96f8db3..fcf2dd0e 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -14,6 +14,8 @@ module Web.Authenticate.Facebook ) where import Network.HTTP.Conduit +import Data.Conduit (ResourceT) +import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types (parseSimpleQuery) import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L8 @@ -76,10 +78,11 @@ accessTokenUrl fb code = , ("client_secret", Just $ facebookClientSecret fb) ] -getAccessToken :: Facebook -> Text -> IO AccessToken -getAccessToken fb code = do +getAccessToken :: Facebook -> Text -> Manager -> ResourceT IO AccessToken +getAccessToken fb code manager = do 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 case lookup "access_token" params of Just x -> return $ AccessToken $ T.pack $ S8.unpack x @@ -92,14 +95,15 @@ graphUrl (AccessToken s) func = `mappend` fromText func `mappend` renderQueryText True [("access_token", Just s)] -getGraphData :: AccessToken -> Text -> IO (Either String Value) -getGraphData at func = do +getGraphData :: AccessToken -> Text -> Manager -> ResourceT IO (Either String Value) +getGraphData at func manager = do 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 -getGraphData_ :: AccessToken -> Text -> IO Value -getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return +getGraphData_ :: AccessToken -> Text -> Manager -> ResourceT IO Value +getGraphData_ a b m = getGraphData a b m >>= either (liftIO . throwIO . InvalidJsonException) return data InvalidJsonException = InvalidJsonException String deriving (Show, Typeable) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index e12d439b..0c1d586f 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -37,10 +37,11 @@ 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 (ResourceIO, runResourceT, ($$), ($=), Source) +import Data.Conduit (ResourceT, ResourceIO, ($$), ($=), Source) import qualified Data.Conduit.List as CL import Data.Conduit.Blaze (builderToByteString) import Blaze.ByteString.Builder (Builder) +import Control.Monad.IO.Class (liftIO) -- | Data type for OAuth client (consumer). -- The default values apply when you use 'newOAuth' @@ -105,39 +106,47 @@ fromStrict :: BS.ByteString -> BSL.ByteString fromStrict = BSL.fromChunks . return -- | Get temporary credential for requesting acces token. -getTemporaryCredential :: OAuth -- ^ OAuth Application - -> IO Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential :: ResourceIO m + => OAuth -- ^ OAuth Application + -> Manager + -> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredential = getTemporaryCredential' id -- | 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 - -> IO Credential -- ^ Temporay Credential (Request Token & Secret). -getTemporaryCredentialWithScope = getTemporaryCredential' . addScope + -> Manager + -> ResourceT m Credential -- ^ Temporay Credential (Request Token & Secret). +getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs) addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m addScope scope req | BS.null scope = req | otherwise = urlEncodedBody [("scope", scope)] req -- | Get temporary credential for requesting access token via the proxy. -getTemporaryCredentialProxy :: Maybe Proxy -- ^ Proxy +getTemporaryCredentialProxy :: ResourceIO m + => Maybe Proxy -- ^ Proxy -> OAuth -- ^ OAuth Application - -> IO Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredentialProxy p = getTemporaryCredential' $ addMaybeProxy p + -> Manager + -> 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 - -> IO Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential' hook oa = do + -> Manager + -> ResourceT 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 <- withManager . httpLbs $ req' + rsp <- httpLbs req' manager if statusCode rsp == status200 then do let dic = parseSimpleQuery . toStrict . responseBody $ rsp 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. authorizeUrl :: OAuth -- ^ OAuth Application @@ -150,31 +159,37 @@ authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True q -- | Get Access token. getAccessToken, getTokenCredential - :: OAuth -- ^ OAuth Application + :: ResourceIO m + => OAuth -- ^ OAuth Application -> 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 -- | Get Access token via the proxy. getAccessTokenProxy, getTokenCredentialProxy - :: Maybe Proxy -- ^ Proxy + :: ResourceIO m + => Maybe Proxy -- ^ Proxy -> OAuth -- ^ OAuth Application -> 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 -getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook +getAccessToken' :: ResourceIO m + => (Request m -> Request m) -- ^ Request Hook -> OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential with oauth_verifier - -> IO Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken' hook oa cr = do + -> Manager + -> ResourceT m Credential -- ^ Token Credential (Access Token & Secret) +getAccessToken' hook oa cr manager = do 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 then do let dic = parseSimpleQuery . toStrict . responseBody $ rsp 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 @@ -204,10 +219,11 @@ delete :: BS.ByteString -- ^ Parameter name delete key = Credential . deleteMap key . unCredential -- | Add OAuth headers & sign to 'Request'. -signOAuth :: OAuth -- ^ OAuth Application +signOAuth :: ResourceIO m + => OAuth -- ^ OAuth Application -> Credential -- ^ Credential - -> Request IO -- ^ Original Request - -> IO (Request IO) -- ^ Signed OAuth Request + -> Request m -- ^ Original Request + -> ResourceT m (Request m) -- ^ Signed OAuth Request signOAuth oa crd req = do crd' <- addTimeStamp =<< addNonce crd let tok = injectOAuthToCred oa crd' @@ -228,15 +244,15 @@ showSigMtd PLAINTEXT = "PLAINTEXT" showSigMtd HMACSHA1 = "HMAC-SHA1" showSigMtd (RSASHA1 _) = "RSA-SHA1" -addNonce :: Credential -> IO Credential +addNonce :: ResourceIO m => Credential -> ResourceT m Credential 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 -addTimeStamp :: Credential -> IO Credential +addTimeStamp :: ResourceIO m => Credential -> ResourceT m Credential addTimeStamp cred = do - stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer - return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred + stamp <- floor . (`diffUTCTime` baseTime) <$> liftIO getCurrentTime + return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred injectOAuthToCred :: OAuth -> Credential -> Credential injectOAuthToCred oa cred = @@ -245,7 +261,7 @@ injectOAuthToCred oa cred = , ("oauth_version", "1.0") ] 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 = case oauthSignatureMethod oa of HMACSHA1 -> do @@ -273,7 +289,7 @@ paramEncode = BS.concatMap escape oct = '%' : replicate (2 - length num) '0' ++ num 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 let bsMtd = BS.map toUpper $ method req isHttps = secure req @@ -293,15 +309,15 @@ getBaseString tok req = do -- So this is OK. 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 (RequestBodyBS s) = return s toLBS (RequestBodyBuilder _ b) = return $ toByteString b toLBS (RequestBodySource _ src) = toLBS' src toLBS (RequestBodySourceChunked src) = toLBS' src -toLBS' :: ResourceIO m => Source m Builder -> m BS.ByteString -toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume +toLBS' :: ResourceIO m => Source m Builder -> ResourceT m BS.ByteString +toLBS' src = fmap BS.concat $ src $= builderToByteString $$ CL.consume isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type" diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index e651c747..7ff0635a 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -10,7 +10,6 @@ module Web.Authenticate.OpenId import Control.Monad.IO.Class import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover, Discovery (..)) -import Control.Failure (Failure (failure)) import OpenId2.Types import Control.Monad (unless) import Data.Text.Lazy.Encoding (decodeUtf8With) @@ -18,8 +17,9 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy (toStrict) import Network.HTTP.Conduit ( parseUrl, urlEncodedBody, responseBody, httpLbs - , HttpException, withManager + , HttpException, Manager ) +import Data.Conduit (ResourceT, ResourceIO) import Control.Arrow ((***), second) import Data.List (unfoldr) import Data.Maybe (fromMaybe) @@ -28,20 +28,19 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Blaze.ByteString.Builder (toByteString) import Network.HTTP.Types (renderQueryText) import Data.Monoid (mappend) +import Control.Exception (throwIO) getForwardUrl - :: ( MonadIO m - , Failure AuthenticateException m - , Failure HttpException m - ) + :: ResourceIO 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. - -> m Text -- ^ URL to send the user to. -getForwardUrl openid' complete mrealm params = do + -> Manager + -> ResourceT m Text -- ^ URL to send the user to. +getForwardUrl openid' complete mrealm params manager = do 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) case disc of Discovery1 server mdelegate -> helper server @@ -66,15 +65,13 @@ getForwardUrl openid' complete mrealm params = do : params authenticate - :: ( MonadIO m - , Failure AuthenticateException m - , Failure HttpException m - ) + :: ResourceIO m => [(Text, Text)] - -> m (Identifier, [(Text, Text)]) -authenticate params = do + -> Manager + -> ResourceT m (Identifier, [(Text, Text)]) +authenticate params manager = do 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." (Just m) | m == "error" -> @@ -85,21 +82,21 @@ authenticate params = do ident <- case lookup "openid.identity" params of Just i -> return i Nothing -> - failure $ AuthenticationException "Missing identity" - disc <- liftIO $ normalize ident >>= discover + liftIO $ throwIO $ AuthenticationException "Missing identity" + disc <- normalize ident >>= flip discover manager let endpoint = case disc of Discovery1 p _ -> p Discovery2 (Provider p) _ _ -> p let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params - req' <- parseUrl $ unpack endpoint + req' <- liftIO $ parseUrl $ unpack endpoint let req = urlEncodedBody params' req' - rsp <- liftIO $ withManager $ httpLbs req + rsp <- httpLbs req manager let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp case lookup "is_valid" rps of 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. parseDirectResponse :: Text -> [(Text, Text)] diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index a1cc1ad2..9aba4978 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -23,8 +23,8 @@ module Web.Authenticate.Rpxnow import Data.Aeson import Network.HTTP.Conduit +import Data.Conduit (ResourceT, ResourceIO) import Control.Monad.IO.Class -import Control.Failure import Data.Maybe import Control.Monad import qualified Data.ByteString.Char8 as S @@ -36,12 +36,9 @@ import Data.Attoparsec.Lazy (parse) import qualified Data.Attoparsec.Lazy as AT import Data.Text (Text) import qualified Data.Aeson.Types -#if MIN_VERSION_aeson(0, 4, 0) import qualified Data.HashMap.Lazy as Map -#else -import qualified Data.Map as Map -#endif import Control.Applicative ((<$>), (<*>)) +import Control.Exception (throwIO) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -51,20 +48,19 @@ data Identifier = Identifier deriving (Eq, Ord, Read, Show, Data, Typeable) -- | Attempt to log a user in. -authenticate :: (MonadIO m, - Failure HttpException m, - Failure AuthenticateException m) +authenticate :: ResourceIO m => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. - -> m Identifier -authenticate apiKey token = do + -> Manager + -> ResourceT m Identifier +authenticate apiKey token manager = do let body = L.fromChunks [ "apiKey=" , S.pack apiKey , "&token=" , S.pack token ] - req' <- parseUrl "https://rpxnow.com" + req' <- liftIO $ parseUrl "https://rpxnow.com" let req = req' { method = "POST" @@ -74,7 +70,7 @@ authenticate apiKey token = do ] , requestBody = RequestBodyLBS body } - res <- liftIO $ withManager $ httpLbs req + res <- httpLbs req manager let b = responseBody res o <- unResult $ parse json b --m <- fromMapping o @@ -84,15 +80,15 @@ authenticate apiKey token = do _ -> mzero case mstat of Success "ok" -> return () - Success stat -> failure $ RpxnowException $ + Success stat -> liftIO $ throwIO $ RpxnowException $ "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 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 = either (failure . RpxnowException) return . AT.eitherResult +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 diff --git a/authenticate.cabal b/authenticate.cabal index 7bb0c040..2485e328 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -18,7 +18,6 @@ library , aeson >= 0.5 , http-conduit >= 1.1 && < 1.2 , tagsoup >= 0.12 && < 0.13 - , failure >= 0.0.0 && < 0.2 , transformers >= 0.1 && < 0.3 , bytestring >= 0.9 , network