module Session.Key
  ( SessionKey (..)
  , SessionKeyManager (..)
  , makeSessionKeyManager
  , sessionKeyToCookieValue
  , sessionKeyFromCookieValue
  )
where

import Internal.Prelude

import Base64 (decodeBase64, encodeBase64)
import Data.ByteString.Char8 qualified as BS8
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Randomization

data SessionKeyManager m = SessionKeyManager
  { forall (m :: * -> *). SessionKeyManager m -> m SessionKey
new :: m SessionKey
  -- ^ Generate a new session key
  --
  -- In a production setting, it is critical that this action be
  -- thread-safe and produce a securely random result.
  , forall (m :: * -> *). SessionKeyManager m -> SessionKey -> Bool
check :: SessionKey -> Bool
  -- ^ Validate that a text is something that plausibly could have
  --   been generated by 'new'.
  }

-- | Secret value that is sent to and subsequently furnished by
--   the client to identify the session
newtype SessionKey = SessionKey {SessionKey -> Text
text :: Text}
  deriving newtype (SessionKey -> SessionKey -> Bool
(SessionKey -> SessionKey -> Bool)
-> (SessionKey -> SessionKey -> Bool) -> Eq SessionKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionKey -> SessionKey -> Bool
== :: SessionKey -> SessionKey -> Bool
$c/= :: SessionKey -> SessionKey -> Bool
/= :: SessionKey -> SessionKey -> Bool
Eq, Eq SessionKey
Eq SessionKey =>
(SessionKey -> SessionKey -> Ordering)
-> (SessionKey -> SessionKey -> Bool)
-> (SessionKey -> SessionKey -> Bool)
-> (SessionKey -> SessionKey -> Bool)
-> (SessionKey -> SessionKey -> Bool)
-> (SessionKey -> SessionKey -> SessionKey)
-> (SessionKey -> SessionKey -> SessionKey)
-> Ord SessionKey
SessionKey -> SessionKey -> Bool
SessionKey -> SessionKey -> Ordering
SessionKey -> SessionKey -> SessionKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SessionKey -> SessionKey -> Ordering
compare :: SessionKey -> SessionKey -> Ordering
$c< :: SessionKey -> SessionKey -> Bool
< :: SessionKey -> SessionKey -> Bool
$c<= :: SessionKey -> SessionKey -> Bool
<= :: SessionKey -> SessionKey -> Bool
$c> :: SessionKey -> SessionKey -> Bool
> :: SessionKey -> SessionKey -> Bool
$c>= :: SessionKey -> SessionKey -> Bool
>= :: SessionKey -> SessionKey -> Bool
$cmax :: SessionKey -> SessionKey -> SessionKey
max :: SessionKey -> SessionKey -> SessionKey
$cmin :: SessionKey -> SessionKey -> SessionKey
min :: SessionKey -> SessionKey -> SessionKey
Ord, Int -> SessionKey -> ShowS
[SessionKey] -> ShowS
SessionKey -> String
(Int -> SessionKey -> ShowS)
-> (SessionKey -> String)
-> ([SessionKey] -> ShowS)
-> Show SessionKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SessionKey -> ShowS
showsPrec :: Int -> SessionKey -> ShowS
$cshow :: SessionKey -> String
show :: SessionKey -> String
$cshowList :: [SessionKey] -> ShowS
showList :: [SessionKey] -> ShowS
Show)

makeSessionKeyManager :: Monad m => Randomization m -> SessionKeyManager m
makeSessionKeyManager :: forall (m :: * -> *).
Monad m =>
Randomization m -> SessionKeyManager m
makeSessionKeyManager (Randomization Natural -> m ByteString
generateRandomBytes) =
  let
    new :: m SessionKey
new =
      Text -> SessionKey
SessionKey
        (Text -> SessionKey)
-> (ByteString -> Text) -> ByteString -> SessionKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeBase64
        (ByteString -> SessionKey) -> m ByteString -> m SessionKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> m ByteString
generateRandomBytes Natural
forall a. Integral a => a
keyLengthInBytes

    check :: SessionKey -> Bool
check (SessionKey Text
text) =
      Text -> Int
T.length Text
text
        Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Integral a => a
keyLengthAsText
        Bool -> Bool -> Bool
&& (Text -> Bool)
-> (ByteString -> Bool) -> Either Text ByteString -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
False)
          ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Integral a => a
keyLengthInBytes) (Int -> Bool) -> (ByteString -> Int) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS8.length)
          (Text -> Either Text ByteString
decodeBase64 Text
text)
  in
    SessionKeyManager {m SessionKey
$sel:new:SessionKeyManager :: m SessionKey
new :: m SessionKey
new, SessionKey -> Bool
$sel:check:SessionKeyManager :: SessionKey -> Bool
check :: SessionKey -> Bool
check}

-- We generate 18-byte session keys. This number is rather arbitrary.
keyLengthInBytes :: Integral a => a
keyLengthInBytes :: forall a. Integral a => a
keyLengthInBytes = a
18

-- 18 bytes in base64 encoding ends up being a text 24 characters
keyLengthAsText :: Integral a => a
keyLengthAsText :: forall a. Integral a => a
keyLengthAsText = a
24

sessionKeyToCookieValue :: SessionKey -> ByteString
sessionKeyToCookieValue :: SessionKey -> ByteString
sessionKeyToCookieValue = (.text) (SessionKey -> Text)
-> (Text -> ByteString) -> SessionKey -> ByteString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> ByteString
encodeUtf8

sessionKeyFromCookieValue :: ByteString -> Maybe SessionKey
sessionKeyFromCookieValue :: ByteString -> Maybe SessionKey
sessionKeyFromCookieValue ByteString
v =
  ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
v Either UnicodeException Text
-> (Either UnicodeException Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& (UnicodeException -> Maybe Text)
-> (Text -> Maybe Text)
-> Either UnicodeException Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> UnicodeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
forall a. a -> Maybe a
Just Maybe Text -> (Text -> SessionKey) -> Maybe SessionKey
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> SessionKey
SessionKey