Release notes and cleanup

changelog.md

@@ -0,0 +1,32 @@
+0.3
+---
+
+- **Addition of the 'Servant.Reflex.Multi' module** which allows the user
+to choose some '(Applicative f, Traversable f) => f' for collecting
+endpoint parameters. The traversable instance is used for passing
+multiple 'XhrRequest's in response to a single event trigger. The
+Applicative instance is used to combine parameters. For example,
+'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'
+will generate a client function:
+`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->
+ m (Event t (f (ReqResult tag Text)))`
+Calling that function with 'f' chosen to be list ('[]'), this call
+`clientFun
+(constDyn ["Greg", "Bernie"])
+(constDyn ["Greetings", "Hey"])
+trigger`
+would produce four XhrRequests per 'trigger' event, one for each
+combination of possible parameters, and one response event
+would carry a list of the four responses.
+A 'zip-wise' combination of the parameters can be chosen with
+a different applicative wrapper: 'ZipList'
+
+- **Event tags**. A new type parameter lets users choose a payload
+value to attach to outgoing requests at the point of triggering,
+and which is embedded in the response, allowing individual
+request-response pairs to be followed. The response's tag has been
+added to each constructor `ReqResult tag a` type.
+
+- **Improved Unicode support** Thanks to Schell Scivally
+(https://github.com/schell) for identifying and fixing a UTF-8
+encoding bug!

src/Servant/Common/Req.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DeriveDataTypeable  #-}
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE GADTs               #-}
@@ -8,13 +6,11 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
 
-{-# LANGUAGE EmptyCase           #-}
 module Servant.Common.Req where
 
 -------------------------------------------------------------------------------
 import           Control.Concurrent
 import           Control.Applicative        (liftA2, liftA3)
-import           Control.Arrow              (second)
 import           Control.Monad              (join)
 import           Control.Monad.IO.Class     (MonadIO, liftIO)
 import           Data.Bifunctor             (first)
@@ -27,44 +23,67 @@ import           Data.Proxy                 (Proxy(..))
 import           Data.Text                  (Text)
 import qualified Data.Text                  as T
 import qualified Data.Text.Encoding         as TE
-import           Data.Traversable
-import           Reflex.Dom
-import           Servant.Common.BaseUrl     (BaseUrl, showBaseUrl, SupportsServantReflex)
+import           Data.Traversable           (forM)
+import           Reflex.Dom                 hiding (tag)
+import           Servant.Common.BaseUrl     (BaseUrl, showBaseUrl,
+                                             SupportsServantReflex)
 import           Servant.API.ContentTypes   (MimeUnrender(..), NoContent(..))
 import           Web.HttpApiData            (ToHttpApiData(..))
 -------------------------------------------------------------------------------
 import           Servant.API.BasicAuth
 
 
+------------------------------------------------------------------------------
+-- | The result of a request event
+data ReqResult tag a
+    = ResponseSuccess tag a XhrResponse
+      -- ^ The succesfully decoded response from a request tagged with 'tag'
+    | ResponseFailure tag Text XhrResponse
+      -- ^ The failure response, which may have failed decoding or had
+      --   a non-successful response code
+    | RequestFailure  tag Text
+      -- ^ A failure to construct the request tagged with 'tag' at trigger time
 
-data ReqResult tag a = ResponseSuccess tag a XhrResponse
-                     | ResponseFailure tag Text XhrResponse
-                     | RequestFailure  tag Text
-
-instance Functor (ReqResult tag) where
-  fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr
-  fmap _ (ResponseFailure tag r x)   = ResponseFailure tag r x
-  fmap _ (RequestFailure  tag r)      = RequestFailure tag r
 
+------------------------------------------------------------------------------
+-- | Simple filter/accessor for successful responses, when you want to
+-- ignore the error case. For example:
+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers
 reqSuccess :: ReqResult tag a -> Maybe a
 reqSuccess (ResponseSuccess _ x _) = Just x
 reqSuccess _                       = Nothing
 
+
+------------------------------------------------------------------------------
+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
 reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
 reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
 reqSuccess' _                         = Nothing
 
+
+------------------------------------------------------------------------------
+-- | Simple filter/accessor for any failure case
 reqFailure :: ReqResult tag a -> Maybe Text
 reqFailure (ResponseFailure _ s _) = Just s
 reqFailure (RequestFailure  _ s)   = Just s
 reqFailure _                       = Nothing
 
+
+------------------------------------------------------------------------------
+-- | Simple filter/accessor for the raw XHR response
 response :: ReqResult tag a -> Maybe XhrResponse
 response (ResponseSuccess _ _ x) = Just x
 response (ResponseFailure _ _ x) = Just x
 response _                       = Nothing
 
 
+------------------------------------------------------------------------------
+instance Functor (ReqResult tag) where
+  fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr
+  fmap _ (ResponseFailure tag r x)   = ResponseFailure tag r x
+  fmap _ (RequestFailure  tag r)      = RequestFailure tag r
+
+
 -------------------------------------------------------------------------------
 -- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
 -- indicate whether the parameter is valid and present, validly absent, or
@@ -76,11 +95,13 @@ data QParam a = QParamSome a
               | QParamInvalid Text
               -- ^ Indication that your validation failed (the request isn't valid)
 
+
 qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
 qParamToQueryPart (QParamSome a)    = Right (Just $ toQueryParam a)
 qParamToQueryPart QNone             = Right Nothing
 qParamToQueryPart (QParamInvalid e) = Left e
 
+
 data QueryPart t = QueryPartParam  (Dynamic t (Either Text (Maybe Text)))
                  | QueryPartParams (Dynamic t [Text])
                  | QueryPartFlag   (Dynamic t Bool)

src/Servant/Reflex/Multi.hs

@@ -1,69 +1,74 @@
-{-# LANGUAGE AllowAmbiguousTypes  #-}
-{-# LANGUAGE CPP                  #-}
-{-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE InstanceSigs         #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE PolyKinds            #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TupleSections        #-}
-{-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+module Servant.Reflex.Multi (
+    -- * Compute servant client functions
+    clientA
+    , BaseUrl(..)
+    , Scheme(..)
+
+    -- * Build QueryParam arguments
+    , QParam(..)
+
+
+    -- * Access response data
+    , ReqResult(..)
+    , reqSuccess
+    , reqSuccess'
+    , reqFailure
+    , response
 
-module Servant.Reflex.Multi
-    ( clientA
     , HasClientMulti(..)
     ) where
 
 ------------------------------------------------------------------------------
-import           Control.Applicative
-import           Control.Arrow           (second)
-import           Data.Functor.Compose
-import           Data.Monoid             ((<>))
-import qualified Data.Set                as Set
-import qualified Data.Text.Encoding      as E
-import           Data.CaseInsensitive    (mk)
-import           Data.Proxy              (Proxy (..))
-import qualified Data.Map                as Map
-import           Data.Text               (Text)
-import qualified Data.Text               as T
-import           GHC.TypeLits            (KnownSymbol, symbolVal)
-import           Servant.API             ((:<|>)(..),(:>), BasicAuth,
-                                          BasicAuthData, BuildHeadersTo(..),
-                                          Capture, contentType, Header,
-                                          Headers(..), HttpVersion, IsSecure,
-                                          MimeRender(..), MimeUnrender,
-                                          NoContent, QueryFlag, QueryParam,
-                                          QueryParams, Raw, ReflectMethod(..),
-                                          RemoteHost, ReqBody,
-                                          ToHttpApiData(..), Vault, Verb)
+import           Control.Applicative    (liftA2)
+import           Data.Functor.Compose   (Compose (..), getCompose)
+import           Data.Proxy             (Proxy (..))
+import qualified Data.Set               as Set
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import qualified Data.Text.Encoding     as E
+import           GHC.TypeLits           (KnownSymbol, symbolVal)
+import           Servant.API            ((:<|>) (..), (:>), BasicAuth,
+                                         BasicAuthData, BuildHeadersTo (..),
+                                         Capture, Header, Headers (..),
+                                         HttpVersion, IsSecure, MimeRender (..),
+                                         MimeUnrender, NoContent, QueryFlag,
+                                         QueryParam, QueryParams, Raw,
+                                         ReflectMethod (..), RemoteHost,
+                                         ReqBody, ToHttpApiData (..), Vault,
+                                         Verb, contentType)
 
-import           Reflex.Dom              (Dynamic, Event, Reflex,
-                                          XhrRequest(..),
-                                          XhrResponseHeaders(..),
-                                          XhrResponse(..), constDyn, ffor, fmapMaybe,
-                                          leftmost, performRequestAsync, attachPromptlyDynWith,
-                                          tagPromptlyDyn )
+import           Reflex.Dom             (Dynamic, Event, Reflex,
+                                         XhrRequest (..),
+                                         XhrResponseHeaders (..),
+                                         attachPromptlyDynWith, constDyn)
 ------------------------------------------------------------------------------
-import           Servant.Common.BaseUrl  (BaseUrl(..), Scheme(..), baseUrlWidget,
-                                          showBaseUrl,
-                                          SupportsServantReflex)
-import           Servant.Common.Req      (Req, ReqResult(..), QParam(..),
-                                          QueryPart(..), addHeader, authData,
-                                          defReq, prependToPathParts,
-                                          -- performRequestCT,
-                                          performRequestsCT,
-                                          -- performRequestNoBody,
-                                          performRequestsNoBody,
-                                          performSomeRequestsAsync,
-                                          qParamToQueryPart, reqBody,
-                                          reqSuccess, reqFailure,
-                                          reqMethod, respHeaders, response,
-                                          qParams)
-import          Servant.Reflex            (BuildHeaderKeysTo(..), toHeaders)
+import           Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
+                                         SupportsServantReflex)
+import           Servant.Common.Req     (QParam (..), QueryPart (..), Req,
+                                         ReqResult (..), addHeader, authData,
+                                         defReq, performRequestsCT,
+                                         performRequestsNoBody,
+                                         performSomeRequestsAsync,
+                                         prependToPathParts, qParamToQueryPart,
+                                         qParams, reqBody, reqFailure,
+                                         reqMethod, reqSuccess, reqSuccess',
+                                         respHeaders, response)
+import           Servant.Reflex         (BuildHeaderKeysTo (..), toHeaders)
 
 
 ------------------------------------------------------------------------------
@@ -102,7 +107,8 @@ instance (SupportsServantReflex t m,
   type ClientMulti t m (Capture capture a :> sublayout) f tag =
     f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
 
-  clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
+  clientWithRouteMulti _ q f tag reqs baseurl vals =
+    clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
     where
       reqs' = (prependToPathParts <$> ps <*>) <$> reqs
       ps    = (fmap .  fmap . fmap) toUrlPiece vals
@@ -122,7 +128,7 @@ instance {-# OVERLAPPABLE #-}
   type ClientMulti t m (Verb method status cts' a) f tag =
     Event t tag -> m (Event t (f (ReqResult tag a)))
 
-  clientWithRouteMulti _ _ f tag reqs baseurl =
+  clientWithRouteMulti _ _ _ _ reqs baseurl =
     performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
       where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
             reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
@@ -137,7 +143,7 @@ instance {-# OVERLAPPING #-}
     Event t tag -> m (Event t (f (ReqResult tag NoContent)))
     -- TODO: how to access input types here?
     -- ExceptT ServantError IO NoContent
-  clientWithRouteMulti Proxy _ _ tag req baseurl =
+  clientWithRouteMulti Proxy _ _ _ req baseurl =
     performRequestsNoBody method req baseurl
       where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
 
@@ -223,7 +229,6 @@ instance (KnownSymbol sym,
           ToHttpApiData a,
           HasClientMulti t m sublayout f tag,
           Reflex t,
-          Traversable f,
           Applicative f)
       => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
 
@@ -249,7 +254,6 @@ instance (KnownSymbol sym,
           ToHttpApiData a,
           HasClientMulti t m sublayout f tag,
           Reflex t,
-          Traversable f,
           Applicative f)
       => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
 
@@ -264,21 +268,19 @@ instance (KnownSymbol sym,
             params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
                         l
             reqs' = liftA2 req' <$> paramlists <*> reqs
-            -- reqs' = req' <$> paramlists <*> reqs
 
 
 instance (KnownSymbol sym,
           HasClientMulti t m sublayout f tag,
           Reflex t,
-          Traversable f,
           Applicative f)
       => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where
 
   type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
     Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
 
-  clientWithRouteMulti Proxy q f tag reqs baseurl flags =
-    clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
+  clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
+    clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
 
     where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
           thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -292,10 +294,9 @@ instance (SupportsServantReflex t m,
                                  -> Event t tag
                                  -> m (Event t (f (ReqResult tag ())))
 
-  clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do
+  clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
     let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
         rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
---     resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''
     resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
     return resps
     where
@@ -306,7 +307,6 @@ instance (SupportsServantReflex t m,
 instance (MimeRender ct a,
           HasClientMulti t m sublayout f tag,
           Reflex t,
-          Traversable f,
           Applicative f)
       => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
 
@@ -359,7 +359,7 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f
     clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
 
 
-instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)
+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
       => HasClientMulti t m (BasicAuth realm usr :> api) f tag where
 
   type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))