diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index f5ed0216..6260dc82 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -33,6 +33,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) import qualified Data.CaseInsensitive as CI +import Data.Text (Text, pack, unpack) data Discovery = Discovery1 String (Maybe String) | Discovery2 Provider Identifier IdentType @@ -53,7 +54,7 @@ discover ident@(Identifier i) = do res2 <- discoverHTML ident case res2 of Just x -> return x - Nothing -> failure $ DiscoveryException i + Nothing -> failure $ DiscoveryException $ unpack i -- YADIS-Based Discovery ------------------------------------------------------- @@ -68,7 +69,7 @@ discoverYADIS :: ( MonadIO m -> m (Maybe (Provider, Identifier, IdentType)) discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do - let uri = fromMaybe (identifier ident) mb_loc + let uri = fromMaybe (unpack $ identifier ident) mb_loc req <- parseUrl uri res <- liftIO $ withManager $ httpLbs req let mloc = fmap S8.unpack @@ -95,7 +96,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat where isOpenId svc = do let tys = serviceTypes svc - localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc + localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc f (x,y) | x `elem` tys = Just y | otherwise = Nothing (lid, itype) <- listToMaybe $ mapMaybe f @@ -117,7 +118,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident) -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. @@ -135,7 +136,7 @@ parseHTML ident = resolve return $ Discovery1 server delegate resolve2 ls = do prov <- lookup "openid2.provider" ls - let lid = maybe ident Identifier $ lookup "openid2.local_id" ls + let lid = maybe ident (Identifier . pack) $ 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 diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 2bcaf1c5..21dbfc82 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -26,12 +26,13 @@ import Network.URI ( uriToString, normalizeCase, normalizeEscape , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment ) +import Data.Text (Text, pack, unpack) -normalize :: Failure AuthenticateException m => String -> m Identifier +normalize :: Failure AuthenticateException m => Text -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i - Nothing -> failure $ NormalizationException ident + Nothing -> failure $ NormalizationException $ unpack ident -- | Normalize an identifier, discarding XRIs. normalizeIdentifier :: Identifier -> Maybe Identifier @@ -42,12 +43,13 @@ normalizeIdentifier = normalizeIdentifier' (const Nothing) -- normalize an XRI. normalizeIdentifier' :: (String -> Maybe String) -> Identifier -> Maybe Identifier -normalizeIdentifier' xri (Identifier str) +normalizeIdentifier' xri (Identifier str') | null str = Nothing - | "xri://" `isPrefixOf` str = Identifier `fmap` xri str - | head str `elem` "=@+$!" = Identifier `fmap` xri str + | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str + | head str `elem` "=@+$!" = (Identifier . pack) `fmap` xri str | otherwise = fmt `fmap` (url >>= norm) where + str = unpack str' url = parseURI str <|> parseURI ("http://" ++ str) norm uri = validScheme >> return u @@ -59,6 +61,7 @@ normalizeIdentifier' xri (Identifier str) | otherwise = uriPath uri fmt u = Identifier + $ pack $ normalizePathSegments $ normalizeEscape $ normalizeCase diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index ac157344..fffe2b33 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -21,12 +21,13 @@ module OpenId2.Types ( import Data.Data (Data) import Data.Typeable (Typeable) import Web.Authenticate.Internal +import Data.Text (Text) -- | An OpenID provider. newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. -newtype Identifier = Identifier { identifier :: String } +newtype Identifier = Identifier { identifier :: Text } deriving (Eq, Ord, Show, Read, Data, Typeable) data IdentType = OPIdent | ClaimedIdent diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 752dfc3e..e8ab39f5 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.OpenId ( getForwardUrl , authenticate @@ -22,25 +23,28 @@ import Network.HTTP.Enumerator import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) getForwardUrl :: ( MonadIO m , Failure AuthenticateException m , Failure HttpException m ) - => String -- ^ The openid the user provided. - -> String -- ^ The URL for this application\'s complete page. - -> Maybe String -- ^ Optional realm - -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions. - -> m String -- ^ URL to send the user to. + => 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 let realm = fromMaybe complete mrealm disc <- normalize openid' >>= discover case disc of Discovery1 server mdelegate -> - return $ qsUrl server + return $ pack $ qsUrl server + $ map (unpack *** unpack) -- FIXME $ ("openid.mode", "checkid_setup") - : ("openid.identity", fromMaybe openid' mdelegate) + : ("openid.identity", maybe openid' pack mdelegate) : ("openid.return_to", complete) : ("openid.realm", realm) : ("openid.trust_root", complete) @@ -50,22 +54,22 @@ getForwardUrl openid' complete mrealm params = do case itype of ClaimedIdent -> i OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select" - return $ qsUrl p + return $ pack $ qsUrl p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup") - : ("openid.claimed_id", i') - : ("openid.identity", i') - : ("openid.return_to", complete) - : ("openid.realm", realm) - : params + : ("openid.claimed_id", unpack i') + : ("openid.identity", unpack i') + : ("openid.return_to", unpack complete) + : ("openid.realm", unpack realm) + : map (unpack *** unpack) params authenticate :: ( MonadIO m , Failure AuthenticateException m , Failure HttpException m ) - => [(String, String)] - -> m (Identifier, [(String, String)]) + => [(Text, Text)] + -> m (Identifier, [(Text, Text)]) authenticate params = do unless (lookup "openid.mode" params == Just "id_res") $ failure $ case lookup "openid.mode" params of @@ -74,8 +78,8 @@ authenticate params = do | m == "error" -> case lookup "openid.error" params of Nothing -> AuthenticationException "An error occurred, but no error message was provided." - (Just e) -> AuthenticationException e - | otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res." + (Just e) -> AuthenticationException $ unpack e + | otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res." ident <- case lookup "openid.identity" params of Just i -> return i Nothing -> @@ -84,20 +88,21 @@ authenticate params = do let endpoint = case disc of Discovery1 p _ -> p Discovery2 (Provider p) _ _ -> p - let params' = map (BSU.fromString *** BSU.fromString) + let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params req' <- parseUrl endpoint let req = urlEncodedBody params' req' rsp <- liftIO $ withManager $ httpLbsRedirect req - let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp + let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME case lookup "is_valid" rps of Just "true" -> return (Identifier ident, rps) _ -> failure $ AuthenticationException "OpenID provider did not validate" -- | Turn a response body into a list of parameters. -parseDirectResponse :: String -> [(String, String)] -parseDirectResponse = unfoldr step +parseDirectResponse :: Text -> [(Text, Text)] +parseDirectResponse = + map (pack *** pack) . unfoldr step . unpack where step [] = Nothing step str = case split (== '\n') str of