authenticate (empty) → 0.0.0
raw patch · 5 files changed
+270/−0 lines, 5 filesdep +basedep +http-wgetdep +jsonsetup-changed
Dependencies added: base, http-wget, json, tagsoup
Files
- LICENSE +25/−0
- Setup.lhs +7/−0
- Web/Authenticate/OpenId.hs +147/−0
- Web/Authenticate/Rpxnow.hs +71/−0
- authenticate.cabal +20/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2008, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Web/Authenticate/OpenId.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleInstances #-}+---------------------------------------------------------+-- |+-- Module : Web.Authenticate.OpenId+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Provides functionality for being an OpenId consumer.+--+---------------------------------------------------------+module Web.Authenticate.OpenId+ ( Identifier (..)+ , getForwardUrl+ , authenticate+ ) where++import Data.Maybe (fromMaybe, fromJust)+import Network.HTTP.Wget+import Text.HTML.TagSoup+import Numeric (showHex)++-- | An openid identifier (ie, a URL).+data Identifier = Identifier { identifier :: String }++instance Monad (Either String) where+ return = Right+ fail = Left+ (Left s) >>= _ = Left s+ (Right x) >>= f = f x++-- | Returns a URL to forward the user to in order to login.+getForwardUrl :: Monad m+ => String -- ^ The openid the user provided.+ -> String -- ^ The URL for this application\'s complete page.+ -> IO (m String) -- ^ URL to send the user to.+getForwardUrl openid complete = do+ bodyIdent' <- wget openid [] []+ case bodyIdent' of+ Left s -> return $ fail s+ Right bodyIdent -> do+ server <- getOpenIdVar "server" bodyIdent+ let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent+ return $ return $ constructUrl server+ [ ("openid.mode", "checkid_setup")+ , ("openid.identity", delegate)+ , ("openid.return_to", complete)+ ]++getOpenIdVar :: Monad m => String -> String -> m String+getOpenIdVar var content = do+ let tags = parseTags content+ let secs = sections (~== ("<link rel=openid." ++ var ++ ">")) tags+ secs' <- mhead secs+ secs'' <- mhead secs'+ return $ fromAttrib "href" secs''+ where+ mhead [] = fail $ "Variable not found: openid." ++ var+ mhead (x:_) = return x++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++-- | Handle a redirect from an OpenID provider and check that the user+-- logged in properly. If it was successfully, 'return's the openid.+-- Otherwise, 'fail's an explanation.+authenticate :: Monad m => [(String, String)] -> IO (m Identifier)+authenticate req = do -- FIXME check openid.mode == id_res (not cancel)+ authUrl' <- getAuthUrl req+ case authUrl' of+ Nothing -> return $ fail "Invalid parameters"+ Just authUrl -> do+ content' <- wget authUrl [] []+ case content' of+ Left s -> return $ fail s+ Right content -> do+ let isValid = contains "is_valid:true" content+ if isValid+ then return $+ return $ Identifier+ (fromJust $ lookup "openid.identity" req)+ else return $ fail content++getAuthUrl :: [(String, String)] -> IO (Maybe String)+getAuthUrl req = do+ let identity' = lookup "openid.identity" req+ case identity' of+ Nothing -> return Nothing+ Just identity -> do+ idContent <- wget identity [] []+ case idContent of+ Nothing -> return Nothing+ Just x -> return $ helper x+ where+ helper :: String -> Maybe String+ helper idContent = do+ server <- getOpenIdVar "server" idContent+ dargs <- mapM makeArg [+ "assoc_handle",+ "sig",+ "signed",+ "identity",+ "return_to"+ ]+ let sargs = [("openid.mode", "check_authentication")]+ return $ constructUrl server $ dargs ++ sargs+ makeArg :: String -> Maybe (String, String)+ makeArg s = do+ let k = "openid." ++ s+ v <- lookup k req+ return (k, v)++contains :: String -> String -> Bool+contains [] _ = True+contains _ [] = False+contains needle haystack =+ begins needle haystack ||+ (contains needle $ tail haystack)++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
+ Web/Authenticate/Rpxnow.hs view
@@ -0,0 +1,71 @@+---------------------------------------------------------+--+-- Module : Web.Authenticate.Rpxnow+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Facilitates authentication with "http://rpxnow.com/".+--+---------------------------------------------------------+module Web.Authenticate.Rpxnow+ ( Identifier (..)+ , authenticate+ ) where++import Text.JSON+import Network.HTTP.Wget+import Data.Maybe (isJust, fromJust)++-- | Information received from Rpxnow after a valid login.+data Identifier = Identifier+ { identifier :: String+ , extraData :: [(String, String)]+ }++-- | Attempt to log a user in.+authenticate :: Monad m+ => String -- ^ API key given by RPXNOW.+ -> String -- ^ Token passed by client.+ -> IO (m Identifier)+authenticate apiKey token = do+ body <- wget+ "https://rpxnow.com/api/v2/auth_info"+ []+ [ ("apiKey", apiKey)+ , ("token", token)+ ]+ case body of+ Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s+ Right b ->+ case decode b >>= getObject of+ Error s -> return $ fail $ "Not a valid JSON response: " ++ s+ Ok o ->+ case valFromObj "stat" o of+ Error _ -> return $ fail "Missing 'stat' field"+ Ok "ok" -> return $ parseProfile o+ Ok stat -> return $ fail $ "Login not accepted: " ++ stat++parseProfile :: Monad m => JSObject JSValue -> m Identifier+parseProfile v = do+ profile <- resultToMonad $ valFromObj "profile" v >>= getObject+ ident <- resultToMonad $ valFromObj "identifier" profile+ let pairs = fromJSObject profile+ pairs' = filter (\(k, _) -> k /= "identifier") pairs+ pairs'' = map fromJust . filter isJust . map takeString $ pairs'+ return $ Identifier ident pairs''++takeString :: (String, JSValue) -> Maybe (String, String)+takeString (k, JSString v) = Just (k, fromJSString v)+takeString _ = Nothing++getObject :: Monad m => JSValue -> m (JSObject JSValue)+getObject (JSObject o) = return o+getObject _ = fail "Not an object"++resultToMonad :: Monad m => Result a -> m a+resultToMonad (Ok x) = return x+resultToMonad (Error s) = fail s
+ authenticate.cabal view
@@ -0,0 +1,20 @@+name: authenticate+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Authentication methods for Haskell web applications.+description: Focus is on remote authentication methods, such as OpenID,+ rpxnow and Google.+category: Web+stability: unstable+cabal-version: >= 1.2+build-type: Simple+homepage: http://github.com/snoyberg/authenticate/tree/master++library+ build-depends: base, json, http-wget, tagsoup+ exposed-modules: Web.Authenticate.Rpxnow,+ Web.Authenticate.OpenId+ ghc-options: -Wall -fno-warn-orphans