69 lines
1.9 KiB
Haskell
69 lines
1.9 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Settings.Cookies
|
|
( CookieSettings(..)
|
|
, HasCookieSettings(..)
|
|
, cookieSettingsToSetCookie
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import Web.Cookie
|
|
import Web.Cookie.Instances ()
|
|
|
|
import Utils.PathPiece
|
|
|
|
import Data.Time.Clock
|
|
import Data.Time.Clock.Instances ()
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
|
|
import Control.Lens ((&))
|
|
import Control.Monad.Fail
|
|
|
|
|
|
data CookieSettings = CookieSettings
|
|
{ cookieExpires :: Maybe NominalDiffTime
|
|
, cookieSameSite :: Maybe SameSiteOption
|
|
, cookieHttpOnly
|
|
, cookieSecure :: Maybe Bool
|
|
} deriving (Eq, Show, Generic, Typeable)
|
|
deriving anyclass (Hashable)
|
|
|
|
instance FromJSON SameSiteOption where
|
|
parseJSON = withText "SameSiteOption" $ \(CI.mk -> ciT) -> HashMap.lookup ciT options
|
|
& maybe (fail . unpack $ "Expected one of: " <> Text.intercalate ", " (map CI.original $ HashMap.keys options)) return
|
|
where options = mconcat
|
|
[ singletonMap "Lax" sameSiteLax
|
|
, singletonMap "Strict" sameSiteStrict
|
|
, singletonMap "None" sameSiteNone
|
|
]
|
|
|
|
deriveFromJSON defaultOptions
|
|
{ omitNothingFields = True
|
|
, fieldLabelModifier = camelToPathPiece' 1
|
|
} ''CookieSettings
|
|
|
|
|
|
class HasCookieSettings ident app | app -> ident where
|
|
getCookieSettings :: app -> ident -> CookieSettings
|
|
|
|
instance HasCookieSettings ident (ident -> CookieSettings) where
|
|
getCookieSettings = id
|
|
|
|
|
|
cookieSettingsToSetCookie :: MonadIO m => CookieSettings -> m SetCookie
|
|
cookieSettingsToSetCookie CookieSettings{..} = do
|
|
now <- liftIO getCurrentTime
|
|
return def
|
|
{ setCookieExpires = addUTCTime <$> cookieExpires <*> pure now
|
|
, setCookieSameSite = cookieSameSite
|
|
, setCookieHttpOnly = fromMaybe (setCookieHttpOnly def) cookieHttpOnly
|
|
, setCookieSecure = fromMaybe (setCookieSecure def) cookieSecure
|
|
}
|