From dffd1e8d40b0ff77895baf173acb48164288701c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 15 Jul 2011 08:32:54 +0300 Subject: [PATCH 01/16] case-insensitive bump --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 4c5f5fda..a5daa74e 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.1.6 +version: 0.9.1.7 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii @@ -24,7 +24,7 @@ library utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, xml >= 1.3.7 && < 1.4, - case-insensitive >= 0.2 && < 0.3, + case-insensitive >= 0.2 && < 0.4, RSA >= 1.0 && < 1.1, time >= 1.1 && < 1.3, base64-bytestring >= 0.1 && < 0.2, From 655ab103fd8e05a565445cda732254ef5effa6f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 19 Jul 2011 15:29:44 +0300 Subject: [PATCH 02/16] openid sample works with newest Yesod --- openid2.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/openid2.hs b/openid2.hs index 4f160b80..70f96e00 100644 --- a/openid2.hs +++ b/openid2.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} import Yesod -import Web.Authenticate.OpenId2 +import Web.Authenticate.OpenId import Data.Object import Data.Maybe (fromMaybe) import Network.HTTP.Enumerator @@ -14,23 +14,23 @@ mkYesod "OID" [$parseRoutes| instance Yesod OID where approot _ = "http://localhost:3000" -getRootR = defaultLayout [$hamlet| -%form!action=@ForwardR@ - OpenId: - %input!type=text!name=openid_identifier!value="http://" - %input!type=submit +getRootR = defaultLayout [$hamlet|\ +
+ \OpenId: + + |] getForwardR = do openid <- runFormGet' $ stringInput "openid_identifier" render <- getUrlRender - url <- liftIO $ getForwardUrl openid $ render CompleteR + url <- liftIO $ getForwardUrl openid (render CompleteR) Nothing [] redirectString RedirectTemporary url return () getCompleteR = do params <- reqGetParams `fmap` getRequest ident <- liftIO $ authenticate params - return $ RepPlain $ toContent ident + return $ RepPlain $ toContent $ show ident -main = withHttpEnumerator $ basicHandler 3000 OID +main = warpDebug 3000 OID From e2eee534c1d7b5b7c43919d82801161bb6b4eb82 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 19 Jul 2011 17:44:53 +0300 Subject: [PATCH 03/16] OpenId uses xml-enumerator and tagsoup --- OpenId2/Discovery.hs | 74 +++++++----------------- OpenId2/Types.hs | 2 +- OpenId2/XRDS.hs | 108 ++++++++++++++--------------------- Web/Authenticate/Internal.hs | 2 +- Web/Authenticate/OpenId.hs | 15 ++--- authenticate.cabal | 2 +- openid2.hs | 8 +-- 7 files changed, 78 insertions(+), 133 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 6260dc82..dd4fee41 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | @@ -21,6 +22,7 @@ module OpenId2.Discovery ( import OpenId2.Types import OpenId2.XRDS +import Debug.Trace -- Libraries import Data.Char import Data.List @@ -34,8 +36,14 @@ import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) import qualified Data.CaseInsensitive as CI import Data.Text (Text, pack, unpack) +import Data.Text.Lazy (toStrict) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Text.HTML.TagSoup (parseTags, Tag (TagOpen)) +import Control.Applicative ((<$>), (<*>)) -data Discovery = Discovery1 String (Maybe String) +data Discovery = Discovery1 Text (Maybe Text) | Discovery2 Provider Identifier IdentType deriving Show @@ -82,7 +90,8 @@ discoverYADIS ident mb_loc redirects = do case mloc' of Just loc -> discoverYADIS ident (Just loc) (redirects - 1) Nothing -> do - let mdoc = parseXRDS $ BSLU.toString $ responseBody res + let mdoc = parseXRDS $ responseBody res + liftIO $ print mdoc case mdoc of Just doc -> return $ parseYADIS ident doc Nothing -> return Nothing @@ -96,7 +105,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat where isOpenId svc = do let tys = serviceTypes svc - localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc + localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc f (x,y) | x `elem` tys = Just y | otherwise = Nothing (lid, itype) <- listToMaybe $ mapMaybe f @@ -118,72 +127,31 @@ discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident) + (parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident) -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. -parseHTML :: Identifier -> String -> Maybe Discovery +parseHTML :: Identifier -> Text -> Maybe Discovery parseHTML ident = resolve . filter isOpenId - . map (dropQuotes *** dropQuotes) - . linkTags - . htmlTags + . mapMaybe linkTag + . parseTags where - isOpenId (rel,_) = "openid" `isPrefixOf` rel + isOpenId (rel, x) = "openid" `T.isPrefixOf` rel resolve1 ls = do server <- lookup "openid.server" ls let delegate = lookup "openid.delegate" ls return $ Discovery1 server delegate resolve2 ls = do prov <- lookup "openid2.provider" ls - let lid = maybe ident (Identifier . pack) $ lookup "openid2.local_id" ls + let lid = maybe ident Identifier $ lookup "openid2.local_id" ls -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only -- result in a claimed identifier. return $ Discovery2 (Provider prov) lid ClaimedIdent resolve ls = resolve2 ls `mplus` resolve1 ls --- FIXME this would all be a lot better if it used tagsoup -- | Filter out link tags from a list of html tags. -linkTags :: [String] -> [(String,String)] -linkTags = mapMaybe f . filter p - where - p = ("link " `isPrefixOf`) - f xs = do - let ys = unfoldr splitAttr (drop 5 xs) - x <- lookup "rel" ys - y <- lookup "href" ys - return (x,y) - - --- | Split a string into strings of html tags. -htmlTags :: String -> [String] -htmlTags [] = [] -htmlTags xs = case break (== '<') xs of - (as,_:bs) -> fmt as : htmlTags bs - (as,[]) -> [as] - where - fmt as = case break (== '>') as of - (bs,_) -> bs - - --- | Split out values from a key="value" like string, in a way that --- is suitable for use with unfoldr. -splitAttr :: String -> Maybe ((String,String),String) -splitAttr xs = case break (== '=') xs of - (_,[]) -> Nothing - (key,_:'"':ys) -> f key (== '"') ys - (key,_:ys) -> f key isSpace ys - where - f key p cs = case break p cs of - (_,[]) -> Nothing - (value,_:rest) -> Just ((key,value), dropWhile isSpace rest) - -dropQuotes :: String -> String -dropQuotes s@('\'':x:y) - | last y == '\'' = x : init y - | otherwise = s -dropQuotes s@('"':x:y) - | last y == '"' = x : init y - | otherwise = s -dropQuotes s = s +--linkTags :: [Tag Text] -> [(Text, Text)] +linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x +linkTag x = Nothing diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index fffe2b33..cb524c1b 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -24,7 +24,7 @@ import Web.Authenticate.Internal import Data.Text (Text) -- | An OpenID provider. -newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) +newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { identifier :: Text } diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs index 1cfba367..ed0d40b9 100644 --- a/OpenId2/XRDS.hs +++ b/OpenId2/XRDS.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : Text.XRDS @@ -20,12 +20,13 @@ module OpenId2.XRDS ( ) where -- Libraries -import Control.Arrow -import Control.Monad -import Data.List -import Data.Maybe -import Text.XML.Light - +import Control.Monad ((>=>)) +import Data.Maybe (listToMaybe) +import Text.XML.Enumerator.Resolved (parseLBS, decodeEntities) +import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute, node) +import qualified Data.ByteString.Lazy as L +import Data.Text (Text) +import qualified Data.Text.Read -- Types ----------------------------------------------------------------------- @@ -34,68 +35,43 @@ type XRDS = [XRD] type XRD = [Service] data Service = Service - { serviceTypes :: [String] - , serviceMediaTypes :: [String] - , serviceURIs :: [String] - , serviceLocalIDs :: [String] + { serviceTypes :: [Text] + , serviceMediaTypes :: [Text] + , serviceURIs :: [Text] + , serviceLocalIDs :: [Text] , servicePriority :: Maybe Int - , serviceExtra :: [Element] } deriving Show --- Utilities ------------------------------------------------------------------- +parseXRDS :: L.ByteString -> Maybe XRDS +parseXRDS str = + either + (const Nothing) + (Just . parseXRDS' . fromDocument) + (parseLBS str decodeEntities) --- | Generate a tag name predicate, that ignores prefix and namespace. -tag :: String -> Element -> Bool -tag n el = qName (elName el) == n +parseXRDS' :: Cursor -> [[Service]] +parseXRDS' = element "{xri://$xrds}XRDS" &/ + element "{xri://$xrd*($v*2.0)}XRD" &| + parseXRD +parseXRD :: Cursor -> [Service] +parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService --- | Filter the attributes of an element by some predicate -findAttr' :: (QName -> Bool) -> Element -> Maybe String -findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el) - - --- | Read, maybe -readMaybe :: Read a => String -> Maybe a -readMaybe str = case reads str of - [(x,"")] -> Just x - _ -> Nothing - - --- | Get the text of an element -getText :: Element -> String -getText el = case elContent el of - [Text cd] -> cdData cd - _ -> [] - --- Parsing --------------------------------------------------------------------- - - -parseXRDS :: String -> Maybe XRDS -parseXRDS str = do - doc <- parseXMLDoc str - let xrds = filterChildren (tag "XRD") doc - return $ map parseXRD xrds - - -parseXRD :: Element -> XRD -parseXRD el = - let svcs = filterChildren (tag "Service") el - in mapMaybe parseService svcs - - -parseService :: Element -> Maybe Service -parseService el = do - let vals t x = first (map getText) $ partition (tag t) x - (tys,tr) = vals "Type" (elChildren el) - (mts,mr) = vals "MediaType" tr - (uris,ur) = vals "URI" mr - (lids,rest) = vals "LocalID" ur - priority = readMaybe =<< findAttr' (("priority" ==) . qName) el - guard $ not $ null tys - return $ Service { serviceTypes = tys - , serviceMediaTypes = mts - , serviceURIs = uris - , serviceLocalIDs = lids - , servicePriority = priority - , serviceExtra = rest - } +parseService :: Cursor -> [Service] +parseService c = + if null types then [] else [Service + { serviceTypes = types + , serviceMediaTypes = mtypes + , serviceURIs = uris + , serviceLocalIDs = localids + , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe + }] + where + types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content + mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content + uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content + localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content + readMaybe t = + case Data.Text.Read.signed Data.Text.Read.decimal t of + Right (i, "") -> Just i + _ -> Nothing diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs index 91393ab1..535005de 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -19,7 +19,7 @@ data AuthenticateException = deriving (Show, Typeable) instance Exception AuthenticateException -qsUrl :: String -> [(String, String)] -> String +qsUrl :: String -> [(String, String)] -> String -- FIXME remove qsUrl s [] = s qsUrl url pairs = url ++ delim : intercalate "&" (map qsPair pairs) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index e8ab39f5..ab4b689c 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -14,8 +14,9 @@ import Control.Failure (Failure (failure)) import OpenId2.Types import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) -import qualified Data.ByteString.UTF8 as BSU -import qualified Data.ByteString.Lazy.UTF8 as BSLU +import Data.Text.Lazy.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Lazy (toStrict) import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect , HttpException, withManager @@ -41,10 +42,10 @@ getForwardUrl openid' complete mrealm params = do disc <- normalize openid' >>= discover case disc of Discovery1 server mdelegate -> - return $ pack $ qsUrl server + return $ pack $ qsUrl (unpack server) $ map (unpack *** unpack) -- FIXME $ ("openid.mode", "checkid_setup") - : ("openid.identity", maybe openid' pack mdelegate) + : ("openid.identity", maybe openid' id mdelegate) : ("openid.return_to", complete) : ("openid.realm", realm) : ("openid.trust_root", complete) @@ -54,7 +55,7 @@ getForwardUrl openid' complete mrealm params = do case itype of ClaimedIdent -> i OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select" - return $ pack $ qsUrl p + return $ pack $ qsUrl (unpack p) $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup") : ("openid.claimed_id", unpack i') @@ -91,10 +92,10 @@ authenticate params = do let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params - req' <- parseUrl endpoint + req' <- parseUrl $ unpack endpoint let req = urlEncodedBody params' req' rsp <- liftIO $ withManager $ httpLbsRedirect req - let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME + 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" diff --git a/authenticate.cabal b/authenticate.cabal index a5daa74e..d29813bd 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -23,7 +23,6 @@ library bytestring >= 0.9 && < 0.10, utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, - xml >= 1.3.7 && < 1.4, case-insensitive >= 0.2 && < 0.4, RSA >= 1.0 && < 1.1, time >= 1.1 && < 1.3, @@ -33,6 +32,7 @@ library text >= 0.5 && < 1.0, http-types >= 0.6 && < 0.7, enumerator >= 0.4.7 && < 0.5, + xml-enumerator >= 0.3.4 && < 0.4, blaze-builder >= 0.2 && < 0.4, attoparsec >= 0.9 && < 0.10, tls >= 0.7 && < 0.8, diff --git a/openid2.hs b/openid2.hs index 70f96e00..4f20f48e 100644 --- a/openid2.hs +++ b/openid2.hs @@ -6,7 +6,7 @@ import Data.Maybe (fromMaybe) import Network.HTTP.Enumerator data OID = OID -mkYesod "OID" [$parseRoutes| +mkYesod "OID" [parseRoutes| / RootR GET /forward ForwardR GET /complete CompleteR GET @@ -14,7 +14,7 @@ mkYesod "OID" [$parseRoutes| instance Yesod OID where approot _ = "http://localhost:3000" -getRootR = defaultLayout [$hamlet|\ +getRootR = defaultLayout [hamlet|\ \OpenId: @@ -25,7 +25,7 @@ getForwardR = do openid <- runFormGet' $ stringInput "openid_identifier" render <- getUrlRender url <- liftIO $ getForwardUrl openid (render CompleteR) Nothing [] - redirectString RedirectTemporary url + redirectText RedirectTemporary url return () getCompleteR = do @@ -33,4 +33,4 @@ getCompleteR = do ident <- liftIO $ authenticate params return $ RepPlain $ toContent $ show ident -main = warpDebug 3000 OID +main = warp 3000 OID From a713f6af2d06cc6280dfb1e0ac51e8cb11d32b30 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 19 Jul 2011 17:57:02 +0300 Subject: [PATCH 04/16] Remove qsUrl and utf8-string --- OpenId2/Discovery.hs | 1 - Web/Authenticate/Internal.hs | 29 +---------------------------- Web/Authenticate/OAuth.hs | 4 ++-- Web/Authenticate/OpenId.hs | 25 +++++++++++++------------ authenticate.cabal | 1 - 5 files changed, 16 insertions(+), 44 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index dd4fee41..d91e4ea8 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -28,7 +28,6 @@ import Data.Char import Data.List import Data.Maybe import Network.HTTP.Enumerator -import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first, (***)) import Control.Monad.IO.Class (MonadIO (liftIO)) diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs index 535005de..84d7d9ee 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -1,11 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module Web.Authenticate.Internal - ( qsEncode - , qsUrl - , AuthenticateException (..) + ( AuthenticateException (..) ) where -import Codec.Binary.UTF8.String (encode) import Numeric (showHex) import Data.List (intercalate) import Data.Typeable (Typeable) @@ -18,27 +15,3 @@ data AuthenticateException = | AuthenticationException String deriving (Show, Typeable) instance Exception AuthenticateException - -qsUrl :: String -> [(String, String)] -> String -- FIXME remove -qsUrl s [] = s -qsUrl url pairs = - url ++ delim : intercalate "&" (map qsPair pairs) - where - qsPair (x, y) = qsEncode x ++ '=' : qsEncode y - delim = if '?' `elem` url then '&' else '?' - -qsEncode :: String -> String -qsEncode = - concatMap go . encode - where - go 32 = "+" -- space - go 46 = "." - go 45 = "-" - go 126 = "~" - go 95 = "_" - go c - | 48 <= c && c <= 57 = [w2c c] - | 65 <= c && c <= 90 = [w2c c] - | 97 <= c && c <= 122 = [w2c c] - go c = '%' : showHex c "" - w2c = toEnum . fromEnum diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index c9287e95..b182ea4a 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -14,7 +14,6 @@ module Web.Authenticate.OAuth paramEncode ) where import Network.HTTP.Enumerator -import Web.Authenticate.Internal (qsUrl) import Data.Data import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL @@ -38,6 +37,7 @@ import Data.Enumerator (($$), run_, Stream (..), continue) import Data.Monoid (mconcat) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (newIORef, readIORef, atomicModifyIORef) +import Network.HTTP.Types (renderSimpleQuery) -- | Data type for OAuth client (consumer). data OAuth = OAuth { oauthServerName :: String -- ^ Service name @@ -103,7 +103,7 @@ getTemporaryCredential oa = do authorizeUrl :: OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential (Request Token & Secret) -> String -- ^ URL to authorize -authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)] +authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True [("oauth_token", token cr)]) -- | Get Access token. getAccessToken, getTokenCredential diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index ab4b689c..2e8d3561 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -12,7 +12,6 @@ import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) import OpenId2.Types -import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -21,11 +20,14 @@ import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect , HttpException, withManager ) -import Control.Arrow ((***)) +import Control.Arrow ((***), second) import Data.List (unfoldr) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Blaze.ByteString.Builder (toByteString) +import Network.HTTP.Types (renderQueryText) +import Data.Monoid (mappend) getForwardUrl :: ( MonadIO m @@ -40,10 +42,9 @@ getForwardUrl getForwardUrl openid' complete mrealm params = do let realm = fromMaybe complete mrealm disc <- normalize openid' >>= discover + let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q) case disc of - Discovery1 server mdelegate -> - return $ pack $ qsUrl (unpack server) - $ map (unpack *** unpack) -- FIXME + Discovery1 server mdelegate -> helper server $ ("openid.mode", "checkid_setup") : ("openid.identity", maybe openid' id mdelegate) : ("openid.return_to", complete) @@ -55,14 +56,14 @@ getForwardUrl openid' complete mrealm params = do case itype of ClaimedIdent -> i OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select" - return $ pack $ qsUrl (unpack p) + helper p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup") - : ("openid.claimed_id", unpack i') - : ("openid.identity", unpack i') - : ("openid.return_to", unpack complete) - : ("openid.realm", unpack realm) - : map (unpack *** unpack) params + : ("openid.claimed_id", i') + : ("openid.identity", i') + : ("openid.return_to", complete) + : ("openid.realm", realm) + : params authenticate :: ( MonadIO m diff --git a/authenticate.cabal b/authenticate.cabal index d29813bd..014d48e7 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -21,7 +21,6 @@ library failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, - utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, case-insensitive >= 0.2 && < 0.4, RSA >= 1.0 && < 1.1, From 5e3ae824da91812b451edca4ef92996dac7b9ee5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 21 Jul 2011 18:03:59 +0300 Subject: [PATCH 05/16] Added BrowserId support --- Web/Authenticate/BrowserId.hs | 37 ++++++++++++++++++++++++++++ authenticate.cabal | 1 + browserid.hs | 46 +++++++++++++++++++++++++++++++++++ 3 files changed, 84 insertions(+) create mode 100644 Web/Authenticate/BrowserId.hs create mode 100644 browserid.hs diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs new file mode 100644 index 00000000..eb95bb27 --- /dev/null +++ b/Web/Authenticate/BrowserId.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module Web.Authenticate.BrowserId + ( browserIdJs + , checkAssertion + ) where + +import Data.Text (Text) +import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, queryString, withManager) +import Network.HTTP.Types (queryTextToQuery) +import Data.Aeson (json, Value (Object, String)) +import Data.Attoparsec.Lazy (parse, maybeResult) +import qualified Data.Map as Map + +-- | Location of the Javascript file hosted by browserid.org +browserIdJs :: Text +browserIdJs = "https://browserid.org/include.js" + +checkAssertion :: Text -- ^ audience + -> Text -- ^ assertion + -> IO (Maybe Text) +checkAssertion audience assertion = do + req' <- parseUrl "https://browserid.org/verify" + let req = req' + { queryString = queryTextToQuery + [ ("audience", Just audience) + , ("assertion", Just assertion) + ] + } + res <- withManager $ httpLbs req + let lbs = responseBody res + return $ maybeResult (parse json lbs) >>= getEmail + where + getEmail (Object o) = + case (Map.lookup "status" o, Map.lookup "email" o) of + (Just (String "okay"), Just (String e)) -> Just e + _ -> Nothing + getEmail _ = Nothing diff --git a/authenticate.cabal b/authenticate.cabal index 014d48e7..32b7e4b6 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -38,6 +38,7 @@ library containers exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, + Web.Authenticate.BrowserId, Web.Authenticate.OpenId.Providers, Web.Authenticate.OAuth, Web.Authenticate.Facebook diff --git a/browserid.hs b/browserid.hs new file mode 100644 index 00000000..bf365956 --- /dev/null +++ b/browserid.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +import Yesod +import Web.Authenticate.BrowserId +import Data.Object +import Data.Maybe (fromMaybe) +import Network.HTTP.Enumerator +import Data.Text (Text) + +data BID = BID +mkYesod "BID" [parseRoutes| +/ RootR GET +/complete/#Text CompleteR GET +|] + +instance Yesod BID where approot _ = "http://localhost:3000" + +getRootR = defaultLayout $ do + addScriptRemote browserIdJs + addJulius [julius| +function bidClick() { + navigator.id.getVerifiedEmail(function(assertion) { + if (assertion) { + document.location = "@{CompleteR ""}" + assertion; + } else { + alert("Invalid BrowserId login"); + } + }); +} +|] + addHamlet [hamlet| +

+ + +|] + +getCompleteR assertion = do + memail <- liftIO $ checkAssertion "localhost:3000" assertion + defaultLayout $ addHamlet [hamlet| +

You tried to log in, let's see if it worked. +$maybe email <- memail +

Yes it did! You are: #{email} +$nothing +

Nope, sorry +|] + +main = warp 3000 BID From a25be7d884a89a7b383cf7ed1650baad9904876c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 21 Jul 2011 18:04:32 +0300 Subject: [PATCH 06/16] Version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 32b7e4b6..0b0d9c8d 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.1.7 +version: 0.9.2 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii From 925c2df50614485da30435da98d77f11cc47160a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jul 2011 07:13:12 +0300 Subject: [PATCH 07/16] BrowserID: Switch from GET to POST --- Web/Authenticate/BrowserId.hs | 13 ++++++------- authenticate.cabal | 2 +- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs index eb95bb27..1dc0cf01 100644 --- a/Web/Authenticate/BrowserId.hs +++ b/Web/Authenticate/BrowserId.hs @@ -5,11 +5,12 @@ module Web.Authenticate.BrowserId ) where import Data.Text (Text) -import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, queryString, withManager) +import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody) import Network.HTTP.Types (queryTextToQuery) import Data.Aeson (json, Value (Object, String)) import Data.Attoparsec.Lazy (parse, maybeResult) import qualified Data.Map as Map +import Data.Text.Encoding (encodeUtf8) -- | Location of the Javascript file hosted by browserid.org browserIdJs :: Text @@ -20,12 +21,10 @@ checkAssertion :: Text -- ^ audience -> IO (Maybe Text) checkAssertion audience assertion = do req' <- parseUrl "https://browserid.org/verify" - let req = req' - { queryString = queryTextToQuery - [ ("audience", Just audience) - , ("assertion", Just assertion) - ] - } + let req = urlEncodedBody + [ ("audience", encodeUtf8 audience) + , ("assertion", encodeUtf8 assertion) + ] req' { method = "POST" } res <- withManager $ httpLbs req let lbs = responseBody res return $ maybeResult (parse json lbs) >>= getEmail diff --git a/authenticate.cabal b/authenticate.cabal index 0b0d9c8d..1d8309ce 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.2 +version: 0.9.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii From 1f866e0972e380f2469acc0c53c57e87c92fdc7f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jul 2011 15:47:15 +0300 Subject: [PATCH 08/16] tagsoup version bump --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 1d8309ce..8dfa684c 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.2.1 +version: 0.9.2.2 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii @@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5, aeson >= 0.3.1.1 && < 0.4, http-enumerator >= 0.6.5.4 && < 0.7, - tagsoup >= 0.6 && < 0.13, + tagsoup >= 0.12 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, From e3afa5ad3340e2437f994d0996804a238e4dc8db Mon Sep 17 00:00:00 2001 From: Arash Rouhani Date: Sun, 14 Aug 2011 21:24:04 +0200 Subject: [PATCH 09/16] Added process to build depends --- authenticate.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 8dfa684c..c4110511 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -35,7 +35,8 @@ library blaze-builder >= 0.2 && < 0.4, attoparsec >= 0.9 && < 0.10, tls >= 0.7 && < 0.8, - containers + containers, + process >= 1.0.1.1 && < 1.1 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.BrowserId, From 0a653feba4bea55705114c4285e118e6dc933b3d Mon Sep 17 00:00:00 2001 From: Arash Rouhani Date: Sun, 14 Aug 2011 21:25:27 +0200 Subject: [PATCH 10/16] Added Kerberos source file and added to modules --- Web/Authenticate/Kerberos.hs | 72 ++++++++++++++++++++++++++++++++++++ authenticate.cabal | 1 + 2 files changed, 73 insertions(+) create mode 100644 Web/Authenticate/Kerberos.hs diff --git a/Web/Authenticate/Kerberos.hs b/Web/Authenticate/Kerberos.hs new file mode 100644 index 00000000..c2c4aa58 --- /dev/null +++ b/Web/Authenticate/Kerberos.hs @@ -0,0 +1,72 @@ +{-# 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) + diff --git a/authenticate.cabal b/authenticate.cabal index c4110511..f18323ab 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -43,6 +43,7 @@ library Web.Authenticate.OpenId.Providers, Web.Authenticate.OAuth, Web.Authenticate.Facebook + Web.Authenticate.Kerberos other-modules: Web.Authenticate.Internal, OpenId2.Discovery, OpenId2.Normalization, From bb20bd8c67b9606e77ba3940e26833c38cd63cee Mon Sep 17 00:00:00 2001 From: Arash Rouhani Date: Sun, 14 Aug 2011 21:26:31 +0200 Subject: [PATCH 11/16] Updated authors --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index f18323ab..35163f12 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -2,7 +2,7 @@ name: authenticate version: 0.9.2.2 license: BSD3 license-file: LICENSE -author: Michael Snoyman, Hiromi Ishii +author: Michael Snoyman, Hiromi Ishii, Arash Rouhani maintainer: Michael Snoyman synopsis: Authentication methods for Haskell web applications. description: Focus is on third-party authentication methods, such as OpenID, From 36b2221b812473a8ad53bf4930d6351373118dd5 Mon Sep 17 00:00:00 2001 From: Arash Rouhani Date: Sun, 14 Aug 2011 23:56:12 +0200 Subject: [PATCH 12/16] version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 35163f12..74289eb5 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.2.2 +version: 0.9.2.3 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani From d1f54b23d271cdbba8a6349365ff762be1bc2229 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 18 Aug 2011 15:57:49 +0300 Subject: [PATCH 13/16] Version bump --- authenticate.cabal | 2 +- openid2.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 74289eb5..642cfbdb 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.2.3 +version: 0.9.3 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani diff --git a/openid2.hs b/openid2.hs index 4f20f48e..7f155640 100644 --- a/openid2.hs +++ b/openid2.hs @@ -12,7 +12,7 @@ mkYesod "OID" [parseRoutes| /complete CompleteR GET |] -instance Yesod OID where approot _ = "http://localhost:3000" +instance Yesod OID where approot _ = "http://10.0.0.3:3000" getRootR = defaultLayout [hamlet|\ From a4bfbdae2c65f47d8e6625693e9abb9b59b39b09 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 19 Aug 2011 08:35:20 +0300 Subject: [PATCH 14/16] time bump --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 642cfbdb..1a5cdd50 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.3 +version: 0.9.3.1 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani @@ -24,7 +24,7 @@ library network >= 2.2.1 && < 2.4, case-insensitive >= 0.2 && < 0.4, RSA >= 1.0 && < 1.1, - time >= 1.1 && < 1.3, + time >= 1.1 && < 1.4, base64-bytestring >= 0.1 && < 0.2, SHA >= 1.4 && < 1.6, random >= 1.0 && < 1.1, From 4c60715026e02b63791155714f34892d36179813 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 22 Aug 2011 23:18:42 +0300 Subject: [PATCH 15/16] process bump --- authenticate.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 1a5cdd50..0fd65495 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.3.1 +version: 0.9.3.2 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani @@ -15,7 +15,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, - aeson >= 0.3.1.1 && < 0.4, + aeson-native >= 0.3.2.11 && < 0.4, http-enumerator >= 0.6.5.4 && < 0.7, tagsoup >= 0.12 && < 0.13, failure >= 0.0.0 && < 0.2, @@ -36,7 +36,7 @@ library attoparsec >= 0.9 && < 0.10, tls >= 0.7 && < 0.8, containers, - process >= 1.0.1.1 && < 1.1 + process >= 1.0.1.1 && < 1.2 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.BrowserId, From a32a2b284e1ee56404ce8da1f0396dc1b2972753 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 23 Aug 2011 08:18:03 +0300 Subject: [PATCH 16/16] Version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 0fd65495..879ad916 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.3.2 +version: 0.10.0 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani