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

Merge branch 'master' of github.com:yesodweb/authenticate

Browse Source
This commit is contained in:
Hiromi Ishii 2012-03-30 17:10:09 +09:00
commit cd0afdf2d5
6 changed files with 33 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
authenticate/OpenId2/Discovery.hs
View File

@ -22,16 +22,14 @@ module OpenId2.Discovery (
import OpenId2.Types
import OpenId2.XRDS
import Debug.Trace
-- Libraries
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.Monad (mplus)
import Control.Monad (mplus, liftM)
import qualified Data.CaseInsensitive as CI
import Data.Text (Text, unpack)
import Data.Text.Lazy (toStrict)
@ -42,13 +40,15 @@ import Text.HTML.TagSoup (parseTags, Tag (TagOpen))
import Control.Applicative ((<$>), (<*>))
import Network.HTTP.Types (status200)
import Control.Exception (throwIO)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Control (MonadBaseControl)
data Discovery = Discovery1 Text (Maybe Text)
| Discovery2 Provider Identifier IdentType
deriving Show
-- | Attempt to resolve an OpenID endpoint, and user identifier.
discover :: ResourceIO m => Identifier -> Manager -> ResourceT m Discovery
discover :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Identifier -> Manager -> m Discovery
discover ident@(Identifier i) manager = do
res1 <- discoverYADIS ident Nothing 10 manager
case res1 of
@ -63,12 +63,12 @@ discover ident@(Identifier i) manager = do
-- | Attempt a YADIS based discovery, given a valid identifier. The result is
-- an OpenID endpoint, and the actual identifier for the user.
discoverYADIS :: ResourceIO m
discoverYADIS :: (MonadResource m, MonadBaseControl IO m)
=> Identifier
-> Maybe String
-> Int -- ^ remaining redirects
-> Manager
-> ResourceT m (Maybe (Provider, Identifier, IdentType))
-> 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
@ -79,7 +79,7 @@ discoverYADIS ident mb_loc redirects manager = do
$ map (first $ map toLower . S8.unpack . CI.original)
$ responseHeaders res
let mloc' = if mloc == mb_loc then Nothing else mloc
if statusCode res == status200
if responseStatus res == status200
then
case mloc' of
Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager
@ -116,10 +116,10 @@ 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 :: ResourceIO m => Identifier -> Manager -> ResourceT m (Maybe Discovery)
discoverHTML :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery)
discoverHTML ident'@(Identifier ident) manager = do
req <- liftIO $ parseUrl $ unpack ident
Response _ _ lbs <- httpLbs req manager
lbs <- liftM responseBody $ httpLbs req manager
return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs
-- | Parse out an OpenID endpoint and an actual identifier from an HTML
@ -146,5 +146,5 @@ parseHTML ident = resolve
-- | Filter out link tags from a list of html tags.
linkTag :: Tag Text -> Maybe (Text, Text)
linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x
linkTag (TagOpen "link" as) = (,) <$> lookup "rel" as <*> lookup "href" as
linkTag _x = Nothing

8
authenticate/Web/Authenticate/BrowserId.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Web.Authenticate.BrowserId
( browserIdJs
, checkAssertion
@ -6,22 +7,23 @@ module Web.Authenticate.BrowserId
import Data.Text (Text)
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)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
-- | Location of the Javascript file hosted by browserid.org
browserIdJs :: Text
browserIdJs = "https://browserid.org/include.js"
checkAssertion :: ResourceIO m
checkAssertion :: (MonadResource m, MonadBaseControl IO m)
=> Text -- ^ audience
-> Text -- ^ assertion
-> Manager
-> ResourceT m (Maybe Text)
-> m (Maybe Text)
checkAssertion audience assertion manager = do
req' <- liftIO $ parseUrl "https://browserid.org/verify"
let req = urlEncodedBody

12
authenticate/Web/Authenticate/OpenId.hs
View File

@ -20,7 +20,6 @@ import Network.HTTP.Conduit
( parseUrl, urlEncodedBody, responseBody, httpLbs
, Manager
)
import Data.Conduit (ResourceT, ResourceIO)
import Control.Arrow ((***), second)
import Data.List (unfoldr)
import Data.Maybe (fromMaybe)
@ -28,17 +27,18 @@ import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString)
import Network.HTTP.Types (renderQueryText)
import Data.Monoid (mappend)
import Control.Exception (throwIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
getForwardUrl
:: ResourceIO m
:: (MonadResource m, MonadBaseControl IO 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.
-> Manager
-> ResourceT m Text -- ^ URL to send the user to.
-> m Text -- ^ URL to send the user to.
getForwardUrl openid' complete mrealm params manager = do
let realm = fromMaybe complete mrealm
disc <- normalize openid' >>= flip discover manager
@ -70,10 +70,10 @@ getForwardUrl openid' complete mrealm params manager = do
: params
authenticate
:: ResourceIO m
:: (MonadBaseControl IO m, MonadResource m, MonadIO m)
=> [(Text, Text)]
-> Manager
-> ResourceT m (Identifier, [(Text, Text)])
-> m (Identifier, [(Text, Text)])
authenticate params manager = do
unless (lookup "openid.mode" params == Just "id_res")
$ liftIO $ throwIO $ case lookup "openid.mode" params of

7
authenticate/Web/Authenticate/Rpxnow.hs
View File

@ -23,7 +23,6 @@ module Web.Authenticate.Rpxnow
import Data.Aeson
import Network.HTTP.Conduit
import Data.Conduit (ResourceT, ResourceIO)
import Control.Monad.IO.Class
import Data.Maybe
import Control.Monad
@ -39,6 +38,8 @@ import qualified Data.Aeson.Types
import qualified Data.HashMap.Lazy as Map
import Control.Applicative ((<$>), (<*>))
import Control.Exception (throwIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
-- | Information received from Rpxnow after a valid login.
data Identifier = Identifier
@ -48,11 +49,11 @@ data Identifier = Identifier
deriving (Eq, Ord, Read, Show, Data, Typeable)
-- | Attempt to log a user in.
authenticate :: ResourceIO m
authenticate :: (MonadResource m, MonadBaseControl IO m)
=> String -- ^ API key given by RPXNOW.
-> String -- ^ Token passed by client.
-> Manager
-> ResourceT m Identifier
-> m Identifier
authenticate apiKey token manager = do
let body = L.fromChunks
[ "apiKey="

12
authenticate/authenticate.cabal
View File

@ -1,5 +1,5 @@
name: authenticate
version: 1.0.0.1
version: 1.2.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman, Hiromi Ishii, Arash Rouhani
@ -15,7 +15,7 @@ homepage: http://github.com/yesodweb/authenticate
library
build-depends: base >= 4 && < 5
, aeson >= 0.5
, http-conduit >= 1.2 && < 1.3
, http-conduit >= 1.4 && < 1.5
, tagsoup >= 0.12 && < 0.13
, transformers >= 0.1 && < 0.3
, bytestring >= 0.9
@ -23,13 +23,15 @@ library
, case-insensitive >= 0.2
, text
, http-types >= 0.6 && < 0.7
, xml-conduit >= 0.5.1.2 && < 0.6
, xml-conduit >= 0.7 && < 0.8
, blaze-builder
, attoparsec
, containers
, unordered-containers
, conduit >= 0.2 && < 0.3
, blaze-builder-conduit >= 0.2 && < 0.3
, conduit >= 0.4 && < 0.5
, resourcet >= 0.3 && < 0.4
, monad-control >= 0.3 && < 0.4
, blaze-builder-conduit >= 0.4 && < 0.5
exposed-modules: Web.Authenticate.Rpxnow,
Web.Authenticate.OpenId,
Web.Authenticate.BrowserId,

2
authenticate/browserid.hs
View File

@ -3,7 +3,7 @@ import Yesod
import Web.Authenticate.BrowserId
import Data.Object
import Data.Maybe (fromMaybe)
import Network.HTTP.Enumerator
import Network.HTTP.Conduit
import Data.Text (Text)
data BID = BID