{-# LANGUAGE ImplicitParams #-}
module Yam.Types(
AppConfig(..)
, Env(..)
, getAttr
, setAttr
, reqAttr
, AppM
, runAppM
, withAppM
, askApp
, askAttr
, withAttr
, requireAttr
, AppMiddleware(..)
, simpleAppMiddleware
, simpleWebMiddleware
, LogFunc
, randomString
, showText
, defJson
, Key
, newKey
, Middleware
, Request(..)
, lift
, when
, Default(..)
, Text
, pack
, encodeUtf8
, decodeUtf8
, MonadIO
, liftIO
, withReaderT
, module Control.Monad.Logger.CallStack
, module Data.Maybe
, module Servant
, module Data.Aeson
, module Data.Word
, module Data.Function
, module Data.Version
) where
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.Reader
import Data.Aeson
import Data.Default
import Data.Function
import Data.Maybe
import Data.Text (Text, justifyRight, pack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Vault.Lazy (Key, newKey)
import qualified Data.Vault.Lazy as L
import Data.Version
import Data.Word
import GHC.Stack
import Network.Wai
import Numeric
import Servant
import System.Random
data AppConfig = AppConfig
{ name :: Text
, port :: Int
} deriving (Eq, Show)
instance FromJSON AppConfig where
parseJSON = withObject "AppConfig" $ \v -> AppConfig
<$> v .:? "name" .!= "application"
<*> v .:? "port" .!= 8888
defJson :: FromJSON a => a
defJson = fromJust $ decode "{}"
instance Default AppConfig where
def = defJson
data Env = Env
{ attributes :: Vault
, reqAttributes :: Maybe Vault
, application :: AppConfig
}
instance Default Env where
def = Env L.empty Nothing def
getAttr :: Key a -> Env -> Maybe a
getAttr k Env{..} = listToMaybe $ catMaybes $ L.lookup k <$> catMaybes [reqAttributes, Just attributes]
reqAttr :: Default a => Key a -> Env -> a
reqAttr k = fromMaybe def . getAttr k
setAttr :: Key a -> a -> Env -> Env
setAttr k v Env{..} = case reqAttributes of
Just av -> Env attributes (Just $ L.insert k v av) application
_ -> Env (L.insert k v attributes) reqAttributes application
newtype AppM m a = AppM { runAppM' :: ReaderT Env m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
runAppM :: Env -> AppM m a -> m a
runAppM e a = runReaderT (runAppM' a) e
instance Monad m => MonadReader Env (AppM m) where
ask = AppM ask
local f (AppM a) = AppM $ local f a
instance MonadUnliftIO m => MonadUnliftIO (AppM m) where
withRunInIO f = do
env <- ask
lift $ withRunInIO (\g -> f $ g . runAppM env)
withAppM :: MonadIO m => (Env -> Env) -> AppM m a -> AppM m a
withAppM f a = do
env <- ask
lift $ runAppM (f env) a
askApp :: Monad m => AppM m AppConfig
askApp = asks application
requireAttr :: MonadIO m => Key a -> AppM m a
requireAttr k = fromJust <$> askAttr k
askAttr :: MonadIO m => Key a -> AppM m (Maybe a)
askAttr = asks . getAttr
withAttr :: MonadIO m => Key a -> a -> AppM m b -> AppM m b
withAttr k v = withAppM (setAttr k v)
newtype AppMiddleware = AppMiddleware {runAM :: Env -> ((Env, Middleware)-> LoggingT IO ()) -> LoggingT IO ()}
instance Semigroup AppMiddleware where
(AppMiddleware am) <> (AppMiddleware bm) = AppMiddleware $ \e f -> am e $ \(e', mw) -> bm e' $ \(e'',mw') -> f (e'', mw . mw')
instance Monoid AppMiddleware where
mempty = AppMiddleware $ \a f -> f (a,id)
simpleAppMiddleware :: HasCallStack => (Bool, Text) -> Key a -> a -> AppMiddleware
simpleAppMiddleware (enabled,amname) k v =
if enabled
then AppMiddleware $ \e f -> do
logInfoCS ?callStack $ amname <> " enabled"
f (setAttr k v e, id)
else mempty
simpleWebMiddleware :: HasCallStack => (Bool, Text) -> Middleware -> AppMiddleware
simpleWebMiddleware (enabled,amname) m =
if enabled
then AppMiddleware $ \e f -> do
logInfoCS ?callStack $ amname <> " enabled"
f (e,m)
else mempty
{-# INLINE randomString #-}
randomString :: Int -> IO Text
randomString n = do
c <- randomIO :: IO Word64
return $ justifyRight n '0' $ pack $ take n $ showHex c ""
{-# INLINE showText #-}
showText :: Show a => a -> Text
showText = pack . show