{-# LANGUAGE CApiFFI #-}

-- | The anonymous cookie that names a visitor's list.
module Todo.Cookie
  ( cookieName
  , newToken
  , readToken
  , setCookie
  ) where

import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as B
import Data.ByteString.Internal qualified as BSI
import Data.ByteString.Lazy qualified as BL
import Data.Char (isHexDigit, isLower, isDigit)
import Data.Text (Text)
import Data.Text.Encoding qualified as T
import Data.Word (Word8)
import Foreign.C.Types (CSize (..), CUInt (..))
import Foreign.Ptr (Ptr, plusPtr)
import System.Posix.Types (CSsize (..))
import Web.Cookie

cookieName :: ByteString
cookieName = "todo_list"

-- | Bytes of randomness in a token: 256 bits, written as 64 hex digits.
tokenBytes :: Int
tokenBytes = 32

foreign import capi unsafe "sys/random.h getrandom"
  c_getrandom :: Ptr Word8 -> CSize -> CUInt -> IO CSsize

-- | A fresh token from the kernel's CSPRNG (getrandom(2), so no file
-- under @/dev@ has to be visible to a sandboxed instance).
newToken :: IO Text
newToken = do
  bytes <- BSI.create tokenBytes (fill tokenBytes)
  pure . T.decodeLatin1 . BL.toStrict . B.toLazyByteString $ B.byteStringHex bytes
  where
    fill 0 _ = pure ()
    fill n p = do
      got <- c_getrandom p (fromIntegral n) 0
      -- A negative answer is EINTR or similar: just ask again.
      when (got < 0) $ fill n p
      when (got > 0) $ fill (n - fromIntegral got) (p `plusPtr` fromIntegral got)

-- | The token in a request's @Cookie@ header, if it has the shape of one
-- this app mints. Anything else, garbled or not, is treated as absent.
readToken :: Maybe ByteString -> Maybe Text
readToken header = do
  value <- lookup cookieName . parseCookies =<< header
  let ok c = isHexDigit c && (isDigit c || isLower c)
  if BS.length value == 2 * tokenBytes && BS.all (ok . BSI.w2c) value
    then Just (T.decodeLatin1 value)
    else Nothing

-- | The @Set-Cookie@ value for a token. @secure@ is set when the app is
-- served over https.
setCookie :: Bool -> Text -> ByteString
setCookie secure token =
  BL.toStrict . B.toLazyByteString . renderSetCookie $
    defaultSetCookie
      { setCookieName = cookieName
      , setCookieValue = T.encodeUtf8 token
      , setCookiePath = Just "/"
      , setCookieMaxAge = Just (400 * 24 * 60 * 60)
      , setCookieHttpOnly = True
      , setCookieSecure = secure
      , setCookieSameSite = Just sameSiteLax
      }