http-enumerator 0.5

OpenId2/Discovery.hs

@@ -29,10 +29,10 @@ import Network.HTTP.Enumerator
 import qualified Data.ByteString.Lazy.UTF8 as BSLU
 import qualified Data.ByteString.Char8 as S8
 import Control.Arrow (first, (***))
-import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Failure (Failure (failure))
 import Control.Monad (mplus, liftM)
-import Network.Wai (ciOriginal)
+import qualified Data.CaseInsensitive as CI
 
 data Discovery = Discovery1 String (Maybe String)
                | Discovery2 Provider Identifier IdentType
@@ -69,11 +69,11 @@ discoverYADIS :: ( MonadIO m
 discoverYADIS _ _ 0 = failure TooManyRedirects
 discoverYADIS ident mb_loc redirects = do
     let uri = fromMaybe (identifier ident) mb_loc
-    req <- parseUrl uri
+    req <- parseUrl $ S8.pack uri
-    res <- httpLbs req
+    res <- liftIO $ withManager $ httpLbs req
     let mloc = fmap S8.unpack
              $ lookup "x-xrds-location"
-             $ map (first $ map toLower . S8.unpack . ciOriginal)
+             $ map (first $ map toLower . S8.unpack . CI.original)
              $ responseHeaders res
     let mloc' = if mloc == mb_loc then Nothing else mloc
     case statusCode res of
@@ -117,7 +117,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m)
              => Identifier
              -> m (Maybe Discovery)
 discoverHTML ident'@(Identifier ident) =
-    (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident
+    (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (S8.pack ident)
 
 -- | Parse out an OpenID endpoint and an actual identifier from an HTML
 -- document.

Web/Authenticate/Facebook.hs

@@ -11,6 +11,7 @@ import Data.Data (Data)
 import Data.Typeable (Typeable)
 import Control.Exception (Exception, throwIO)
 import Data.Attoparsec.Lazy (parse, eitherResult)
+import qualified Data.ByteString.Char8 as S8
 
 data Facebook = Facebook
     { facebookClientId :: String
@@ -48,7 +49,7 @@ accessTokenUrl fb code = concat
 getAccessToken :: Facebook -> String -> IO AccessToken
 getAccessToken fb code = do
     let url = accessTokenUrl fb code
-    b <- simpleHttp url
+    b <- simpleHttp $ S8.pack url
     let (front, back) = splitAt 13 $ L8.unpack b
     case front of
         "access_token=" -> return $ AccessToken back
@@ -65,7 +66,7 @@ graphUrl (AccessToken s) func = concat
 getGraphData :: AccessToken -> String -> IO (Either String Value)
 getGraphData at func = do
     let url = graphUrl at func
-    b <- simpleHttp url
+    b <- simpleHttp $ S8.pack url
     return $ eitherResult $ parse json b
 
 getGraphData' :: AccessToken -> String -> IO Value

Web/Authenticate/OAuth.hs

@@ -30,9 +30,15 @@ import Data.Digest.Pure.SHA
 import Data.ByteString.Base64
 import Data.Time
 import Numeric
-import Network.Wai (ResponseHeader)
 import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))
-
+import Network.HTTP.Types (Header)
+import Control.Arrow (second)
+import qualified Data.ByteString.Char8 as S8
+import Blaze.ByteString.Builder (toByteString)
+import Data.Enumerator (($$), run_, Stream (..), continue)
+import Data.Monoid (mconcat)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.IORef (newIORef, readIORef, atomicModifyIORef)
 
 -- | Data type for OAuth client (consumer).
 data OAuth = OAuth { oauthServerName      :: String        -- ^ Service name
@@ -85,9 +91,9 @@ fromStrict = BSL.fromChunks . return
 getTemporaryCredential :: OAuth         -- ^ OAuth Application
                        -> IO Credential -- ^ Temporary Credential (Request Token & Secret).
 getTemporaryCredential oa = do
-  let req = fromJust $ parseUrl (oauthRequestUri oa)
+  let req = fromJust $ parseUrl $ S8.pack $ oauthRequestUri oa
   req' <- signOAuth oa emptyCredential (req { method = "POST" }) 
-  rsp <- httpLbs req'
+  rsp <- withManager $ httpLbs req'
   let dic = parseQueryString . toStrict . responseBody $ rsp
   return $ Credential dic
 
@@ -103,8 +109,8 @@ getAccessToken, getTokenCredential
                -> Credential    -- ^ Temporary Credential with oauth_verifier
                -> IO Credential -- ^ Token Credential (Access Token & Secret)
 getAccessToken oa cr = do
-  let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
+  let req = (fromJust $ parseUrl $ S8.pack $ oauthAccessTokenUri oa) { method = "POST" }
-  rsp <- signOAuth oa cr req >>= httpLbs
+  rsp <- signOAuth oa cr req >>= withManager . httpLbs
   let dic = parseQueryString . toStrict . responseBody $ rsp
   return $ Credential dic
 
@@ -136,12 +142,12 @@ delete key = Credential . deleteMap key . unCredential
 -- | Add OAuth headers & sign to 'Request'.
 signOAuth :: OAuth              -- ^ OAuth Application
           -> Credential         -- ^ Credential
-          -> Request            -- ^ Original Request
+          -> Request IO         -- ^ Original Request
-          -> IO Request         -- ^ Signed OAuth Request
+          -> IO (Request IO)    -- ^ Signed OAuth Request
 signOAuth oa crd req = do
   crd' <- addTimeStamp =<< addNonce crd
   let tok = injectOAuthToCred oa crd'
-      sign = genSign oa tok req
+  sign <- genSign oa tok req
   return $ addAuthHeader (insert "oauth_signature" sign tok) req
 
 baseTime :: UTCTime
@@ -171,19 +177,19 @@ injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa
           , ("oauth_version", "1.0")
           ] cred
 
-genSign :: OAuth -> Credential -> Request -> BS.ByteString
+genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString
 genSign oa tok req =
   case oauthSignatureMethod oa of
-    HMACSHA1 ->
+    HMACSHA1 -> do
-      let text = getBaseString tok req
+      text <- getBaseString tok req
-          key  = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
+      let key  = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
-      in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text
+      return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text
     PLAINTEXT ->
-      BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
+      return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
     RSASHA1 pr ->
-      encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req)
+      liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)
 
-addAuthHeader :: Credential -> Request -> Request
+addAuthHeader :: Credential -> Request a -> Request a
 addAuthHeader (Credential cred) req =
   req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req }
 
@@ -199,24 +205,44 @@ paramEncode = BS.concatMap escape
                                oct = '%' : replicate (2 - length num) '0' ++ num
                            in BS.pack oct
 
-getBaseString :: Credential -> Request -> BSL.ByteString
+getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString
-getBaseString tok req =
+getBaseString tok req = do
   let bsMtd  = BS.map toUpper $ method req
       isHttps = secure req
       scheme = if isHttps then "https" else "http"
       bsPort = if (isHttps && port req /= 443) || (not isHttps && port req /= 80)
                  then ':' `BS.cons` BS.pack (show $ port req) else ""
       bsURI = BS.concat [scheme, "://", host req, bsPort, path req]
-      bsQuery = queryString req
+      bsQuery = map (second $ fromMaybe "") $ queryString req
-      bsBodyQ = if isBodyFormEncoded $ requestHeaders req
+  bsBodyQ <- if isBodyFormEncoded $ requestHeaders req
-                  then parseQueryString (toStrict $ requestBody req) else []
+                  then liftM parseQueryString $ toLBS (requestBody req)
-      bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok
+                  else return []
+  let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok
       allParams = bsQuery++bsBodyQ++bsAuthParams
       bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple
                    $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams
-  in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
+  -- FIXME it would be much better to use http-types functions here
+  return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
 
-isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> Bool
+toLBS :: MonadIO m => RequestBody m -> m BS.ByteString
+toLBS (RequestBodyLBS l) = return $ toStrict l
+toLBS (RequestBodyBS s) = return s
+toLBS (RequestBodyBuilder _ b) = return $ toByteString b
+toLBS (RequestBodyEnum _ enum) = do
+    i <- liftIO $ newIORef id
+    run_ $ enum $$ go i
+    liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i
+  where
+    go i =
+        continue go'
+      where
+        go' (Chunks []) = continue go'
+        go' (Chunks x) = do
+            liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ()))
+            continue go'
+        go' EOF = return ()
+
+isBodyFormEncoded :: [Header] -> Bool
 isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"
 
 compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering

Web/Authenticate/OpenId.hs

@@ -14,10 +14,11 @@ import OpenId2.Types
 import Web.Authenticate.Internal (qsUrl)
 import Control.Monad (unless)
 import qualified Data.ByteString.UTF8 as BSU
+import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy.UTF8 as BSLU
 import Network.HTTP.Enumerator
     ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
-    , HttpException
+    , HttpException, withManager
     )
 import Control.Arrow ((***))
 import Data.List (unfoldr)
@@ -87,9 +88,9 @@ authenticate params = do
     let params' = map (BSU.fromString *** BSU.fromString)
                 $ ("openid.mode", "check_authentication")
                 : filter (\(k, _) -> k /= "openid.mode") params
-    req' <- parseUrl endpoint
+    req' <- parseUrl $ S8.pack endpoint
     let req = urlEncodedBody params' req'
-    rsp <- httpLbsRedirect req
+    rsp <- liftIO $ withManager $ httpLbsRedirect req
     let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
     case lookup "is_valid" rps of
         Just "true" -> return (Identifier ident, rps)

Web/Authenticate/Rpxnow.hs

@@ -71,9 +71,10 @@ authenticate apiKey token = do
                 , requestHeaders =
                     [ ("Content-Type", "application/x-www-form-urlencoded")
                     ]
-                , requestBody = body
+                , requestBody = RequestBodyLBS body
+                , checkCerts = const $ return True
                 }
-    res <- httpLbsRedirect req
+    res <- liftIO $ withManager $ httpLbsRedirect req
     let b = responseBody res
     unless (200 <= statusCode res && statusCode res < 300) $
         liftIO $ throwIO $ StatusCodeException (statusCode res) b

authenticate.cabal

@@ -16,7 +16,7 @@ homepage:        http://github.com/snoyberg/authenticate/tree/master
 library
     build-depends:   base >= 4 && < 5,
                      aeson >= 0.3.1.1 && < 0.4,
-                     http-enumerator >= 0.3.0 && < 0.4,
+                     http-enumerator >= 0.5.1 && < 0.6,
                      tagsoup >= 0.6 && < 0.13,
                      failure >= 0.0.0 && < 0.2,
                      transformers >= 0.1 && < 0.3,
@@ -24,7 +24,7 @@ library
                      utf8-string >= 0.3 && < 0.4,
                      network >= 2.2.1 && < 2.4,
                      xml >= 1.3.7 && < 1.4,
-                     wai >= 0.3 && < 0.4,
+                     case-insensitive >= 0.2 && < 0.3,
                      RSA >= 1.0 && < 1.1,
                      time >= 1.1 && < 1.3,
                      base64-bytestring >= 0.1 && < 0.2,
@@ -32,6 +32,9 @@ library
                      random >= 1.0 && < 1.1,
                      wai-extra >= 0.3 && < 0.4,
                      text >= 0.5 && < 1.0,
+                     http-types >= 0.6 && < 0.7,
+                     enumerator >= 0.4.7 && < 0.5,
+                     blaze-builder >= 0.2 && < 0.4,
                      attoparsec >= 0.8.5 && < 0.9
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,