@@ -1,24 +1,22 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE MultiParamTypeClasses #-}
15−{-# LANGUAGE OverloadedStrings #-}
16−{-# LANGUAGE PolyKinds #-}
17−{-# LANGUAGE ScopedTypeVariables #-}
18−{-# LANGUAGE TupleSections #-}
19−{-# LANGUAGE TypeFamilies #-}
20−{-# LANGUAGE TypeOperators #-}
21−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE InstanceSigs #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+
17+#if MIN_VERSION_base(4,9,0)
18+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
19+#endif
2220
2321-- #include "overlapping-compat.h"
2422-- | This module provides 'client' which can automatically generate
@@ -44,6 +42,7 @@ import Data.Proxy (Proxy (..))
4442import qualified Data.Map as Map
4543import Data.Text (Text)
4644import qualified Data.Text as T
45+import GHC.Exts (Constraint)
4746import GHC.TypeLits (KnownSymbol, symbolVal)
4847import Servant.API ((:<|>)(..),(:>), BasicAuth,
4948 BasicAuthData, BuildHeadersTo(..),
@@ -54,6 +53,7 @@ import Servant.API ((:<|>)(..),(:>), BasicAuth,
5453 QueryParams, Raw, ReflectMethod(..),
5554 RemoteHost, ReqBody,
5655 ToHttpApiData(..), Vault, Verb)
56+import qualified Servant.Auth as Auth
5757
5858import Reflex.Dom (Dynamic, Event, Reflex,
5959 XhrRequest(..),
@@ -524,3 +524,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall
524524more specific. This in turn generally means adding yet another instance (one
525525for empty and one for non-empty lists).
526526-}
527+
528+
529+-- SUPPORT FOR servant-auth --
530+
531+-- For JavaScript clients we should be sending/storing JSON web tokens in a
532+-- way that is inaccessible to JavaScript.
533+--
534+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM
535+-- app this means the @servant-auth@ client should only verify that the API
536+-- supports Cookie-based authentication but do nothing with the token
537+-- directly.
538+
539+-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures
540+-- we're not trying to rely on cookies when the API does not use them.
541+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
542+
543+ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
544+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
545+
546+
547+type family HasCookieAuth xs :: Constraint where
548+ HasCookieAuth (Auth.Cookie ': xs) = ()
549+ HasCookieAuth (x ': xs) = HasCookieAuth xs
550+ HasCookieAuth '[] = CookieAuthNotEnabled
551+
552+class CookieAuthNotEnabled
553+