packages feed

yam-app 0.1.7 → 0.1.8

raw patch · 8 files changed

+58/−56 lines, 8 files

Files

src/Yam/App.hs view
@@ -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
src/Yam/App/Context.hs view
@@ -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
src/Yam/Import.hs view
@@ -45,6 +45,7 @@   , encodeToText   , FromJSON(..)   , ToJSON(..)+  , typeMismatch   , decode   , Default(..)   , MonadBaseControl
src/Yam/Logger.hs view
@@ -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 "")
src/Yam/Prop.hs view
@@ -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
src/Yam/Transaction.hs view
@@ -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 []
src/Yam/Transaction/Sqlite.hs view
@@ -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))
yam-app.cabal view
@@ -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