content: -- 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.SessionStore.Cassandra (interpretSessionStoreCassandra) where
  
  import Cassandra
  import Data.Id
  import Data.Time.Clock
  import Imports
  import Polysemy
  import Polysemy.Embed
  import Wire.API.User.Auth
  import Wire.SessionStore
  
  interpretSessionStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor SessionStore r
  interpretSessionStoreCassandra casClient =
    interpret $
      runEmbedded (runClient casClient) . \case
        InsertCookie uid cookie ttl -> embed $ insertCookieImpl uid cookie ttl
        LookupCookie uid utc cid -> embed $ lookupCookieImpl uid utc cid
        ListCookies uid -> embed $ listCookiesImpl uid
        DeleteAllCookies uid -> embed $ deleteAllCookiesImpl uid
        DeleteCookies uid cc -> embed $ deleteCookiesImpl uid cc
  
  insertCookieImpl :: (MonadClient m) => UserId -> Cookie () -> Maybe TTL -> m ()
  insertCookieImpl u ck ttl =
    let i = cookieId ck
        x = cookieExpires ck
        c = cookieCreated ck
        t = cookieType ck
        l = cookieLabel ck
        s = cookieSucc ck
        o = fromMaybe (TTL (round (diffUTCTime x c))) ttl
     in retry x5 $ write cql (params LocalQuorum (u, x, i, t, c, l, s, o))
    where
      cql :: PrepQuery W (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId, TTL) ()
      cql =
        "INSERT INTO user_cookies (user, expires, id, type, created, label, succ_id) \
        \VALUES (?, ?, ?, ?, ?, ?, ?) USING TTL ?"
  
  lookupCookieImpl :: (MonadClient m) => UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ()))
  lookupCookieImpl u t c =
    fmap mkCookie <$> retry x1 (query1 cql (params LocalQuorum (u, t, c)))
    where
      mkCookie (typ, created, label, csucc) =
        Cookie
          { cookieId = c,
            cookieCreated = created,
            cookieExpires = t,
            cookieType = typ,
            cookieLabel = label,
            cookieSucc = csucc,
            cookieValue = ()
          }
      cql :: PrepQuery R (UserId, UTCTime, CookieId) (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
      cql =
        "SELECT type, created, label, succ_id \
        \FROM user_cookies \
        \WHERE user = ? AND expires = ? AND id = ?"
  
  listCookiesImpl :: (MonadClient m) => UserId -> m [Cookie ()]
  listCookiesImpl u =
    map toCookie <$> retry x1 (query cql (params LocalQuorum (Identity u)))
    where
      cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId)
      cql =
        "SELECT id, created, expires, type, label, succ_id \
        \FROM user_cookies \
        \WHERE user = ? \
        \ORDER BY expires ASC"
      toCookie :: (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) -> Cookie ()
      toCookie (i, ct, et, t, l, sc) =
        Cookie
          { cookieId = i,
            cookieType = t,
            cookieCreated = ct,
            cookieExpires = et,
            cookieLabel = l,
            cookieSucc = sc,
            cookieValue = ()
          }
  
  deleteCookiesImpl :: (MonadClient m) => UserId -> [Cookie ()] -> m ()
  deleteCookiesImpl u cs = retry x5 . batch $ do
    setType BatchUnLogged
    setConsistency LocalQuorum
    for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c)
    where
      cql :: PrepQuery W (UserId, UTCTime, CookieId) ()
      cql = "DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?"
  
  deleteAllCookiesImpl :: (MonadClient m) => UserId -> m ()
  deleteAllCookiesImpl u = retry x5 (write cql (params LocalQuorum (Identity u)))
    where
      cql :: PrepQuery W (Identity UserId) ()
      cql = "DELETE FROM user_cookies WHERE user = ?"
  