module Wire.API.Routes.Cookies where
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map qualified as M
import Data.Metrics.Servant
import Data.SOP
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import GHC.TypeLits
import Imports
import Servant
import Servant.OpenApi
import Web.Cookie (parseCookies)
import Wire.API.Routes.Version
data (:::) a b
data Cookies (cs :: [Type])
type cs = Header "Cookie" (CookieTuple cs)
type family CookieTypes (cs :: [Type]) :: [Type]
type instance CookieTypes '[] = '[]
type instance CookieTypes ((label ::: x) ': cs) = ([Either Text x] ': CookieTypes cs)
newtype CookieTuple cs = CookieTuple {forall (cs :: [*]). CookieTuple cs -> NP I (CookieTypes cs)
unCookieTuple :: NP I (CookieTypes cs)}
type CookieMap = Map ByteString (NonEmpty ByteString)
type instance
SpecialiseToVersion v (Cookies cs :> api) =
Cookies cs :> SpecialiseToVersion v api
instance (HasOpenApi api) => HasOpenApi (Cookies cs :> api) where
toOpenApi :: Proxy (Cookies cs :> api) -> OpenApi
toOpenApi Proxy (Cookies cs :> api)
_ = Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
class CookieArgs (cs :: [Type]) where
type AddArgs cs a :: Type
uncurryArgs :: AddArgs cs a -> CookieTuple cs -> a
mapArgs :: (a -> b) -> AddArgs cs a -> AddArgs cs b
mkTuple :: CookieMap -> Either Text (CookieTuple cs)
emptyTuple :: CookieTuple cs
instance CookieArgs '[] where
type AddArgs '[] a = a
uncurryArgs :: forall a. AddArgs '[] a -> CookieTuple '[] -> a
uncurryArgs AddArgs '[] a
a CookieTuple '[]
_ = a
AddArgs '[] a
a
mapArgs :: forall a b. (a -> b) -> AddArgs '[] a -> AddArgs '[] b
mapArgs a -> b
h = a -> b
AddArgs '[] a -> AddArgs '[] b
h
mkTuple :: CookieMap -> Either Text (CookieTuple '[])
mkTuple CookieMap
_ = CookieTuple '[] -> Either Text (CookieTuple '[])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CookieTuple '[]
forall (cs :: [*]). CookieArgs cs => CookieTuple cs
emptyTuple
emptyTuple :: CookieTuple '[]
emptyTuple = NP I (CookieTypes '[]) -> CookieTuple '[]
forall (cs :: [*]). NP I (CookieTypes cs) -> CookieTuple cs
CookieTuple NP I '[]
NP I (CookieTypes '[])
forall {k} (a :: k -> *). NP a '[]
Nil
instance
( CookieArgs cs,
KnownSymbol label,
FromHttpApiData x
) =>
CookieArgs ((label ::: (x :: Type)) ': cs)
where
type AddArgs ((label ::: x) ': cs) a = [Either Text x] -> AddArgs cs a
uncurryArgs :: forall a.
AddArgs ((label ::: x) : cs) a
-> CookieTuple ((label ::: x) : cs) -> a
uncurryArgs AddArgs ((label ::: x) : cs) a
f (CookieTuple (I x
x :* NP I xs
xs)) = forall (cs :: [*]) a.
CookieArgs cs =>
AddArgs cs a -> CookieTuple cs -> a
uncurryArgs @cs (AddArgs ((label ::: x) : cs) a
x -> AddArgs cs a
f x
x) (NP I (CookieTypes cs) -> CookieTuple cs
forall (cs :: [*]). NP I (CookieTypes cs) -> CookieTuple cs
CookieTuple NP I xs
NP I (CookieTypes cs)
xs)
mapArgs :: forall a b.
(a -> b)
-> AddArgs ((label ::: x) : cs) a -> AddArgs ((label ::: x) : cs) b
mapArgs a -> b
h AddArgs ((label ::: x) : cs) a
f = forall (cs :: [*]) a b.
CookieArgs cs =>
(a -> b) -> AddArgs cs a -> AddArgs cs b
mapArgs @cs a -> b
h (AddArgs cs a -> AddArgs cs b)
-> ([Either Text x] -> AddArgs cs a)
-> [Either Text x]
-> AddArgs cs b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddArgs ((label ::: x) : cs) a
[Either Text x] -> AddArgs cs a
f
mkTuple :: CookieMap -> Either Text (CookieTuple ((label ::: x) : cs))
mkTuple CookieMap
m = do
let k :: Text
k = String -> Text
T.pack (Proxy label -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @label))
[ByteString]
bs <- [ByteString] -> Either Text [ByteString]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> Either Text [ByteString])
-> (Maybe (NonEmpty ByteString) -> [ByteString])
-> Maybe (NonEmpty ByteString)
-> Either Text [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString]
-> (NonEmpty ByteString -> [ByteString])
-> Maybe (NonEmpty ByteString)
-> [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (NonEmpty ByteString) -> Either Text [ByteString])
-> Maybe (NonEmpty ByteString) -> Either Text [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> CookieMap -> Maybe (NonEmpty ByteString)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> ByteString
T.encodeUtf8 Text
k) CookieMap
m
let vs :: [Either Text x]
vs = (ByteString -> Either Text x) -> [ByteString] -> [Either Text x]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Either Text x
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader [ByteString]
bs
CookieTuple NP I (CookieTypes cs)
t <- forall (cs :: [*]).
CookieArgs cs =>
CookieMap -> Either Text (CookieTuple cs)
mkTuple @cs CookieMap
m
CookieTuple ((label ::: x) : cs)
-> Either Text (CookieTuple ((label ::: x) : cs))
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NP I (CookieTypes ((label ::: x) : cs))
-> CookieTuple ((label ::: x) : cs)
forall (cs :: [*]). NP I (CookieTypes cs) -> CookieTuple cs
CookieTuple ([Either Text x] -> I [Either Text x]
forall a. a -> I a
I [Either Text x]
vs I [Either Text x]
-> NP I (CookieTypes cs) -> NP I ([Either Text x] : CookieTypes cs)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I (CookieTypes cs)
t))
emptyTuple :: CookieTuple ((label ::: x) : cs)
emptyTuple = NP I (CookieTypes ((label ::: x) : cs))
-> CookieTuple ((label ::: x) : cs)
forall (cs :: [*]). NP I (CookieTypes cs) -> CookieTuple cs
CookieTuple ([Either Text x] -> I [Either Text x]
forall a. a -> I a
I [] I [Either Text x]
-> NP I (CookieTypes cs) -> NP I ([Either Text x] : CookieTypes cs)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* CookieTuple cs -> NP I (CookieTypes cs)
forall (cs :: [*]). CookieTuple cs -> NP I (CookieTypes cs)
unCookieTuple (forall (cs :: [*]). CookieArgs cs => CookieTuple cs
emptyTuple @cs))
mkCookieMap :: [(ByteString, ByteString)] -> CookieMap
mkCookieMap :: [(ByteString, ByteString)] -> CookieMap
mkCookieMap = ((ByteString, ByteString) -> CookieMap -> CookieMap)
-> CookieMap -> [(ByteString, ByteString)] -> CookieMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(ByteString
k, ByteString
v) -> (NonEmpty ByteString -> NonEmpty ByteString -> NonEmpty ByteString)
-> ByteString -> NonEmpty ByteString -> CookieMap -> CookieMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NonEmpty ByteString -> NonEmpty ByteString -> NonEmpty ByteString
forall a. Semigroup a => a -> a -> a
(<>) ByteString
k (ByteString -> NonEmpty ByteString
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
v)) CookieMap
forall a. Monoid a => a
mempty
instance (CookieArgs cs) => FromHttpApiData (CookieTuple cs) where
parseHeader :: ByteString -> Either Text (CookieTuple cs)
parseHeader = CookieMap -> Either Text (CookieTuple cs)
forall (cs :: [*]).
CookieArgs cs =>
CookieMap -> Either Text (CookieTuple cs)
mkTuple (CookieMap -> Either Text (CookieTuple cs))
-> (ByteString -> CookieMap)
-> ByteString
-> Either Text (CookieTuple cs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> CookieMap
mkCookieMap ([(ByteString, ByteString)] -> CookieMap)
-> (ByteString -> [(ByteString, ByteString)])
-> ByteString
-> CookieMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)]
parseCookies
parseUrlPiece :: Text -> Either Text (CookieTuple cs)
parseUrlPiece = ByteString -> Either Text (CookieTuple cs)
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text (CookieTuple cs))
-> (Text -> ByteString) -> Text -> Either Text (CookieTuple cs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
instance
( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
CookieArgs cs,
HasServer api ctx
) =>
HasServer (Cookies cs :> api) ctx
where
type ServerT (Cookies cs :> api) m = AddArgs cs (ServerT api m)
route :: forall env.
Proxy (Cookies cs :> api)
-> Context ctx
-> Delayed env (Server (Cookies cs :> api))
-> Router env
route Proxy (Cookies cs :> api)
_ Context ctx
ctx Delayed env (Server (Cookies cs :> api))
action =
Proxy (CookieHeader cs :> api)
-> Context ctx
-> Delayed env (Server (CookieHeader cs :> api))
-> Router env
forall env.
Proxy (CookieHeader cs :> api)
-> Context ctx
-> Delayed env (Server (CookieHeader cs :> api))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
(forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CookieHeader cs :> api))
Context ctx
ctx
( (AddArgs cs (ServerT api Handler)
-> Maybe (CookieTuple cs) -> ServerT api Handler)
-> Delayed env (AddArgs cs (ServerT api Handler))
-> Delayed env (Maybe (CookieTuple cs) -> ServerT api Handler)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\AddArgs cs (ServerT api Handler)
f -> AddArgs cs (ServerT api Handler)
-> CookieTuple cs -> ServerT api Handler
forall (cs :: [*]) a.
CookieArgs cs =>
AddArgs cs a -> CookieTuple cs -> a
forall a. AddArgs cs a -> CookieTuple cs -> a
uncurryArgs AddArgs cs (ServerT api Handler)
f (CookieTuple cs -> ServerT api Handler)
-> (Maybe (CookieTuple cs) -> CookieTuple cs)
-> Maybe (CookieTuple cs)
-> ServerT api Handler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieTuple cs -> Maybe (CookieTuple cs) -> CookieTuple cs
forall a. a -> Maybe a -> a
fromMaybe CookieTuple cs
forall (cs :: [*]). CookieArgs cs => CookieTuple cs
emptyTuple)
Delayed env (Server (Cookies cs :> api))
Delayed env (AddArgs cs (ServerT api Handler))
action
)
hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (Cookies cs :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Cookies cs :> api) m
-> ServerT (Cookies cs :> api) n
hoistServerWithContext Proxy (Cookies cs :> api)
_ Proxy ctx
ctx forall x. m x -> n x
f = forall (cs :: [*]) a b.
CookieArgs cs =>
(a -> b) -> AddArgs cs a -> AddArgs cs b
mapArgs @cs (Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
ctx m x -> n x
forall x. m x -> n x
f)
instance (RoutesToPaths api) => RoutesToPaths (Cookies cs :> api) where
getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api