diff --git a/http-client-auth.cabal b/http-client-auth.cabal --- a/http-client-auth.cabal +++ b/http-client-auth.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: http-client-auth -version: 0.1.0.0 +version: 0.1.0.1 synopsis: HTTP authorization (both basic and digest) done right description: Multiple challenges aren't implemented. Authentication-Info header isn't either. license: BSD3 @@ -17,15 +17,17 @@ library exposed-modules: Network.HTTP.Client.Auth -- other-modules: - build-depends: base ==4.6.*, - blaze-builder ==0.3.*, - base64-string ==0.2.*, - transformers ==0.3.*, - crypto-conduit ==0.5.*, - bytestring ==0.10.*, - utf8-string ==0.3.*, - case-insensitive ==1.0.*, - conduit ==1.0.*, - pureMD5 ==2.1.*, - http-conduit ==1.9.* - hs-source-dirs: src + build-depends: base >= 4.0 && < 10.0, + blaze-builder >= 0.3, + base64-string >= 0.2, + transformers >= 0.3, + crypto-conduit >= 0.5, + bytestring >= 0.10, + utf8-string >= 0.3, + case-insensitive >= 1.0, + conduit >= 1.0, + pureMD5 >= 2.1, + http-conduit >= 2.1, + resourcet >= 1.1, + http-client >= 0.4 + hs-source-dirs: src diff --git a/src/Network/HTTP/Client/Auth.hs b/src/Network/HTTP/Client/Auth.hs --- a/src/Network/HTTP/Client/Auth.hs +++ b/src/Network/HTTP/Client/Auth.hs @@ -19,27 +19,31 @@ import Control.Monad (join, guard, mplus, mzero) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT(MaybeT, runMaybeT), mapMaybeT) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Control.Monad.Trans.State (State, evalState, get, put) import Crypto.Conduit (sinkHash) import qualified Data.ByteString.Lazy as L (toChunks) import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) +import qualified Data.ByteString as B (ByteString, null) import qualified Data.ByteString.UTF8 as BU (fromString, toString) import Data.CaseInsensitive (mk) import Data.Char (isAlphaNum, isAscii, isSpace) -import Data.Conduit (ResourceT, runResourceT, yield, (=$), ($$)) +import Data.Conduit (Source, yield, (=$), ($$)) import qualified Data.Conduit.List as CL (concatMap, sourceList) import Data.Digest.Pure.MD5 (md5, MD5Digest) +import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (intersperse, isPrefixOf) import Data.Maybe (catMaybes) import Data.Monoid (Monoid (mappend, mconcat, mempty)) +import Network.HTTP.Client (GivesPopper, Popper) import Network.HTTP.Conduit (Request(checkStatus, method, path, queryString, requestBody, requestHeaders), RequestBody ( RequestBodyBS, RequestBodyBuilder, - RequestBodySource, - RequestBodySourceChunked, + RequestBodyStream, + RequestBodyStreamChunked, RequestBodyLBS ), Response(responseHeaders)) @@ -283,17 +287,17 @@ Just header -> parseChallenge header -- | This function creates a string that should be sent in the Authorization header. makeRequestHeader - :: Monad m => String -- ^ login + :: String -- ^ login -> String -- ^ password -> String -- ^ string to use as cnonce, not very important yet - -> Request m -- ^ first request, already sent to the server + -> Request -- ^ first request, already sent to the server -> Challenge -- ^ challenge generated by server in responce to that request - -> MaybeT m String + -> MaybeT (ResourceT IO) String makeRequestHeader _ _ _ _ None = mzero makeRequestHeader login password _ _ (Basic _) = return $ "Basic " ++ concat (lines $ B64.encode $ login ++ ':' : password) makeRequestHeader login password cnonce req (Digest dc) = - do entityBodyHash <- lift $ makeRequestBodyHash req + do entityBodyHash <- lift $ lift $ makeRequestBodyHash req let fields = [ return "Digest", @@ -314,8 +318,8 @@ Just o -> return $ "opaque=\"" ++ o ++ "\"", case qop dc of Nothing -> mzero - Just Auth -> return "qop=auth" - Just AuthInt -> return "qop=auth-int", + Just Auth -> return "qop=\"auth\"" + Just AuthInt -> return "qop=\"auth-int\"", case qop dc of Nothing -> mzero Just _ -> return "nc=00000001" @@ -348,22 +352,36 @@ return $ concat $ intersperse " " $ catMaybes fields where -- | This function extracts URI part from the request. -- It wouldn't include the host name. -makeRequestUri :: Request m -> String +makeRequestUri :: Request -> String makeRequestUri req = let p = BU.toString $ path req pp = if "/" `isPrefixOf` p then p else '/' : p q = BU.toString $ queryString req qq = if "?" `isPrefixOf` q then q else '?' : q in pp ++ qq +popperToSource :: Popper -> Source IO B.ByteString +popperToSource p = src where + src = + do str <- lift p + if B.null str then return() else + do yield str + src +gpToHash :: GivesPopper () -> IO MD5Digest +gpToHash gp = + do ref <- newIORef $ md5 $ LU.fromString "" + gp $ \p -> + do str <- popperToSource p $$ sinkHash + writeIORef ref str + readIORef ref -- | This function makes an MD5 hash of the request body -makeRequestBodyHash :: Monad m => Request m -> m String +makeRequestBodyHash :: Request -> IO String makeRequestBodyHash req = case requestBody req of RequestBodyLBS lbs -> CL.sourceList (L.toChunks lbs) $$ hashSink RequestBodyBS bs -> yield bs $$ hashSink RequestBodyBuilder _ bldr -> yield bldr $$ bldrSink - RequestBodySource _ bldr -> bldr $$ bldrSink - RequestBodySourceChunked bldr -> bldr $$ bldrSink + RequestBodyStream _ gp -> fmap show $ gpToHash gp + RequestBodyStreamChunked gp -> fmap show $ gpToHash gp where bldrSink = CL.concatMap (L.toChunks . toLazyByteString) =$ hashSink hashSink = fmap (show :: MD5Digest -> String) sinkHash @@ -373,9 +391,9 @@ requestWithAuth :: String -- ^ login -> String -- ^ password - -> (Request (ResourceT IO) -> IO (Response body)) + -> (Request -> IO (Response body)) -- ^ function like @withManager . httpLbs@, to actually send a request - -> Request (ResourceT IO) -- ^ request to send (without authorization) + -> Request -- ^ request to send (without authorization) -> MaybeT IO (Response body) requestWithAuth login password query req = do let safeReq = req {checkStatus = \_ _ _ -> Nothing}