diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -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 diff --git a/examples/test.hs b/examples/test.hs new file mode 100644 --- /dev/null +++ b/examples/test.hs @@ -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 diff --git a/openid.cabal b/openid.cabal new file mode 100644 --- /dev/null +++ b/openid.cabal @@ -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 +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 diff --git a/src/Codec/Binary/Base64.hs b/src/Codec/Binary/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Binary/Base64.hs @@ -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 + diff --git a/src/Codec/Encryption/DH.hsc b/src/Codec/Encryption/DH.hsc new file mode 100644 --- /dev/null +++ b/src/Codec/Encryption/DH.hsc @@ -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 +#include +#include + +-- 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 diff --git a/src/Data/Digest/OpenSSL/SHA.hs b/src/Data/Digest/OpenSSL/SHA.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digest/OpenSSL/SHA.hs @@ -0,0 +1,73 @@ +{-# INCLUDE #-} +{-# 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) diff --git a/src/Network/OpenID.hs b/src/Network/OpenID.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID.hs @@ -0,0 +1,30 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.URI +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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 diff --git a/src/Network/OpenID/Association.hs b/src/Network/OpenID/Association.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Association.hs @@ -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 diff --git a/src/Network/OpenID/Association/Manager.hs b/src/Network/OpenID/Association/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Association/Manager.hs @@ -0,0 +1,36 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Network.Class +-- Copyright : (c) Trevor Elliott, 2008 +-- License : AllRightsReserved +-- +-- Maintainer : Trevor Elliott +-- 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)] diff --git a/src/Network/OpenID/Association/Map.hs b/src/Network/OpenID/Association/Map.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Association/Map.hs @@ -0,0 +1,46 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Assocation.Map +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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 diff --git a/src/Network/OpenID/Authentication.hs b/src/Network/OpenID/Authentication.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Authentication.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Authentication +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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" diff --git a/src/Network/OpenID/Discovery.hs b/src/Network/OpenID/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Discovery.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Discovery +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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) diff --git a/src/Network/OpenID/HTTP.hs b/src/Network/OpenID/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/HTTP.hs @@ -0,0 +1,160 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.HTTP +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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) diff --git a/src/Network/OpenID/Normalization.hs b/src/Network/OpenID/Normalization.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Normalization.hs @@ -0,0 +1,54 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Normalization +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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 [] diff --git a/src/Network/OpenID/Types.hs b/src/Network/OpenID/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Types.hs @@ -0,0 +1,111 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Types +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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 diff --git a/src/Network/OpenID/Utils.hs b/src/Network/OpenID/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Utils.hs @@ -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 diff --git a/src/Network/SSL.hs b/src/Network/SSL.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSL.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} +{-# INCLUDE #-} +{-# INCLUDE #-} +{-# INCLUDE #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.SSL +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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 diff --git a/src/Text/XRDS.hs b/src/Text/XRDS.hs new file mode 100644 --- /dev/null +++ b/src/Text/XRDS.hs @@ -0,0 +1,116 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XRDS +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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 + }