diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 38d62d81..b0b24a36 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -8,8 +8,7 @@ import Data.Object.Json import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S -import qualified Codec.Binary.UTF8.String -import Numeric (showHex) +import Web.Authenticate.Internal (qsEncode) data Facebook = Facebook { facebookClientId :: String @@ -21,22 +20,6 @@ data Facebook = Facebook newtype AccessToken = AccessToken { unAccessToken :: String } deriving (Show, Eq, Read) -qsEncode :: String -> String -qsEncode = - concatMap go . Codec.Binary.UTF8.String.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 - getForwardUrl :: Facebook -> [String] -> String getForwardUrl fb perms = concat [ "https://graph.facebook.com/oauth/authorize?client_id=" diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs new file mode 100644 index 00000000..191c6bd7 --- /dev/null +++ b/Web/Authenticate/Internal.hs @@ -0,0 +1,22 @@ +module Web.Authenticate.Internal + ( qsEncode + ) where + +import Codec.Binary.UTF8.String (encode) +import Numeric (showHex) + +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/OpenId.hs b/Web/Authenticate/OpenId.hs index 0cebb4da..c26c70e9 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -25,13 +25,14 @@ module Web.Authenticate.OpenId import Network.HTTP.Enumerator import Text.HTML.TagSoup -import Numeric (showHex) import "transformers" Control.Monad.IO.Class import Data.Data import Control.Failure hiding (Error) import Control.Exception import Control.Monad (liftM) import qualified Data.ByteString.Lazy.Char8 as L8 +import Web.Authenticate.Internal (qsEncode) +import Data.List (intercalate) -- | An openid identifier (ie, a URL). newtype Identifier = Identifier { identifier :: String } @@ -80,14 +81,12 @@ getOpenIdVar var content = do mhead [] = failure $ MissingVar $ "openid." ++ var mhead (x:_) = return x -constructUrl :: String -> [(String, String)] -> String -- FIXME no longer needed, use Request value directly +constructUrl :: String -> [(String, String)] -> String constructUrl url [] = url -constructUrl url args = url ++ "?" ++ queryString' args - where - queryString' [] = error "queryString with empty args cannot happen" - queryString' [first] = onePair first - queryString' (first:rest) = onePair first ++ "&" ++ queryString' rest - onePair (x, y) = urlEncode x ++ "=" ++ urlEncode y +constructUrl url args = + url ++ "?" ++ intercalate "&" (map qsPair args) + where + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. @@ -158,18 +157,3 @@ begins :: String -> String -> Bool begins [] _ = True begins _ [] = False begins (x:xs) (y:ys) = x == y && begins xs ys - -urlEncode :: String -> String -urlEncode = concatMap urlEncodeChar - -urlEncodeChar :: Char -> String -urlEncodeChar x - | safeChar (fromEnum x) = return x - | otherwise = '%' : showHex (fromEnum x) "" - -safeChar :: Int -> Bool -safeChar x - | x >= fromEnum 'a' && x <= fromEnum 'z' = True - | x >= fromEnum 'A' && x <= fromEnum 'Z' = True - | x >= fromEnum '0' && x <= fromEnum '9' = True - | otherwise = False diff --git a/authenticate.cabal b/authenticate.cabal index 78e12749..75aecaab 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -26,4 +26,5 @@ library exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.Facebook + other-modules: Web.Authenticate.Internal ghc-options: -Wall