134 lines
6.3 KiB
Haskell
134 lines
6.3 KiB
Haskell
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
|