diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..019dac95 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.swp +dist diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..11dc17a1 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs new file mode 100644 index 00000000..60d57be8 --- /dev/null +++ b/Web/Authenticate/Rpxnow.hs @@ -0,0 +1,71 @@ +--------------------------------------------------------- +-- | +-- Module : Web.Authenticate.Rpxnow +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- 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 diff --git a/authenticate.cabal b/authenticate.cabal new file mode 100644 index 00000000..547f2697 --- /dev/null +++ b/authenticate.cabal @@ -0,0 +1,18 @@ +name: authenticate +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +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 + +library + build-depends: base, json, http-wget + exposed-modules: Web.Authenticate.Rpxnow + ghc-options: -Wall