@@ -1,17 +1,14 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE LambdaCase #-}
45{-# LANGUAGE ScopedTypeVariables #-}
56module Servant.Common.Req where
67
7−-- import Control.Exception
8−-- import Control.Monad
9−-- import Control.Monad.Catch (MonadThrow)
10−-- import Control.Monad.IO.Class
11−-- import Control.Monad.Trans.Except
128import Control.Applicative (liftA2)
139import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)
1410import qualified Data.ByteString.Lazy.Char8 as BL
11+import Data.Maybe
1512import qualified Data.Text.Encoding as TE
1613-- import qualified Data.Foldable as F
1714import qualified Data.List as L
@@ -64,9 +61,13 @@ import Web.HttpApiData
6461
6562-- instance Exception ServantError
6663
64+data QueryPart t = QueryPartParam (Behavior t [String])
65+ | QueryPartFlag (Behavior t Bool)
66+
6767data Req t = Req
6868 { reqPathParts :: [Behavior t (Maybe String)]
69− , qParams :: [(String, Behavior t [String])]
69+ -- , qParams :: [(String, Behavior t [QueryPart])]
70+ , qParams :: [(String, QueryPart t)]
7071 , reqBody :: Maybe (ByteString, String)
7172 -- , reqAccept :: [MediaType]
7273 , headers :: [(String, Behavior t String)]
@@ -103,21 +104,40 @@ performRequest reqMethod req _ trigger = do
103104 let urlParts :: Behavior t (Maybe [String]) = fmap sequence t
104105 let urlPath :: Behavior t (Maybe String) = (fmap.fmap) (L.intercalate "/") urlParts
105106
106− let oneNamedPair :: String -> [String] -> String
107− oneNamedPair pName ps =
108− L.intercalate "&" $ map (\p -> pName ++ "=" ++ p) ps
107+ queryPartString :: (String, QueryPart t) -> Behavior t (Maybe String)
108+ queryPartString (pName, qp) = case qp of
109+ QueryPartParam ps -> ffor ps $ \pStrings -> -- case null pStrings of
110+ if null pStrings
111+ then Nothing
112+ else Just (L.intercalate "&" (fmap (\p -> pName ++ '=' : p) pStrings))
113+ QueryPartFlag fl -> ffor fl $ \case
114+ True -> Just pName
115+ False -> Nothing
116+
117+ queryPartStrings = map queryPartString (qParams req)
118+ queryPartStrings' = sequence queryPartStrings :: Behavior t [Maybe String]
119+ queryString :: Behavior t (Maybe String ) =
120+ ffor queryPartStrings' $ \qs -> Just (L.intercalate "&" (catMaybes qs))
121+ xhrUrl = (liftA2 . liftA2) (\p q -> p ++ '?' : q) urlPath queryString
122+ xhrReq = (fmap . fmap) (\p -> XhrRequest reqMethod p def) xhrUrl
123+
124+ performRequestAsync (fmapMaybe id $ tag xhrReq trigger)
109125
110− t' :: [Behavior t String]
111− t' = map (\(pName, pVals) -> fmap (oneNamedPair pName) pVals)
112− (qParams req)
126+ -- let oneNamedPair :: String -> [QueryPart] -> String
127+ -- oneNamedPair pName ps =
128+ -- L.intercalate "&" $ ffor ps $ \case
129+ -- QueryPartParam pval -> pName ++ "=" ++ pval
130+ -- QueryPartFlag True -> pName
131+ -- QueryPartFlag False -> error "Impossible case"
113132
114− queryString :: Behavior t String
115− queryString = fmap (L.intercalate "&") (sequence t')
133+ -- t' :: [Behavior t String]
134+ -- t' = map (\(pName, pVals) -> fmap (oneNamedPair pName) pVals)
135+ -- (qParams req)
116136
117− xhrUrl = (liftA2 . liftA2) (\u q -> u ++ '?' : q) urlPath (fmap Just queryString)
118− xhrReq = (fmap . fmap) (\p -> XhrRequest reqMethod p def) xhrUrl
137+ -- queryString :: Behavior t String
138+ -- queryString = fmap (L.intercalate "&") (sequence t')
119139
120− performRequestAsync (fmapMaybe id $ tag xhrReq trigger)
140+ -- xhrUrl = (liftA2 . liftA2) (\u q -> u ++ '?' : q) urlPath (fmap Just queryString)
121141
122142-- TODO implement
123143-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
@@ -137,9 +157,9 @@ performRequestCT ct reqMethod req reqHost trigger = do
137157 return $ ffor resp $ \xhr ->
138158 (hushed (mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
139159 =<< _xhrResponse_responseText xhr, xhr)
140− where hushed :: (x -> Either e y) -> (x -> Maybe y)
160+ where hushed :: (x -> Either e y) -> x -> Maybe y
141161 hushed f ea = case f ea of
142− Left e -> Nothing
162+ Left _ -> Nothing
143163 Right a -> Just a
144164
145165