authenticate 0.11.1 → 1.0.0

raw patch · 9 files changed

+87/−600 lines, 9 filesdep −RSAdep −SHAdep −base64-bytestringdep ~attoparsecdep ~blaze-builderdep ~blaze-builder-conduitPVP ok

version bump matches the API change (PVP)

Dependencies removed: RSA, SHA, base64-bytestring, failure, process, random, time, tls

Dependency ranges changed: attoparsec, blaze-builder, blaze-builder-conduit, bytestring, conduit, http-conduit, network, text, xml-conduit

API changes (from Hackage documentation)

Files

• OpenId2/Discovery.hs +22/−17
• OpenId2/Normalization.hs +4/−3
• Web/Authenticate/BrowserId.hs +10/−6
• Web/Authenticate/Facebook.hs +0/−115
• Web/Authenticate/Kerberos.hs +0/−72
• Web/Authenticate/OAuth.hs +0/−317
• Web/Authenticate/OpenId.hs +18/−21
• Web/Authenticate/Rpxnow.hs +13/−17
• authenticate.cabal +20/−32

@@ -27,11 +27,11 @@ 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 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 @@     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 @@  -- | 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.

@@ -21,18 +21,19 @@ 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

@@ -5,26 +5,30 @@     ) 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

@@ -1,115 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-module Web.Authenticate.Facebook-    ( Facebook (..)-    , AccessToken (..)-    , getForwardUrlParams-    , getForwardUrlWithState-    , getForwardUrl-    , getAccessToken-    , getGraphData-    , getGraphData_-    , getLogoutUrl-    ) where--import Network.HTTP.Conduit-import Network.HTTP.Types (parseSimpleQuery)-import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as L8-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-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Blaze.ByteString.Builder (toByteString, copyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromText)-import Network.HTTP.Types (renderQueryText)-import Data.Monoid (mappend)-import Data.ByteString (ByteString)-import Control.Arrow ((***))--data Facebook = Facebook-    { facebookClientId :: Text-    , facebookClientSecret :: Text-    , facebookRedirectUri :: Text-    }-    deriving (Show, Eq, Read, Ord, Data, Typeable)--newtype AccessToken = AccessToken { unAccessToken :: Text }-    deriving (Show, Eq, Read, Ord, Data, Typeable)--getForwardUrlParams :: Facebook -> [(Text, Text)] -> Text-getForwardUrlParams fb params =-    TE.decodeUtf8 $ toByteString $-    copyByteString "https://graph.facebook.com/oauth/authorize"-    `mappend`-    renderQueryText True-        (  ("client_id", Just $ facebookClientId fb)-         : ("redirect_uri", Just $ facebookRedirectUri fb)-         : map (id *** Just) params)---- Internal function used to simplify getForwardUrl & getForwardUrlWithState-getForwardUrlWithExtra_ :: Facebook -> [Text] -> [(Text, Text)] -> Text-getForwardUrlWithExtra_ fb perms extra = getForwardUrlParams fb $ (if null perms-                                                                   then id-                                                                   else (("scope", T.intercalate "," perms):)) extra--getForwardUrlWithState :: Facebook -> [Text] -> Text -> Text-getForwardUrlWithState fb perms state = getForwardUrlWithExtra_ fb perms [("state", state)]--getForwardUrl :: Facebook -> [Text] -> Text-getForwardUrl fb perms = getForwardUrlWithExtra_ fb perms []--accessTokenUrl :: Facebook -> Text -> ByteString-accessTokenUrl fb code =-    toByteString $-    copyByteString "https://graph.facebook.com/oauth/access_token"-    `mappend`-    renderQueryText True-        [ ("client_id", Just $ facebookClientId fb)-        , ("redirect_uri", Just $ facebookRedirectUri fb)-        , ("code", Just code)-        , ("client_secret", Just $ facebookClientSecret fb)-        ]--getAccessToken :: Facebook -> Text -> IO AccessToken-getAccessToken fb code = do-    let url = accessTokenUrl fb code-    b <- simpleHttp $ S8.unpack url-    let params = parseSimpleQuery $ S8.concat $ L8.toChunks b-    case lookup "access_token" params of-        Just x -> return $ AccessToken $ T.pack $ S8.unpack x-        Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b--graphUrl :: AccessToken -> Text -> ByteString-graphUrl (AccessToken s) func =-    toByteString $-    copyByteString "https://graph.facebook.com/"-    `mappend` fromText func-    `mappend` renderQueryText True [("access_token", Just s)]--getGraphData :: AccessToken -> Text -> IO (Either String Value)-getGraphData at func = do-    let url = graphUrl at func-    b <- simpleHttp $ S8.unpack url-    return $ eitherResult $ parse json b--getGraphData_ :: AccessToken -> Text -> IO Value-getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return--data InvalidJsonException = InvalidJsonException String-    deriving (Show, Typeable)-instance Exception InvalidJsonException---- | Logs out the user from their Facebook session.-getLogoutUrl :: AccessToken-             -> Text -- ^ URL the user should be directed to in your site domain.-             -> Text -- ^ Logout URL in @https://www.facebook.com/@.-getLogoutUrl (AccessToken s) next =-    TE.decodeUtf8 $ toByteString $-    copyByteString "https://www.facebook.com/logout.php"-    `mappend` renderQueryText True [("next", Just next), ("access_token", Just s)]

@@ -1,72 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Module for using a kerberos authentication service.------ Please note that all configuration should have been done--- manually on the machine prior to running the code.------ On linux machines the configuration might be in /etc/krb5.conf.--- It's worth checking if the Kerberos service provider (e.g. your university)--- already provide a complete configuration file.------ Be certain that you can manually login from a shell by typing------ > kinit username------ If you fill in your password and the program returns no error code,--- then your kerberos configuration is setup properly.--- Only then can this module be of any use.-module Web.Authenticate.Kerberos-  ( loginKerberos-  , KerberosAuthResult(..)-  ) where--import Data.Text (Text)-import qualified Data.Text as T-import Data.Maybe (fromJust)-import Control.Monad (msum, guard)-import System.Process (readProcessWithExitCode)-import System.Timeout (timeout)-import System.Exit (ExitCode(..))---- | Occurreable results of a Kerberos login-data KerberosAuthResult = Ok-                        | NoSuchUser-                        | WrongPassword-                        | TimeOut-                        | UnknownError Text--instance Show KerberosAuthResult where-  show Ok                 = "Login sucessful"-  show NoSuchUser         = "Wrong username"-  show WrongPassword      = "Wrong password"-  show TimeOut            = "kinit respone timeout"-  show (UnknownError msg) = "Unkown error: " ++ T.unpack msg----- Given the errcode and stderr, return error-value-interpretError :: Int -> Text -> KerberosAuthResult-interpretError _ errmsg = fromJust . msum $-    ["Client not found in Kerberos database while getting" --> NoSuchUser,-     "Preauthentication failed while getting" --> WrongPassword,-     Just $ UnknownError errmsg]-  where-    substr --> kError = guard (substr `T.isInfixOf` errmsg) >> Just kError---- | Given the username and password, try login to Kerberos service-loginKerberos :: Text -- ^ Username-              -> Text -- ^ Password-              -> IO KerberosAuthResult-loginKerberos username password = do-    timedFetch <- timeout (10*1000000) fetch-    case timedFetch of-      Just res -> return res-      Nothing  -> return TimeOut-  where-    fetch :: IO KerberosAuthResult-    fetch = do-      (exitCode, _out, err) <- readProcessWithExitCode-          "kinit" [T.unpack username] (T.unpack password)-      case exitCode of-        ExitSuccess   -> return Ok-        ExitFailure x -> return $ interpretError x (T.pack err)-

@@ -1,317 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-module Web.Authenticate.OAuth-    ( -- * Data types-      OAuth(..), newOAuth, SignMethod(..), Credential(..), OAuthException(..),-      -- * Operations for credentials-      newCredential, emptyCredential, insert, delete, inserts,-      -- * Signature-      signOAuth, genSign,-      -- * Url & operation for authentication-      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 Control.Applicative-import Network.HTTP.Types (parseSimpleQuery)-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-import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))-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 qualified Data.Conduit.List as CL-import Data.Conduit.Blaze (builderToByteString)-import Blaze.ByteString.Builder (Builder)---- | Data type for OAuth client (consumer).--- The default values apply when you use 'newOAuth'-data OAuth = OAuth { oauthServerName      :: String        -- ^ Service name (You MUST specify)-                   , oauthRequestUri      :: String        -- ^ URI to request temporary credential (You MUST specify)-                   , oauthAccessTokenUri  :: String        -- ^ Uri to obtain access token (You MUST specify)-                   , oauthAuthorizeUri    :: String        -- ^ Uri to authorize (You MUST specify)-                   , 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')-                   } deriving (Show, Eq, Ord, Read, Data, Typeable)---- | Default value for OAuth datatype.--- You must specify at least oauthServerName, URIs and Tokens.-newOAuth :: OAuth-newOAuth = OAuth { oauthSignatureMethod = HMACSHA1-                 , oauthCallback = Nothing-                 , oauthRealm    = Nothing-                 }---- | Data type for signature method.-data SignMethod = PLAINTEXT-                | HMACSHA1-                | RSASHA1 PrivateKey-                  deriving (Show, Eq, Ord, Read, Data, Typeable)--deriving instance Typeable PrivateKey-deriving instance Data PrivateKey-deriving instance Read PrivateKey-deriving instance Ord PrivateKey-deriving instance Eq PrivateKey---- | 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 :: OAuth         -- ^ OAuth Application-                       -> IO 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-                                -> OAuth         -- ^ OAuth Application-                                -> IO Credential -- ^ Temporay Credential (Request Token & Secret).-getTemporaryCredentialWithScope = getTemporaryCredential' . addScope--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-                            -> OAuth         -- ^ OAuth Application-                            -> IO Credential -- ^ Temporary Credential (Request Token & Secret).-getTemporaryCredentialProxy p = getTemporaryCredential' $ addMaybeProxy p--getTemporaryCredential' :: (Request IO -> Request IO) -- ^ Request Hook-                        -> OAuth                      -- ^ OAuth Application-                        -> IO Credential              -- ^ Temporary Credential (Request Token & Secret).-getTemporaryCredential' hook oa = 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'-  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)---- | URL to obtain OAuth verifier.-authorizeUrl :: OAuth           -- ^ OAuth Application-             -> Credential      -- ^ Temporary Credential (Request Token & Secret)-             -> String          -- ^ URL to authorize-authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries)-  where queries = case oauthCallback oa of-                    Nothing       -> [("oauth_token", token cr)]-                    Just callback -> [("oauth_token", token cr), ("oauth_callback", callback)]---- | Get Access token.-getAccessToken, getTokenCredential-               :: OAuth         -- ^ OAuth Application-               -> Credential    -- ^ Temporary Credential with oauth_verifier-               -> IO Credential -- ^ Token Credential (Access Token & Secret)-getAccessToken = getAccessToken' id---- | Get Access token via the proxy.-getAccessTokenProxy, getTokenCredentialProxy-               :: Maybe Proxy   -- ^ Proxy-               -> OAuth         -- ^ OAuth Application-               -> Credential    -- ^ Temporary Credential with oauth_verifier-               -> IO Credential -- ^ Token Credential (Access Token & Secret)-getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p--getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook-                -> OAuth                      -- ^ OAuth Application-                -> Credential                 -- ^ Temporary Credential with oauth_verifier-                -> IO Credential              -- ^ Token Credential (Access Token & Secret)-getAccessToken' hook oa cr = do-  let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }-  rsp <- withManager . httpLbs =<< 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)---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---- | Add OAuth headers & sign to 'Request'.-signOAuth :: OAuth              -- ^ OAuth Application-          -> Credential         -- ^ Credential-          -> 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-  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 :: Credential -> IO Credential-addNonce cred = do-  nonce <- replicateM 10 (randomRIO ('a','z'))-  return $ insert "oauth_nonce" (BS.pack nonce) cred--addTimeStamp :: Credential -> IO Credential-addTimeStamp cred = do-  stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer-  return $ insert "oauth_timestamp" (BS.pack $ show stamp) 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--genSign :: ResourceIO m => OAuth -> Credential -> Request m -> m BS.ByteString-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 ->-      liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)--addAuthHeader :: BS.ByteString -> Credential -> Request a -> Request a-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--getBaseString :: ResourceIO 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 = 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]--toLBS :: ResourceIO 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' :: ResourceIO m => Source m Builder -> m BS.ByteString-toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume--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--addMaybeProxy :: Maybe Proxy -> Request m -> Request m-addMaybeProxy p req = req { proxy = p }

@@ -10,7 +10,6 @@ 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.Lazy (toStrict) import Network.HTTP.Conduit     ( parseUrl, urlEncodedBody, responseBody, httpLbs-    , HttpException, withManager+    , Manager     )+import Data.Conduit (ResourceT, ResourceIO) import Control.Arrow ((***), second) import Data.List (unfoldr) import Data.Maybe (fromMaybe)@@ -28,20 +28,19 @@ 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 @@                 : 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 @@     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)]

@@ -23,8 +23,8 @@  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 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 @@     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 @@                     ]                 , 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 @@                     _ -> 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

@@ -1,12 +1,11 @@ name:            authenticate-version:         0.11.1+version:         1.0.0 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,-                 rpxnow and Facebook.+description:     Focus is on third-party authentication methods, such as OpenID and BrowserID. category:        Web stability:       Stable cabal-version:   >= 1.6@@ -14,38 +13,27 @@ homepage:        http://github.com/yesodweb/authenticate  library-    build-depends:   base >= 4 && < 5,-                     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 && < 0.10,-                     network >= 2.2.1 && < 2.4,-                     case-insensitive >= 0.2,-                     RSA >= 1.0 && < 1.1,-                     time >= 1.1,-                     base64-bytestring >= 0.1 && < 0.2,-                     SHA >= 1.4 && < 1.6,-                     random >= 1.0 && < 1.1,-                     text >= 0.5 && < 1.0,-                     http-types >= 0.6 && < 0.7,-                     xml-conduit >= 0.5 && < 0.6,-                     blaze-builder >= 0.2 && < 0.4,-                     attoparsec >= 0.9,-                     tls >= 0.7 && < 0.9,-                     containers,-                     unordered-containers,-                     process >= 1.0.1.1 && < 1.2,-                     conduit >= 0.0 && < 0.1,-                     blaze-builder-conduit >= 0.0 && < 0.1+    build-depends:   base                          >= 4        && < 5+                   , aeson                         >= 0.5+                   , http-conduit                  >= 1.2      && < 1.3+                   , tagsoup                       >= 0.12     && < 0.13+                   , transformers                  >= 0.1      && < 0.3+                   , bytestring                    >= 0.9+                   , network+                   , case-insensitive              >= 0.2+                   , text+                   , http-types                    >= 0.6      && < 0.7+                   , xml-conduit                   >= 0.5.1.2  && < 0.6+                   , blaze-builder+                   , attoparsec+                   , containers+                   , unordered-containers+                   , conduit                       >= 0.2      && < 0.3+                   , blaze-builder-conduit         >= 0.2      && < 0.3     exposed-modules: Web.Authenticate.Rpxnow,                      Web.Authenticate.OpenId,                      Web.Authenticate.BrowserId,-                     Web.Authenticate.OpenId.Providers,-                     Web.Authenticate.OAuth,-                     Web.Authenticate.Facebook-                     Web.Authenticate.Kerberos+                     Web.Authenticate.OpenId.Providers     other-modules:   Web.Authenticate.Internal,                      OpenId2.Discovery,                      OpenId2.Normalization,