Servantify logout endpoint

libs/wire-api/src/Wire/API/Routes/Cookies.hs

@@ -32,18 +32,32 @@ import Web.Cookie (parseCookies)
 
 data (:::) a b
 
+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
+-- either '(:::)' or '(::?)'. The former makes the corresponding cookie
+-- mandatory, while the latter makes it optional, and returns a 'Maybe' result.
+--
+-- For example:
+-- @@
+-- Cookies '["foo" ::: Int64, "bar" ::? Text]
+-- @@
+-- results in a mandatory cookie with name "foo" containing a 64-bit integer,
+-- and an optional cookie with name "bar" containing an arbitrary text value.
 data Cookies (cs :: [*])
 
 type CookieHeader cs = Header' '[Required] "Cookie" (CookieTuple cs)
 
-type CookieType = NonEmpty
-
 -- CookieTypes = map snd
 type family CookieTypes (cs :: [*]) :: [*]
 
 type instance CookieTypes '[] = '[]
 
-type instance CookieTypes ((lbl ::: x) ': cs) = (CookieType x ': CookieTypes cs)
+type instance CookieTypes ((lbl ::: x) ': cs) = (NonEmpty x ': CookieTypes cs)
+
+type instance CookieTypes ((lbl ::? x) ': cs) = ([x] ': CookieTypes cs)
 
 newtype CookieTuple cs = CookieTuple {unCookieTuple :: NP I (CookieTypes cs)}
 
@@ -74,7 +88,7 @@ instance
   ) =>
   CookieArgs ((lbl ::: (x :: *)) ': cs)
   where
-  type AddArgs ((lbl ::: x) ': cs) a = CookieType x -> AddArgs cs a
+  type AddArgs ((lbl ::: x) ': cs) a = NonEmpty x -> AddArgs cs a
   uncurryArgs f (CookieTuple (I x :* xs)) = uncurryArgs @cs (f x) (CookieTuple xs)
   mapArgs h f = mapArgs @cs h . f
   mkTuple m = do
@@ -84,6 +98,23 @@ instance
     CookieTuple t <- mkTuple @cs m
     pure (CookieTuple (I vs :* t))
 
+instance
+  ( CookieArgs cs,
+    KnownSymbol lbl,
+    FromHttpApiData x
+  ) =>
+  CookieArgs ((lbl ::? (x :: *)) ': cs)
+  where
+  type AddArgs ((lbl ::? x) ': cs) a = [x] -> AddArgs cs a
+  uncurryArgs f (CookieTuple (I x :* xs)) = uncurryArgs @cs (f x) (CookieTuple xs)
+  mapArgs h f = mapArgs @cs h . f
+  mkTuple m = do
+    let k = T.pack (symbolVal (Proxy @lbl))
+    bs <- pure . maybe [] toList $ M.lookup (T.encodeUtf8 k) m
+    vs <- traverse parseHeader bs
+    CookieTuple t <- mkTuple @cs m
+    pure (CookieTuple (I vs :* t))
+
 mkCookieMap :: [(ByteString, ByteString)] -> CookieMap
 mkCookieMap = foldr (\(k, v) -> M.insertWith (<>) k (pure v)) mempty
 

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -1159,6 +1159,7 @@ type AuthAPI =
              \ header, with the latter being preferred."
         :> Cookies '["zuid" ::: SomeUserToken]
         :> Bearer SomeAccessToken
+        -- TODO: access_token query parameter
         :> MultiVerb1 'POST '[JSON] TokenResponse
     )
     :<|> Named
@@ -1192,6 +1193,37 @@ type AuthAPI =
                     Bool
                :> MultiVerb1 'POST '[JSON] TokenResponse
            )
+    :<|> Named
+           "logout"
+           ( "access" :> "logout"
+               :> Summary "Log out in order to remove a cookie from the server"
+               :> Description
+                    "Calling this endpoint will effectively revoke the given cookie\
+                    \ and subsequent calls to /access with the same cookie will\
+                    \ result in a 403."
+               :> Cookies '["zuid" ::? SomeUserToken]
+               :> Bearer SomeAccessToken
+               -- TODO: access_token query parameter
+               :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Logout")
+           )
+
+-- post "/access/logout" (continue logoutH) $
+--   accept "application" "json" .&. tokenRequest
+-- document "POST" "logout" $ do
+--   Doc.summary "Log out in order to remove a cookie from the server."
+--   Doc.notes
+--     "Calling this endpoint will effectively revoke the given cookie \
+--     \and subsequent calls to /access with the same cookie will \
+--     \result in a 403."
+--   Doc.parameter Doc.Header "cookie" Doc.bytes' $
+--     Doc.description "The 'zuid' cookie header"
+--   Doc.parameter Doc.Header "Authorization" Doc.bytes' $ do
+--     Doc.description "The access-token as 'Authorization' header."
+--     Doc.optional
+--   Doc.parameter Doc.Query "access_token" Doc.bytes' $ do
+--     Doc.description "The access-token as query parameter."
+--     Doc.optional
+--   Doc.errorResponse (errorToWai @'E.BadCredentials)
 
 type BrigAPI =
   UserAPI

services/brig/src/Brig/API/Auth.hs

@@ -25,20 +25,19 @@ import qualified Brig.User.Auth as Auth
 import Brig.ZAuth hiding (Env, settings)
 import Control.Lens (view)
 import Data.List.NonEmpty (NonEmpty ((:|)))
-import qualified Data.List.NonEmpty as NE
 import Data.List1 (List1 (..))
 import qualified Data.ZAuth.Token as ZAuth
 import Imports
 import Network.Wai.Utilities ((!>>))
-import Wire.API.User.Auth
+import Wire.API.User.Auth hiding (access)
 
-access :: NonEmpty SomeUserToken -> Maybe SomeAccessToken -> Handler r SomeAccess
-access ut mat = do
-  partitionTokens ut mat >>= either (uncurry renew) (uncurry renew)
-  where
-    renew t mt =
-      traverse mkUserTokenCookie
-        =<< wrapHttpClientE (Auth.renewAccess (List1 t) mt) !>> zauthError
+accessH :: NonEmpty SomeUserToken -> Maybe SomeAccessToken -> Handler r SomeAccess
+accessH ut mat = partitionTokens ut mat >>= either (uncurry access) (uncurry access)
+
+access :: TokenPair u a => NonEmpty (Token u) -> Maybe (Token a) -> Handler r SomeAccess
+access t mt =
+  traverse mkUserTokenCookie
+    =<< wrapHttpClientE (Auth.renewAccess (List1 t) mt) !>> zauthError
 
 sendLoginCode :: SendLoginCode -> Handler r LoginCodeTimeout
 sendLoginCode (SendLoginCode phone call force) = do
@@ -52,6 +51,17 @@ login l (fromMaybe False -> persist) = do
   c <- wrapHttpClientE (Auth.login l typ) !>> loginError
   traverse mkUserTokenCookie c
 
+logoutH :: [SomeUserToken] -> Maybe SomeAccessToken -> Handler r ()
+logoutH [] Nothing = throwStd authMissingCookieAndToken
+logoutH [] (Just _) = throwStd authMissingCookie
+logoutH uts mat =
+  partitionTokens uts mat
+    >>= either (uncurry logout) (uncurry logout)
+
+logout :: TokenPair u a => NonEmpty (Token u) -> Maybe (Token a) -> Handler r ()
+logout _ Nothing = throwStd authMissingToken
+logout uts (Just at) = wrapHttpClientE $ Auth.logout (List1 uts) at !>> zauthError
+
 --------------------------------------------------------------------------------
 -- Utils
 
@@ -71,7 +81,8 @@ mkUserTokenCookie c = do
       }
 
 partitionTokens ::
-  NonEmpty SomeUserToken ->
+  Foldable f =>
+  f SomeUserToken ->
   Maybe SomeAccessToken ->
   Handler
     r
@@ -80,7 +91,7 @@ partitionTokens ::
         (NonEmpty (ZAuth.Token ZAuth.LegalHoldUser), Maybe (ZAuth.Token ZAuth.LegalHoldAccess))
     )
 partitionTokens tokens mat =
-  case (partitionEithers (map toEither (NE.toList tokens)), mat) of
+  case (partitionEithers (map toEither (toList tokens)), mat) of
     -- only PlainUserToken
     ((at : ats, []), Nothing) -> pure (Left (at :| ats, Nothing))
     ((at : ats, []), Just (PlainAccessToken a)) -> pure (Left (at :| ats, Just a))

services/brig/src/Brig/API/Public.hs

@@ -283,9 +283,10 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey
 
     authAPI :: ServerT AuthAPI (Handler r)
     authAPI =
-      Named @"access" access
+      Named @"access" accessH
         :<|> Named @"send-login-code" sendLoginCode
         :<|> Named @"login" login
+        :<|> Named @"logout" logoutH
 
 -- Note [ephemeral user sideeffect]
 -- If the user is ephemeral and expired, it will be removed upon calling