OpenId uses Text

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

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
+  | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str
-  | head str `elem` "=@+$!"   = Identifier `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

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

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.
+    => Text -- ^ The openid the user provided.
-    -> String -- ^ The URL for this application\'s complete page.
+    -> Text -- ^ The URL for this application\'s complete page.
-    -> Maybe String -- ^ Optional realm
+    -> Maybe Text -- ^ Optional realm
-    -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
+    -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
-    -> m String -- ^ URL to send the user to.
+    -> 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.claimed_id", unpack i')
-                : ("openid.identity", i')
+                : ("openid.identity", unpack i')
-                : ("openid.return_to", complete)
+                : ("openid.return_to", unpack complete)
-                : ("openid.realm", realm)
+                : ("openid.realm", unpack realm)
-                : params
+                : map (unpack *** unpack) params
 
 authenticate
     :: ( MonadIO m
        , Failure AuthenticateException m
        , Failure HttpException m
        )
-    => [(String, String)]
+    => [(Text, Text)]
-    -> m (Identifier, [(String, String)])
+    -> 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
+                                  (Just e) -> AuthenticationException $ unpack e
-                            | otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res."
+                            | 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 :: Text -> [(Text, Text)]
-parseDirectResponse  = unfoldr step
+parseDirectResponse  =
+    map (pack *** pack) . unfoldr step . unpack
   where
     step []  = Nothing
     step str = case split (== '\n') str of