{-# LANGUAGE UndecidableInstances #-}

module Mensam.Server.Server.Handler.RequestHash where

import Mensam.Server.Application.LoggerCustom.Class

import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Control
import Control.Monad.Trans.Control.Identity
import Control.Monad.Trans.Reader
import Data.Foldable
import Data.Hashable qualified
import Data.Kind
import Network.Wai
import Servant
import Servant.Server.Internal.Delayed

type Hash :: Type
newtype Hash = MkHash {Hash -> Word
getHash :: Word}

instance Show Hash where
  show :: Hash -> String
show Hash
hash = String
paddingString String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hashString
   where
    hashString :: String
hashString = Word -> String
forall a. Show a => a -> String
show (Word -> String) -> Word -> String
forall a b. (a -> b) -> a -> b
$ Hash -> Word
getHash Hash
hash
    paddingString :: String
paddingString = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
paddingLength Char
'0'
    paddingLength :: Int
paddingLength = Int
maxHashLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hashString
     where
      maxHashLength :: Int
maxHashLength = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show (Word -> String) -> Word -> String
forall a b. (a -> b) -> a -> b
$ Hash -> Word
getHash (Hash -> Word) -> Hash -> Word
forall a b. (a -> b) -> a -> b
$ Word -> Hash
MkHash Word
forall a. Bounded a => a
maxBound

requestHash :: Request -> Hash
requestHash :: Request -> Hash
requestHash = Word -> Hash
MkHash (Word -> Hash) -> (Request -> Word) -> Request -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Request -> Int) -> Request -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Hashable a => a -> Int
Data.Hashable.hash (String -> Int) -> (Request -> String) -> Request -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> String
forall a. Show a => a -> String
show

type RequestHashT :: (Type -> Type) -> Type -> Type
newtype RequestHashT m a = RequestHashT {forall (m :: * -> *) a. RequestHashT m a -> ReaderT Hash m a
unRequestHashT :: ReaderT Hash m a}
  deriving newtype (Functor (RequestHashT m)
Functor (RequestHashT m) =>
(forall a. a -> RequestHashT m a)
-> (forall a b.
    RequestHashT m (a -> b) -> RequestHashT m a -> RequestHashT m b)
-> (forall a b c.
    (a -> b -> c)
    -> RequestHashT m a -> RequestHashT m b -> RequestHashT m c)
-> (forall a b.
    RequestHashT m a -> RequestHashT m b -> RequestHashT m b)
-> (forall a b.
    RequestHashT m a -> RequestHashT m b -> RequestHashT m a)
-> Applicative (RequestHashT m)
forall a. a -> RequestHashT m a
forall a b.
RequestHashT m a -> RequestHashT m b -> RequestHashT m a
forall a b.
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
forall a b.
RequestHashT m (a -> b) -> RequestHashT m a -> RequestHashT m b
forall a b c.
(a -> b -> c)
-> RequestHashT m a -> RequestHashT m b -> RequestHashT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (RequestHashT m)
forall (m :: * -> *) a. Applicative m => a -> RequestHashT m a
forall (m :: * -> *) a b.
Applicative m =>
RequestHashT m a -> RequestHashT m b -> RequestHashT m a
forall (m :: * -> *) a b.
Applicative m =>
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
forall (m :: * -> *) a b.
Applicative m =>
RequestHashT m (a -> b) -> RequestHashT m a -> RequestHashT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> RequestHashT m a -> RequestHashT m b -> RequestHashT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> RequestHashT m a
pure :: forall a. a -> RequestHashT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
RequestHashT m (a -> b) -> RequestHashT m a -> RequestHashT m b
<*> :: forall a b.
RequestHashT m (a -> b) -> RequestHashT m a -> RequestHashT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> RequestHashT m a -> RequestHashT m b -> RequestHashT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> RequestHashT m a -> RequestHashT m b -> RequestHashT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
*> :: forall a b.
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
RequestHashT m a -> RequestHashT m b -> RequestHashT m a
<* :: forall a b.
RequestHashT m a -> RequestHashT m b -> RequestHashT m a
Applicative, (forall a b. (a -> b) -> RequestHashT m a -> RequestHashT m b)
-> (forall a b. a -> RequestHashT m b -> RequestHashT m a)
-> Functor (RequestHashT m)
forall a b. a -> RequestHashT m b -> RequestHashT m a
forall a b. (a -> b) -> RequestHashT m a -> RequestHashT m b
forall (m :: * -> *) a b.
Functor m =>
a -> RequestHashT m b -> RequestHashT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RequestHashT m a -> RequestHashT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RequestHashT m a -> RequestHashT m b
fmap :: forall a b. (a -> b) -> RequestHashT m a -> RequestHashT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RequestHashT m b -> RequestHashT m a
<$ :: forall a b. a -> RequestHashT m b -> RequestHashT m a
Functor, Applicative (RequestHashT m)
Applicative (RequestHashT m) =>
(forall a b.
 RequestHashT m a -> (a -> RequestHashT m b) -> RequestHashT m b)
-> (forall a b.
    RequestHashT m a -> RequestHashT m b -> RequestHashT m b)
-> (forall a. a -> RequestHashT m a)
-> Monad (RequestHashT m)
forall a. a -> RequestHashT m a
forall a b.
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
forall a b.
RequestHashT m a -> (a -> RequestHashT m b) -> RequestHashT m b
forall (m :: * -> *). Monad m => Applicative (RequestHashT m)
forall (m :: * -> *) a. Monad m => a -> RequestHashT m a
forall (m :: * -> *) a b.
Monad m =>
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
forall (m :: * -> *) a b.
Monad m =>
RequestHashT m a -> (a -> RequestHashT m b) -> RequestHashT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RequestHashT m a -> (a -> RequestHashT m b) -> RequestHashT m b
>>= :: forall a b.
RequestHashT m a -> (a -> RequestHashT m b) -> RequestHashT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
>> :: forall a b.
RequestHashT m a -> RequestHashT m b -> RequestHashT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> RequestHashT m a
return :: forall a. a -> RequestHashT m a
Monad)
  deriving newtype ((forall (m :: * -> *). Monad m => Monad (RequestHashT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> RequestHashT m a)
-> MonadTrans RequestHashT
forall (m :: * -> *). Monad m => Monad (RequestHashT m)
forall (m :: * -> *) a. Monad m => m a -> RequestHashT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> RequestHashT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> RequestHashT m a
MonadTrans, MonadTrans RequestHashT
MonadTrans RequestHashT =>
(forall (m :: * -> *) a.
 Monad m =>
 (Run RequestHashT -> m a) -> RequestHashT m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT RequestHashT a) -> RequestHashT m a)
-> MonadTransControl RequestHashT
forall (m :: * -> *) a.
Monad m =>
m (StT RequestHashT a) -> RequestHashT m a
forall (m :: * -> *) a.
Monad m =>
(Run RequestHashT -> m a) -> RequestHashT m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run RequestHashT -> m a) -> RequestHashT m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run RequestHashT -> m a) -> RequestHashT m a
$crestoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT RequestHashT a) -> RequestHashT m a
restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT RequestHashT a) -> RequestHashT m a
MonadTransControl, MonadTransControl RequestHashT
MonadTransControl RequestHashT =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. RequestHashT m x -> m x) -> m a) -> RequestHashT m a)
-> MonadTransControlIdentity RequestHashT
forall (m :: * -> *) a.
Monad m =>
((forall x. RequestHashT m x -> m x) -> m a) -> RequestHashT m a
forall (t :: (* -> *) -> * -> *).
MonadTransControl t =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. t m x -> m x) -> m a) -> t m a)
-> MonadTransControlIdentity t
$cliftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. RequestHashT m x -> m x) -> m a) -> RequestHashT m a
liftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. RequestHashT m x -> m x) -> m a) -> RequestHashT m a
MonadTransControlIdentity)

instance MonadLoggerCustom m => MonadLogger (RequestHashT m) where
  monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> RequestHashT m ()
monadLoggerLog Loc
loc LogSource
logSource LogLevel
logLevel msg
logStr = do
    LogStr
reqHash <- String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> (Hash -> String) -> Hash -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> String
forall a. Show a => a -> String
show (Hash -> LogStr) -> RequestHashT m Hash -> RequestHashT m LogStr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Hash m Hash -> RequestHashT m Hash
forall (m :: * -> *) a. ReaderT Hash m a -> RequestHashT m a
RequestHashT ReaderT Hash m Hash
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Bool
logColorCapability <- m Bool -> RequestHashT m Bool
forall (m :: * -> *) a. Monad m => m a -> RequestHashT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
forall (m :: * -> *). MonadLoggerCustom m => m Bool
colorfulLogCapability
    m () -> RequestHashT m ()
forall (m :: * -> *) a. Monad m => m a -> RequestHashT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RequestHashT m ())
-> (LogStr -> m ()) -> LogStr -> RequestHashT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> LogSource -> LogLevel -> LogStr -> m ()
forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> m ()
monadLoggerLog Loc
loc LogSource
logSource LogLevel
logLevel (LogStr -> m ()) -> (LogStr -> LogStr) -> LogStr -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (LogStr -> RequestHashT m ()) -> LogStr -> RequestHashT m ()
forall a b. (a -> b) -> a -> b
$
      Bool -> LogStrWithFontEffects -> LogStr
renderLogStrWithFontEffectsUnsafe Bool
logColorCapability (LogStrWithFontEffects -> LogStr)
-> LogStrWithFontEffects -> LogStr
forall a b. (a -> b) -> a -> b
$
        [LogStrWithFontEffects] -> LogStrWithFontEffects
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
          [ FontEffects -> LogStr -> LogStrWithFontEffects
withFontEffects ([Int] -> FontEffects
MkFontEffects [Int
2, Int
33]) (LogStr -> LogStrWithFontEffects)
-> LogStr -> LogStrWithFontEffects
forall a b. (a -> b) -> a -> b
$ LogStr
"#[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
reqHash LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"]"
          , LogStrWithFontEffects
" "
          , LogStr -> LogStrWithFontEffects
withoutFontEffects (LogStr -> LogStrWithFontEffects)
-> LogStr -> LogStrWithFontEffects
forall a b. (a -> b) -> a -> b
$ msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
logStr
          ]

deriving via
  RequestHashT ((t2 :: (Type -> Type) -> Type -> Type) m)
  instance
    MonadLoggerCustom (t2 m) => MonadLogger (ComposeT RequestHashT t2 m)

runRequestHashT :: Hash -> RequestHashT m a -> m a
runRequestHashT :: forall (m :: * -> *) a. Hash -> RequestHashT m a -> m a
runRequestHashT Hash
reqHash = (ReaderT Hash m a -> Hash -> m a)
-> Hash -> ReaderT Hash m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Hash m a -> Hash -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Hash
reqHash (ReaderT Hash m a -> m a)
-> (RequestHashT m a -> ReaderT Hash m a)
-> RequestHashT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestHashT m a -> ReaderT Hash m a
forall (m :: * -> *) a. RequestHashT m a -> ReaderT Hash m a
unRequestHashT

type RequestHash :: Type
data RequestHash

instance HasServer api context => HasServer (RequestHash :> api) context where
  type ServerT (RequestHash :> api) m = Hash -> ServerT api m
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (RequestHash :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (RequestHash :> api) m
-> ServerT (RequestHash :> api) n
hoistServerWithContext Proxy (RequestHash :> api)
Proxy Proxy context
pc forall x. m x -> n x
nt ServerT (RequestHash :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Hash -> ServerT api m) -> Hash -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (RequestHash :> api) m
Hash -> ServerT api m
s
  route :: forall env.
Proxy (RequestHash :> api)
-> Context context
-> Delayed env (Server (RequestHash :> api))
-> Router env
route Proxy (RequestHash :> api)
Proxy Context context
context Delayed env (Server (RequestHash :> api))
subserver = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$ Delayed env (Hash -> Server api)
-> (Request -> Hash) -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed env (Server (RequestHash :> api))
Delayed env (Hash -> Server api)
subserver Request -> Hash
requestHash