-- 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 :: forall (r :: EffectRow).
Member (Embed IO) r =>
ClientState -> InterpreterFor SessionStore r
interpretSessionStoreCassandra ClientState
casClient =
  (forall (rInitial :: EffectRow) x.
 SessionStore (Sem rInitial) x -> Sem r x)
-> Sem (SessionStore : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  SessionStore (Sem rInitial) x -> Sem r x)
 -> Sem (SessionStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    SessionStore (Sem rInitial) x -> Sem r x)
-> Sem (SessionStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$
    (forall x. Client x -> IO x) -> Sem (Embed Client : r) x -> Sem r x
forall (m1 :: * -> *) (m2 :: * -> *) (r :: EffectRow) a.
Member (Embed m2) r =>
(forall x. m1 x -> m2 x) -> Sem (Embed m1 : r) a -> Sem r a
runEmbedded (ClientState -> Client x -> IO x
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
casClient) (Sem (Embed Client : r) x -> Sem r x)
-> (SessionStore (Sem rInitial) x -> Sem (Embed Client : r) x)
-> SessionStore (Sem rInitial) x
-> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      InsertCookie UserId
uid Cookie ()
cookie Maybe TTL
ttl -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ UserId -> Cookie () -> Maybe TTL -> Client ()
forall (m :: * -> *).
MonadClient m =>
UserId -> Cookie () -> Maybe TTL -> m ()
insertCookieImpl UserId
uid Cookie ()
cookie Maybe TTL
ttl
      LookupCookie UserId
uid UTCTime
utc CookieId
cid -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ UserId -> UTCTime -> CookieId -> Client (Maybe (Cookie ()))
forall (m :: * -> *).
MonadClient m =>
UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ()))
lookupCookieImpl UserId
uid UTCTime
utc CookieId
cid
      ListCookies UserId
uid -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ UserId -> Client [Cookie ()]
forall (m :: * -> *). MonadClient m => UserId -> m [Cookie ()]
listCookiesImpl UserId
uid
      DeleteAllCookies UserId
uid -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ UserId -> Client ()
forall (m :: * -> *). MonadClient m => UserId -> m ()
deleteAllCookiesImpl UserId
uid
      DeleteCookies UserId
uid [Cookie ()]
cc -> Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> Client x -> Sem (Embed Client : r) x
forall a b. (a -> b) -> a -> b
$ UserId -> [Cookie ()] -> Client ()
forall (m :: * -> *).
MonadClient m =>
UserId -> [Cookie ()] -> m ()
deleteCookiesImpl UserId
uid [Cookie ()]
cc

insertCookieImpl :: (MonadClient m) => UserId -> Cookie () -> Maybe TTL -> m ()
insertCookieImpl :: forall (m :: * -> *).
MonadClient m =>
UserId -> Cookie () -> Maybe TTL -> m ()
insertCookieImpl UserId
u Cookie ()
ck Maybe TTL
ttl =
  let i :: CookieId
i = Cookie () -> CookieId
forall a. Cookie a -> CookieId
cookieId Cookie ()
ck
      x :: UTCTime
x = Cookie () -> UTCTime
forall a. Cookie a -> UTCTime
cookieExpires Cookie ()
ck
      c :: UTCTime
c = Cookie () -> UTCTime
forall a. Cookie a -> UTCTime
cookieCreated Cookie ()
ck
      t :: CookieType
t = Cookie () -> CookieType
forall a. Cookie a -> CookieType
cookieType Cookie ()
ck
      l :: Maybe CookieLabel
l = Cookie () -> Maybe CookieLabel
forall a. Cookie a -> Maybe CookieLabel
cookieLabel Cookie ()
ck
      s :: Maybe CookieId
s = Cookie () -> Maybe CookieId
forall a. Cookie a -> Maybe CookieId
cookieSucc Cookie ()
ck
      o :: TTL
o = TTL -> Maybe TTL -> TTL
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> TTL
TTL (NominalDiffTime -> Int32
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
x UTCTime
c))) Maybe TTL
ttl
   in RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PrepQuery
  W
  (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel,
   Maybe CookieId, TTL)
  ()
-> QueryParams
     (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel,
      Maybe CookieId, TTL)
-> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery
  W
  (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel,
   Maybe CookieId, TTL)
  ()
cql (Consistency
-> (UserId, UTCTime, CookieId, CookieType, UTCTime,
    Maybe CookieLabel, Maybe CookieId, TTL)
-> QueryParams
     (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel,
      Maybe CookieId, TTL)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (UserId
u, UTCTime
x, CookieId
i, CookieType
t, UTCTime
c, Maybe CookieLabel
l, Maybe CookieId
s, TTL
o))
  where
    cql :: PrepQuery W (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId, TTL) ()
    cql :: PrepQuery
  W
  (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel,
   Maybe CookieId, TTL)
  ()
cql =
      PrepQuery
  W
  (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel,
   Maybe CookieId, TTL)
  ()
"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 :: forall (m :: * -> *).
MonadClient m =>
UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ()))
lookupCookieImpl UserId
u UTCTime
t CookieId
c =
  ((CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
 -> Cookie ())
-> Maybe (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
-> Maybe (Cookie ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
-> Cookie ()
mkCookie (Maybe (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
 -> Maybe (Cookie ()))
-> m (Maybe
        (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId))
-> m (Maybe (Cookie ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetrySettings
-> m (Maybe
        (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId))
-> m (Maybe
        (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId))
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery
  R
  (UserId, UTCTime, CookieId)
  (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
-> QueryParams (UserId, UTCTime, CookieId)
-> m (Maybe
        (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId))
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m (Maybe b)
query1 PrepQuery
  R
  (UserId, UTCTime, CookieId)
  (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
cql (Consistency
-> (UserId, UTCTime, CookieId)
-> QueryParams (UserId, UTCTime, CookieId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (UserId
u, UTCTime
t, CookieId
c)))
  where
    mkCookie :: (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
-> Cookie ()
mkCookie (CookieType
typ, UTCTime
created, Maybe CookieLabel
label, Maybe CookieId
csucc) =
      Cookie
        { $sel:cookieId:Cookie :: CookieId
cookieId = CookieId
c,
          $sel:cookieCreated:Cookie :: UTCTime
cookieCreated = UTCTime
created,
          $sel:cookieExpires:Cookie :: UTCTime
cookieExpires = UTCTime
t,
          $sel:cookieType:Cookie :: CookieType
cookieType = CookieType
typ,
          $sel:cookieLabel:Cookie :: Maybe CookieLabel
cookieLabel = Maybe CookieLabel
label,
          $sel:cookieSucc:Cookie :: Maybe CookieId
cookieSucc = Maybe CookieId
csucc,
          $sel:cookieValue:Cookie :: ()
cookieValue = ()
        }
    cql :: PrepQuery R (UserId, UTCTime, CookieId) (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
    cql :: PrepQuery
  R
  (UserId, UTCTime, CookieId)
  (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
cql =
      PrepQuery
  R
  (UserId, UTCTime, CookieId)
  (CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId)
"SELECT type, created, label, succ_id \
      \FROM user_cookies \
      \WHERE user = ? AND expires = ? AND id = ?"

listCookiesImpl :: (MonadClient m) => UserId -> m [Cookie ()]
listCookiesImpl :: forall (m :: * -> *). MonadClient m => UserId -> m [Cookie ()]
listCookiesImpl UserId
u =
  ((CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
  Maybe CookieId)
 -> Cookie ())
-> [(CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
     Maybe CookieId)]
-> [Cookie ()]
forall a b. (a -> b) -> [a] -> [b]
map (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
 Maybe CookieId)
-> Cookie ()
toCookie ([(CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
   Maybe CookieId)]
 -> [Cookie ()])
-> m [(CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
       Maybe CookieId)]
-> m [Cookie ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetrySettings
-> m [(CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
       Maybe CookieId)]
-> m [(CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
       Maybe CookieId)]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery
  R
  (Identity UserId)
  (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
   Maybe CookieId)
-> QueryParams (Identity UserId)
-> m [(CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
       Maybe CookieId)]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery
  R
  (Identity UserId)
  (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
   Maybe CookieId)
cql (Consistency -> Identity UserId -> QueryParams (Identity UserId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (UserId -> Identity UserId
forall a. a -> Identity a
Identity UserId
u)))
  where
    cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId)
    cql :: PrepQuery
  R
  (Identity UserId)
  (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
   Maybe CookieId)
cql =
      PrepQuery
  R
  (Identity UserId)
  (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
   Maybe CookieId)
"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 :: (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel,
 Maybe CookieId)
-> Cookie ()
toCookie (CookieId
i, UTCTime
ct, UTCTime
et, CookieType
t, Maybe CookieLabel
l, Maybe CookieId
sc) =
      Cookie
        { $sel:cookieId:Cookie :: CookieId
cookieId = CookieId
i,
          $sel:cookieType:Cookie :: CookieType
cookieType = CookieType
t,
          $sel:cookieCreated:Cookie :: UTCTime
cookieCreated = UTCTime
ct,
          $sel:cookieExpires:Cookie :: UTCTime
cookieExpires = UTCTime
et,
          $sel:cookieLabel:Cookie :: Maybe CookieLabel
cookieLabel = Maybe CookieLabel
l,
          $sel:cookieSucc:Cookie :: Maybe CookieId
cookieSucc = Maybe CookieId
sc,
          $sel:cookieValue:Cookie :: ()
cookieValue = ()
        }

deleteCookiesImpl :: (MonadClient m) => UserId -> [Cookie ()] -> m ()
deleteCookiesImpl :: forall (m :: * -> *).
MonadClient m =>
UserId -> [Cookie ()] -> m ()
deleteCookiesImpl UserId
u [Cookie ()]
cs = RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (m () -> m ()) -> (BatchM () -> m ()) -> BatchM () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchM () -> m ()
forall (m :: * -> *). MonadClient m => BatchM () -> m ()
batch (BatchM () -> m ()) -> BatchM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  BatchType -> BatchM ()
setType BatchType
BatchUnLogged
  Consistency -> BatchM ()
setConsistency Consistency
LocalQuorum
  [Cookie ()] -> (Cookie () -> BatchM ()) -> BatchM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Cookie ()]
cs ((Cookie () -> BatchM ()) -> BatchM ())
-> (Cookie () -> BatchM ()) -> BatchM ()
forall a b. (a -> b) -> a -> b
$ \Cookie ()
c -> PrepQuery W (UserId, UTCTime, CookieId) ()
-> (UserId, UTCTime, CookieId) -> BatchM ()
forall a b.
(Show a, Tuple a, Tuple b) =>
PrepQuery W a b -> a -> BatchM ()
addPrepQuery PrepQuery W (UserId, UTCTime, CookieId) ()
cql (UserId
u, Cookie () -> UTCTime
forall a. Cookie a -> UTCTime
cookieExpires Cookie ()
c, Cookie () -> CookieId
forall a. Cookie a -> CookieId
cookieId Cookie ()
c)
  where
    cql :: PrepQuery W (UserId, UTCTime, CookieId) ()
    cql :: PrepQuery W (UserId, UTCTime, CookieId) ()
cql = PrepQuery W (UserId, UTCTime, CookieId) ()
"DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?"

deleteAllCookiesImpl :: (MonadClient m) => UserId -> m ()
deleteAllCookiesImpl :: forall (m :: * -> *). MonadClient m => UserId -> m ()
deleteAllCookiesImpl UserId
u = RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (PrepQuery W (Identity UserId) ()
-> QueryParams (Identity UserId) -> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Identity UserId) ()
cql (Consistency -> Identity UserId -> QueryParams (Identity UserId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (UserId -> Identity UserId
forall a. a -> Identity a
Identity UserId
u)))
  where
    cql :: PrepQuery W (Identity UserId) ()
    cql :: PrepQuery W (Identity UserId) ()
cql = PrepQuery W (Identity UserId) ()
"DELETE FROM user_cookies WHERE user = ?"