diff --git a/src/Yam/App.hs b/src/Yam/App.hs --- a/src/Yam/App.hs +++ b/src/Yam/App.hs @@ -91,8 +91,8 @@ Nothing -> return context { defLogger = config {rank = logRank} } enable :: FromJSON a => Text -> Bool -> Text -> (Maybe a -> AppM IO ()) -> AppM IO () -enable keyEnable def key action = do - enables <- getPropOrDefault def keyEnable +enable keyEnable d key action = do + enables <- getPropOrDefault d keyEnable when enables $ getProp key >>= action keyLogger :: Text @@ -122,11 +122,10 @@ keySecondaryTransaction = "Extension.Transaction.Secondary" instance (MonadIO m, MonadBaseControl IO m, MonadMask m) => MonadTransaction (AppM m) where - connectionPool = requireExtension keyTransaction - secondaryPool = getExtension keySecondaryTransaction - setConnectionPool p s = do - setExtension keyTransaction p - forM_ s (setExtension keySecondaryTransaction) + connectionPool = requireExtension keyTransaction + secondaryPool = getExtension keySecondaryTransaction + withConnectionPool p s = withExtension keyTransaction p + . maybe id (withExtension keySecondaryTransaction) s keyEvent :: Text keyEvent = "Extension.Event." @@ -141,8 +140,8 @@ registerEventHandler' p hname h = do hs <- eventHandler p context <- ask - let key = keyEvent <> cs (eventKey p) - h' = runAppM context . h - name = fromMaybe (key <> "." <> showText (length hs + 1)) hname - infoLn $ "Register eventHandler " <> name <> " for " <> key + let key = keyEvent <> cs (eventKey p) + h' = runAppM context . h + nm = fromMaybe (key <> "." <> showText (length hs + 1)) hname + infoLn $ "Register eventHandler " <> nm <> " for " <> key setExtension key (h':hs) diff --git a/src/Yam/App/Context.hs b/src/Yam/App/Context.hs --- a/src/Yam/App/Context.hs +++ b/src/Yam/App/Context.hs @@ -7,7 +7,8 @@ , getExtensionOrDefault , getExtension , setExtension - , lockExtenstion + , withExtension + , lockExtension , emptyContext , cleanContext , YamContextException @@ -67,13 +68,18 @@ where go True = throwM ExtensionHasFreezed go _ = return () -lockExtenstion :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () -lockExtenstion = setExtension extensionLockKey True +lockExtension :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () +lockExtension = setExtension extensionLockKey True -unlockExtenstion :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () -unlockExtenstion = setExtension extensionLockKey False +unlockExtension :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () +unlockExtension = setExtension extensionLockKey False +withExtension :: (MonadYamLogger m, HasYamContext m, MonadMask m, Typeable a) => Text -> a -> m b -> m b +withExtension k a action = do + setExtension k a + action `finally` go k + where go key = do extension >>= void . liftIO . M.delete key + traceLn $ "Unregister extension <<" <> key <> ">>" + cleanContext :: (MonadYamLogger m, HasYamContext m, MonadMask m) => m () -> m () -cleanContext action = do - debugLn $ "Clean up context" - unlockExtenstion `finally` action +cleanContext action = unlockExtension `finally` action diff --git a/src/Yam/Event.hs b/src/Yam/Event.hs --- a/src/Yam/Event.hs +++ b/src/Yam/Event.hs @@ -23,8 +23,8 @@ thenNotify ma e = do a <- ma let printStack :: (Event e, MonadYamLogger m) => e -> SomeException -> m () - printStack e x = do - errorLn $ "Event " <> encodeToText e <> " Failed!" + printStack event x = do + errorLn $ "Event " <> encodeToText event <> " Failed!" errorLn $ "Exception: " <> showText x withLoggerName "Event" $ do infoLn $ "Event " <> encodeToText e <> " Received!" diff --git a/src/Yam/Import.hs b/src/Yam/Import.hs --- a/src/Yam/Import.hs +++ b/src/Yam/Import.hs @@ -27,6 +27,7 @@ , isNothing , isJust , finally + , bracket_ , MonadMask , MonadThrow , MonadCatch @@ -106,6 +107,7 @@ showText :: Show a => a -> Text showText = cs . show +_hex :: [Char] _hex = ['0'..'9'] <> ['a'..'f'] randomHex :: Int -> IO Text diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs --- a/src/Yam/Logger.hs +++ b/src/Yam/Logger.hs @@ -70,12 +70,12 @@ logL = logL' callStack logL' :: MonadYamLogger m => forall msg . (ToLogStr msg) => CallStack -> LogRank -> msg -> m () -logL' callStack r msg = do +logL' stack r msg = do conf <- loggerConfig mayName <- fetchName liftIO $ when (r >= rank conf) $ do now <- clock conf - logger conf (cs now) (getName (getCallStack callStack) `mergeMaybe` (cs <$> mayName)) r (toLogStr msg) + logger conf (cs now) (getName (getCallStack stack) `mergeMaybe` (cs <$> mayName)) r (toLogStr msg) where getName [] = Nothing getName ((_,loc):_) = Just $ (<>" ") $ cs $ srcLocModule loc @@ -90,8 +90,8 @@ setName m = do conf <- loggerConfig liftIO $ myThreadId >>= void . go m (name conf) - where go (Just m) cache tid = M.insert tid m cache - go _ cache tid = M.delete tid cache + where go (Just nm) cache tid = M.insert tid nm cache + go _ cache tid = M.delete tid cache logLn :: (MonadYamLogger m, HasCallStack) => LogRank -> Text -> m () logLn = logLn' callStack @@ -130,17 +130,17 @@ newLog :: LoggerSet -> IO LoggerConfig newLog = defaultLoggerConfig . mkLogger . pushLogStr where mkLogger :: FastLogger -> LoggerFunc - mkLogger logger time mayName rank msg = do + mkLogger fl time mayName rk msg = do thread <- myThreadId - let name = time + let pre = time <> " [" <> showText thread <> "] " - <> showText rank + <> showText rk <> " " <> fromMaybe "" mayName <> " - " - logger $ toLogStr name <> msg + fl $ toLogStr pre <> msg withLoggerName :: (MonadYamLogger m, MonadMask m) => Text -> m a -> m a withLoggerName nm action = do @@ -150,12 +150,6 @@ where merge n (Just v) = v <> "." <> n merge n _ = n -withLogger :: (MonadYamLogger m) => (LoggerConfig -> LoggerConfig) -> m a -> m a -withLogger modify action = do - conf <- loggerConfig - withLoggerConfig (modify conf) action - - type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () toMonadLogger :: (MonadYamLogger m) => m LogFunc @@ -167,7 +161,7 @@ toRank _ = INFO mkLogger :: LoggerConfig -> LogFunc mkLogger context = let go :: HasCallStack => LogFunc - go _ name level msg = runReaderT (withLoggerName name $ logL' callStack (toRank level) (msg <> "\n")) context + go _ pre level msg = runReaderT (withLoggerName pre $ logL' callStack (toRank level) (msg <> "\n")) context in go toWaiLogger :: (MonadYamLogger m) => m ApacheLogger diff --git a/src/Yam/Prop.hs b/src/Yam/Prop.hs --- a/src/Yam/Prop.hs +++ b/src/Yam/Prop.hs @@ -54,7 +54,7 @@ runProp v ma = runReaderT ma ("NO_NAME", v) getPropOrDefault :: (FromJSON a, MonadThrow m, MonadProp m) => a -> Text -> m a -getPropOrDefault def key = fromMaybe def <$> getProp key +getPropOrDefault d key = fromMaybe d <$> getProp key requiredProp :: (FromJSON a, MonadThrow m, MonadProp m) => Text -> m a requiredProp key = getProp key >>= maybe (throwM $ KeyNotFound key) return @@ -62,19 +62,19 @@ getProp :: (FromJSON a, MonadThrow m, MonadProp m) => Text -> m (Maybe a) getProp key = propertySource >>= go key (splitKey key) where go :: (FromJSON a, Monad m, MonadThrow m) => Text -> [Text] -> PropertySource -> m (Maybe a) - go key hs (s,v) = to key s $ foldl' fetch (Just v) hs + go k hs (s,v) = to k s $ foldl' fetch (Just v) hs fetch :: Maybe Value -> Text -> Maybe Value fetch Nothing _ = Nothing fetch (Just v) h = fetch' v h fetch' Null _ = Just Null - fetch' (Object map) h = case M.lookup h map of + fetch' (Object m) h = case M.lookup h m of Just v -> Just v Nothing -> Just Null - fetch' v h = Nothing + fetch' _ _ = Nothing to :: (FromJSON a, Monad m, MonadThrow m) => Text -> Text -> Maybe Value -> m (Maybe a) - to k s Nothing = throwM $ TypeMismatch k + to k _ Nothing = throwM $ TypeMismatch k to _ _ (Just Null) = return Nothing - to k s (Just v) = case fromJSON v of + to k _ (Just v) = case fromJSON v of Error e -> throwM $ ParseFailed k $ cs e Success a -> return (Just a) splitKey :: Text -> [Text] @@ -125,7 +125,7 @@ mergePropertySource :: [PropertySource] -> PropertySource mergePropertySource = foldl' merge emptyPropertySource where merge :: (Text, Value) -> (Text, Value) -> (Text, Value) - merge (n1,v1) (n2,v2) = (n1, merge' v1 v2) + merge (n1,v1) (_,v2) = (n1, merge' v1 v2) merge' Null a = a merge' (Object a) (Object b) = Object (M.unionWith merge' a b) merge' a _ = a diff --git a/src/Yam/Transaction.hs b/src/Yam/Transaction.hs --- a/src/Yam/Transaction.hs +++ b/src/Yam/Transaction.hs @@ -8,7 +8,7 @@ module Yam.Transaction( Transaction - , TransactionPool(..) + , TransactionPool , DataSource(..) , MonadTransaction(..) , DataSourceConnector @@ -66,7 +66,7 @@ class (MonadIO m, MonadBaseControl IO m, MonadYamLogger m) => MonadTransaction m where connectionPool :: m TransactionPool - setConnectionPool :: TransactionPool -> Maybe TransactionPool -> m () + withConnectionPool :: TransactionPool -> Maybe TransactionPool -> m a -> m a secondaryPool :: m (Maybe TransactionPool) secondaryPool = return Nothing @@ -84,28 +84,26 @@ instance Exception DataSourceException initDataSource :: (MonadTransaction m, MonadMask m) => [DataSourceProvider m a] -> DataSource -> Maybe DataSource -> m a -> m a -initDataSource maps ds ds2nd action = let map = M.fromList maps in go map ds ds2nd action - where go map ds ds2 action = do - logger <- toMonadLogger - getConnector map logger ds $ \p -> +initDataSource maps ds1 ds2nd action = let m = M.fromList maps in go m ds1 ds2nd action + where go m' ds ds2 action' = do + lg <- toMonadLogger + getConnector m' lg ds $ \p -> case ds2 of - Nothing -> setConnectionPool p Nothing >> action - Just s2 -> getConnector map logger s2 $ \v -> setConnectionPool p (Just v) >> action - getConnector map logger ds = case M.lookup (dbtype ds) map of + Nothing -> withConnectionPool p Nothing action' + Just s2 -> getConnector m' lg s2 $ \v -> withConnectionPool p (Just v) action' + getConnector m2 l ds = case M.lookup (dbtype ds) m2 of Nothing -> \_ -> throwM $ DataSourceNotSupported $ cs $ dbtype ds - Just db -> db logger ds + Just db -> db l ds runTrans :: MonadTransaction m => Transaction a -> m a -runTrans trans = connectionPool >>= executePool trans - -executePool trans p = liftIO (runSqlPool trans p) +runTrans trans = connectionPool >>= liftIO . runSqlPool trans runSecondaryTrans :: (MonadTransaction m, MonadMask m) => Transaction a -> m a runSecondaryTrans trans = do pool <- secondaryPool case pool of Nothing -> throwM $ DataSourcePoolNotFound "Secondary Pool" - Just p -> withLoggerName "Backup" $ executePool trans p + Just p -> withLoggerName "Backup" $ liftIO $ runSqlPool trans p class FromPersistValue a where parsePersistValue :: [PersistValue] -> a diff --git a/src/Yam/Transaction/Sqlite.hs b/src/Yam/Transaction/Sqlite.hs --- a/src/Yam/Transaction/Sqlite.hs +++ b/src/Yam/Transaction/Sqlite.hs @@ -14,8 +14,8 @@ instance HasDataSource SQLite where connector _ logger ds a = runLoggingT (withSqlitePool (conn ds) (toThread ds) (lift.a)) logger - where toThread ds | conn ds == conn def = 1 - | otherwise = thread ds + where toThread d | conn d == conn def = 1 + | otherwise = thread d sqliteProvider :: (MonadTransaction m, MonadThrow m) => DataSourceProvider m a sqliteProvider = ("sqlite", connector (Proxy :: Proxy SQLite)) diff --git a/yam-app.cabal b/yam-app.cabal --- a/yam-app.cabal +++ b/yam-app.cabal @@ -1,5 +1,5 @@ name: yam-app -version: 0.1.10 +version: 0.1.11 synopsis: Yam App description: Base Module for Yam homepage: https://github.com/leptonyu/yam/tree/master/yam-app#readme