@@ -6,7 +6,7 @@
66{-# LANGUAGE TupleSections #-}
77module Servant.Common.Req where
88
9−import Control.Applicative (liftA2)
9+import Control.Applicative (liftA2, liftA3)
1010import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)
1111import qualified Data.ByteString.Lazy.Char8 as BL
1212import Data.Maybe
@@ -93,18 +93,29 @@ addHeader name val req = req { headers = headers req
9393displayHttpRequest :: String -> String
9494displayHttpRequest httpmethod = "HTTP " ++ httpmethod ++ " request"
9595
96−
97−performRequest :: forall t m.MonadWidget t m => String -> Req t -> Dynamic t BaseUrl
96+-- | This function actually performs the request.
97+performRequest :: forall t m.MonadWidget t m
98+ => String
99+ -> Req t
100+ -> Dynamic t BaseUrl
98101 -> Event t ()
99102 -> m (Event t XhrResponse)
100103 -- -> ExceptT ServantError IO ( Int, ByteString, MediaType
101104 -- , [HTTP.Header], Response ByteString)
102−performRequest reqMethod req _ trigger = do
105+performRequest reqMethod req reqHost trigger = do
103106
104107 -- Ridiculous functor-juggling! How to clean this up?
105− let t :: Behavior t [Maybe String] = sequence $ reqPathParts req
106− let urlParts :: Behavior t (Maybe [String]) = fmap sequence t
107− let urlPath :: Behavior t (Maybe String) = (fmap.fmap) (L.intercalate "/") urlParts
108+ let t :: Behavior t [Maybe String]
109+ t = sequence $ reqPathParts req
110+
111+ baseUrl :: Behavior t (Maybe String)
112+ baseUrl = Just . showBaseUrl <$> current reqHost
113+
114+ urlParts :: Behavior t (Maybe [String])
115+ urlParts = fmap sequence t
116+
117+ urlPath :: Behavior t (Maybe String)
118+ urlPath = (fmap.fmap) (L.intercalate "/") urlParts
108119
109120 queryPartString :: (String, QueryPart t) -> Behavior t (Maybe String)
110121 queryPartString (pName, qp) = case qp of
@@ -116,11 +127,16 @@ performRequest reqMethod req _ trigger = do
116127 True -> Just pName
117128 False -> Nothing
118129
130+
119131 queryPartStrings = map queryPartString (qParams req)
120132 queryPartStrings' = sequence queryPartStrings :: Behavior t [Maybe String]
121133 queryString :: Behavior t (Maybe String) =
122134 ffor queryPartStrings' $ \qs -> Just (L.intercalate "&" (catMaybes qs))
123− xhrUrl = (liftA2 . liftA2) (\p q -> if null q then p else p ++ '?' : q) urlPath queryString
135+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if null q then p else p ++ '?' : q) baseUrl urlPath queryString
136+ where
137+ (</>) :: String -> String -> String
138+ x </> y | ("/" `L.isSuffixOf` x) || ("/" `L.isPrefixOf` y) = x ++ y
139+ | otherwise = x ++ '/':y
124140
125141 xhrHeaders :: Behavior t [(String, String)]
126142 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal