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

import Freckle.App.Prelude

import Data.Char (isControl, isSpace)
import qualified Data.Text as T
import Database.Memcache.Types (Key)
import GHC.Stack (HasCallStack)
import UnliftIO.Exception (throwString)

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

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

-- | 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 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 container whitespace"
  | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> CacheKey
CacheKey Text
t
 where
  invalid :: String -> Either String CacheKey
invalid String
msg =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Not a valid memcached key:\n  " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t forall a. Semigroup a => a -> a -> a
<> String
"\n\n" forall a. Semigroup a => a -> a -> a
<> String
msg

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

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