@@ -33,6 +33,9 @@ import Servant.API.ContentTypes
3333import Reflex
3434import Reflex.Dom
3535
36+import Servant.API.BasicAuth
37+import qualified Data.ByteString.Char8 as BS
38+
3639-- import qualified Network.HTTP.Client as Client
3740
3841import Web.HttpApiData
@@ -66,10 +69,11 @@ data Req t = Req
6669 , reqBody :: Maybe (Behavior t (Either String (BL.ByteString, String)))
6770 -- , reqAccept :: [MediaType] -- TODO ?
6871 , headers :: [(String, Behavior t String)]
72+ , authData :: Maybe (Behavior t (Maybe BasicAuthData))
6973 }
7074
7175defReq :: Reflex t => Req t
72−defReq = Req "GET" [] [] Nothing []
76+defReq = Req "GET" [] [] Nothing [] Nothing
7377
7478prependToPathParts :: Reflex t => Behavior t (Either String String) -> Req t -> Req t
7579prependToPathParts p req =
@@ -139,7 +143,6 @@ performRequest reqMethod req reqHost trigger = do
139143 xhrHeaders :: Behavior t [(String, String)]
140144 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal
141145
142−
143146 mkConfigBody :: [(String,String)] -> (Either String (BL.ByteString, String)) -> Either String XhrRequestConfig
144147 mkConfigBody hs rb = case rb of
145148 Left e -> Left e
@@ -152,7 +155,20 @@ performRequest reqMethod req reqHost trigger = do
152155 xhrOpts = case reqBody req of
153156 Nothing -> fmap (\h -> Right $ def { _xhrRequestConfig_headers = Map.fromList h }) xhrHeaders
154157 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
155− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMethod p opt) xhrUrl xhrOpts
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+
171+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMethod p opt) xhrUrl (addAuth xhrOpts)
156172
157173 let reqs = tag xhrReq trigger
158174 okReqs = fmapMaybe (either (const Nothing) Just) reqs