-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

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

-- | A combinator to extract cookies from an HTTP request. The recommended way
-- to use this combinator is to specify it exactly once in the description of
-- an endpoint, passing a list of pairs of cookie name and type, separated by
-- '(:::)'. Cookies are always optional.
--
-- For example:
-- @@
-- Cookies '["foo" ::: Int64, "bar" ::: Text]
-- @@
-- results in a cookie with name "foo" containing a 64-bit integer, and a
-- cookie with name "bar" containing an arbitrary text value.
data Cookies (cs :: [Type])

type CookieHeader cs = Header "Cookie" (CookieTuple cs)

-- CookieTypes = map snd
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
  -- example: AddArgs ["foo" :: Foo, "bar" :: Bar] a = Foo -> Bar -> a
  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