module Utils.Cookies.Registered
  ( RegisteredCookie(..)
  , lookupRegisteredCookie, lookupRegisteredCookies
  , lookupRegisteredCookieJson, lookupRegisteredCookiesJson
  , setRegisteredCookie, setRegisteredCookie'
  , setRegisteredCookieJson, setRegisteredCookieJson'
  , modifyRegisteredCookieJson, modifyRegisteredCookieJson'
  , tellRegisteredCookieJson, tellRegisteredCookieJson'
  , deleteRegisteredCookie, deleteRegisteredCookie'
  ) where

import ClassyPrelude.Yesod

import Settings.Cookies

import Utils.Cookies
import Utils.PathPiece

import Data.Universe
import Control.Lens

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Text as Aeson
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString.Base64.URL as Base64

import Web.Cookie (SetCookie(..))

import Data.Char (isAscii)
import Data.Monoid (Last(..))


data RegisteredCookie = CookieSession | CookieXSRFToken | CookieLang | CookieSystemMessageState | CookieActiveAuthTags
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
  deriving anyclass (Universe, Finite, Hashable)

nullaryPathPiece ''RegisteredCookie $ toUpper . camelToPathPiece' 1
pathPieceJSON ''RegisteredCookie
pathPieceJSONKey ''RegisteredCookie


_CookieEncoded :: Prism' Text Text
_CookieEncoded = prism' cEncode cDecode
  where
    b64Prefix = "base64url:"

    cDecode t
      | Just encoded <- Text.stripPrefix b64Prefix t
      = either (const Nothing) Just . Text.decodeUtf8' <=< either (const Nothing) Just . Base64.decode $ Text.encodeUtf8 encoded
      | Text.all isAscii t = Just t
      | otherwise = Nothing

    cEncode t
      | Text.all isAscii t
      , not $ b64Prefix `Text.isPrefixOf` t
      = t
      | otherwise
      = b64Prefix <> Text.decodeUtf8 (Base64.encode $ Text.encodeUtf8 t)

newtype RegisteredCookieCurrentValue = RegisteredCookieCurrentValue { getRegisteredCookieCurrentValue :: Maybe Text }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)


-- Primitive
setRegisteredCookie' :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> t -> m ()
setRegisteredCookie' modSet ident@(toPathPiece -> name) (review _CookieEncoded . repack -> content) = do
  path <- getCookiePath
  defSetCookie <- cookieSettingsToSetCookie . ($ ident) =<< getsYesod getCookieSettings

  setCookie $ modSet defSetCookie
    { setCookieName     = Text.encodeUtf8 name
    , setCookieValue    = Text.encodeUtf8 content
    , setCookiePath     = Just path
    }

  cacheBySet (Text.encodeUtf8 name) . RegisteredCookieCurrentValue $ Just content

setRegisteredCookie :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> t -> m ()
setRegisteredCookie = setRegisteredCookie' id

setRegisteredCookieJson' :: (ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> v -> m ()
setRegisteredCookieJson' modSet name = setRegisteredCookie' modSet name . Aeson.encodeToLazyText

setRegisteredCookieJson :: (ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> v -> m ()
setRegisteredCookieJson = setRegisteredCookieJson' id

modifyRegisteredCookieJson' :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> ([v] -> Maybe v) -> m ()
modifyRegisteredCookieJson' modSet name modVal = lookupRegisteredCookiesJson pure name >>= maybe deleteRegisteredCookie'' (setRegisteredCookieJson' modSet name) . modVal
  where deleteRegisteredCookie'' = do
          path <- getCookiePath
          let cookieSettings = modSet def{ setCookiePath = Just path }
          deleteRegisteredCookie' name . maybe "/" Text.decodeUtf8 $ setCookiePath cookieSettings

modifyRegisteredCookieJson :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> ([v] -> Maybe v) -> m ()
modifyRegisteredCookieJson = modifyRegisteredCookieJson' id

tellRegisteredCookieJson' :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m), Monoid v) => (SetCookie -> SetCookie) -> RegisteredCookie -> v -> m ()
tellRegisteredCookieJson' modSet name x = modifyRegisteredCookieJson' modSet name $ pure . (<> x) . fold

tellRegisteredCookieJson :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m), Monoid v) => RegisteredCookie -> v -> m ()
tellRegisteredCookieJson = tellRegisteredCookieJson' id

-- Primitive
deleteRegisteredCookie' :: MonadHandler m
                        => RegisteredCookie -- ^ key
                        -> Text -- ^ path
                        -> m ()
deleteRegisteredCookie' (toPathPiece -> name) path = do
  deleteCookie name path
  cacheBySet (Text.encodeUtf8 name) $ RegisteredCookieCurrentValue Nothing

deleteRegisteredCookie :: (MonadHandler m, Yesod (HandlerSite m)) => RegisteredCookie -> m ()
deleteRegisteredCookie name = deleteRegisteredCookie' name . Text.decodeUtf8 =<< getCookiePath

-- Primitive
lookupRegisteredCookies :: (Textual t, Monoid m, MonadHandler f) => (t -> m) -> RegisteredCookie -> f m
lookupRegisteredCookies toM (toPathPiece -> name) = do
  cachedVal <- cacheByGet (Text.encodeUtf8 name)
  case cachedVal of
    Nothing
      -> foldMap (toM . repack) . mapMaybe (preview _CookieEncoded) <$> lookupCookies name
    Just (RegisteredCookieCurrentValue v)
      -> return . maybe mempty (toM . repack) $ v ^? _Just . _CookieEncoded

lookupRegisteredCookie :: (Textual t, MonadHandler m) => RegisteredCookie -> m (Maybe t)
lookupRegisteredCookie = fmap getLast . lookupRegisteredCookies pure

lookupRegisteredCookiesJson :: (FromJSON v, Monoid m, MonadHandler f) => (v -> m) -> RegisteredCookie -> f m
lookupRegisteredCookiesJson toM = fmap (fromMaybe mempty) . lookupRegisteredCookies (fmap toM . Aeson.decodeStrict' . Text.encodeUtf8)

lookupRegisteredCookieJson :: (FromJSON v, MonadHandler m) => RegisteredCookie -> m (Maybe v)
lookupRegisteredCookieJson = fmap getLast . lookupRegisteredCookiesJson pure