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.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.

7
OpenId2/Normalization.hs
View File

@ -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

16
Web/Authenticate/BrowserId.hs
View File

@ -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

20
Web/Authenticate/Facebook.hs
View File

@ -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)

88
Web/Authenticate/OAuth.hs
View File

@ -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"

39
Web/Authenticate/OpenId.hs
View File

@ -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)]

30
Web/Authenticate/Rpxnow.hs
View File

@ -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

1
authenticate.cabal
View File

@ -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