module Network.HTTP.Client.Auth
(
requestWithAuth,
Challenge,
realm,
getChallenge,
makeRequestHeader,
extractAuthHeader,
parseChallenge,
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.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 (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,
RequestBodyStream,
RequestBodyStreamChunked,
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
data Challenge = None | Basic BasicChallenge | Digest DigestChallenge deriving Show
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
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
parseChallenge :: String -> Maybe Challenge
parseChallenge header =
flip evalState header $ runMaybeT $
fmap Basic parseBasicChallenge `orElse` fmap Digest parseDigestChallenge
getChallenge :: Response body -> Maybe Challenge
getChallenge req =
case extractAuthHeader req of
Nothing -> return None
Just header -> parseChallenge header
makeRequestHeader
:: String
-> String
-> String
-> Request
-> Challenge
-> 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 $ 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
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
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
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
requestWithAuth
:: String
-> String
-> (Request -> IO (Response body))
-> Request
-> 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