yam-app 0.1.10 → 0.1.11
raw patch · 9 files changed
+59/−60 lines, 9 files
Files
- src/Yam/App.hs +10/−11
- src/Yam/App/Context.hs +14/−8
- src/Yam/Event.hs +2/−2
- src/Yam/Import.hs +2/−0
- src/Yam/Logger.hs +9/−15
- src/Yam/Prop.hs +7/−7
- src/Yam/Transaction.hs +12/−14
- src/Yam/Transaction/Sqlite.hs +2/−2
- yam-app.cabal +1/−1
src/Yam/App.hs view
@@ -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)
src/Yam/App/Context.hs view
@@ -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
src/Yam/Event.hs view
@@ -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!"
src/Yam/Import.hs view
@@ -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
src/Yam/Logger.hs view
@@ -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
src/Yam/Prop.hs view
@@ -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
src/Yam/Transaction.hs view
@@ -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
src/Yam/Transaction/Sqlite.hs view
@@ -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))
yam-app.cabal view
@@ -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