http-client-tls 0.3.0 → 0.3.1

raw patch · 5 files changed

+171/−1 lines, 5 filesdep +case-insensitivedep +criteriondep +cryptonitedep ~basedep ~http-clientPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, criterion, cryptonite, memory, transformers

Dependency ranges changed: base, http-client

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Network/HTTP/Client/TLS.hs +125/−0
• bench/Bench.hs +15/−0
• http-client-tls.cabal +17/−1
• test/Spec.hs +10/−0

@@ -1,3 +1,7 @@+## 0.3.1++* Add `applyDigestAuth`+ ## 0.3.0  * Support http-client 0.5

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} -- | Support for making connections via the connection package and, in turn, -- the tls package suite. --@@ -7,6 +8,8 @@     ( -- * Settings       tlsManagerSettings     , mkManagerSettings+      -- * Digest authentication+    , applyDigestAuth       -- * Global manager     , getGlobalManager     , setGlobalManager@@ -20,8 +23,17 @@ import Network.Socket (HostAddress) import qualified Network.TLS as TLS import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import Data.IORef (IORef, newIORef, readIORef, writeIORef) import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad (guard)+import qualified Data.CaseInsensitive as CI+import Data.Maybe (fromMaybe, isJust)+import Network.HTTP.Types (status401)+import Crypto.Hash (hash, Digest, MD5)+import Control.Arrow ((***))+import Data.ByteArray.Encoding (convertToBase, Base (Base16))  -- | Create a TLS-enabled 'ManagerSettings' with the given 'NC.TLSSettings' and -- 'NC.SockSettings'@@ -125,3 +137,116 @@ -- @since 0.2.4 setGlobalManager :: Manager -> IO () setGlobalManager = writeIORef globalManager++-- | Apply digest authentication to this request.+--+-- Note that this function will need to make an HTTP request to the+-- server in order to get the nonce, thus the need for a @Manager@ and+-- to live in @IO@. This also means that the request body will be sent+-- to the server. If the request body in the supplied @Request@ can+-- only be read once, you should replace it with a dummy value.+--+-- In the event of successfully generating a digest, this will return+-- a @Just@ value. If there is any problem with generating the digest,+-- it will return @Nothing@.+--+-- @since 0.3.1+applyDigestAuth :: MonadIO m+                => S.ByteString -- ^ username+                -> S.ByteString -- ^ password+                -> Request+                -> Manager+                -> m (Maybe Request)+applyDigestAuth user pass req man = liftIO $ do+    res <- httpNoBody req man+    return $ do+        guard $ responseStatus res == status401+        h1 <- lookup "WWW-Authenticate" $ responseHeaders res+        h2 <- stripCI "Digest " h1+        let pieces = map (strip *** strip) (toPairs h2)+        realm <- lookup "realm" pieces+        nonce <- lookup "nonce" pieces+        let qop = isJust $ lookup "qop" pieces+            digest+                | qop = md5 $ S.concat+                    [ ha1+                    , ":"+                    , nonce+                    , ":00000001:deadbeef:auth:"+                    , ha2+                    ]+                | otherwise = md5 $ S.concat [ha1, ":", nonce, ":", ha2]+              where+                ha1 = md5 $ S.concat [user, ":", realm, ":", pass]++                -- we always use no qop or qop=auth+                ha2 = md5 $ S.concat [method req, ":", path req]++                md5 bs = convertToBase Base16 (hash bs :: Digest MD5)+            key = "Authorization"+            val = S.concat+                [ "Digest username=\""+                , user+                , "\", realm=\""+                , realm+                , "\", nonce=\""+                , nonce+                , "\", uri=\""+                , path req+                , "\", response=\""+                , digest+                , "\""+                -- FIXME algorithm?+                , case lookup "opaque" pieces of+                    Nothing -> ""+                    Just o -> S.concat [", opaque=\"", o, "\""]+                , if qop+                    then ", qop=auth, nc=00000001, cnonce=\"deadbeef\""+                    else ""+                ]+        return req+            { requestHeaders = (key, val)+                             : filter+                                    (\(x, _) -> x /= key)+                                    (requestHeaders req)+            , cookieJar = Just $ responseCookieJar res+            }+  where+    stripCI x y+        | CI.mk x == CI.mk (S.take len y) = Just $ S.drop len y+        | otherwise = Nothing+      where+        len = S.length x++    _comma = 44+    _equal = 61+    _dquot = 34+    _space = 32++    strip = fst . S.spanEnd (== _space) . S.dropWhile (== _space)++    toPairs bs0+        | S.null bs0 = []+        | otherwise =+            let bs1 = S.dropWhile (== _space) bs0+                (key, bs2) = S.break (\w -> w == _equal || w == _comma) bs1+             in case () of+                  ()+                    | S.null bs2 -> [(key, "")]+                    | S.head bs2 == _equal ->+                        let (val, rest) = parseVal $ S.tail bs2+                         in (key, val) : toPairs rest+                    | otherwise ->+                        assert (S.head bs2 == _comma) $+                        (key, "") : toPairs (S.tail bs2)++    parseVal bs0 = fromMaybe (parseUnquoted bs0) $ do+        guard $ not $ S.null bs0+        guard $ S.head bs0 == _dquot+        let (x, y) = S.break (== _dquot) $ S.tail bs0+        guard $ not $ S.null y+        Just (x, S.drop 1 $ S.dropWhile (/= _comma) y)++    parseUnquoted bs =+        let (x, y) = S.break (== _comma) bs+         in (x, S.drop 1 y)

@@ -0,0 +1,15 @@+module Main where++import Criterion.Main+import Network.HTTP.Client+import Network.HTTP.Client.TLS++main :: IO ()+main = defaultMain [+      bgroup "newManager" [+            bench "defaultManagerSettings" $+                whnfIO (newManager defaultManagerSettings)+          , bench "tlsManagerSettings" $+                whnfIO (newManager tlsManagerSettings)+          ]+    ]

@@ -1,5 +1,5 @@ name:                http-client-tls-version:             0.3.0+version:             0.3.1 synopsis:            http-client backend using the connection package and tls library description:         Hackage documentation generation is not reliable. For up to date documentation, please see: <https://www.stackage.org/package/http-client-tls>. homepage:            https://github.com/snoyberg/http-client@@ -23,7 +23,13 @@                      , network                      , tls >= 1.2                      , bytestring+                     , case-insensitive+                     , transformers+                     , http-types+                     , cryptonite+                     , memory   default-language:    Haskell2010+  ghc-options:         -Wall  test-suite spec   main-is:             Spec.hs@@ -35,3 +41,13 @@                      , http-client                      , http-client-tls                      , http-types++benchmark benchmark+  main-is:             Bench.hs+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  default-language:    Haskell2010+  build-depends:       base+                     , criterion+                     , http-client+                     , http-client-tls

@@ -10,3 +10,13 @@         manager <- newManager tlsManagerSettings         withResponse "https://httpbin.org/status/418" manager $ \res ->             responseStatus res `shouldBe` status418++    it "digest authentication" $ do+        man <- newManager defaultManagerSettings+        Just req <- applyDigestAuth+            "user"+            "passwd"+            "http://httpbin.org/digest-auth/qop/user/passwd"+            man+        response <- httpNoBody req man+        responseStatus response `shouldBe` status200