{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
module Yam.Prelude(
randomString
, showText
, throwS
, randomCode
, whenException
, LogFunc
, Default(..)
, Text
, pack
, HasCallStack
, MonadError(..)
, MonadUnliftIO(..)
, SomeException(..)
, fromException
, bracket
, throw
, try
, catch
, when
, lift
, (<>)
, LogLevel(..)
, logInfo
, logError
, logWarn
, logDebug
, Loc(..)
, MonadIO(..)
, HasContextEntry(..)
, TryContextEntry(..)
, fromMaybe
, (&)
, decodeUtf8
, encodeUtf8
, fromJust
, Version
, Middleware
, RunSalak(..)
, liftSalak
, liftX
) where
import Control.Exception hiding (Handler)
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Data.Aeson
import qualified Data.Binary as B
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16.Lazy as B16
import qualified Data.ByteString.Lazy as L
import Data.Default
import Data.Function
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Vector as V
import Data.Version
import Data.Word
import GHC.Stack
import Network.Wai
import Salak
import Servant
import Servant.Server.Internal.ServerError
import System.IO.Unsafe (unsafePerformIO)
import System.Random.MWC
newtype RunSalak a = RunSalak { unSalak :: LoggingT (RunSalakT IO) a } deriving (Functor, Applicative, Monad)
instance HasSourcePack RunSalak where
askSourcePack = liftSalak askSourcePack
logSP = liftSalak . logSP
readLogs = liftSalak readLogs
instance MonadIO RunSalak where
liftIO = RunSalak . liftIO
instance MonadLogger RunSalak where
monadLoggerLog a b c d = RunSalak (monadLoggerLog a b c d)
instance MonadLoggerIO RunSalak where
askLoggerIO = RunSalak askLoggerIO
instance MonadUnliftIO RunSalak where
askUnliftIO = RunSalak $ do
f <- lift askUnliftIO
lf <- askLoggerIO
return $ UnliftIO $ \ma -> unliftIO f (runLoggingT (unSalak ma) lf)
liftSalak :: RunSalakT IO a -> RunSalak a
liftSalak = RunSalak . lift
liftX :: LoggingT IO a -> RunSalak a
liftX f = do
lf <- askLoggerIO
liftIO $ runLoggingT f lf
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
{-# NOINLINE randomGen #-}
randomGen :: GenIO
randomGen = unsafePerformIO createSystemRandom
randomString :: IO ByteString
randomString = L.toStrict . B16.encode . B.encode <$> (uniform randomGen :: IO Word64)
{-# INLINE showText #-}
showText :: Show a => a -> Text
showText = pack . show
data WebErrResult = WebErrResult
{ message :: Text
}
instance ToJSON WebErrResult where
toJSON WebErrResult{..} = object [ "message" .= message ]
throwS
:: (HasCallStack, MonadIO m, MonadLogger m)
=> ServerError
-> Text
-> m a
throwS e msg = do
logErrorCS ?callStack msg
liftIO $ throw e { errBody = encode $ WebErrResult msg}
whenException :: SomeException -> Response
whenException e = responseServerError $ fromMaybe err400 { errBody = encode $ WebErrResult $ showText e} (fromException e :: Maybe ServerError)
randomCode :: V.Vector Char -> Int -> IO String
randomCode seed v = do
let l = V.length seed
vs <- replicateM v (uniformR (0, l - 1) randomGen)
return $ (seed V.!) <$> vs
class TryContextEntry (cxt :: [*]) (entry :: *) where
tryContextEntry :: Context cxt -> Maybe entry
instance {-# OVERLAPPABLE #-} TryContextEntry as entry => TryContextEntry (a ': as) entry where
tryContextEntry (_ :. as) = tryContextEntry as
instance {-# OVERLAPPABLE #-} TryContextEntry a entry where
tryContextEntry _ = Nothing
instance TryContextEntry (entry ': as) entry where
tryContextEntry (a :. _) = Just a