bead409 · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

Added support for BasicAuth

bead409sjorn-10 years ago

src/Servant/Common/Req.hs+19−3

compare with master

unifiedsplit

@@ -33,6 +33,9 @@ import Servant.API.ContentTypes

33import Reflex

34import Reflex.Dom

36+import Servant.API.BasicAuth

37+import qualified Data.ByteString.Char8 as BS

38+

36-- import qualified Network.HTTP.Client as Client

39-- import qualified Network.HTTP.Client as Client

38import Web.HttpApiData

41import Web.HttpApiData

@@ -66,10 +69,11 @@ data Req t = Req

66 , reqBody :: Maybe (Behavior t (Either String (BL.ByteString, String)))

69 , reqBody :: Maybe (Behavior t (Either String (BL.ByteString, String)))

67 -- , reqAccept :: [MediaType] -- TODO ?

70 -- , reqAccept :: [MediaType] -- TODO ?

68 , headers :: [(String, Behavior t String)]

71 , headers :: [(String, Behavior t String)]

72+ , authData :: Maybe (Behavior t (Maybe BasicAuthData))

69 }

73 }

71defReq :: Reflex t => Req t

75defReq :: Reflex t => Req t

72−defReq = Req "GET" [] [] Nothing []

76+defReq = Req "GET" [] [] Nothing [] Nothing

74prependToPathParts :: Reflex t => Behavior t (Either String String) -> Req t -> Req t

78prependToPathParts :: Reflex t => Behavior t (Either String String) -> Req t -> Req t

75prependToPathParts p req =

79prependToPathParts p req =

@@ -139,7 +143,6 @@ performRequest reqMethod req reqHost trigger = do

139 xhrHeaders :: Behavior t [(String, String)]

143 xhrHeaders :: Behavior t [(String, String)]

140 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal

144 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal

141

145

142−

143 mkConfigBody :: [(String,String)] -> (Either String (BL.ByteString, String)) -> Either String XhrRequestConfig

146 mkConfigBody :: [(String,String)] -> (Either String (BL.ByteString, String)) -> Either String XhrRequestConfig

144 mkConfigBody hs rb = case rb of

147 mkConfigBody hs rb = case rb of

145 Left e -> Left e

148 Left e -> Left e

@@ -152,7 +155,20 @@ performRequest reqMethod req reqHost trigger = do

152 xhrOpts = case reqBody req of

155 xhrOpts = case reqBody req of

153 Nothing -> fmap (\h -> Right $ def { _xhrRequestConfig_headers = Map.fromList h }) xhrHeaders

156 Nothing -> fmap (\h -> Right $ def { _xhrRequestConfig_headers = Map.fromList h }) xhrHeaders

154 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

157 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

158+

159+ mkAuth :: Maybe BasicAuthData -> Either String XhrRequestConfig -> Either String XhrRequestConfig

160+ mkAuth _ (Left e) = Left e

161+ mkAuth Nothing r = r

162+ mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

163+ { _xhrRequestConfig_user = Just $ BS.unpack u

164+ , _xhrRequestConfig_password = Just $ BS.unpack p}

165+

166+ addAuth :: Behavior t (Either String XhrRequestConfig) -> Behavior t (Either String XhrRequestConfig)

167+ addAuth xhr = case authData req of

168+ Nothing -> xhr

169+ Just auth -> liftA2 mkAuth auth xhr

170+

155− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMethod p opt) xhrUrl xhrOpts

171+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMethod p opt) xhrUrl (addAuth xhrOpts)

156

172

157 let reqs = tag xhrReq trigger

173 let reqs = tag xhrReq trigger

158 okReqs = fmapMaybe (either (const Nothing) Just) reqs

174 okReqs = fmapMaybe (either (const Nothing) Just) reqs

src/Servant/Reflex.hs+11

@@ -427,6 +427,17 @@ instance HasClient t m api => HasClient t m (IsSecure :> api) where

427 clientWithRoute Proxy q req baseurl =

428 clientWithRoute (Proxy :: Proxy api) q req baseurl

429

430+instance (HasClient t m api, Reflex t)

431+ => HasClient t m (BasicAuth realm usr :> api) where

432+

433+ type Client t m (BasicAuth realm usr :> api) = Behavior t (Maybe BasicAuthData)

434+ -> Client t m api

435+

436+ clientWithRoute Proxy q req baseurl authdata =

437+ clientWithRoute (Proxy :: Proxy api) q req' baseurl

438+ where

439+ req' = req { authData = Just authdata }

440+

430-- instance HasClient t m subapi =>

441-- instance HasClient t m subapi =>

431-- HasClient t m (WithNamedConfig name config subapi) where

442-- HasClient t m (WithNamedConfig name config subapi) where

432

443