WIP: logout

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

@@ -52,6 +52,16 @@ login l (fromMaybe False -> persist) = do
   c <- wrapHttpClientE (Auth.login l typ) !>> loginError
   traverse mkUserTokenCookie c
 
+logout :: [SomeUserToken] -> Maybe SomeAccessToken -> Handler r ()
+logout [] Nothing = throwStd authMissingCookieAndToken
+logout [] (Just _) = throwStd authMissingCookie
+logout _ Nothing = throwStd authMissingToken
+
+--logout (Just (Left _)) (Just (Right _)) = throwStd authTokenMismatch
+--logout (Just (Right _)) (Just (Left _)) = throwStd authTokenMismatch
+--logout (Just (Left ut)) (Just (Left at)) = wrapHttpClientE (Auth.logout ut at) !>> zauthError
+--logout (Just (Right ut)) (Just (Right at)) = wrapHttpClientE (Auth.logout ut at) !>> zauthError
+
 --------------------------------------------------------------------------------
 -- Utils
 

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

@@ -286,6 +286,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey
       Named @"access" access
         :<|> Named @"send-login-code" sendLoginCode
         :<|> Named @"login" login
+        :<|> Named @"logout" logout
 
 -- Note [ephemeral user sideeffect]
 -- If the user is ephemeral and expired, it will be removed upon calling