module Freckle.App.Memcached.CacheKey
  ( CacheKey
  , cacheKey
  , cacheKeyThrow
  , fromCacheKey
  ) where

import Prelude

import Control.Exception.Annotated.UnliftIO (throwWithCallStack)
import Control.Monad.IO.Class (MonadIO)
import Data.Char (isControl, isSpace)
import Data.Hashable (Hashable)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Database.Memcache.Types (Key)
import GHC.Stack (HasCallStack)
import OpenTelemetry.Trace (ToAttribute (..))

newtype CacheKey = CacheKey Text
  deriving stock (Int -> CacheKey -> ShowS
[CacheKey] -> ShowS
CacheKey -> String
(Int -> CacheKey -> ShowS)
-> (CacheKey -> String) -> ([CacheKey] -> ShowS) -> Show CacheKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheKey -> ShowS
showsPrec :: Int -> CacheKey -> ShowS
$cshow :: CacheKey -> String
show :: CacheKey -> String
$cshowList :: [CacheKey] -> ShowS
showList :: [CacheKey] -> ShowS
Show)
  deriving newtype (CacheKey -> CacheKey -> Bool
(CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool) -> Eq CacheKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
/= :: CacheKey -> CacheKey -> Bool
Eq, Eq CacheKey
Eq CacheKey =>
(Int -> CacheKey -> Int) -> (CacheKey -> Int) -> Hashable CacheKey
Int -> CacheKey -> Int
CacheKey -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> CacheKey -> Int
hashWithSalt :: Int -> CacheKey -> Int
$chash :: CacheKey -> Int
hash :: CacheKey -> Int
Hashable)

unCacheKey :: CacheKey -> Text
unCacheKey :: CacheKey -> Text
unCacheKey (CacheKey Text
x) = Text
x

instance ToAttribute CacheKey where
  toAttribute :: CacheKey -> Attribute
toAttribute = Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> (CacheKey -> Text) -> CacheKey -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey -> Text
unCacheKey

-- | Build a 'CacheKey', ensuring it's valid for Memcached
--
-- <https://github.com/memcached/memcached/blob/master/doc/protocol.txt#L41>
--
-- @
-- Currently the length limit of a key is set at 250 characters (of course,
-- normally clients wouldn't need to use such long keys); the key must not
-- include control characters or whitespace.
-- @
cacheKey :: Text -> Either String CacheKey
cacheKey :: Text -> Either String CacheKey
cacheKey Text
t
  | Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
250 = String -> Either String CacheKey
invalid String
"Must be fewer than 250 characters"
  | (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isControl Text
t = String -> Either String CacheKey
invalid String
"Cannot contain control characters"
  | (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace Text
t = String -> Either String CacheKey
invalid String
"Cannot contain whitespace"
  | Bool
otherwise = CacheKey -> Either String CacheKey
forall a b. b -> Either a b
Right (CacheKey -> Either String CacheKey)
-> CacheKey -> Either String CacheKey
forall a b. (a -> b) -> a -> b
$ Text -> CacheKey
CacheKey Text
t
 where
  invalid :: String -> Either String CacheKey
invalid String
msg =
    String -> Either String CacheKey
forall a b. a -> Either a b
Left (String -> Either String CacheKey)
-> String -> Either String CacheKey
forall a b. (a -> b) -> a -> b
$ String
"Not a valid memcached key:\n  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg

-- | Build a 'CacheKey' and throw if invalid
cacheKeyThrow :: (MonadIO m, HasCallStack) => Text -> m CacheKey
cacheKeyThrow :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> m CacheKey
cacheKeyThrow = (String -> m CacheKey)
-> (CacheKey -> m CacheKey) -> Either String CacheKey -> m CacheKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> m CacheKey
forall e (m :: * -> *) a.
(MonadIO m, Exception e, HasCallStack) =>
e -> m a
throwWithCallStack (IOError -> m CacheKey)
-> (String -> IOError) -> String -> m CacheKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError) CacheKey -> m CacheKey
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String CacheKey -> m CacheKey)
-> (Text -> Either String CacheKey) -> Text -> m CacheKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String CacheKey
cacheKey

fromCacheKey :: CacheKey -> Key
fromCacheKey :: CacheKey -> Key
fromCacheKey = Text -> Key
T.encodeUtf8 (Text -> Key) -> (CacheKey -> Text) -> CacheKey -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey -> Text
unCacheKey