{-# LANGUAGE OverloadedStrings #-}

-- | A high-level wrapper for 'Web.Cookie.SetCookie' that interfaces with servant types, generates
-- and verifies cookie name from the type, handles randomness generation, and cookie deletion.
module SAML2.WebSSO.Cookie
  ( SimpleSetCookie (..),
    cookieName,
    cookieToHeader,
    toggleCookie,
  )
where

import Control.Lens
import Control.Monad.Except
import Data.Binary.Builder (toLazyByteString)
import Data.ByteString.Builder qualified as SBSBuilder
import Data.Proxy
import Data.String.Conversions
import Data.Text qualified as ST
import Data.Time
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.Types
import Network.HTTP.Types.Header qualified as HttpTypes
import SAML2.WebSSO.SP
import SAML2.WebSSO.Types
import SAML2.WebSSO.XML
import Servant.API as Servant hiding (URI (..))
import Web.Cookie

newtype SimpleSetCookie name = SimpleSetCookie {fromSimpleSetCookie :: SetCookie}
  deriving (Eq, Show)

instance (KnownSymbol name) => ToHttpApiData (SimpleSetCookie name) where
  toUrlPiece = cs . SBSBuilder.toLazyByteString . renderSetCookie . fromSimpleSetCookie

instance (KnownSymbol name) => FromHttpApiData (SimpleSetCookie name) where
  parseUrlPiece = headerValueToCookie

cookieToHeader :: SimpleSetCookie name -> HttpTypes.Header
cookieToHeader =
  ("set-cookie",)
    . cs
    . toLazyByteString
    . renderSetCookie
    . fromSimpleSetCookie

cookieName :: forall (proxy :: Symbol -> Type) (name :: Symbol). (KnownSymbol name) => proxy name -> SBS
cookieName _ = cs $ symbolVal (Proxy @name)

headerValueToCookie :: forall name. (KnownSymbol name) => ST -> Either ST (SimpleSetCookie name)
headerValueToCookie txt = do
  let cookie = parseSetCookie $ cs txt
  case ["missing cookie name" | setCookieName cookie == ""]
    <> [ cs $ "wrong cookie name: got " <> setCookieName cookie <> ", expected " <> cookieName (Proxy @name)
       | setCookieName cookie /= cookieName (Proxy @name)
       ]
    <> ["missing cookie value" | setCookieValue cookie == ""] of
    errs@(_ : _) -> throwError $ ST.intercalate ", " errs
    [] -> pure (SimpleSetCookie cookie)

toggleCookie :: forall name m. (Applicative m, SP m, KnownSymbol name) => SBS -> Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie name)
toggleCookie path =
  fmap SimpleSetCookie . \case
    Just (value, ttl) ->
      getNow <&> \now ->
        cookie
          { setCookieValue = cs value,
            setCookieExpires = Just . fromTime $ ttl `addTime` now,
            setCookieMaxAge = Just $ realToFrac ttl
          }
    Nothing ->
      pure
        cookie
          { setCookieValue = "",
            setCookieExpires = Just $ fromTime beginningOfTime,
            setCookieMaxAge = Just (-1)
          }
  where
    cookie =
      defaultSetCookie
        { setCookieName = cookieName (Proxy @name),
          setCookieSecure = True,
          setCookiePath = Just path,
          setCookieHttpOnly = True,
          setCookieSameSite = Just sameSiteStrict
        }

beginningOfTime :: Time
beginningOfTime = unsafeReadTime "1970-01-01T00:00:00Z"
