diff --git a/src/Yam/App.hs b/src/Yam/App.hs --- a/src/Yam/App.hs +++ b/src/Yam/App.hs @@ -42,10 +42,10 @@ go "production" = Production go _ = Development -runAppM :: (Monad m) => YamContext -> AppM m a -> m a +runAppM :: Monad m => YamContext -> AppM m a -> m a runAppM = flip runReaderT -instance (MonadIO m, MonadThrow m) => HasYamContext (AppM m) where +instance MonadIO m => HasYamContext (AppM m) where yamContext = ask defaultContext :: IO YamContext 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 @@ -29,7 +29,7 @@ emptyContext :: IO YamContext emptyContext = YamContext <$> stdoutLogger <*> M.empty -class (MonadIO m, MonadThrow m) => HasYamContext m where +class MonadIO m => HasYamContext m where yamContext :: m YamContext extensionLockKey :: Text @@ -43,7 +43,7 @@ deriving Show instance Exception YamContextException -requireExtension :: (HasYamContext m, Typeable a) => Text -> m a +requireExtension :: (HasYamContext m, MonadThrow m, Typeable a) => Text -> m a requireExtension key = extension >>= liftIO . M.lookup key >>= get . (fromDynamic =<<) where get Nothing = throwM $ ExtensionNotFound key get (Just r) = return r @@ -54,7 +54,7 @@ getExtensionOrDefault :: (HasYamContext m, Typeable a) => a -> Text -> m a getExtensionOrDefault a key = (fromMaybe a . (fromDynamic =<<)) <$> (extension >>= liftIO . M.lookup key) -setExtension :: (MonadYamLogger m, HasYamContext m, Typeable a) => Text -> a -> m () +setExtension :: (MonadYamLogger m, HasYamContext m, MonadThrow m, Typeable a) => Text -> a -> m () setExtension key a = do when (extensionLockKey /= key) checkLock @@ -62,16 +62,16 @@ when (extensionLockKey /= key) (debugLn $ "Register extension <<" <> key <> ">>") -checkLock :: HasYamContext m => m () +checkLock :: (HasYamContext m, MonadThrow m) => m () checkLock = getExtensionOrDefault False extensionLockKey >>= go where go True = throwM ExtensionHasFreezed go _ = return () -lockExtenstion :: (MonadYamLogger m, HasYamContext m) => m () +lockExtenstion :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () lockExtenstion = setExtension extensionLockKey True -unlockExtenstion :: (MonadYamLogger m, HasYamContext m) => m () +unlockExtenstion :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () unlockExtenstion = setExtension extensionLockKey False -cleanContext :: (MonadYamLogger m, HasYamContext m) => m () -> m () +cleanContext :: (MonadYamLogger m, HasYamContext m, MonadThrow m) => m () -> m () cleanContext action = unlockExtenstion >> action diff --git a/src/Yam/Import.hs b/src/Yam/Import.hs --- a/src/Yam/Import.hs +++ b/src/Yam/Import.hs @@ -45,6 +45,7 @@ , encodeToText , FromJSON(..) , ToJSON(..) + , typeMismatch , decode , Default(..) , MonadBaseControl diff --git a/src/Yam/Logger.hs b/src/Yam/Logger.hs --- a/src/Yam/Logger.hs +++ b/src/Yam/Logger.hs @@ -58,7 +58,7 @@ , name :: LoggerCache } -class (MonadIO m) => MonadYamLogger m where +class MonadIO m => MonadYamLogger m where loggerConfig :: m LoggerConfig withLoggerConfig :: LoggerConfig -> m a -> m a @@ -69,15 +69,15 @@ logL :: (MonadYamLogger m, HasCallStack) => forall msg . (ToLogStr msg) => LogRank -> msg -> m () logL = logL' callStack -logL' :: (MonadYamLogger m) => forall msg . (ToLogStr msg) => CallStack -> LogRank -> msg -> m () +logL' :: MonadYamLogger m => forall msg . (ToLogStr msg) => CallStack -> LogRank -> msg -> m () logL' callStack r msg = do conf <- loggerConfig mayName <- fetchName liftIO $ when (r >= rank conf) $ do now <- clock conf - logger conf (cs now) (cs <$> mayName `mergeMaybe` getName (getCallStack callStack)) r (toLogStr msg) + logger conf (cs now) (getName (getCallStack callStack) `mergeMaybe` (cs <$> mayName)) r (toLogStr msg) where getName [] = Nothing - getName ((_,loc):_) = Just $ cs $ srcLocModule loc + getName ((_,loc):_) = Just $ (<>" ") $ cs $ srcLocModule loc fetchName :: MonadYamLogger m => m (Maybe Text) fetchName = do @@ -165,12 +165,12 @@ toRank LevelWarn = WARN toRank LevelError = ERROR toRank _ = INFO - mkLogger :: HasCallStack => LoggerConfig -> LogFunc - mkLogger context _ name level msg = runReaderT (withLoggerName name $ logL' callStack (toRank level) (msg <> "\n")) context + mkLogger :: LoggerConfig -> LogFunc + mkLogger context = let go :: HasCallStack => LogFunc + go _ name level msg = runReaderT (withLoggerName name $ logL' callStack (toRank level) (msg <> "\n")) context + in go toWaiLogger :: (MonadYamLogger m) => m ApacheLogger toWaiLogger = do mkLogger <- flip runReaderT <$> loggerConfig liftIO $ apacheLogger - <$> initLogger FromFallback (LogCallback (mkLogger . go) $ return ()) (return "") - where go :: HasCallStack => LogStr -> ReaderT LoggerConfig IO () - go = logL' callStack INFO + <$> initLogger FromFallback (LogCallback (mkLogger . logL' emptyCallStack INFO) $ return ()) (return "") diff --git a/src/Yam/Prop.hs b/src/Yam/Prop.hs --- a/src/Yam/Prop.hs +++ b/src/Yam/Prop.hs @@ -16,7 +16,6 @@ , loadCommandLineArgs , mergePropertySource , runProp - , parseProp ) where import Yam.Import @@ -36,48 +35,48 @@ emptyPropertySource :: PropertySource emptyPropertySource = ("DEFAULT", Null) -class (Monad m, MonadThrow m) => MonadProp m where +class Monad m => MonadProp m where propertySource :: m PropertySource type ValueProperty = ReaderT PropertySource -instance (Monad m, MonadThrow m) => MonadProp (ValueProperty m) where +instance Monad m => MonadProp (ValueProperty m) where propertySource = ask -data PropException = ParseFailed Text +data PropException = ParseFailed Text Text | KeyNotFound Text + | TypeMismatch Text | FileNotFound FilePath | FileLoadFailed FilePath deriving Show instance Exception PropException -parseProp :: Value -> ValueProperty (ExceptT PropException Parser) a -> Parser a -parseProp v ma = do - eab <- runExceptT $ runProp v ma - case eab of - Left e -> fail $ show e - Right v -> return v - runProp :: (Monad m) => Value -> ValueProperty m a -> m a runProp v ma = runReaderT ma ("NO_NAME", v) -getPropOrDefault :: (FromJSON a, MonadProp m) => a -> Text -> m a +getPropOrDefault :: (FromJSON a, MonadThrow m, MonadProp m) => a -> Text -> m a getPropOrDefault def key = fromMaybe def <$> getProp key -requiredProp :: (FromJSON a, MonadProp m) => Text -> m a +requiredProp :: (FromJSON a, MonadThrow m, MonadProp m) => Text -> m a requiredProp key = getProp key >>= maybe (throwM $ KeyNotFound key) return -getProp :: (FromJSON a, MonadProp m) => Text -> m (Maybe a) -getProp key = propertySource >>= go (splitKey key) - where go :: (FromJSON a, Monad m, MonadThrow m) => [Text] -> PropertySource -> m (Maybe a) - go hs (s,v) = to s $ foldl' fetch v hs - fetch :: Value -> Text -> Value - fetch (Object map) h = fromMaybe Null $ M.lookup h map - fetch _ _ = Null - to :: (FromJSON a, Monad m, MonadThrow m) => Text -> Value -> m (Maybe a) - to _ Null = return Nothing - to s v = case fromJSON v of - Error e -> throwM $ ParseFailed $ cs e +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 + 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 + Just v -> Just v + Nothing -> Just Null + fetch' v h = Nothing + to :: (FromJSON a, Monad m, MonadThrow m) => Text -> Text -> Maybe Value -> m (Maybe a) + to k s Nothing = throwM $ TypeMismatch k + to _ _ (Just Null) = return Nothing + to k s (Just v) = case fromJSON v of + Error e -> throwM $ ParseFailed k $ cs e Success a -> return (Just a) splitKey :: Text -> [Text] splitKey k | T.null k = [] @@ -122,7 +121,7 @@ to ([], _) = Nothing toValue :: [([Text], Value)] -> Value toValue [([],value)] = value - toValue vs = Object $ M.map toValue $ M.fromListWith (++) $ mapMaybe to vs + toValue vs = Object $ M.map toValue $ M.fromListWith (<>) $ mapMaybe to vs mergePropertySource :: [PropertySource] -> PropertySource mergePropertySource = foldl' merge emptyPropertySource diff --git a/src/Yam/Transaction.hs b/src/Yam/Transaction.hs --- a/src/Yam/Transaction.hs +++ b/src/Yam/Transaction.hs @@ -30,6 +30,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Data.Acquire (with) +import Data.Aeson import Data.Conduit import qualified Data.Conduit.List as CL import Data.Either (rights) @@ -52,18 +53,19 @@ } deriving Show instance FromJSON DataSource where - parseJSON v = parseProp v $ do - dsDt <- getPropOrDefault (dbtype def) "type" - dsCn <- getPropOrDefault (conn def) "conn" - dsTh <- getPropOrDefault (thread def) "thread" - dsMi <- getPropOrDefault (Yam.Transaction.migrate def) "migrate" - dsEx <- getProp "extra" + parseJSON (Object v) = do + dsDt <- v .:? "type" .!= dbtype def + dsCn <- v .:? "conn" .!= conn def + dsTh <- v .:? "thread" .!= thread def + dsMi <- v .:? "migrate" .!= Yam.Transaction.migrate def + dsEx <- v .:? "extra" return $ DataSource dsDt dsCn dsTh dsMi dsEx + parseJSON v = typeMismatch "DataSource" v instance Default DataSource where def = DataSource "sqlite" ":memory:" 10 True Nothing -class (MonadIO m, MonadBaseControl IO m, MonadYamLogger m, MonadMask m) => MonadTransaction m where +class (MonadIO m, MonadBaseControl IO m, MonadYamLogger m) => MonadTransaction m where connectionPool :: m TransactionPool setConnectionPool :: TransactionPool -> Maybe TransactionPool -> m () secondaryPool :: m (Maybe TransactionPool) @@ -73,7 +75,7 @@ type DataSourceProvider m a = (Text, DataSourceConnector m a) class HasDataSource ds where - connector :: MonadTransaction m => Proxy ds -> DataSourceConnector m a + connector :: (MonadTransaction m, MonadThrow m) => Proxy ds -> DataSourceConnector m a data DataSourceException = DataSourcePoolNotFound Text | DataSourceNotSupported Text @@ -82,7 +84,7 @@ instance Exception DataSourceException -initDataSource :: (MonadTransaction m) => [DataSourceProvider m a] -> DataSource -> Maybe DataSource -> m a -> m a +initDataSource :: (MonadTransaction m, MonadThrow 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 @@ -99,7 +101,7 @@ executePool trans p = liftIO (runSqlPool trans p) -runSecondaryTrans :: MonadTransaction m => Transaction a -> m a +runSecondaryTrans :: (MonadTransaction m, MonadMask m) => Transaction a -> m a runSecondaryTrans trans = do pool <- secondaryPool case pool of @@ -126,7 +128,7 @@ dbNow "sqlite" = selectValue "SELECT CURRENT_TIMESTAMP" dbNow "postgresql" = selectValue "SELECT CURRENT_TIMESTAMP" dbNow "oracle" = selectValue "SELECT SYSDATE FROM DUAL" - dbNow dbms = throwM $ DataSourceNotSupported $ cs $ dbms + dbNow dbms = throwM $ DataSourceNotSupported $ cs dbms selectValue :: (PersistField a) => Text -> Transaction [a] selectValue sql = fmap unSingle <$> rawSql sql [] 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 @@ -17,5 +17,5 @@ where toThread ds | conn ds == conn def = 1 | otherwise = thread ds -sqliteProvider :: MonadTransaction m => DataSourceProvider m a +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.7 +version: 0.1.8 synopsis: Yam App description: Base Module for Yam homepage: https://github.com/leptonyu/yam/tree/master/yam-app#readme