{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Internal module exposing the guts of the package.  Use at
-- your own risk.  No API stability guarantees apply.
--
-- Also exports orphan instances of @PersistField{,Sql} SessionId@.
module Web.ServerSession.Backend.Persistent.Internal.Types
  ( ByteStringJ(..)
    -- * Orphan instances
    -- ** SessionId
    -- $orphanSessionId
    -- ** SessionMap
    -- $orphanSessionMap
  ) where

import Control.Applicative as A
import Control.Arrow (first)
import Control.Monad ((>=>), mzero)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Database.Persist (PersistField(..))
import Database.Persist.Sql (PersistFieldSql(..), SqlType(..))
import Web.ServerSession.Core
import Web.ServerSession.Core.Internal (SessionId(..))

import qualified Data.Aeson as A
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.HashMap.Strict as HM
import qualified Data.Serialize as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE


----------------------------------------------------------------------


-- $orphanSessionId
--
-- @
-- instance 'PersistField'    ('SessionId' sess)
-- instance 'PersistFieldSql' ('SessionId' sess)
-- @
--
-- Does not do sanity checks (DB is trusted).
instance PersistField (SessionId sess) where
  toPersistValue :: SessionId sess -> PersistValue
toPersistValue = Text -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (Text -> PersistValue)
-> (SessionId sess -> Text) -> SessionId sess -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall sess. SessionId sess -> Text
unS
  fromPersistValue :: PersistValue -> Either Text (SessionId sess)
fromPersistValue = (Text -> SessionId sess)
-> Either Text Text -> Either Text (SessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SessionId sess
forall sess. Text -> SessionId sess
S (Either Text Text -> Either Text (SessionId sess))
-> (PersistValue -> Either Text Text)
-> PersistValue
-> Either Text (SessionId sess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text Text
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistFieldSql (SessionId sess) where
  sqlType :: Proxy (SessionId sess) -> SqlType
sqlType Proxy (SessionId sess)
p = Proxy Text -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType ((SessionId sess -> Text) -> Proxy (SessionId sess) -> Proxy Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SessionId sess -> Text
forall sess. SessionId sess -> Text
unS Proxy (SessionId sess)
p)


----------------------------------------------------------------------


-- | Newtype of a 'ByteString' with JSON support via base64url.
newtype ByteStringJ = B { ByteStringJ -> ByteString
unB :: ByteString }
  deriving (ByteStringJ -> ByteStringJ -> Bool
(ByteStringJ -> ByteStringJ -> Bool)
-> (ByteStringJ -> ByteStringJ -> Bool) -> Eq ByteStringJ
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByteStringJ -> ByteStringJ -> Bool
$c/= :: ByteStringJ -> ByteStringJ -> Bool
== :: ByteStringJ -> ByteStringJ -> Bool
$c== :: ByteStringJ -> ByteStringJ -> Bool
Eq, Eq ByteStringJ
Eq ByteStringJ
-> (ByteStringJ -> ByteStringJ -> Ordering)
-> (ByteStringJ -> ByteStringJ -> Bool)
-> (ByteStringJ -> ByteStringJ -> Bool)
-> (ByteStringJ -> ByteStringJ -> Bool)
-> (ByteStringJ -> ByteStringJ -> Bool)
-> (ByteStringJ -> ByteStringJ -> ByteStringJ)
-> (ByteStringJ -> ByteStringJ -> ByteStringJ)
-> Ord ByteStringJ
ByteStringJ -> ByteStringJ -> Bool
ByteStringJ -> ByteStringJ -> Ordering
ByteStringJ -> ByteStringJ -> ByteStringJ
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
min :: ByteStringJ -> ByteStringJ -> ByteStringJ
$cmin :: ByteStringJ -> ByteStringJ -> ByteStringJ
max :: ByteStringJ -> ByteStringJ -> ByteStringJ
$cmax :: ByteStringJ -> ByteStringJ -> ByteStringJ
>= :: ByteStringJ -> ByteStringJ -> Bool
$c>= :: ByteStringJ -> ByteStringJ -> Bool
> :: ByteStringJ -> ByteStringJ -> Bool
$c> :: ByteStringJ -> ByteStringJ -> Bool
<= :: ByteStringJ -> ByteStringJ -> Bool
$c<= :: ByteStringJ -> ByteStringJ -> Bool
< :: ByteStringJ -> ByteStringJ -> Bool
$c< :: ByteStringJ -> ByteStringJ -> Bool
compare :: ByteStringJ -> ByteStringJ -> Ordering
$ccompare :: ByteStringJ -> ByteStringJ -> Ordering
$cp1Ord :: Eq ByteStringJ
Ord, Int -> ByteStringJ -> ShowS
[ByteStringJ] -> ShowS
ByteStringJ -> String
(Int -> ByteStringJ -> ShowS)
-> (ByteStringJ -> String)
-> ([ByteStringJ] -> ShowS)
-> Show ByteStringJ
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByteStringJ] -> ShowS
$cshowList :: [ByteStringJ] -> ShowS
show :: ByteStringJ -> String
$cshow :: ByteStringJ -> String
showsPrec :: Int -> ByteStringJ -> ShowS
$cshowsPrec :: Int -> ByteStringJ -> ShowS
Show, ReadPrec [ByteStringJ]
ReadPrec ByteStringJ
Int -> ReadS ByteStringJ
ReadS [ByteStringJ]
(Int -> ReadS ByteStringJ)
-> ReadS [ByteStringJ]
-> ReadPrec ByteStringJ
-> ReadPrec [ByteStringJ]
-> Read ByteStringJ
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ByteStringJ]
$creadListPrec :: ReadPrec [ByteStringJ]
readPrec :: ReadPrec ByteStringJ
$creadPrec :: ReadPrec ByteStringJ
readList :: ReadS [ByteStringJ]
$creadList :: ReadS [ByteStringJ]
readsPrec :: Int -> ReadS ByteStringJ
$creadsPrec :: Int -> ReadS ByteStringJ
Read, Typeable)

instance PersistField ByteStringJ where
  toPersistValue :: ByteStringJ -> PersistValue
toPersistValue = ByteString -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (ByteString -> PersistValue)
-> (ByteStringJ -> ByteString) -> ByteStringJ -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringJ -> ByteString
unB
  fromPersistValue :: PersistValue -> Either Text ByteStringJ
fromPersistValue = (ByteString -> ByteStringJ)
-> Either Text ByteString -> Either Text ByteStringJ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteStringJ
B (Either Text ByteString -> Either Text ByteStringJ)
-> (PersistValue -> Either Text ByteString)
-> PersistValue
-> Either Text ByteStringJ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text ByteString
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue

instance PersistFieldSql ByteStringJ where
  sqlType :: Proxy ByteStringJ -> SqlType
sqlType Proxy ByteStringJ
p = Proxy ByteString -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType ((ByteStringJ -> ByteString)
-> Proxy ByteStringJ -> Proxy ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteStringJ -> ByteString
unB Proxy ByteStringJ
p)

instance A.FromJSON ByteStringJ where
  parseJSON :: Value -> Parser ByteStringJ
parseJSON (A.String Text
t) =
    (String -> Parser ByteStringJ)
-> (ByteString -> Parser ByteStringJ)
-> Either String ByteString
-> Parser ByteStringJ
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Parser ByteStringJ -> String -> Parser ByteStringJ
forall a b. a -> b -> a
const Parser ByteStringJ
forall (m :: * -> *) a. MonadPlus m => m a
mzero) (ByteStringJ -> Parser ByteStringJ
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteStringJ -> Parser ByteStringJ)
-> (ByteString -> ByteStringJ) -> ByteString -> Parser ByteStringJ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteStringJ
B) (Either String ByteString -> Parser ByteStringJ)
-> Either String ByteString -> Parser ByteStringJ
forall a b. (a -> b) -> a -> b
$
    ByteString -> Either String ByteString
B64URL.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$
    Text -> ByteString
TE.encodeUtf8 Text
t
  parseJSON Value
_ = Parser ByteStringJ
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance A.ToJSON ByteStringJ where
  toJSON :: ByteStringJ -> Value
toJSON = Text -> Value
A.String (Text -> Value) -> (ByteStringJ -> Text) -> ByteStringJ -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ByteStringJ -> ByteString) -> ByteStringJ -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64URL.encode (ByteString -> ByteString)
-> (ByteStringJ -> ByteString) -> ByteStringJ -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringJ -> ByteString
unB


----------------------------------------------------------------------


-- $orphanSessionMap
--
-- @
-- instance 'PersistField'    'SessionMap'
-- instance 'PersistFieldSql' 'SessionMap'
-- instance 'S.Serialize'       'SessionMap'
-- instance 'A.FromJSON'        'SessionMap'
-- instance 'A.ToJSON'          'SessionMap'
-- @

-- 'PersistField' for 'SessionMap' serializes using @cereal@ on
-- the database.  We tried to use @aeson@ but @cereal@ is twice
-- faster and uses half the memory for this use case.
--
-- The JSON instance translates to objects using base64url for
-- the values of 'ByteString' (cf. 'ByteStringJ').
instance PersistField SessionMap where
  toPersistValue :: SessionMap -> PersistValue
toPersistValue   = ByteString -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (ByteString -> PersistValue)
-> (SessionMap -> ByteString) -> SessionMap -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> ByteString
forall a. Serialize a => a -> ByteString
S.encode
  fromPersistValue :: PersistValue -> Either Text SessionMap
fromPersistValue = PersistValue -> Either Text ByteString
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (PersistValue -> Either Text ByteString)
-> (ByteString -> Either Text SessionMap)
-> PersistValue
-> Either Text SessionMap
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ((String -> Either Text SessionMap)
-> (SessionMap -> Either Text SessionMap)
-> Either String SessionMap
-> Either Text SessionMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text SessionMap
forall a b. a -> Either a b
Left (Text -> Either Text SessionMap)
-> (String -> Text) -> String -> Either Text SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) SessionMap -> Either Text SessionMap
forall a b. b -> Either a b
Right (Either String SessionMap -> Either Text SessionMap)
-> (ByteString -> Either String SessionMap)
-> ByteString
-> Either Text SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String SessionMap
forall a. Serialize a => ByteString -> Either String a
S.decode)

instance PersistFieldSql SessionMap where
  sqlType :: Proxy SessionMap -> SqlType
sqlType Proxy SessionMap
_ = SqlType
SqlBlob

instance S.Serialize SessionMap where
  put :: Putter SessionMap
put = Putter [(ByteString, ByteString)]
forall t. Serialize t => Putter t
S.put Putter [(ByteString, ByteString)]
-> (SessionMap -> [(ByteString, ByteString)]) -> Putter SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, ByteString) -> (ByteString, ByteString))
-> [(Text, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString)
-> (Text, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Text -> ByteString
TE.encodeUtf8) ([(Text, ByteString)] -> [(ByteString, ByteString)])
-> (SessionMap -> [(Text, ByteString)])
-> SessionMap
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text ByteString -> [(Text, ByteString)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text ByteString -> [(Text, ByteString)])
-> (SessionMap -> HashMap Text ByteString)
-> SessionMap
-> [(Text, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text ByteString
unSessionMap
  get :: Get SessionMap
get = HashMap Text ByteString -> SessionMap
SessionMap (HashMap Text ByteString -> SessionMap)
-> ([(ByteString, ByteString)] -> HashMap Text ByteString)
-> [(ByteString, ByteString)]
-> SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, ByteString)] -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, ByteString)] -> HashMap Text ByteString)
-> ([(ByteString, ByteString)] -> [(Text, ByteString)])
-> [(ByteString, ByteString)]
-> HashMap Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> (Text, ByteString))
-> [(ByteString, ByteString)] -> [(Text, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> Text)
-> (ByteString, ByteString) -> (Text, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> Text
TE.decodeUtf8) ([(ByteString, ByteString)] -> SessionMap)
-> Get [(ByteString, ByteString)] -> Get SessionMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Get [(ByteString, ByteString)]
forall t. Serialize t => Get t
S.get

instance A.FromJSON SessionMap where
  parseJSON :: Value -> Parser SessionMap
parseJSON = (HashMap Text ByteStringJ -> SessionMap)
-> Parser (HashMap Text ByteStringJ) -> Parser SessionMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HashMap Text ByteStringJ -> SessionMap
fixup (Parser (HashMap Text ByteStringJ) -> Parser SessionMap)
-> (Value -> Parser (HashMap Text ByteStringJ))
-> Value
-> Parser SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (HashMap Text ByteStringJ)
forall a. FromJSON a => Value -> Parser a
A.parseJSON
    where
      fixup :: HM.HashMap Text ByteStringJ -> SessionMap
      fixup :: HashMap Text ByteStringJ -> SessionMap
fixup = HashMap Text ByteString -> SessionMap
SessionMap (HashMap Text ByteString -> SessionMap)
-> (HashMap Text ByteStringJ -> HashMap Text ByteString)
-> HashMap Text ByteStringJ
-> SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteStringJ -> ByteString)
-> HashMap Text ByteStringJ -> HashMap Text ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteStringJ -> ByteString
unB

instance A.ToJSON SessionMap where
  toJSON :: SessionMap -> Value
toJSON = HashMap Text ByteStringJ -> Value
forall a. ToJSON a => a -> Value
A.toJSON (HashMap Text ByteStringJ -> Value)
-> (SessionMap -> HashMap Text ByteStringJ) -> SessionMap -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text ByteStringJ
mangle
    where
      mangle :: SessionMap -> HM.HashMap Text ByteStringJ
      mangle :: SessionMap -> HashMap Text ByteStringJ
mangle = (ByteString -> ByteStringJ)
-> HashMap Text ByteString -> HashMap Text ByteStringJ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteStringJ
B (HashMap Text ByteString -> HashMap Text ByteStringJ)
-> (SessionMap -> HashMap Text ByteString)
-> SessionMap
-> HashMap Text ByteStringJ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text ByteString
unSessionMap