openid (empty) → 0.1
raw patch · 20 files changed
+2002/−0 lines, 20 filesdep +HTTPdep +basedep +bytestringsetup-changed
Dependencies added: HTTP, base, bytestring, containers, monadLib, nano-hmac, network, time, xml
Files
- LICENSE +30/−0
- Setup.lhs +4/−0
- examples/Makefile +21/−0
- examples/test.hs +30/−0
- openid.cabal +57/−0
- src/Codec/Binary/Base64.hs +145/−0
- src/Codec/Encryption/DH.hsc +199/−0
- src/Data/Digest/OpenSSL/SHA.hs +73/−0
- src/Network/OpenID.hs +30/−0
- src/Network/OpenID/Association.hs +214/−0
- src/Network/OpenID/Association/Manager.hs +36/−0
- src/Network/OpenID/Association/Map.hs +46/−0
- src/Network/OpenID/Authentication.hs +152/−0
- src/Network/OpenID/Discovery.hs +173/−0
- src/Network/OpenID/HTTP.hs +160/−0
- src/Network/OpenID/Normalization.hs +54/−0
- src/Network/OpenID/Types.hs +111/−0
- src/Network/OpenID/Utils.hs +129/−0
- src/Network/SSL.hs +222/−0
- src/Text/XRDS.hs +116/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Trevor Elliott++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS OR CONTRIBUTORS 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,4 @@+#!/usr/bin/runhaskell++> import Distribution.Simple+> main = defaultMain
+ examples/Makefile view
@@ -0,0 +1,21 @@+GHC=ghc -odir $(ODIR) -hidir $(ODIR) -W+ODIR=.ghc+HSC2HS=hsc2hs+SRC=../src++all : $(ODIR) test++$(ODIR) :+ mkdir $(ODIR)++test : $(ODIR)/DH.hs test.hs+ $(GHC) -lcrypto -lssl --make test -i$(SRC) $(ODIR)/DH.hs -Wall++$(ODIR)/DH.hs : $(SRC)/Codec/Encryption/DH.hsc+ $(HSC2HS) $< -o $@++clean :+ $(RM) -r $(ODIR)+ $(RM) test++.PHONY : all clean depend
+ examples/test.hs view
@@ -0,0 +1,30 @@++import MonadLib+import Network.OpenID+import Network.SSL++import Network.Socket+import System.Environment++main = withSocketsDo $ do+ sslInit+ [ident,check] <- getArgs+ case normalizeIdentifier (Identifier ident) of+ Nothing -> putStrLn "Unable to normalize identifier"+ Just i -> do+ let resolve = makeRequest True+ rpi <- discover resolve i+ case rpi of+ Left err -> putStrLn $ "discover: " ++ show err+ Right (p,i) -> do+ putStrLn ("found provider: " ++ show p)+ putStrLn ("found identity: " ++ show i)+ eam <- associate emptyAssociationMap True resolve p+ case eam of+ Left err -> putStrLn $ "associate: " ++ show err+ Right am -> do+ let au = authenticationURI am Setup p i check Nothing+ print au+ line <- getLine+ let params = parseParams line+ print =<< verifyAuthentication am params check resolve
+ openid.cabal view
@@ -0,0 +1,57 @@+name: openid+version: 0.1+cabal-version: >= 1.6+synopsis: An implementation of the OpenID-2.0 spec.+description: An implementation of the OpenID-2.0 spec.+category: Network+author: Trevor Elliott+maintainer: trevor@geekgateway.com+copyright: (c) 2008. Trevor Elliott <trevor@geekgateway.com>+license: BSD3+license-file: LICENSE+build-type: Simple+tested-with: GHC == 6.8.2+extra-source-files: examples/Makefile, examples/test.hs+++flag split-base+ default: True+ description: Use the new split base package.++library+ if flag(split-base)+ build-depends: base >= 3,+ bytestring == 0.9.1.*,+ containers == 0.1.0.*+ else+ build-depends: base < 3+ build-depends: HTTP == 3001.1.*,+ monadLib == 3.4.5.*,+ nano-hmac == 0.2.0.*,+ network == 2.2.0.*,+ time == 1.1.2.*,+ xml == 1.3.1.*+ extra-libraries: crypto, ssl+ hs-source-dirs: src+ exposed-modules: Codec.Binary.Base64,+ Codec.Encryption.DH,+ Data.Digest.OpenSSL.SHA,+ Network.SSL,+ Network.OpenID,+ Network.OpenID.Association,+ Network.OpenID.Association.Manager,+ Network.OpenID.Association.Map,+ Network.OpenID.Authentication,+ Network.OpenID.Discovery,+ Network.OpenID.HTTP,+ Network.OpenID.Normalization,+ Network.OpenID.Types,+ Network.OpenID.Utils,+ Text.XRDS+ ghc-options: -W+ extensions: EmptyDataDecls,+ FlexibleContexts,+ FlexibleInstances,+ ForeignFunctionInterface,+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses
+ src/Codec/Binary/Base64.hs view
@@ -0,0 +1,145 @@+{- |++ Module : Codec.Binary.Base64+ Copyright : (c) 2006-2008++ Maintainer : + Stability : unstable+ Portability : GHC++ Base64 decoding and encoding routines.++ Note:+ This module was taken from the mime package released by Galois, Inc. The+ original author is unknown.+-}+module Codec.Binary.Base64 + ( encodeRaw -- :: Bool -> [Word8] -> String+ , encodeRawString -- :: Bool -> String -> String+ , encodeRawPrim -- :: Bool -> Char -> Char -> [Word8] -> String++ , formatOutput -- :: Int -> Maybe String -> String -> String++ , decode -- :: String -> [Word8]+ , decodeToString -- :: String -> String+ , decodePrim -- :: Char -> Char -> String -> [Word8]+ ) where++import Data.Bits+import Data.Char+import Data.Word+import Data.Maybe++encodeRawString :: Bool -> String -> String+encodeRawString trail xs = encodeRaw trail (map (fromIntegral.ord) xs)++-- | 'formatOutput n mbLT str' formats 'str', splitting it+-- into lines of length 'n'. The optional value lets you control what+-- line terminator sequence to use; the default is CRLF (as per MIME.)+formatOutput :: Int -> Maybe String -> String -> String+formatOutput n mbTerm str+ | n <= 0 = error ("formatOutput: negative line length " ++ show n)+ | otherwise = chop n str+ where+ crlf :: String+ crlf = fromMaybe "\r\n" mbTerm++ chop _ "" = ""+ chop i xs =+ case splitAt i xs of+ (as,"") -> as+ (as,bs) -> as ++ crlf ++ chop i bs++encodeRaw :: Bool -> [Word8] -> String+encodeRaw trail bs = encodeRawPrim trail '+' '/' bs++-- lets you control what non-alphanum characters to use+-- (The base64url variation uses '*' and '-', for instance.)+-- No support for mapping these to multiple characters in the output though.+encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String+encodeRawPrim trail ch62 ch63 ls = encoder ls+ where+ trailer xs ys+ | not trail = xs+ | otherwise = xs ++ ys+ f = fromB64 ch62 ch63 + encoder [] = []+ encoder [x] = trailer (take 2 (encode3 f x 0 0 "")) "=="+ encoder [x,y] = trailer (take 3 (encode3 f x y 0 "")) "="+ encoder (x:y:z:ws) = encode3 f x y z (encoder ws)++encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String+encode3 f a b c rs = + f (low6 (w24 `shiftR` 18)) :+ f (low6 (w24 `shiftR` 12)) :+ f (low6 (w24 `shiftR` 6)) :+ f (low6 w24) : rs+ where+ w24 :: Word32+ w24 = (fromIntegral a `shiftL` 16) ++ (fromIntegral b `shiftL` 8) + + fromIntegral c++decodeToString :: String -> String+decodeToString str = map (chr.fromIntegral) $ decode str++decode :: String -> [Word8]+decode str = decodePrim '+' '/' str++decodePrim :: Char -> Char -> String -> [Word8]+decodePrim ch62 ch63 str = decoder $ takeUntilEnd str+ where+ takeUntilEnd "" = []+ takeUntilEnd ('=':_) = []+ takeUntilEnd (x:xs) = + case toB64 ch62 ch63 x of+ Nothing -> takeUntilEnd xs+ Just b -> b : takeUntilEnd xs++decoder :: [Word8] -> [Word8]+decoder [] = []+decoder [x] = take 1 (decode4 x 0 0 0 [])+decoder [x,y] = take 1 (decode4 x y 0 0 []) -- upper 4 bits of second val are known to be 0.+decoder [x,y,z] = take 2 (decode4 x y z 0 [])+decoder (x:y:z:w:xs) = decode4 x y z w (decoder xs)++decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]+decode4 a b c d rs =+ (lowByte (w24 `shiftR` 16)) :+ (lowByte (w24 `shiftR` 8)) :+ (lowByte w24) : rs+ where+ w24 :: Word32+ w24 =+ (fromIntegral a) `shiftL` 18 .|.+ (fromIntegral b) `shiftL` 12 .|.+ (fromIntegral c) `shiftL` 6 .|.+ (fromIntegral d)++toB64 :: Char -> Char -> Char -> Maybe Word8+toB64 a b ch+ | ch >= 'A' && ch <= 'Z' = Just (fromIntegral (ord ch - ord 'A'))+ | ch >= 'a' && ch <= 'z' = Just (26 + fromIntegral (ord ch - ord 'a'))+ | ch >= '0' && ch <= '9' = Just (52 + fromIntegral (ord ch - ord '0'))+ | ch == a = Just 62+ | ch == b = Just 63+ | otherwise = Nothing++fromB64 :: Char -> Char -> Word8 -> Char+fromB64 ch62 ch63 x + | x < 26 = chr (ord 'A' + xi)+ | x < 52 = chr (ord 'a' + (xi-26))+ | x < 62 = chr (ord '0' + (xi-52))+ | x == 62 = ch62+ | x == 63 = ch63+ | otherwise = error ("fromB64: index out of range " ++ show x)+ where+ xi :: Int+ xi = fromIntegral x++low6 :: Word32 -> Word8+low6 x = fromIntegral (x .&. 0x3f)++lowByte :: Word32 -> Word8+lowByte x = (fromIntegral x) .&. 0xff+
+ src/Codec/Encryption/DH.hsc view
@@ -0,0 +1,199 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}++module Codec.Encryption.DH (+ -- * Diffie-Hellman key exchange+ DHParams(..)+ , DHParamError(..)+ , Modulus+ , Generator+ , newDHParams+ , checkDHParams+ , generateKey+ , computeKey+ ) where++import Data.List+import Foreign+import Foreign.C++#include <openssl/bn.h>+#include <openssl/dh.h>+#include <openssl/engine.h>++-- Types -----------------------------------------------------------------------++type Generator = Int+type Modulus = Integer++data DHParams = DHParams+ { dhPrivateKey :: [Word8]+ , dhPublicKey :: [Word8]+ , dhGenerator :: Generator+ , dhModulus :: Modulus+ } deriving Show++data DHParamError+ = PNotPrime+ | PNotSafePrime+ | UnableToCheckGenerator+ | NotSuitableGenerator+ deriving Show+++-- Utilities -------------------------------------------------------------------++roll :: [Word8] -> Integer+roll = foldr step 0 . reverse+ where step n acc = acc `shiftL` 8 .|. fromIntegral n++unroll :: Integer -> [Word8]+unroll = reverse . unfoldr step+ where+ step 0 = Nothing+ step n = Just (fromIntegral n, n `shiftR` 8)+++withDH :: DHParams -> a -> (Ptr DHParams -> IO a) -> IO a+withDH ps a f = c_DH_new >>= \ptr -> if ptr == nullPtr+ then return a+ else do bin2bn (dhPrivateKey ps) >>= (#poke DH, priv_key) ptr+ bin2bn (dhPublicKey ps) >>= (#poke DH, pub_key) ptr+ bin2bn (unroll $ dhModulus ps) >>= (#poke DH, p) ptr+ bin2bn (unroll $ toInteger $ dhGenerator ps) >>= (#poke DH, g) ptr+ res <- f ptr+ c_DH_free ptr+ return res+++dhToDHParams :: Ptr DHParams -> IO DHParams+dhToDHParams ptr = do+ privKey <- bn2bin =<< (#peek DH, priv_key) ptr+ pubKey <- bn2bin =<< (#peek DH, pub_key) ptr+ p <- bn2bin =<< (#peek DH, p) ptr+ g <- bn2bin =<< (#peek DH, g) ptr+ return $ DHParams { dhPrivateKey = privKey+ , dhPublicKey = pubKey+ , dhGenerator = fromInteger $ roll g+ , dhModulus = roll p+ }++-- Diffie-Hellman --------------------------------------------------------------++newDHParams :: Int -> Generator -> IO (Maybe DHParams)+newDHParams len gen = do+ ptr <- c_DH_generate_parameters (toEnum len) (toEnum gen) nullPtr nullPtr+ if ptr == nullPtr+ then return Nothing+ else c_DH_generate_key ptr >>= \res -> case res of+ 1 -> do ps <- dhToDHParams ptr+ c_DH_free ptr+ return (Just ps)+ _ -> return Nothing+++generateKey :: Modulus -> Generator -> IO (Maybe DHParams)+generateKey p g = c_DH_new >>= \ptr -> if ptr == nullPtr+ then return Nothing+ else do bin2bn (unroll p) >>= (#poke DH, p) ptr+ bin2bn (unroll (toInteger g)) >>= (#poke DH, g) ptr+ res <- c_DH_generate_key ptr+ case res of+ 1 -> do ps <- dhToDHParams ptr+ c_DH_free ptr+ return (Just ps)+ _ -> return Nothing+++codesToErrors :: Int -> [DHParamError]+codesToErrors n = foldl f [] flags+ where+ f fs (b,e) | testBit n b = e : fs+ | otherwise = fs+ flags = [ (0, PNotPrime)+ , (1, PNotSafePrime)+ , (2, UnableToCheckGenerator)+ , (3, NotSuitableGenerator)+ ]+++checkDHParams :: DHParams -> IO [DHParamError]+checkDHParams ps =+ withDH ps [] $ \dh ->+ alloca $ \codes ->+ do res <- c_DH_check dh codes+ case res of+ 1 -> (codesToErrors . fromEnum) `fmap` peek codes+ _ -> return []+++{-# NOINLINE computeKey #-}+computeKey :: [Word8] -> DHParams -> [Word8]+computeKey pubKey ps = unsafePerformIO $+ withDH ps [] $ \dh ->+ c_DH_size dh >>= \size ->+ allocaArray (fromEnum size) $ \key ->+ withBIGNUM pubKey $ \pk ->+ do res <- c_DH_compute_key key pk dh+ case res of+ (-1) -> return []+ _ -> map (toEnum . fromEnum) `fmap` peekArray (fromEnum size) key+++foreign import ccall unsafe "openssl/dh.h DH_new"+ c_DH_new :: IO (Ptr DHParams)+foreign import ccall unsafe "openssl/dh.h DH_generate_parameters"+ c_DH_generate_parameters :: CInt -> CInt -> Ptr () -> Ptr ()+ -> IO (Ptr DHParams)+foreign import ccall unsafe "openssl/dh.h DH_generate_key"+ c_DH_generate_key :: Ptr DHParams -> IO CInt+foreign import ccall unsafe "openssl/dh.h DH_compute_key"+ c_DH_compute_key :: Ptr CUChar -> Ptr BIGNUM -> Ptr DHParams -> IO CInt+foreign import ccall unsafe "openssl/dh.h DH_check"+ c_DH_check :: Ptr DHParams -> Ptr CInt -> IO CInt+foreign import ccall unsafe "openssl/dh.h DH_size"+ c_DH_size :: Ptr DHParams -> IO CInt+foreign import ccall "openssl/dh.h DH_free"+ c_DH_free :: Ptr DHParams -> IO ()+++-- OpenSSL BIGNUM --------------------------------------------------------------++data BIGNUM+++withBIGNUM :: [Word8] -> (Ptr BIGNUM -> IO a) -> IO a+withBIGNUM bs f = do+ bn <- bin2bn bs+ res <- f bn+ c_BN_free bn+ return res+++bin2bn :: [Word8] -> IO (Ptr BIGNUM)+bin2bn bs = withArrayLen (map (toEnum . fromEnum) bs) $ \len array ->+ c_BN_bin2bn array (toEnum $ fromEnum len) nullPtr+++bn2bin :: Ptr BIGNUM -> IO [Word8]+bn2bin ptr = do+ len <- numBytes ptr+ array <- mallocArray len+ size <- c_BN_bn2bin ptr array+ list <- peekArray len array+ return $ map (toEnum . fromEnum) $ take (fromEnum size) list+++-- | Figure out how many bytes are used by a BIGNUM+numBytes :: Ptr BIGNUM -> IO Int+numBytes ptr = f `fmap` c_BN_num_bits ptr+ where f bits = (fromEnum bits + 7) `div` 8+++foreign import ccall unsafe "openssl/bn.h BN_bin2bn"+ c_BN_bin2bn :: Ptr CUChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM)+foreign import ccall unsafe "openssl/bn.h BN_bn2bin"+ c_BN_bn2bin :: Ptr BIGNUM -> Ptr CUChar -> IO CInt+foreign import ccall unsafe "openssl/bn.h BN_free"+ c_BN_free :: Ptr BIGNUM -> IO ()+foreign import ccall unsafe "openssl/bn.h BN_num_bits"+ c_BN_num_bits :: Ptr BIGNUM -> IO CInt
+ src/Data/Digest/OpenSSL/SHA.hs view
@@ -0,0 +1,73 @@+{-# INCLUDE <openssl/evp.h> #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}++--------------------------------------------------------------------------------+-- |+-- Module : Data.Digest.OpenSSL.SHA+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer :+-- Stability :+-- Portability :+--++module Data.Digest.OpenSSL.SHA (sha1, sha256) where++import Control.Exception+import Foreign+import Foreign.C++data EVP_MD+data EVP_MD_CTX++-- | Sha1 hashing+{-# NOINLINE sha1 #-}+sha1 :: [Word8] -> [Word8]+sha1 = unsafePerformIO . hashWith c_EVP_sha1+++-- | Sha256 hashing+{-# NOINLINE sha256 #-}+sha256 :: [Word8] -> [Word8]+sha256 = unsafePerformIO . hashWith c_EVP_sha256+++-- | General purpose digest function wrapper for OpenSSL.+hashWith :: IO (Ptr EVP_MD) -> [Word8] -> IO [Word8]+hashWith hf bs =+ bracket c_EVP_MD_CTX_create c_EVP_MD_CTX_destroy $ \ evp_md_ctx ->+ withArrayLen (map (toEnum . fromEnum) bs) $ \ len arr -> do+ h <- hf+ c_EVP_DigestInit_ex evp_md_ctx h nullPtr+ c_EVP_DigestUpdate evp_md_ctx arr (toEnum len)+ allocaArray 64 $ \ hash ->+ alloca $ \ num -> do+ c_EVP_DigestFinal_ex evp_md_ctx hash num+ n <- peek num+ hs <- peekArray (fromEnum n) hash+ return $ map (toEnum . fromEnum) hs+++++foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_create"+ c_EVP_MD_CTX_create :: IO (Ptr EVP_MD_CTX)++foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_destroy"+ c_EVP_MD_CTX_destroy :: Ptr EVP_MD_CTX -> IO ()++foreign import ccall unsafe "openssl/evp.h EVP_DigestInit_ex"+ c_EVP_DigestInit_ex :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> Ptr () -> IO CInt++foreign import ccall unsafe "openssl/evp.h EVP_DigestUpdate"+ c_EVP_DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CUChar -> CInt -> IO CInt++foreign import ccall unsafe "openssl/evp.h EVP_DigestFinal_ex"+ c_EVP_DigestFinal_ex :: Ptr EVP_MD_CTX -> Ptr CUChar -> Ptr CUInt -> IO CInt++foreign import ccall unsafe "openssl/evp.h EVP_sha1"+ c_EVP_sha1 :: IO (Ptr EVP_MD)++foreign import ccall unsafe "openssl/evp.h EVP_sha256"+ c_EVP_sha256 :: IO (Ptr EVP_MD)
+ src/Network/OpenID.hs view
@@ -0,0 +1,30 @@++--------------------------------------------------------------------------------+-- |+-- Module : Network.URI+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.OpenID (+ module Network.OpenID.Association+ , module Network.OpenID.Authentication+ , module Network.OpenID.Discovery+ , module Network.OpenID.HTTP+ , module Network.OpenID.Normalization+ , module Network.OpenID.Types+ , module Network.OpenID.Utils+ ) where++-- Friends+import Network.OpenID.Association+import Network.OpenID.Authentication+import Network.OpenID.Discovery+import Network.OpenID.HTTP+import Network.OpenID.Normalization+import Network.OpenID.Types+import Network.OpenID.Utils
+ src/Network/OpenID/Association.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,+ MultiParamTypeClasses #-}++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Association+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : +-- Stability : +-- Portability : +--++module Network.OpenID.Association (+ -- * Association+ associate+ , associate'++ -- * Lower-level interface+ , Assoc, runAssoc, AssocEnv(..)+ , associate_++ , module Network.OpenID.Association.Manager+ , module Network.OpenID.Association.Map+ ) where++-- Friends+import Codec.Binary.Base64+import Codec.Encryption.DH+import Data.Digest.OpenSSL.SHA+import Network.OpenID.Association.Manager+import Network.OpenID.Association.Map+import Network.OpenID.HTTP+import Network.OpenID.Types+import Network.OpenID.Utils++-- Libraries+import Data.Bits+import Data.List+import Data.Maybe+import Data.Time+import Data.Word+import MonadLib+import Network.HTTP hiding (Result)++-- Utilities -------------------------------------------------------------------++-- | Check to see if an AssocType and SessionType pairing is valid.+validPairing :: AssocType -> SessionType -> Bool+validPairing _ NoEncryption = True+validPairing HmacSha256 DhSha256 = True+validPairing HmacSha1 DhSha256 = True+validPairing _ _ = False+++-- | Generate parameters for Diffie-Hellman key exchange, based on the provided+-- SessionType.+newSessionTypeParams :: SessionType -> IO (Maybe DHParams)+newSessionTypeParams NoEncryption = return Nothing+newSessionTypeParams st = newDHParams bits gen+ where+ bits = case st of+ NoEncryption -> 0+ DhSha1 -> 160+ DhSha256 -> 256+ gen = 2 -- for now?+++-- | Turn DHParams into a list of key/value pairs that can be sent to a+-- Provider.+dhPairs :: DHParams -> Params+dhPairs dh = [ ("openid.dh_modulus", enci $ dhModulus dh)+ , ("openid.dh_gen", enci $ toInteger $ dhGenerator dh)+ , ("openid.dh_consumer_public", enc $ dhPublicKey dh)+ ]+ where+ enc = encodeRaw True . btwoc+ enci = enc . unroll+++-- | Give the hash algorithm for a session type+hash :: SessionType -> [Word8] -> [Word8]+hash NoEncryption = id+hash DhSha1 = sha1+hash DhSha256 = sha256+++-- | Get the mac key from a set of Diffie-Hellman parameters, and the public+-- key of the server.+decodeMacKey :: SessionType -> [Word8] -> [Word8] -> DHParams -> [Word8]+decodeMacKey st mac pubKey dh = zipWith xor key mac+ where key = hash st $ btwoc $ computeKey pubKey dh+++-- Interface -------------------------------------------------------------------+++-- | Associate with a provider.+-- By default, this tries to use DH-SHA256 and HMAC-SHA256, and falls back to+-- whatever the server recommends, if the Bool parameter is True.+associate :: AssociationManager am+ => am -> Bool -> Resolver IO -> Provider -> IO (Either Error am)+associate am rec res prov = associate' am rec res prov HmacSha256 DhSha256+++-- | Associate with a provider, attempting to use the provided association+-- methods. The Bool specifies whether or not recovery should be attempted+-- upon a failed request.+associate' :: AssociationManager am+ => am -> Bool -> Resolver IO -> Provider -> AssocType -> SessionType+ -> IO (Either Error am)+associate' am rec res prov at st+ = runAssoc (AssocEnv getCurrentTime newSessionTypeParams)+ $ associate_ am rec res prov at st+++-- | Association environment+data AssocEnv m = AssocEnv+ { currentTime :: m UTCTime+ , createParams :: SessionType -> m (Maybe DHParams)+ }+++-- | Association monad+newtype Assoc m a = Assoc (ReaderT (AssocEnv m) (ExceptionT Error m) a)+ deriving (Functor,Monad)++instance MonadT Assoc where+ lift = Assoc . lift . lift++instance Monad m => ExceptionM (Assoc m) Error where+ raise e = Assoc (raise e)++instance Monad m => ReaderM (Assoc m) (AssocEnv m) where+ ask = Assoc ask+++-- | Running a computation in the association monad+runAssoc :: (Monad m, BaseM m m)+ => AssocEnv m -> Assoc m a -> m (Either Error a)+runAssoc env (Assoc m) = runExceptionT (runReaderT env m)+++-- | Use the underlying monad to retrieve the current time.+getTime :: Monad m => Assoc m UTCTime+getTime = lift . currentTime =<< ask+++-- | Generate Diffie-Hellman parameters in the underlying monad.+newParams :: Monad m => SessionType -> Assoc m (Maybe DHParams)+newParams st = ask >>= \env -> lift (createParams env st)+++-- | A "pure" version of association. It will run in whatever base monad is+-- provided, layering exception handling over that.+associate_ :: (Monad m, AssociationManager am)+ => am -> Bool -> Resolver m -> Provider -> AssocType -> SessionType+ -> Assoc m am+associate_ am' recover resolve prov at st = do+ now <- getTime+ let am = expire am' now+ if isJust (findAssociation am prov)+ then return am+ else case validPairing at st of+ True -> do+ mb_dh <- newParams st+ let body = formatParams+ $ ("openid.ns", openidNS)+ : ("openid.mode", "associate")+ : ("openid.assoc_type", show at)+ : ("openid.session_type", show st)+ : maybe [] dhPairs mb_dh+ ersp <- lift $ resolve $ postRequest (providerURI prov) body+ withResponse ersp $ \rsp -> do+ let ps = parseDirectResponse (rspBody rsp)+ case rspCode rsp of+ (2,0,0) -> handleAssociation am ps mb_dh prov now at st+ (4,0,0)+ | recover -> recoverAssociation am ps resolve prov at st+ | otherwise ->+ let m = maybe "" (": " ++) (lookup "error" ps)+ in raise $ Error $ "unable to associate" ++ m+ _ -> raise $ Error "unexpected HTTP response"+ False -> raise $ Error "invalid association and session type pairing"+++-- | Attempt to recover from an association failure+recoverAssociation :: (Monad m, AssociationManager am)+ => am -> Params -> Resolver m -> Provider+ -> AssocType -> SessionType+ -> Assoc m am+recoverAssociation am ps res prov at st = associate_ am False res prov+ (l at "assoc_type") (l st "session_type")+ where l d k = fromMaybe d (readMaybe =<< lookup k ps)+++-- | Handle the response to an associate request.+handleAssociation :: (Monad m, AssociationManager am)+ => am -> Params -> Maybe DHParams -> Provider -> UTCTime+ -> AssocType -> SessionType+ -> Assoc m am+handleAssociation am ps mb_dh prov now at st = do+ ah <- lookupParam "assoc_handle" ps+ ei <- readParam "expires_in" ps+ mk <- case (st,mb_dh) of+ (NoEncryption,_) -> decode `fmap` lookupParam "mac_key" ps+ (_,Just dh) -> do+ mk <- lookupParam "enc_mac_key" ps+ pubKey <- lookupParam "dh_server_public" ps+ return $ decodeMacKey st (decode mk) (decode pubKey) dh+ _ -> raise (Error "Diffie-Hellman parameters not generated")+ return $ addAssociation am now prov+ $ Association ei ah mk at
+ src/Network/OpenID/Association/Manager.hs view
@@ -0,0 +1,36 @@++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Network.Class+-- Copyright : (c) Trevor Elliott, 2008+-- License : AllRightsReserved+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.OpenID.Association.Manager where++-- friends+import Network.OpenID.Types++-- libraries+import Data.Time+++-- | Manage pairs of Providers and Associations.+class AssociationManager am where+ -- | Find an association.+ findAssociation :: am -> Provider -> Maybe Association++ -- | Add a new association, and set its expiration to be relative to the "now"+ -- parameter passed in.+ addAssociation :: am -> UTCTime -> Provider -> Association -> am++ -- | Expire associations in the manager that are older than the supplied "now"+ -- parameter.+ expire :: am -> UTCTime -> am++ -- | Export all associations, and their expirations+ exportAssociations :: am -> [(String,UTCTime,Association)]
+ src/Network/OpenID/Association/Map.hs view
@@ -0,0 +1,46 @@++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Assocation.Map+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.OpenID.Association.Map (+ -- Association Map+ AssociationMap+ , emptyAssociationMap+ ) where++-- friends+import Network.OpenID.Association.Manager+import Network.OpenID.Types++-- libraries+import Data.Time+import qualified Data.Map as Map+++-- | A simple association manager based on Data.Map+newtype AssociationMap = AM (Map.Map String (UTCTime,Association))+ deriving Show++instance AssociationManager AssociationMap where+ findAssociation (AM m) p = snd `fmap` Map.lookup (showProvider p) m++ addAssociation (AM m) now p a = AM (Map.insert (showProvider p) (expire,a) m)+ where expire = addUTCTime (toEnum (assocExpiresIn a)) now++ expire (AM m) now = AM (Map.filter ((now >) . fst) m)++ exportAssociations (AM m) = map f (Map.toList m)+ where f (p,(t,a)) = (p,t,a)+++-- | An empty association map.+emptyAssociationMap :: AssociationMap+emptyAssociationMap = AM Map.empty
+ src/Network/OpenID/Authentication.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleContexts #-}++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Authentication+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.OpenID.Authentication (+ -- * Types+ CheckIdMode(..)++ -- * Authentication+ , authenticationURI+ , verifyAuthentication+ ) where++-- friends+import Codec.Binary.Base64+import Network.OpenID.Association.Manager+import Network.OpenID.HTTP+import Network.OpenID.Types+import Network.OpenID.Utils++-- libraries+import Data.List+import MonadLib+import Network.HTTP+import Network.URI+import Numeric++import qualified Data.ByteString as BS+import qualified Data.Digest.OpenSSL.HMAC as HMAC+++--------------------------------------------------------------------------------+-- Types++data CheckIdMode = Immediate | Setup++instance Show CheckIdMode where+ show Immediate = "checkid_immediate"+ show Setup = "checkid_setup"++instance Read CheckIdMode where+ readsPrec _ s | "checkid_immediate" `isPrefixOf` s = [(Immediate, drop 17 s)]+ | "checkid_setup" `isPrefixOf` s = [(Setup, drop 13 s)]+ | otherwise = []++--------------------------------------------------------------------------------+-- Utilities++-- | Get the mac hash type+macHash :: AssocType -> HMAC.CryptoHashFunction+macHash HmacSha1 = HMAC.sha1+macHash HmacSha256 = HMAC.sha256+++-- | Parse a provider within the Result monad+parseProvider' :: ExceptionM m Error => String -> m Provider+parseProvider' = maybe err return . parseProvider+ where err = raise (Error "unable to parse openid.op_endpoint")+++-- | Get the signed fields from a set of parameters+getSignedFields :: ExceptionM m Error => [String] -> Params -> m Params+getSignedFields ks ps = maybe err return (mapM lkp ks)+ where+ err = raise (Error "not all signed parameters present")+ lkp k = (,) k `fmap` lookup ("openid." ++ k) ps+++--------------------------------------------------------------------------------+-- Authentication++-- | Generate an authentication URL+authenticationURI :: AssociationManager am+ => am -> CheckIdMode -> Provider -> Identifier -> ReturnTo+ -> Maybe Realm -> URI+authenticationURI am mode prov ident rt mb_realm =+ addParams params (providerURI prov)+ where+ params = [ ("openid.ns", openidNS)+ , ("openid.mode", show mode)+ , ("openid.claimed_id", getIdentifier ident)+ , ("openid.identity", getIdentifier ident)+ , ("openid.return_to", rt)+ ] ++ ah +++ maybe [] (\r -> [("openid.realm", r)]) mb_realm+ ah = case findAssociation am prov of+ Nothing -> []+ Just a -> [("openid.assoc_handle", assocHandle a)]+++-- | Verify a signature on a set of params.+verifyAuthentication :: (Monad m, AssociationManager am)+ => am -> Params -> ReturnTo -> Resolver m+ -> m (Either Error ())+verifyAuthentication am ps rto resolve =+ runExceptionT $ do+ u <- lookupParam "openid.return_to" ps+ unless (u == rto) $ raise $ Error $ "invalid return path: " ++ u+ prov <- parseProvider' =<< lookupParam "openid.op_endpoint" ps+ case findAssociation am prov of+ Nothing -> verifyDirect ps prov resolve+ Just assoc -> verifyWithAssociation ps assoc+++-- | Verify an assertion directly+verifyDirect :: Monad m+ => Params -> Provider -> Resolver m -> ExceptionT Error m ()+verifyDirect ps prov resolve = do+ let body = formatParams+ $ ("openid.mode","check_authentication")+ : filter (\p -> fst p /= "openid.mode") ps+ ersp <- lift $ resolve Request+ { rqURI = providerURI prov+ , rqMethod = POST+ , rqHeaders =+ [ Header HdrContentLength $ show $ length body+ , Header HdrContentType "application/x-www-form-urlencoded"+ ]+ , rqBody = body+ }+ withResponse ersp $ \rsp -> do+ let rps = parseDirectResponse (rspBody rsp)+ case lookup "is_valid" rps of+ Just "true" -> return ()+ _ -> raise (Error "invalid authentication request")+++-- | Verify with an association+verifyWithAssociation :: Monad m+ => Params -> Association -> ExceptionT Error m ()+verifyWithAssociation ps a = do+ mode <- lookupParam "openid.mode" ps+ unless (mode == "id_res") $ raise $ Error $ "unexpected openid.mode: " ++ mode+ sigParams <- breaks (',' ==) `fmap` lookupParam "openid.signed" ps+ sig <- decode `fmap` lookupParam "openid.sig" ps+ sps <- getSignedFields sigParams ps+ let h = macHash (assocType a)+ msg = map (toEnum . fromEnum) (formatDirectParams sps)+ mc = HMAC.unsafeHMAC h (BS.pack (assocMacKey a)) (BS.pack msg)+ sig' = case readHex mc of+ [(x,"")] -> unroll x+ _ -> []+ unless (sig' == sig) $ raise $ Error "invalid signature"
+ src/Network/OpenID/Discovery.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE FlexibleContexts #-}++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Discovery+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.OpenID.Discovery (+ -- * Discovery+ discover+ ) where++-- Friends+import Network.OpenID.Types+import Text.XRDS++-- Libraries+import Data.Char+import Data.List+import Data.Maybe+import MonadLib+import Network.HTTP hiding (Result)+import Network.URI+++type M = ExceptionT Error+++-- | Attempt to resolve an OpenID endpoint, and user identifier.+discover :: Monad m+ => Resolver m -> Identifier -> m (Either Error (Provider,Identifier))+discover resolve ident = do+ res <- runExceptionT (discoverYADIS resolve ident Nothing)+ case res of+ Right {} -> return res+ _ -> runExceptionT (discoverHTML resolve ident)+++-- YADIS-Based Discovery -------------------------------------------------------++-- | Attempt a YADIS based discovery, given a valid identifier. The result is+-- an OpenID endpoint, and the actual identifier for the user.+discoverYADIS :: Monad m+ => Resolver m -> Identifier -> Maybe String+ -> M m (Provider,Identifier)+discoverYADIS resolve ident mb_loc = do+ let err = raise . Error+ uri = fromMaybe (getIdentifier ident) mb_loc+ case parseURI uri of+ Nothing -> err "Unable to parse identifier as a URI"+ Just uri -> do+ estr <- lift $ resolve Request+ { rqMethod = GET+ , rqURI = uri+ , rqHeaders = []+ , rqBody = ""+ }+ case estr of+ Left e -> err $ "HTTP request error: " ++ show e+ Right rsp -> case rspCode rsp of+ (2,0,0) -> case findHeader (HdrCustom "X-XRDS-Location") rsp of+ Just loc -> discoverYADIS resolve ident (Just loc)+ _ -> do+ let e = err "Unable to parse YADIS document"+ doc <- maybe e return $ parseXRDS $ rspBody rsp+ parseYADIS ident doc+ _ -> err "HTTP request error: unexpected response code"+++-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml+-- document.+parseYADIS :: ExceptionM m Error+ => Identifier -> XRDS -> m (Provider,Identifier)+parseYADIS ident = handleError . listToMaybe . mapMaybe isOpenId . concat+ where+ handleError = maybe e return+ where e = raise (Error "YADIS document doesn't include an OpenID provider")+ isOpenId svc = do+ let tys = serviceTypes svc+ localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc+ f (x,y) | x `elem` tys = Just y+ | otherwise = mzero+ lid <- listToMaybe $ mapMaybe f+ [ ("http://specs.openid.net/auth/2.0/server", ident)+ -- claimed identifiers+ , ("http://specs.openid.net/auth/2.0/signon", localId)+ , ("http://openid.net/signon/1.0" , localId)+ , ("http://openid.net/signon/1.1" , localId)+ ]+ uri <- parseProvider =<< listToMaybe (serviceURIs svc)+ return (uri,lid)+++-- HTML-Based Discovery --------------------------------------------------------++-- | Attempt to discover an OpenID endpoint, from an HTML document. The result+-- will be an endpoint on success, and the actual identifier of the user.+discoverHTML :: Monad m+ => Resolver m -> Identifier -> M m (Provider,Identifier)+discoverHTML resolve ident = do+ let err = raise . Error+ case parseURI (getIdentifier ident) of+ Nothing -> err "Unable to parse identifier as a URI"+ Just uri -> do+ estr <- lift $ resolve Request+ { rqMethod = GET+ , rqURI = uri+ , rqHeaders = []+ , rqBody = ""+ }+ case estr of+ Left e -> err $ "HTTP request error: " ++ show e+ Right rsp -> case rspCode rsp of+ (2,0,0) -> maybe (err "Unable to find identifier in HTML") return+ $ parseHTML ident $ rspBody rsp+ _ -> err "HTTP request error: unexpected response code"+++-- | Parse out an OpenID endpoint and an actual identifier from an HTML+-- document.+parseHTML :: Identifier -> String -> Maybe (Provider,Identifier)+parseHTML ident = resolve+ . filter isOpenId+ . linkTags+ . htmlTags+ where+ isOpenId (rel,_) = "openid" `isPrefixOf` rel+ resolve ls = do+ prov <- parseProvider =<< lookup "openid2.provider" ls+ let lid = maybe ident Identifier $ lookup "openid2.local_id" ls+ return (prov,lid)+++-- | Filter out link tags from a list of html tags.+linkTags :: [String] -> [(String,String)]+linkTags = mapMaybe f . filter p+ where+ p = ("link " `isPrefixOf`)+ f xs = do+ let ys = unfoldr splitAttr (drop 5 xs)+ x <- lookup "rel" ys+ y <- lookup "href" ys+ return (x,y)+++-- | Split a string into strings of html tags.+htmlTags :: String -> [String]+htmlTags [] = []+htmlTags xs = case break (== '<') xs of+ (as,_:bs) -> fmt as : htmlTags bs+ (as,[]) -> [as]+ where+ fmt as = case break (== '>') as of+ (bs,_) -> bs+++-- | Split out values from a key="value" like string, in a way that+-- is suitable for use with unfoldr.+splitAttr :: String -> Maybe ((String,String),String)+splitAttr xs = case break (== '=') xs of+ (_,[]) -> Nothing+ (key,_:'"':ys) -> f key (== '"') ys+ (key,_:ys) -> f key isSpace ys+ where+ f key p cs = case break p cs of+ (_,[]) -> Nothing+ (value,_:rest) -> Just ((key,value), dropWhile isSpace rest)
+ src/Network/OpenID/HTTP.hs view
@@ -0,0 +1,160 @@++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.HTTP+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.OpenID.HTTP (+ -- * Request Interface+ makeRequest++ -- * HTTP Utilities+ , getRequest+ , postRequest++ -- * Request/Response Parsing and Formatting+ , parseDirectResponse+ , formatParams+ , formatDirectParams+ , escapeParam+ , addParams+ , parseParams+ ) where++-- friends+import Network.OpenID.Types+import Network.OpenID.Utils+import Network.SSL++-- libraries+import Data.List+import MonadLib+import Network.BSD+import Network.HTTP hiding (host,port)+import Network.Socket+import Network.URI hiding (query)+++-- | Perform an http request.+-- If the Bool parameter is set to True, redirects from the server will be+-- followed.+makeRequest :: Bool -> Resolver IO+makeRequest followRedirect req = case getAuthority (rqURI req) of+ Left err -> return (Left err)+ Right (host,port) -> do+ hi <- getHostByName host+ sock <- socket AF_INET Stream 0+ connect sock $ SockAddrInet port $ head $ hostAddresses hi+ ersp <- if uriScheme (rqURI req) == "https:"+ then inBase $ do+ mb_sh <- inBase (sslConnect sock)+ case mb_sh of+ Nothing -> return $ Left $ ErrorMisc "sslConnect failed"+ Just sh -> simpleHTTP_ sh req+ else simpleHTTP_ sock req+ case ersp of+ Left err -> return (Left err)+ Right rsp -> handleRedirect followRedirect req rsp+++-- | Follow a redirect+handleRedirect :: Bool -> Request -> Response -> IO (Either ConnError Response)+handleRedirect False _ rsp = return (Right rsp)+handleRedirect _ req rsp = case rspCode rsp of+ (3,0,2) -> case parseURI =<< findHeader HdrLocation rsp of+ Just uri -> makeRequest False req { rqURI = uri }+ Nothing -> return (Right rsp)+ _ -> return (Right rsp)+++-- | Get the port and hostname associated with an http request+getAuthority :: URI -> Either ConnError (HostName,PortNumber)+getAuthority uri = case uriAuthority uri of+ Nothing -> Left $ ErrorMisc "No uri authority"+ Just auth ->+ let host = uriRegName auth+ readPort = readMaybe . tail+ port | null (uriPort auth) = case uriScheme uri of+ "https:" -> Just 443+ "http:" -> Just 80+ _ -> Nothing+ | otherwise = fromInteger `fmap` readPort (uriPort auth)+ in case port of+ Nothing -> Left $ ErrorMisc "Unable to parse port number"+ Just p -> Right (host,p)++-- Utilities -------------------------------------------------------------------+++getRequest :: URI -> Request+getRequest uri = Request+ { rqURI = uri+ , rqMethod = GET+ , rqHeaders = []+ , rqBody = ""+ }+++postRequest :: URI -> String -> Request+postRequest uri body = Request+ { rqURI = uri+ , rqMethod = POST+ , rqHeaders =+ [ Header HdrContentType "application/x-www-form-urlencoded"+ , Header HdrContentLength $ show $ length body+ ]+ , rqBody = body+ }++-- Parsing and Formatting ------------------------------------------------------++-- | Turn a response body into a list of parameters.+parseDirectResponse :: String -> Params+parseDirectResponse = unfoldr step+ where+ step [] = Nothing+ step str = case split (== '\n') str of+ (ps,rest) -> Just (split (== ':') ps,rest)+++-- | Format OpenID parameters as a query string+formatParams :: Params -> String+formatParams = intercalate "&" . map f+ where f (x,y) = x ++ "=" ++ escapeParam y+++-- | Format OpenID parameters as a direct response+formatDirectParams :: Params -> String+formatDirectParams = concatMap f+ where f (x,y) = x ++ ":" ++ y ++ "\n"+++-- | Escape for the query string of a URI+escapeParam :: String -> String+escapeParam = escapeURIString isUnreserved+++-- | Add Parameters to a URI+addParams :: Params -> URI -> URI+addParams ps uri = uri { uriQuery = query }+ where+ f (k,v) = (k,v)+ ps' = map f ps+ query = '?' : formatParams (parseParams (uriQuery uri) ++ ps')+++-- | Parse OpenID parameters out of a url string+parseParams :: String -> Params+parseParams xs = case split (== '?') xs of+ (_,bs) -> unfoldr step bs+ where+ step [] = Nothing+ step bs = case split (== '&') bs of+ (as,rest) -> case split (== '=') as of+ (k,v) -> Just ((k, unEscapeString v),rest)
+ src/Network/OpenID/Normalization.hs view
@@ -0,0 +1,54 @@++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Normalization+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability : +-- Portability : +--++module Network.OpenID.Normalization where++-- Friends+import Network.OpenID.Types++-- Libraries+import Control.Applicative+import Control.Monad+import Data.List+import Network.URI hiding (scheme,path)+++-- | Normalize an identifier, discarding XRIs.+normalizeIdentifier :: Identifier -> Maybe Identifier+normalizeIdentifier = normalizeIdentifier' (const Nothing)+++-- | Normalize the user supplied identifier, using a supplied function to+-- normalize an XRI.+normalizeIdentifier' :: (String -> Maybe String) -> Identifier+ -> Maybe Identifier+normalizeIdentifier' xri (Identifier str)+ | null str = Nothing+ | "xri://" `isPrefixOf` str = Identifier `fmap` xri str+ | head str `elem` "=@+$!" = Identifier `fmap` xri str+ | otherwise = fmt `fmap` (url >>= norm)+ where+ url = parseURI str <|> parseURI ("http://" ++ str)++ norm uri = validScheme >> return u+ where+ scheme = uriScheme uri+ validScheme = guard (scheme == "http:" || scheme == "https:")+ u = uri { uriFragment = "", uriPath = path }+ path | null (uriPath uri) = "/"+ | otherwise = uriPath uri++ fmt u = Identifier+ $ normalizePathSegments+ $ normalizeEscape+ $ normalizeCase+ $ uriToString (const "") u []
+ src/Network/OpenID/Types.hs view
@@ -0,0 +1,111 @@++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Types+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability : +-- Portability : +--++module Network.OpenID.Types (+ AssocType(..)+ , SessionType(..)+ , Association(..)+ , Params+ , ReturnTo+ , Realm+ , Resolver+ , Provider+ , parseProvider+ , showProvider+ , providerURI+ , modifyProvider+ , Identifier(..)+ , Error(..)+ ) where++-- Libraries+import Control.Monad+import Data.List+import Data.Word+import Network.URI++import Network.HTTP++--------------------------------------------------------------------------------+-- Types++-- | Supported association types+data AssocType = HmacSha1 | HmacSha256++instance Show AssocType where+ show HmacSha1 = "HMAC-SHA1"+ show HmacSha256 = "HMAC-SHA256"++instance Read AssocType where+ readsPrec _ str | "HMAC-SHA1" `isPrefixOf` str = [(HmacSha1 ,drop 9 str)]+ | "HMAC-SHA256" `isPrefixOf` str = [(HmacSha256, drop 11 str)]+ | otherwise = []+++-- | Session types for association establishment+data SessionType = NoEncryption | DhSha1 | DhSha256++instance Show SessionType where+ show NoEncryption = "no-encryption"+ show DhSha1 = "DH-SHA1"+ show DhSha256 = "DH-SHA256"++instance Read SessionType where+ readsPrec _ str+ | "no-encryption" `isPrefixOf` str = [(NoEncryption, drop 13 str)]+ | "DH-SHA1" `isPrefixOf` str = [(DhSha1, drop 7 str)]+ | "DH-SHA256" `isPrefixOf` str = [(DhSha256, drop 9 str)]+ | otherwise = []+++-- | An association with a provider.+data Association = Association+ { assocExpiresIn :: Int+ , assocHandle :: String+ , assocMacKey :: [Word8]+ , assocType :: AssocType+ } deriving Show+++-- | Parameter lists for communication with the server+type Params = [(String,String)]++-- | A return to path+type ReturnTo = String++-- | A realm of uris for a provider to inform a user about+type Realm = String++-- | A way to resolve an HTTP request+type Resolver m = Request -> m (Either ConnError Response)++-- | An OpenID provider.+newtype Provider = Provider { providerURI :: URI } deriving (Eq,Show)++-- | Parse a provider+parseProvider :: String -> Maybe Provider+parseProvider = fmap Provider . parseURI++-- | Show a provider+showProvider :: Provider -> String+showProvider (Provider uri) = uriToString (const "") uri []++-- | Modify the URI in a provider+modifyProvider :: (URI -> URI) -> Provider -> Provider+modifyProvider f (Provider uri) = Provider (f uri)++-- | A valid OpenID identifier.+newtype Identifier = Identifier { getIdentifier :: String }+ deriving (Eq,Show,Read)++-- | Errors+newtype Error = Error String deriving Show
+ src/Network/OpenID/Utils.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE FlexibleContexts #-}++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Utils+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer :+-- Stability :+-- Portability :+--++module Network.OpenID.Utils (+ -- * General Helpers+ readMaybe+ , breaks+ , split+ , roll+ , unroll+ , btwoc++ -- * OpenID Defaults+ , defaultModulus+ , openidNS++ -- * MonadLib helpers+ , readM+ , lookupParam+ , readParam+ , withResponse+ ) where++-- friends+import Network.OpenID.Types++-- libraries+import Data.Bits+import Data.Char+import Data.List+import Data.Maybe+import Data.Word+import MonadLib+import Network.HTTP+++-- General Helpers -------------------------------------------------------------++-- | Read, maybe.+readMaybe :: Read a => String -> Maybe a+readMaybe str = case reads str of+ [(x,"")] -> Just x+ _ -> Nothing+++-- | Break up a string by a predicate.+breaks :: (a -> Bool) -> [a] -> [[a]]+breaks p xs = case break p xs of+ (as,_:bs) -> as : breaks p bs+ (as,_) -> [as]+++-- | Spit a list into a pair, removing the element that caused the predicate to+-- succeed.+split :: (a -> Bool) -> [a] -> ([a],[a])+split p as = case break p as of+ (xs,_:ys) -> (xs,ys)+ pair -> pair+++-- | Build an Integer out of a big-endian list of bytes.+roll :: [Word8] -> Integer+roll = foldr step 0 . reverse+ where step n acc = acc `shiftL` 8 .|. fromIntegral n+++-- | Turn an Integer into a big-endian list of bytes+unroll :: Integer -> [Word8]+unroll = reverse . unfoldr step+ where+ step 0 = Nothing+ step i = Just (fromIntegral i, i `shiftR` 8)+++-- | Pad out a list of bytes to represent a positive, big-endian list of bytes.+btwoc :: [Word8] -> [Word8]+btwoc [] = [0x0]+btwoc bs@(x:_) | testBit x 7 = 0x0 : bs+ | otherwise = bs+++-- OpenID Defaults -------------------------------------------------------------++-- | The OpenID-2.0 namespace.+openidNS :: String+openidNS = "http://specs.openid.net/auth/2.0"+++-- | Default modulus for Diffie-Hellman key exchange.+defaultModulus :: Integer+defaultModulus = 0xDCF93A0B883972EC0E19989AC5A2CE310E1D37717E8D9571BB7623731866E61EF75A2E27898B057F9891C2E27A639C3F29B60814581CD3B2CA3986D2683705577D45C2E7E52DC81C7A171876E5CEA74B1448BFDFAF18828EFD2519F14E45E3826634AF1949E5B535CC829A483B8A76223E5D490A257F05BDFF16F2FB22C583AB+++-- MonadLib Helpers ------------------------------------------------------------++-- | Read inside of an Exception monad+readM :: (ExceptionM m e, Read a) => e -> String -> m a+readM e str = case reads str of+ [(x,"")] -> return x+ _ -> raise e+++-- | Lookup parameters inside an exception handling monad+lookupParam :: ExceptionM m Error => String -> Params -> m String+lookupParam k ps = maybe err return (lookup k ps)+ where err = raise $ Error $ "field not present: " ++ k+++-- | Read a field+readParam :: (Read a, ExceptionM m Error) => String -> Params -> m a+readParam k ps = readM err =<< lookupParam k ps+ where err = Error ("unable to read field: " ++ k)+++-- | Make an HTTP request, and run a function with a successful response+withResponse :: ExceptionM m Error+ => Either ConnError Response -> (Response -> m a) -> m a+withResponse (Left err) _ = raise $ Error $ show err+withResponse (Right rsp) f = f rsp
+ src/Network/SSL.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}+{-# INCLUDE <openssl/err.h> #-}+{-# INCLUDE <openssl/rand.h> #-}+{-# INCLUDE <openssl/ssl.h> #-}++--------------------------------------------------------------------------------+-- |+-- Module : Network.SSL+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Network.SSL (+ -- * Types+ SSLHandle++ -- * Library Functions+ , sslInit+ , randSeed+ , sslConnect+ , sslRead+ , sslReadWhile+ , sslWrite+ ) where++-- Libraries+import Control.Monad+import Data.List+import Data.Maybe+import Data.Word+import Foreign.C+import Foreign.ForeignPtr+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable+import Network.Socket+import Network.Stream+++wrap m = Right `fmap` m `catch` handler+ where handler = return . Left . ErrorMisc . show+++instance Stream SSLHandle where+ readLine sh = wrap (upd `fmap` sslReadWhile (/= c) sh)+ where+ c = toEnum (fromEnum '\n')+ upd bs = map (toEnum . fromEnum) bs ++ "\n"+ readBlock sh n = wrap (map (toEnum . fromEnum) `fmap` sslRead sh n)+ writeBlock sh bs = wrap $ sslWrite sh $ map (toEnum . fromEnum) bs+ close (SH (_,_,sock)) = sClose sock+++++newtype SSLHandle = SH (ForeignPtr SSL,ForeignPtr SSL_CTX,Socket)++-- | Initialize OpenSSL+sslInit :: IO ()+sslInit = do+ c_SSL_library_init+ c_SSL_load_error_strings+++-- | Seed the PRNG.+-- On systems that don't provide /dev/urandom, use this to seed the PRNG.+randSeed :: [Word8] -> IO ()+randSeed bs = withArray bs (\buf -> c_RAND_seed buf len)+ where len = genericLength bs+++-- | Initiate an ssl connection.+-- XXX: needs some error handling.+sslConnect :: Socket -> IO (Maybe SSLHandle)+sslConnect sock =+ notNull (c_SSL_CTX_new =<< c_SSLv23_client_method) $ \ctx ->+ newForeignPtr p_SSL_CTX_free ctx >>= \pctx ->+ notNull (c_SSL_new ctx) $ \ssl ->+ newForeignPtr p_SSL_shutdown ssl >>= \pssl ->+ setSocket ssl sock >>= \b ->+ if not b+ then return Nothing+ else+ let loop = c_SSL_connect ssl >>= \ret -> case ret of+ 1 -> return $ Just $ SH (pssl,pctx,sock)+ 0 -> return Nothing+ _ -> c_SSL_get_error ssl ret >>= \code -> case code of+ 2 -> loop+ _ -> return Nothing+ in loop+++-- | Read n bytes from an SSLHandle+sslRead :: SSLHandle -> Int -> IO [Word8]+sslRead (SH (pssl,_,_)) n = withForeignPtr pssl (loop n)+ where+ loop n ssl | n < 1024 = aux ssl n+ | otherwise = do xs <- aux ssl 1024+ ys <- loop (n - 1024) ssl+ return (xs ++ ys)+ aux ssl n = allocaArray n aux'+ where+ aux' buf = do+ ret <- c_SSL_read ssl buf (toEnum n)+ bs <- peekArray (toEnum n) buf+ if ret >= 0+ then return bs+ else c_SSL_get_error ssl ret >>= \r -> case r of+ -- need to try again to finish the read+ 2 -> aux' buf+ 0 -> return []+ _ -> getError >>= error . ("sslRead: " ++)+++sslReadWhile :: (Word8 -> Bool) -> SSLHandle -> IO [Word8]+sslReadWhile p (SH (pssl,_,_)) = withForeignPtr pssl f+ where+ f ssl = allocaArray 1 loop+ where+ loop buf = do+ ret <- c_SSL_read ssl buf 1+ b <- peek buf+ if ret == 1 && p b+ then do+ bs <- loop buf+ return (b:bs)+ else c_SSL_get_error ssl ret >>= \r -> case r of+ 2 -> loop buf+ 0 -> return []+ _ -> getError >>= error . ("sslReadWhile: " ++)+++-- | Write a block of bytes to an SSLHandle+sslWrite :: SSLHandle -> [Word8] -> IO ()+sslWrite _ [] = return ()+sslWrite (SH (pssl,_,_)) bs = withForeignPtr pssl $ \ssl -> withArrayLen bs (write ssl)+ where+ write ssl len buf = do+ ret <- c_SSL_write ssl buf (toEnum len)+ if ret > 0+ then return ()+ else c_SSL_get_error ssl ret >>= \r -> case r of+ 2 -> write ssl len buf+ 0 -> return ()+ _ -> getError >>= error . ("sslWrite:" ++)+++-- Utility Functions -----------------------------------------------------------++notNull :: IO (Ptr a) -> (Ptr a -> IO (Maybe b)) -> IO (Maybe b)+notNull m f = do+ ptr <- m+ if ptr == nullPtr+ then return Nothing+ else f ptr+++-- | Associate a socket with an SSL handle+setSocket :: Ptr SSL -> Socket -> IO Bool+setSocket ssl sock = c_SSL_set_fd ssl (fdSocket sock) >>= \ret ->+ case ret of+ 1 -> return True+ _ -> return False+++getError :: IO String+getError = allocaArray 120 $ \array -> do+ c_ERR_error_string 120 array+ peekCString array+++-- OpenSSL Interface -----------------------------------------------------------++data SSL_CTX+data SSL+++foreign import ccall "openssl/ssl.h SSL_CTX_new"+ c_SSL_CTX_new :: Ptr () -> IO (Ptr SSL_CTX)++foreign import ccall "openssl/ssl.h SSLv23_client_method"+ c_SSLv23_client_method :: IO (Ptr ())++foreign import ccall "openssl/ssl.h SSL_library_init"+ c_SSL_library_init :: IO ()++foreign import ccall "openssl/ssl.h SSL_load_error_strings"+ c_SSL_load_error_strings :: IO ()++foreign import ccall "openssl/rand.h RAND_seed"+ c_RAND_seed :: Ptr Word8 -> CInt -> IO ()++foreign import ccall "openssl/ssl.h SSL_new"+ c_SSL_new :: Ptr SSL_CTX -> IO (Ptr SSL)++foreign import ccall "openssl/ssl.h &SSL_shutdown"+ p_SSL_shutdown :: FunPtr (Ptr SSL -> IO ())++foreign import ccall "openssl/ssl.h &SSL_CTX_free"+ p_SSL_CTX_free :: FunPtr (Ptr SSL_CTX -> IO ())++foreign import ccall "openssl/ssl.h SSL_set_fd"+ c_SSL_set_fd :: Ptr SSL -> CInt -> IO CInt++foreign import ccall "openssl/ssl.h SSL_connect"+ c_SSL_connect :: Ptr SSL -> IO CInt++foreign import ccall "openssl/ssl.h SSL_get_error"+ c_SSL_get_error :: Ptr SSL -> CInt -> IO CInt++foreign import ccall "openssl/err.h ERR_error_string"+ c_ERR_error_string :: CULong -> CString -> IO CString++foreign import ccall "openssl/ssl.h SSL_read"+ c_SSL_read :: Ptr SSL -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall "openssl/ssl.h SSL_write"+ c_SSL_write :: Ptr SSL -> Ptr Word8 -> CInt -> IO CInt
+ src/Text/XRDS.hs view
@@ -0,0 +1,116 @@++--------------------------------------------------------------------------------+-- |+-- Module : Text.XRDS+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module Text.XRDS (+ -- * Types+ XRDS, XRD+ , Service(..)++ -- * Utility Functions+ , isUsable+ , hasType++ -- * Parsing+ , parseXRDS+ ) where++-- Libraries+import Control.Arrow+import Control.Monad+import Data.List+import Data.Maybe+import Text.XML.Light+++-- Types -----------------------------------------------------------------------++type XRDS = [XRD]++type XRD = [Service]++data Service = Service+ { serviceTypes :: [String]+ , serviceMediaTypes :: [String]+ , serviceURIs :: [String]+ , serviceLocalIDs :: [String]+ , servicePriority :: Maybe Int+ , serviceExtra :: [Element]+ } deriving Show++-- Utilities -------------------------------------------------------------------++-- | Check to see if an XRDS service description is usable.+isUsable :: XRDS -> Bool+isUsable = not . null . concat+++-- | Generate a tag name predicate, that ignores prefix and namespace.+tag :: String -> Element -> Bool+tag n el = qName (elName el) == n+++-- | Filter the attributes of an element by some predicate+findAttr' :: (QName -> Bool) -> Element -> Maybe String+findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el)+++-- | Read, maybe+readMaybe :: Read a => String -> Maybe a+readMaybe str = case reads str of+ [(x,"")] -> Just x+ _ -> Nothing+++-- | Get the text of an element+getText :: Element -> String+getText el = case elContent el of+ [Text cd] -> cdData cd+ _ -> []+++-- | Generate a predicate over Service Types.+hasType :: String -> Service -> Bool+hasType ty svc = ty `elem` serviceTypes svc+++-- Parsing ---------------------------------------------------------------------+++parseXRDS :: String -> Maybe XRDS+parseXRDS str = do+ doc <- parseXMLDoc str+ let xrds = filterChildren (tag "XRD") doc+ return $ map parseXRD xrds+++parseXRD :: Element -> XRD+parseXRD el =+ let svcs = filterChildren (tag "Service") el+ in mapMaybe parseService svcs+++parseService :: Element -> Maybe Service+parseService el = do+ let vals t x = first (map getText) $ partition (tag t) x+ (tys,tr) = vals "Type" (elChildren el)+ (mts,mr) = vals "MediaType" tr+ (uris,ur) = vals "URI" mr+ (lids,rest) = vals "LocalID" ur+ priority = readMaybe =<< findAttr' (("priority" ==) . qName) el+ guard $ not $ null tys+ return $ Service { serviceTypes = tys+ , serviceMediaTypes = mts+ , serviceURIs = uris+ , serviceLocalIDs = lids+ , servicePriority = priority+ , serviceExtra = rest+ }