authenticate 0.6.4 → 0.6.5

raw patch · 4 files changed

+60/−44 lines, 4 filesdep +utf8-stringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: utf8-string

API changes (from Hackage documentation)

Files

• Web/Authenticate/Facebook.hs +8/−7
• Web/Authenticate/Internal.hs +22/−0
• Web/Authenticate/OpenId.hs +25/−34
• authenticate.cabal +5/−3

@@ -8,6 +8,7 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S+import Web.Authenticate.Internal (qsEncode)  data Facebook = Facebook     { facebookClientId :: String@@ -22,24 +23,24 @@ getForwardUrl :: Facebook -> [String] -> String getForwardUrl fb perms = concat     [ "https://graph.facebook.com/oauth/authorize?client_id="-    , facebookClientId fb -- FIXME escape+    , qsEncode $ facebookClientId fb     , "&redirect_uri="-    , facebookRedirectUri fb -- FIXME escape+    , qsEncode $ facebookRedirectUri fb     , if null perms         then ""-        else "&scope=" ++ intercalate "," perms+        else "&scope=" ++ qsEncode (intercalate "," perms)     ]  accessTokenUrl :: Facebook -> String -> String accessTokenUrl fb code = concat     [ "https://graph.facebook.com/oauth/access_token?client_id="-    , facebookClientId fb+    , qsEncode $ facebookClientId fb     , "&redirect_uri="-    , facebookRedirectUri fb+    , qsEncode $ facebookRedirectUri fb     , "&client_secret="-    , facebookClientSecret fb+    , qsEncode $ facebookClientSecret fb     , "&code="-    , code+    , qsEncode code     ]  getAccessToken :: Facebook -> String -> IO AccessToken

@@ -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

@@ -25,13 +25,14 @@  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 Control.Monad (liftM, unless) 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 }@@ -47,7 +48,8 @@ -- | Returns a URL to forward the user to in order to login. getForwardUrl :: (MonadIO m,                   Failure InvalidUrlException m,-                  Failure HttpException m+                  Failure HttpException m,+                  Failure MissingVar m                   )               => String -- ^ The openid the user provided.               -> String -- ^ The URL for this application\'s complete page.@@ -64,7 +66,11 @@                         , ("openid.return_to", complete)                         ] -getOpenIdVar :: Monad m => String -> String -> m String+data MissingVar = MissingVar String+    deriving (Typeable, Show)+instance Exception MissingVar++getOpenIdVar :: Failure MissingVar m => String -> String -> m String getOpenIdVar var content = do     let tags = parseTags content     let secs = sections (~== ("<link rel=openid." ++ var ++ ">")) tags@@ -72,17 +78,15 @@     secs'' <- mhead secs'     return $ fromAttrib "href" secs''     where-        mhead [] = fail $ "Variable not found: openid." ++ var -- FIXME+        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.@@ -90,15 +94,16 @@ authenticate :: (MonadIO m,                  Failure AuthenticateException m,                  Failure InvalidUrlException m,-                 Failure HttpException m)+                 Failure HttpException m,+                 Failure MissingVar m)              => [(String, String)]              -> m Identifier-authenticate req = do -- FIXME check openid.mode == id_res (not cancel)+authenticate req = do+    unless (lookup "openid.mode" req == Just "id_res") $+        failure $ AuthenticateException "authenticate without openid.mode=id_res"     authUrl <- getAuthUrl req-    content' <- simpleHttp authUrl-    let content = L8.unpack content'-    let isValid = contains "is_valid:true" content-    if isValid+    content <- L8.unpack `liftM` simpleHttp authUrl+    if contains "is_valid:true" content         then Identifier `liftM` alookup "openid.identity" req         else failure $ AuthenticateException content @@ -117,7 +122,8 @@  getAuthUrl :: (MonadIO m, Failure AuthenticateException m,                Failure InvalidUrlException m,-               Failure HttpException m)+               Failure HttpException m,+               Failure MissingVar m)            => [(String, String)] -> m String getAuthUrl req = do     identity <- alookup "openid.identity" req@@ -151,18 +157,3 @@ 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

@@ -1,5 +1,5 @@ name:            authenticate-version:         0.6.4+version:         0.6.5 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -21,8 +21,10 @@                      tagsoup >= 0.6 && < 0.12,                      failure >= 0.0.0 && < 0.2,                      transformers >= 0.1 && < 0.3,-                     bytestring >= 0.9 && < 0.10+                     bytestring >= 0.9 && < 0.10,+                     utf8-string >= 0.3 && < 0.4     exposed-modules: Web.Authenticate.Rpxnow,                      Web.Authenticate.OpenId,                      Web.Authenticate.Facebook-    ghc-options:     -Wall -fno-warn-orphans+    other-modules:   Web.Authenticate.Internal+    ghc-options:     -Wall