diff --git a/openid.cabal b/openid.cabal --- a/openid.cabal +++ b/openid.cabal @@ -1,5 +1,5 @@ name: openid -version: 0.1.1.0 +version: 0.1.2.0 cabal-version: >= 1.6 synopsis: An implementation of the OpenID-2.0 spec. description: An implementation of the OpenID-2.0 spec. @@ -21,18 +21,18 @@ library if flag(split-base) - build-depends: base >= 3, + build-depends: base >= 3 && < 10, bytestring == 0.9.1.*, - containers == 0.1.0.* + containers == 0.2.* else build-depends: base < 3 - build-depends: HTTP == 3001.1.*, + build-depends: HTTP >= 4000.0.5 && < 4000.1, monadLib == 3.4.5.*, nano-hmac == 0.2.0.*, - network == 2.2.0.*, + network == 2.2.*, time == 1.1.2.*, xml == 1.3.1.*, - HsOpenSSL == 0.5.* + HsOpenSSL == 0.6.* hs-source-dirs: src exposed-modules: Codec.Binary.Base64, Codec.Encryption.DH, diff --git a/src/Network/OpenID/Association.hs b/src/Network/OpenID/Association.hs --- a/src/Network/OpenID/Association.hs +++ b/src/Network/OpenID/Association.hs @@ -42,7 +42,7 @@ import Data.Time import Data.Word import MonadLib -import Network.HTTP hiding (Result) +import Network.HTTP -- Utilities ------------------------------------------------------------------- @@ -171,7 +171,7 @@ : ("openid.assoc_type", show at) : ("openid.session_type", show st) : maybe [] dhPairs mb_dh - ersp <- lift $ resolve $ postRequest (providerURI prov) body + ersp <- lift $ resolve $ Network.OpenID.HTTP.postRequest (providerURI prov) body withResponse ersp $ \rsp -> do let ps = parseDirectResponse (rspBody rsp) case rspCode rsp of diff --git a/src/Network/OpenID/Discovery.hs b/src/Network/OpenID/Discovery.hs --- a/src/Network/OpenID/Discovery.hs +++ b/src/Network/OpenID/Discovery.hs @@ -25,7 +25,7 @@ import Data.List import Data.Maybe import MonadLib -import Network.HTTP hiding (Result) +import Network.HTTP import Network.URI @@ -70,7 +70,7 @@ 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" + _ -> err $ "HTTP request error: unexpected response code "++show (rspCode rsp) -- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml @@ -119,7 +119,7 @@ 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" + _ -> err $ "HTTP request error: unexpected response code "++show (rspCode rsp) -- | Parse out an OpenID endpoint and an actual identifier from an HTML diff --git a/src/Network/OpenID/HTTP.hs b/src/Network/OpenID/HTTP.hs --- a/src/Network/OpenID/HTTP.hs +++ b/src/Network/OpenID/HTTP.hs @@ -15,8 +15,8 @@ makeRequest -- * HTTP Utilities - , getRequest - , postRequest + , Network.OpenID.HTTP.getRequest + , Network.OpenID.HTTP.postRequest -- * Request/Response Parsing and Formatting , parseDirectResponse @@ -36,8 +36,12 @@ import Data.List import MonadLib import Network.BSD -import Network.HTTP hiding (host,port) +import Network.HTTP (Request(..), Response(..), findHeader, RequestMethod(..), + Header(..), HeaderName(..), normalizeRequest, NormalizeRequestOptions(..), + defaultNormalizeRequestOptions) import Network.Socket +import Network.HTTP.Stream (ConnError(..), simpleHTTP_) +import Network.StreamSocket () -- Stream instance for Socket in HTTP package import Network.URI hiding (query) @@ -56,15 +60,17 @@ mb_sh <- inBase (sslConnect sock) case mb_sh of Nothing -> return $ Left $ ErrorMisc "sslConnect failed" - Just sh -> simpleHTTP_ sh req - else simpleHTTP_ sock req + Just sh -> simpleHTTP_ sh normReq + else simpleHTTP_ sock normReq case ersp of Left err -> return (Left err) - Right rsp -> handleRedirect followRedirect req rsp + Right rsp -> handleRedirect followRedirect normReq rsp + where + normReq = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} req -- | Follow a redirect -handleRedirect :: Bool -> Request -> Response -> IO (Either ConnError Response) +handleRedirect :: Bool -> Request String -> Response String -> IO (Either ConnError (Response String)) handleRedirect False _ rsp = return (Right rsp) handleRedirect _ req rsp = case rspCode rsp of (3,0,_) -> case parseURI =<< findHeader HdrLocation rsp of @@ -92,7 +98,7 @@ -- Utilities ------------------------------------------------------------------- -getRequest :: URI -> Request +getRequest :: URI -> Request String getRequest uri = Request { rqURI = uri , rqMethod = GET @@ -101,7 +107,7 @@ } -postRequest :: URI -> String -> Request +postRequest :: URI -> String -> Request String postRequest uri body = Request { rqURI = uri , rqMethod = POST diff --git a/src/Network/OpenID/Types.hs b/src/Network/OpenID/Types.hs --- a/src/Network/OpenID/Types.hs +++ b/src/Network/OpenID/Types.hs @@ -34,6 +34,7 @@ import Network.URI import Network.HTTP +import Network.Stream -------------------------------------------------------------------------------- -- Types @@ -86,7 +87,7 @@ type Realm = String -- | A way to resolve an HTTP request -type Resolver m = Request -> m (Either ConnError Response) +type Resolver m = Request String -> m (Either ConnError (Response String)) -- | An OpenID provider. newtype Provider = Provider { providerURI :: URI } deriving (Eq,Show) diff --git a/src/Network/OpenID/Utils.hs b/src/Network/OpenID/Utils.hs --- a/src/Network/OpenID/Utils.hs +++ b/src/Network/OpenID/Utils.hs @@ -42,6 +42,7 @@ import Data.Word import MonadLib import Network.HTTP +import Network.Stream -- General Helpers ------------------------------------------------------------- @@ -124,6 +125,6 @@ -- | Make an HTTP request, and run a function with a successful response withResponse :: ExceptionM m Error - => Either ConnError Response -> (Response -> m a) -> m a + => Either ConnError (Response String) -> (Response String -> m a) -> m a withResponse (Left err) _ = raise $ Error $ show err withResponse (Right rsp) f = f rsp