content: {-# 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
      , clientWithOptsA
      , BaseUrl(..)
      , Scheme(..)
  
      -- * Build QueryParam arguments
      , QParam(..)
  
      -- * Access response data
      , withCredentials
  
      -- * Access response data
      , ReqResult(..)
      , reqSuccess
      , reqSuccess'
      , reqFailure
      , response
  
      , HasClientMulti(..)
      ) where
  
  ------------------------------------------------------------------------------
  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           Servant.API.Description (Summary)
  
  import           Reflex.Dom.Core         (Dynamic, Event, Reflex,
                                            XhrRequest (..),
                                            XhrResponseHeaders (..),
                                            attachPromptlyDynWith, constDyn)
  ------------------------------------------------------------------------------
  import           Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
                                           SupportsServantReflex)
  import           Servant.Common.Req     (ClientOptions,
                                           QParam (..), QueryPart (..), Req,
                                           ReqResult (..), addHeader, authData,
                                           defReq,
                                           defaultClientOptions,
                                           performRequestsCT,
                                           performRequestsNoBody,
                                           performSomeRequestsAsync,
                                           prependToPathParts, qParamToQueryPart,
                                           qParams, reqBody, reqFailure,
                                           reqMethod, reqSuccess, reqSuccess',
                                           respHeaders, response, withCredentials)
  import           Servant.Reflex         (BuildHeaderKeysTo (..), toHeaders)
  
  
  ------------------------------------------------------------------------------
  clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
          => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
          -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
  clientA p q f tag baseurl  =
      clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
      defaultClientOptions
  
  
  -- | A version of @client@ that sets the withCredentials flag
  -- on requests. Use this function for clients of CORS API's
  clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
                   => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
                   -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag
  clientWithOptsA p q f tag baseurl opts =
      clientWithRouteMulti p q f tag
      (constDyn (pure defReq)) baseurl opts
  
  ------------------------------------------------------------------------------
  class HasClientMulti t m layout f (tag :: *) where
    type ClientMulti t m layout f tag :: *
    clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
                         -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
                         -> ClientOptions -> ClientMulti t m layout f tag
  
  
  ------------------------------------------------------------------------------
  instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
      HasClientMulti t m (a :<|> b) f tag where
    type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
                                            ClientMulti t m b f tag
    clientWithRouteMulti Proxy q f tag reqs baseurl opts =
      clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
      clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
  
  
  ------------------------------------------------------------------------------
  instance (SupportsServantReflex t m,
            ToHttpApiData a,
            HasClientMulti t m sublayout f tag,
            Applicative f)
        => HasClientMulti t m (Capture capture a :> sublayout) f tag where
  
    type ClientMulti t m (Capture capture a :> sublayout) f tag =
      f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
  
    clientWithRouteMulti _ q f tag reqs baseurl opts vals =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
      where
        reqs' = (prependToPathParts <$> ps <*>) <$> reqs
        ps    = (fmap .  fmap . fmap) toUrlPiece vals
  
  
  ------------------------------------------------------------------------------
  -- VERB (Returning content) --
  instance {-# OVERLAPPABLE #-}
    -- Note [Non-Empty Content Types]
    (MimeUnrender ct a,
     ReflectMethod method, cts' ~ (ct ': cts),
     SupportsServantReflex t m,
     Applicative f,
     Traversable f
    ) => HasClientMulti t m (Verb method status cts' a) f tag where
  
    type ClientMulti t m (Verb method status cts' a) f tag =
      Event t tag -> m (Event t (f (ReqResult tag a)))
  
    clientWithRouteMulti _ _ _ _ reqs baseurl opts =
      performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
        where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
              reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
  
  
  ------------------------------------------------------------------------------
  -- -- VERB (No content) --
  instance {-# OVERLAPPING #-}
    (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>
    HasClientMulti t m (Verb method status cts NoContent) f tag where
    type ClientMulti t m (Verb method status cts NoContent) f tag =
      Event t tag -> m (Event t (f (ReqResult tag NoContent)))
      -- TODO: how to access input types here?
      -- ExceptT ServantError IO NoContent
    clientWithRouteMulti Proxy _ _ _ req baseurl opts =
      performRequestsNoBody method req baseurl opts
        where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
  
  
  ------------------------------------------------------------------------------
  instance {-# OVERLAPPABLE #-}
    -- Note [Non-Empty Content Types]
    ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
      ReflectMethod method, cts' ~ (ct ': cts),
      SupportsServantReflex t m,
      Traversable f
    ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
    type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
      Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
    clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
      let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
      resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
      return $ fmap toHeaders <$> resp
      where
        reqs' = fmap (\r ->
                  r { respHeaders =
                      OnlyHeaders (Set.fromList
                                   (buildHeaderKeysTo (Proxy :: Proxy ls)))
                    }) <$> reqs
  
  
  ------------------------------------------------------------------------------
  instance {-# OVERLAPPABLE #-}
    ( BuildHeadersTo ls,
      BuildHeaderKeysTo ls,
      ReflectMethod method,
      SupportsServantReflex t m,
      Traversable f
    ) => HasClientMulti t m (Verb method status
                             cts (Headers ls NoContent)) f tag where
    type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
      = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
    clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
      let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
      resp <- performRequestsNoBody method reqs' baseurl opts triggers
      return $ fmap toHeaders <$> resp
      where reqs' = fmap (\req ->
                      req {respHeaders = OnlyHeaders (Set.fromList
                           (buildHeaderKeysTo (Proxy :: Proxy ls)))
                          }) <$> reqs
  
  
  ------------------------------------------------------------------------------
  instance (KnownSymbol sym,
            ToHttpApiData a,
            HasClientMulti t m sublayout f tag,
            SupportsServantReflex t m,
            Traversable f,
            Applicative f)
        => HasClientMulti t m (Header sym a :> sublayout) f tag where
  
    type ClientMulti t m (Header sym a :> sublayout) f tag =
      f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
  
    clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
      clientWithRouteMulti (Proxy :: Proxy sublayout) f
                      q tag
                      reqs'
                      baseurl opts
      where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
            reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
                    <$> eVals <*>) <$> reqs
  
  
  ------------------------------------------------------------------------------
  instance HasClientMulti t m sublayout f tag
    => HasClientMulti t m (HttpVersion :> sublayout) f tag where
  
    type ClientMulti t m (HttpVersion :> sublayout) f tag =
      ClientMulti t m sublayout f tag
  
    clientWithRouteMulti Proxy q f tag =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
  
  
  ------------------------------------------------------------------------------
  instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)
    => HasClientMulti t m (Summary sym :> sublayout) f tag where
  
    type ClientMulti t m (Summary sym :> sublayout) f tag =
      ClientMulti t m sublayout f tag
  
    clientWithRouteMulti Proxy q f tag =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
  
  
  ------------------------------------------------------------------------------
  instance (KnownSymbol sym,
            ToHttpApiData a,
            HasClientMulti t m sublayout f tag,
            Reflex t,
            Applicative f)
        => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
  
    type ClientMulti t m (QueryParam sym a :> sublayout) f tag =
      Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag
  
    -- if mparam = Nothing, we don't add it to the query string
    -- TODO: Check the above comment
    clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
        reqs' baseurl opts
  
      where pname = symbolVal (Proxy :: Proxy sym)
            p prm = QueryPartParam $ fmap qParamToQueryPart prm
            paramPair mp = (T.pack pname, p mp)
            -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)
            --         <$> mparams <*> reqs
            reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })
                    <$> mparams <*> reqs
  
  
  instance (KnownSymbol sym,
            ToHttpApiData a,
            HasClientMulti t m sublayout f tag,
            Reflex t,
            Applicative f)
        => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
  
    type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
      Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
  
        where req' l r = r { qParams =  (T.pack pname, params' (constDyn l)) : qParams r }
              pname   = symbolVal (Proxy :: Proxy sym)
              params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
                          l
              reqs' = liftA2 req' <$> paramlists <*> reqs
  
  
  instance (KnownSymbol sym,
            HasClientMulti t m sublayout f tag,
            Reflex t,
            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 opts flags =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
  
      where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
            thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
            pName      = symbolVal (Proxy :: Proxy sym)
            reqs'      = liftA2 req' <$> flags <*> reqs
  
  
  instance (SupportsServantReflex t m,
            Traversable f, Applicative f) => HasClientMulti t m Raw f tag where
    type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))
                                   -> Event t tag
                                   -> m (Event t (f (ReqResult tag ())))
  
    clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
      let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
          rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
      resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
      return resps
      where
        aux (tag, Right r) = ResponseSuccess tag () r
        aux (tag, Left  e) = RequestFailure tag e
  
  
  instance (MimeRender ct a,
            HasClientMulti t m sublayout f tag,
            Reflex t,
            Applicative f)
        => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
  
    type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
      Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
      clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
         where req'        b r = r { reqBody = bodyBytesCT (constDyn b) }
               ctProxy         = Proxy :: Proxy ct
               ctString        = T.pack $ show $ contentType ctProxy
               bodyBytesCT b   = Just $ (fmap . fmap)
                                 (\b' -> (mimeRender ctProxy b', ctString))
                                 b
               reqs'           = liftA2 req' <$> bodies <*> reqs
  
  
  instance (KnownSymbol path,
            HasClientMulti t m sublayout f tag,
            Reflex t,
            Functor f) => HasClientMulti t m (path :> sublayout) f tag where
    type ClientMulti t m (path :> sublayout) f tag = ClientMulti t m sublayout f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl =
       clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
                       (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)
                       baseurl
  
      where p = symbolVal (Proxy :: Proxy path)
  
  
  instance HasClientMulti t m api f tag => HasClientMulti t m (Vault :> api) f tag where
    type ClientMulti t m (Vault :> api) f tag = ClientMulti t m api f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl =
      clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
  
  
  instance HasClientMulti t m api f tag => HasClientMulti t m (RemoteHost :> api) f tag where
    type ClientMulti t m (RemoteHost :> api) f tag = ClientMulti t m api f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl =
      clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
  
  
  instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f tag where
    type ClientMulti t m (IsSecure :> api) f tag = ClientMulti t m api f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl =
      clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
  
  
  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))
                                                 -> ClientMulti t m api f tag
  
    clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
      clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
        where
          req'  a r = r { authData = Just (constDyn a) }
          reqs' = liftA2 req' <$> authdatas <*> reqs
  