{-# LANGUAGE OverloadedStrings #-}

-- | Encrypted, authenticated sessions stored entirely in a browser cookie.
-- Uses Crypton's XChaCha20-Poly1305 with fresh 192-bit OS-random nonces.
-- Keys are supplied by the application; this library never writes them to disk.
--
-- Use 'cookieSessionCodec' with @defaultClientSessionCfg@ and @ClientSessions@
-- from "Web.Spock.Config".
-- Spock checks the authenticated expiry using the server clock. Use HTTPS,
-- Secure/HttpOnly cookies and CSRF protection, for example defaultBrowserSpockCfg.
--
-- Stateless cookies cannot revoke individual sessions or merge simultaneous
-- requests. Logout expires this browser's cookie; copies remain replayable until
-- expiry or key removal. Use a server backend when immediate revocation or
-- concurrent counters are required. Keep payloads small; Spock limits the entire
-- Set-Cookie value to 4096 bytes and rejects oversized changes before saving them.
module Web.Spock.Session.Cookie
  ( CookieKey, CookieKeyRing, CookieKeyError (..),
    cookieKey, cookieKeyRing, cookieSessionCodec
  ) where

import Control.Exception (Exception, throwIO)
import Control.Monad (guard)
import qualified Crypto.Cipher.ChaChaPoly1305 as C
import Crypto.Error (CryptoFailable (..))
import Data.Aeson
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as B64
import qualified Data.ByteString.Lazy as BL
import Data.List (nub)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import System.Entropy (getEntropy)
import Web.Spock.Config (ClientSessionCodec (..))
import Web.Spock.Internal.SessionManager (Session (..))

-- | Validated 256-bit key and public wire identifier. No Show instance; identifiers
-- are visible in the cookie, but key material must come from a secret manager.
data CookieKey = CookieKey T.Text BA.ScrubbedBytes

-- | Application namespace, primary encryption key, and accepted older keys.
-- Deploy a new primary with the old key still accepted, then remove the old key
-- after its last possible session expiry. All workers must share the key ring.
data CookieKeyRing = CookieKeyRing T.Text CookieKey [CookieKey]

-- | Configuration errors never include key material or cookie contents.
data CookieKeyError = InvalidKeyId | InvalidKeyLength | InvalidNamespace
  | DuplicateKeyId | TooManyKeys | CookieEncryptionFailure
  deriving (CookieKeyError -> CookieKeyError -> Bool
(CookieKeyError -> CookieKeyError -> Bool)
-> (CookieKeyError -> CookieKeyError -> Bool) -> Eq CookieKeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CookieKeyError -> CookieKeyError -> Bool
== :: CookieKeyError -> CookieKeyError -> Bool
$c/= :: CookieKeyError -> CookieKeyError -> Bool
/= :: CookieKeyError -> CookieKeyError -> Bool
Eq, Int -> CookieKeyError -> ShowS
[CookieKeyError] -> ShowS
CookieKeyError -> String
(Int -> CookieKeyError -> ShowS)
-> (CookieKeyError -> String)
-> ([CookieKeyError] -> ShowS)
-> Show CookieKeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CookieKeyError -> ShowS
showsPrec :: Int -> CookieKeyError -> ShowS
$cshow :: CookieKeyError -> String
show :: CookieKeyError -> String
$cshowList :: [CookieKeyError] -> ShowS
showList :: [CookieKeyError] -> ShowS
Show)

instance Exception CookieKeyError

-- | A 32-byte key and a 1–32 character identifier using ASCII letters, digits,
-- underscore or hyphen. Generate keys with a cryptographic OS random source.
cookieKey :: T.Text -> BS.ByteString -> Either CookieKeyError CookieKey
cookieKey :: Text -> ByteString -> Either CookieKeyError CookieKey
cookieKey Text
name ByteString
bytes
  | Text -> Bool
T.null Text
name Bool -> Bool -> Bool
|| Text -> Int
T.length Text
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
32 Bool -> Bool -> Bool
|| Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
valid Text
name) = CookieKeyError -> Either CookieKeyError CookieKey
forall a b. a -> Either a b
Left CookieKeyError
InvalidKeyId
  | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
32 = CookieKeyError -> Either CookieKeyError CookieKey
forall a b. a -> Either a b
Left CookieKeyError
InvalidKeyLength
  | Bool
otherwise = CookieKey -> Either CookieKeyError CookieKey
forall a b. b -> Either a b
Right (CookieKey -> Either CookieKeyError CookieKey)
-> CookieKey -> Either CookieKeyError CookieKey
forall a b. (a -> b) -> a -> b
$ Text -> ScrubbedBytes -> CookieKey
CookieKey Text
name (ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
bytes)
  where
    valid :: Char -> Bool
valid Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z'
      Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

-- | Bind cookies to an application namespace (1–128 UTF-8 bytes). Accept at
-- most seven old keys, with unique identifiers across the entire ring.
cookieKeyRing :: T.Text -> CookieKey -> [CookieKey] -> Either CookieKeyError CookieKeyRing
cookieKeyRing :: Text
-> CookieKey -> [CookieKey] -> Either CookieKeyError CookieKeyRing
cookieKeyRing Text
namespace CookieKey
primary [CookieKey]
old
  | Text -> Bool
T.null Text
namespace Bool -> Bool -> Bool
|| ByteString -> Int
BS.length (Text -> ByteString
T.encodeUtf8 Text
namespace) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
128 = CookieKeyError -> Either CookieKeyError CookieKeyRing
forall a b. a -> Either a b
Left CookieKeyError
InvalidNamespace
  | [CookieKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CookieKey]
old Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
7 = CookieKeyError -> Either CookieKeyError CookieKeyRing
forall a b. a -> Either a b
Left CookieKeyError
TooManyKeys
  | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ids Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub [Text]
ids) = CookieKeyError -> Either CookieKeyError CookieKeyRing
forall a b. a -> Either a b
Left CookieKeyError
DuplicateKeyId
  | Bool
otherwise = CookieKeyRing -> Either CookieKeyError CookieKeyRing
forall a b. b -> Either a b
Right (CookieKeyRing -> Either CookieKeyError CookieKeyRing)
-> CookieKeyRing -> Either CookieKeyError CookieKeyRing
forall a b. (a -> b) -> a -> b
$ Text -> CookieKey -> [CookieKey] -> CookieKeyRing
CookieKeyRing Text
namespace CookieKey
primary [CookieKey]
old
  where ids :: [Text]
ids = [Text
name | CookieKey Text
name ScrubbedBytes
_ <- CookieKey
primary CookieKey -> [CookieKey] -> [CookieKey]
forall a. a -> [a] -> [a]
: [CookieKey]
old]

-- | A versioned JSON codec. All session fields are encrypted and authenticated;
-- the namespace, cookie name, wire version and key identifier are authenticated
-- as associated data. Decoding never releases unauthenticated JSON. An accepted
-- old key triggers reissue with the primary key, including with fixed expiry.
--
-- Changing the namespace or removing a key invalidates affected cookies. The
-- decoder also bounds input size before attempting cryptography. It returns
-- Nothing for malformed, tampered or unknown-key input; the manager creates a
-- new empty session only if the request uses one.
cookieSessionCodec :: (ToJSON sess, FromJSON sess) => CookieKeyRing -> ClientSessionCodec sess
cookieSessionCodec :: forall sess.
(ToJSON sess, FromJSON sess) =>
CookieKeyRing -> ClientSessionCodec sess
cookieSessionCodec (CookieKeyRing Text
namespace CookieKey
primary [CookieKey]
old) = (forall conn st. Text -> Session conn sess st -> IO ByteString)
-> (forall conn st.
    Text -> ByteString -> IO (Maybe (Session conn sess st, Bool)))
-> ClientSessionCodec sess
forall sess.
(forall conn st. Text -> Session conn sess st -> IO ByteString)
-> (forall conn st.
    Text -> ByteString -> IO (Maybe (Session conn sess st, Bool)))
-> ClientSessionCodec sess
ClientSessionCodec Text -> Session conn sess st -> IO ByteString
forall conn st. Text -> Session conn sess st -> IO ByteString
forall {sess} {conn} {st}.
ToJSON sess =>
Text -> Session conn sess st -> IO ByteString
encodeSession Text -> ByteString -> IO (Maybe (Session conn sess st, Bool))
forall conn st.
Text -> ByteString -> IO (Maybe (Session conn sess st, Bool))
forall {f :: * -> *} {sess} {conn} {st}.
(Applicative f, FromJSON sess) =>
Text -> ByteString -> f (Maybe (Session conn sess st, Bool))
decodeSession
  where
    CookieKey Text
primaryId ScrubbedBytes
primaryBytes = CookieKey
primary
    aad :: Text -> Text -> ByteString
aad Text
name Text
kid = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode ([Text
"Spock.session.cookie", Text
"v1", Text
namespace, Text
name, Text
kid] :: [T.Text])
    encodeSession :: Text -> Session conn sess st -> IO ByteString
encodeSession Text
name Session conn sess st
session = do
      nonce <- Int -> IO ByteString
getEntropy Int
24
      state <- case C.nonce24 nonce >>= C.initializeX primaryBytes of
        CryptoPassed State
s -> State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (State -> IO State) -> State -> IO State
forall a b. (a -> b) -> a -> b
$ State -> State
C.finalizeAAD (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ ByteString -> State -> State
forall ba. ByteArrayAccess ba => ba -> State -> State
C.appendAAD (Text -> Text -> ByteString
aad Text
name Text
primaryId) State
s
        CryptoFailed CryptoError
_ -> CookieKeyError -> IO State
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO CookieKeyError
CookieEncryptionFailure
      let plain = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode (Value -> LazyByteString) -> Value -> LazyByteString
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Value
object
            [Key
"id" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Session conn sess st -> Text
forall conn sess st. Session conn sess st -> Text
sess_id Session conn sess st
session, Key
"csrf" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Session conn sess st -> Text
forall conn sess st. Session conn sess st -> Text
sess_csrfToken Session conn sess st
session,
             Key
"expires" Key -> UTCTime -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Session conn sess st -> UTCTime
forall conn sess st. Session conn sess st -> UTCTime
sess_validUntil Session conn sess st
session, Key
"data" Key -> sess -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data Session conn sess st
session]
          (encrypted, finalState) = C.encrypt plain state
          packed = ByteString
nonce ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
encrypted ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Auth -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (State -> Auth
C.finalize State
finalState) :: BS.ByteString)
      pure $ "v1." <> T.encodeUtf8 primaryId <> "." <> B64.encodeUnpadded packed
    decodeSession :: Text -> ByteString -> f (Maybe (Session conn sess st, Bool))
decodeSession Text
name ByteString
input = Maybe (Session conn sess st, Bool)
-> f (Maybe (Session conn sess st, Bool))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Session conn sess st, Bool)
 -> f (Maybe (Session conn sess st, Bool)))
-> Maybe (Session conn sess st, Bool)
-> f (Maybe (Session conn sess st, Bool))
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
input Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4096)
      (kid, encoded) <- case Word8 -> ByteString -> [ByteString]
BS.split Word8
46 ByteString
input of
        [ByteString
"v1", ByteString
k, ByteString
value] -> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
k, ByteString
value)
        [ByteString]
_ -> Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
      key <- lookup kid [(T.encodeUtf8 k, bytes) | CookieKey k bytes <- primary : old]
      packed <- either (const Nothing) Just $ B64.decodeUnpadded encoded
      -- Reject alternate base64 spellings of the same authenticated message.
      guard (B64.encodeUnpadded packed == encoded && BS.length packed >= 40)
      let (nonce, rest) = BS.splitAt 24 packed
          (encrypted, tag) = BS.splitAt (BS.length rest - 16) rest
      initial <- case C.nonce24 nonce >>= C.initializeX key of
        CryptoPassed State
s -> State -> Maybe State
forall a. a -> Maybe a
Just State
s
        CryptoFailed CryptoError
_ -> Maybe State
forall a. Maybe a
Nothing
      kidText <- either (const Nothing) Just $ T.decodeUtf8' kid
      let state = State -> State
C.finalizeAAD (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ ByteString -> State -> State
forall ba. ByteArrayAccess ba => ba -> State -> State
C.appendAAD (Text -> Text -> ByteString
aad Text
name Text
kidText) State
initial
          (plain, finalState) = C.decrypt encrypted state
          expected = Auth -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (State -> Auth
C.finalize State
finalState) :: BS.ByteString
      guard (BA.constEq expected tag)
      value <- decodeStrict' plain
      session <- parseMaybeSession value
      pure (session, kid /= T.encodeUtf8 primaryId)

parseMaybeSession :: FromJSON sess => Value -> Maybe (Session conn sess st)
parseMaybeSession :: forall sess conn st.
FromJSON sess =>
Value -> Maybe (Session conn sess st)
parseMaybeSession Value
value = case Value -> Result (SessionPayload conn sess st)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
  Success (SessionPayload Session conn sess st
session) -> Session conn sess st -> Maybe (Session conn sess st)
forall a. a -> Maybe a
Just Session conn sess st
session
  Error String
_ -> Maybe (Session conn sess st)
forall a. Maybe a
Nothing

newtype SessionPayload conn sess st = SessionPayload (Session conn sess st)

instance FromJSON sess => FromJSON (SessionPayload conn sess st) where
  parseJSON :: Value -> Parser (SessionPayload conn sess st)
parseJSON = String
-> (Object -> Parser (SessionPayload conn sess st))
-> Value
-> Parser (SessionPayload conn sess st)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Session" ((Object -> Parser (SessionPayload conn sess st))
 -> Value -> Parser (SessionPayload conn sess st))
-> (Object -> Parser (SessionPayload conn sess st))
-> Value
-> Parser (SessionPayload conn sess st)
forall a b. (a -> b) -> a -> b
$ \Object
o -> Session conn sess st -> SessionPayload conn sess st
forall conn sess st.
Session conn sess st -> SessionPayload conn sess st
SessionPayload (Session conn sess st -> SessionPayload conn sess st)
-> Parser (Session conn sess st)
-> Parser (SessionPayload conn sess st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text -> UTCTime -> sess -> Session conn sess st
forall conn sess st.
Text -> Text -> UTCTime -> sess -> Session conn sess st
Session
    (Text -> Text -> UTCTime -> sess -> Session conn sess st)
-> Parser Text
-> Parser (Text -> UTCTime -> sess -> Session conn sess st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser (Text -> UTCTime -> sess -> Session conn sess st)
-> Parser Text -> Parser (UTCTime -> sess -> Session conn sess st)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"csrf" Parser (UTCTime -> sess -> Session conn sess st)
-> Parser UTCTime -> Parser (sess -> Session conn sess st)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser UTCTime
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"expires" Parser (sess -> Session conn sess st)
-> Parser sess -> Parser (Session conn sess st)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser sess
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data")