http-client-auth (empty) → 0.1.0.0
raw patch · 4 files changed
+455/−0 lines, 4 filesdep +basedep +base64-stringdep +blaze-buildersetup-changed
Dependencies added: base, base64-string, blaze-builder, bytestring, case-insensitive, conduit, crypto-conduit, http-conduit, pureMD5, transformers, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- http-client-auth.cabal +31/−0
- src/Network/HTTP/Client/Auth.hs +392/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Miguel Mitrofanov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Miguel Mitrofanov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER 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.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ http-client-auth.cabal view
@@ -0,0 +1,31 @@+-- Initial http-client-auth.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: http-client-auth +version: 0.1.0.0 +synopsis: HTTP authorization (both basic and digest) done right +description: Multiple challenges aren't implemented. Authentication-Info header isn't either. +license: BSD3 +license-file: LICENSE +author: Miguel Mitrofanov +maintainer: miguelimo38@yandex.ru +-- copyright: +category: Network +build-type: Simple +cabal-version: >=1.8 + +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
+ src/Network/HTTP/Client/Auth.hs view
@@ -0,0 +1,392 @@+module Network.HTTP.Client.Auth+(+ requestWithAuth,+-- * High-level functions+ Challenge,+ realm,+ getChallenge,+ makeRequestHeader,+-- * Low-level functions+ extractAuthHeader,+ parseChallenge,+-- * Utils+ makeRequestUri,+ makeRequestBodyHash+)+where+import Blaze.ByteString.Builder (toLazyByteString)+import Codec.Binary.Base64.String as B64 (encode)+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.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.UTF8 as BU (fromString, toString)+import Data.CaseInsensitive (mk)+import Data.Char (isAlphaNum, isAscii, isSpace)+import Data.Conduit (ResourceT, runResourceT, yield, (=$), ($$))+import qualified Data.Conduit.List as CL (concatMap, sourceList)+import Data.Digest.Pure.MD5 (md5, MD5Digest)+import Data.List (intersperse, isPrefixOf)+import Data.Maybe (catMaybes)+import Data.Monoid (Monoid (mappend, mconcat, mempty))+import Network.HTTP.Conduit+ (Request(checkStatus, method, path, queryString, requestBody, requestHeaders),+ RequestBody+ (+ RequestBodyBS,+ RequestBodyBuilder,+ RequestBodySource,+ RequestBodySourceChunked,+ RequestBodyLBS+ ),+ Response(responseHeaders))+data Once a = NotEncountered | Once a | Multiple deriving Show+instance Monoid (Once a) where+ mempty = NotEncountered+ NotEncountered `mappend` o = o+ Once a `mappend` NotEncountered = Once a+ Once _ `mappend` Once _ = Multiple+ Once _ `mappend` Multiple = Multiple+ Multiple `mappend` _ = Multiple+onceToMaybe :: Once a -> Maybe (Maybe a)+onceToMaybe NotEncountered = Just Nothing+onceToMaybe (Once a) = Just (Just a)+onceToMaybe Multiple = Nothing+-- multiple challenges, anyone?+-- | This is an abstract type representing the challenge sent by the server.+data Challenge = None | Basic BasicChallenge | Digest DigestChallenge deriving Show+-- | Realm is the only thing users are supposed to know about the challenge.+realm :: Challenge -> Maybe String+realm None = Nothing+realm (Basic bc) = Just $ basicRealm bc+realm (Digest dc) = Just $ digestRealm dc+newtype BasicChallenge = BasicChallenge {basicRealm :: String} deriving Show+data DigestChallenge =+ DigestChallenge+ {+ digestRealm :: String,+ domain :: Maybe String,+ nonce :: String,+ opaque :: Maybe String,+ stale :: Maybe Bool,+ algorithm :: Maybe DigestAlgorithm,+ qop :: Maybe QopValue+ } deriving Show+data MDigestChallenge =+ MDigestChallenge+ {+ mDigestRealm :: Once String,+ mDomain :: Once String,+ mNonce :: Once String,+ mOpaque :: Once String,+ mStale :: Once Bool,+ mAlgorithm :: Once DigestAlgorithm,+ mQop :: Maybe QopValue+ } deriving Show+instance Monoid MDigestChallenge where+ mempty =+ MDigestChallenge+ {+ mDigestRealm = mempty,+ mDomain = mempty,+ mNonce = mempty,+ mOpaque = mempty,+ mStale = mempty,+ mAlgorithm = mempty,+ mQop = mempty+ }+ mappend md1 md2 =+ let mapp f = mappend (f md1) (f md2)+ in MDigestChallenge+ {+ mDigestRealm = mapp mDigestRealm,+ mDomain = mapp mDomain,+ mNonce = mapp mNonce,+ mOpaque = mapp mOpaque,+ mStale = mapp mStale,+ mAlgorithm = mapp mAlgorithm,+ mQop = mapp mQop+ }+finDigestChallenge :: MDigestChallenge -> Maybe DigestChallenge+finDigestChallenge md =+ do _digestRealm <- join $ onceToMaybe $ mDigestRealm md+ _domain <- onceToMaybe $ mDomain md+ _nonce <- join $ onceToMaybe $ mNonce md+ _opaque <- onceToMaybe $ mOpaque md+ _stale <- onceToMaybe $ mStale md+ _algorithm <- onceToMaybe $ mAlgorithm md+ let result =+ DigestChallenge+ {+ digestRealm = _digestRealm,+ domain = _domain,+ nonce = _nonce,+ opaque = _opaque,+ stale = _stale,+ algorithm = _algorithm,+ qop = mQop md+ }+ return result+data DigestAlgorithm = MD5 | MD5Sess deriving Show+data QopValue = Auth | AuthInt deriving Show+instance Monoid QopValue where+ mempty = AuthInt+ Auth `mappend` _ = Auth+ AuthInt `mappend` a = a+-- | This function extracts a WWW-Authenticate header from the response.+extractAuthHeader :: Response body -> Maybe String+extractAuthHeader resp =+ fmap (BU.toString) $+ lookup (mk $ BU.fromString "WWW-Authenticate") $+ responseHeaders resp+isWordChar :: Char -> Bool+isWordChar c = isAscii c && (c `elem` "_.-:" || isAlphaNum c)+orElse :: MaybeT (State String) a -> MaybeT (State String) a -> MaybeT (State String) a+orElse p1 p2 =+ do str <- lift get+ p1 `mplus` (lift (put str) >> p2)+token :: MaybeT (State String) String+token =+ do str <- lift get+ let ~(tok, rst) = span isWordChar str+ guard $ not $ null tok+ lift $ put $ dropWhile isSpace rst+ return tok+equal :: MaybeT (State String) ()+equal =+ do '=' : rst <- lift get+ lift $ put $ dropWhile isSpace rst+singleQuote :: MaybeT (State String) ()+singleQuote =+ do '"' : rst <- lift get+ lift $ put $ dropWhile isSpace rst+quotedStr :: MaybeT (State String) String+quotedStr =+ let getStr str =+ do (f, rst) <- return $ span (`notElem` "\"\\") str+ let quote =+ do '"' : tl <- return rst+ lift $ put $ dropWhile isSpace tl+ return f+ let escape =+ do '\\' : c : tl <- return rst+ guard $ isAscii c+ s <- getStr tl+ return $ f ++ c : s+ quote `orElse` escape+ in do '"' : str <- lift get+ getStr str+commaSep :: MaybeT (State String) a -> MaybeT (State String) [a]+commaSep g =+ let commaSepG =+ do a <- g+ str <- lift get+ as <-+ case str of+ ',' : rst ->+ do lift $ put $ dropWhile isSpace rst+ commaSepG+ _ -> return []+ return $ a : as+ in commaSepG+eol :: MaybeT (State String) ()+eol =+ do str <- lift get+ guard $ null str+parseDigestChallenge :: MaybeT (State String) DigestChallenge+parseDigestChallenge =+ do digest <- token+ guard $ digest == "Digest"+ fields <- commaSep parseDigestFields+ eol+ MaybeT $ return $ finDigestChallenge $ mconcat fields+parseDigestFields :: MaybeT (State String) MDigestChallenge+parseDigestFields =+ do param <- token+ case param of+ "realm" ->+ do equal+ str <- quotedStr+ return $ mempty {mDigestRealm = Once str}+ "domain" ->+ do equal+ str <- quotedStr+ return $ mempty {mDomain = Once str}+ "nonce" ->+ do equal+ str <- quotedStr+ return $ mempty {mNonce = Once str}+ "opaque" ->+ do equal+ str <- quotedStr+ return $ mempty {mOpaque = Once str}+ "stale" ->+ do equal+ str <- token+ return $ mempty {mStale = Once $ str == "true"}+ "algorithm" ->+ do equal+ str <- token+ case str of+ "MD5" -> return $ mempty {mAlgorithm = Once MD5}+ "MD5-sess" -> return $ mempty {mAlgorithm = Once MD5Sess}+ _ -> mzero+ "qop" ->+ do equal+ singleQuote+ qops <- commaSep token+ singleQuote+ let qopsData =+ flip fmap qops $ \t ->+ case t of+ "auth" -> Just Auth+ "auth-int" -> Just AuthInt+ _ -> mempty+ return $ mempty {mQop = mconcat qopsData}+ _ ->+ do equal+ _ <- token `orElse` quotedStr+ return mempty+parseBasicChallenge :: MaybeT (State String) BasicChallenge+parseBasicChallenge =+ do basic <- token+ guard $ basic == "Basic"+ parseRealm+ where+ parseRealm =+ do param <- token+ case param of+ "realm" ->+ do equal+ str <- quotedStr+ return $ BasicChallenge {basicRealm = str}+ _ ->+ do equal+ _ <- token `orElse` quotedStr+ parseRealm+-- | This function parses the WWW-Authenticate header line to get a challenge.+-- If it fails, it's probably because the header is malformed+parseChallenge :: String -> Maybe Challenge+parseChallenge header =+ flip evalState header $ runMaybeT $+ fmap Basic parseBasicChallenge `orElse` fmap Digest parseDigestChallenge+-- | This function parses the response headers to get the challenge.+-- It failes if there is some challenge, but it can't be parsed.+-- If there is no challenge at all, function doesn't fail.+getChallenge :: Response body -> Maybe Challenge+getChallenge req =+ case extractAuthHeader req of+ Nothing -> return None+ Just header -> parseChallenge header+-- | This function creates a string that should be sent in the Authorization header.+makeRequestHeader + :: Monad m => String -- ^ login+ -> String -- ^ password+ -> String -- ^ string to use as cnonce, not very important yet+ -> Request m -- ^ first request, already sent to the server+ -> Challenge -- ^ challenge generated by server in responce to that request+ -> MaybeT m 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+ let fields =+ [+ return "Digest",+ return $ "username=\"" ++ login ++ "\"",+ return $ "realm=\"" ++ digestRealm dc ++ "\"",+ return $ "nonce=\"" ++ nonce dc ++ "\"",+ return $ "uri=\"" ++ uri ++ "\"",+ return $ "response=\"" ++ requestDigest ++ "\"",+ case algorithm dc of+ Nothing -> mzero+ Just MD5 -> return "algorithm=MD5"+ Just MD5Sess -> return "algorithm=MD5-sess",+ case qop dc of+ Nothing -> mzero+ Just _ -> return $ "cnonce=\"" ++ cnonce ++ "\"",+ case opaque dc of+ Nothing -> mzero+ Just o -> return $ "opaque=\"" ++ o ++ "\"",+ case qop dc of+ Nothing -> mzero+ Just Auth -> return "qop=auth"+ Just AuthInt -> return "qop=auth-int",+ case qop dc of+ Nothing -> mzero+ Just _ -> return "nc=00000001"+ ]+ requestDigest =+ case qop dc of+ Nothing -> h $ h a1 ++ ':' : nonce dc ++ ':' : h a2+ Just Auth ->+ h $+ h a1 ++ ':' : nonce dc ++ ":00000001:" +++ cnonce ++ ":auth:" ++ h a2+ Just AuthInt ->+ h $+ h a1 ++ ':' : nonce dc ++ ":00000001:" +++ cnonce ++ ":auth-int:" ++ h a2+ a1 =+ case algorithm dc of+ Just MD5Sess ->+ h (login ++ ':' : digestRealm dc ++ ':' : password) +++ ':' : nonce dc ++ ':' : cnonce+ _ -> login ++ ':' : digestRealm dc ++ ':' : password+ a2 = + case qop dc of+ Just AuthInt ->+ mtd ++ ':' : uri ++ ':' : entityBodyHash+ _ -> mtd ++ ':' : uri+ uri = makeRequestUri req+ mtd = BU.toString $ method req+ h = show . md5 . LU.fromString+ 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 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+-- | This function makes an MD5 hash of the request body+makeRequestBodyHash :: Monad m => Request m -> m 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+ where+ bldrSink = CL.concatMap (L.toChunks . toLazyByteString) =$ hashSink+ hashSink = fmap (show :: MD5Digest -> String) sinkHash+-- | This is the main function. It sends a request, gets the response, and,+-- if this response requires authorization, it sends the same request again,+-- now including authorization data (user-supplied login and password).+requestWithAuth+ :: String -- ^ login+ -> String -- ^ password+ -> (Request (ResourceT IO) -> IO (Response body))+ -- ^ function like @withManager . httpLbs@, to actually send a request+ -> Request (ResourceT IO) -- ^ request to send (without authorization)+ -> MaybeT IO (Response body)+requestWithAuth login password query req =+ do let safeReq = req {checkStatus = \_ _ _ -> Nothing}+ resp <- lift $ query safeReq+ Just challenge <- return $ getChallenge resp+ let repeatReq =+ do let makeHeader = makeRequestHeader login password "test" req challenge+ header <- mapMaybeT runResourceT makeHeader+ let reqHeader = + (mk (BU.fromString "Authorization"),+ BU.fromString header)+ authReq = req {requestHeaders = reqHeader : requestHeaders req}+ lift $ query authReq+ repeatReq `mplus` return resp