rio 0.1.12.0 → 0.1.13.0

raw patch · 7 files changed

+357/−58 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• rio.cabal +2/−2
• src/RIO.hs +22/−0
• src/RIO/Prelude/IO.hs +10/−0
• src/RIO/Prelude/Logger.hs +207/−1
• src/RIO/Prelude/RIO.hs +9/−0
• src/RIO/Process.hs +100/−55

@@ -1,5 +1,12 @@ # Changelog for rio +## 0.1.13.0++* Add `withLazyFileUtf8`+* Add `mapRIO`+* Add generic logger+* Add `exeExtensions` and improve `findExecutable` on Windows [#205](https://github.com/commercialhaskell/rio/issues/205)+ ## 0.1.12.0  * Add `logFormat` and `setLogFormat` for `LogOptions`.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7dc639bd135a48a7ddeeaf2a43e7de51ccc95f000475f44c042aaa133defb453+-- hash: 8e4af889359b601656dfdc5de6e99c1ae5312558aa4768684771e5a0fb8e6a8e  name:           rio-version:        0.1.12.0+version:        0.1.13.0 synopsis:       A standard library for Haskell description:    See README and Haddocks at <https://www.stackage.org/package/rio> category:       Control

@@ -37,6 +37,7 @@     -- * @MonadIO@ and @MonadUnliftIO@   , module Control.Monad.IO.Unlift     -- * Logger+    -- $logging-intro   , module RIO.Prelude.Logger     -- * Display   , module RIO.Prelude.Display@@ -115,3 +116,24 @@ import UnliftIO.Temporary import UnliftIO.Timeout import UnliftIO.Concurrent++--------------------------------------------------------------------------------+-- $logging-intro+--+-- The logging system in RIO is built upon "log functions", which are+-- accessed in RIO's environment via a class like "has log+-- function". There are two provided:+--+-- * In the common case: for logging plain text (via 'Utf8Builder')+--   efficiently, there is 'LogFunc', which can be created via+--   'withLogFunc', and is accessed via 'HasLogFunc'. This provides+--   all the classical logging facilities: timestamped text output+--   with log levels and colors (if terminal-supported) to the+--   terminal. We log output via 'logInfo', 'logDebug', etc.+--+-- * In the advanced case: where logging takes on a more semantic+--   meaning and the logs need to be digested, acted upon, translated+--   or serialized upstream (to e.g. a JSON logging server), we have+--   'GLogFunc' (as in "generic log function"), and is accessed via+--   'HasGLogFunc'. In this case, we log output via 'glog'. See the+--   Type-generic logger section for more information.

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module RIO.Prelude.IO   ( withLazyFile+  , withLazyFileUtf8   , readFileBinary   , writeFileBinary   , readFileUtf8@@ -12,6 +13,8 @@ import qualified Data.ByteString         as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy    as BL+import qualified Data.Text.Lazy          as TL+import qualified Data.Text.Lazy.IO       as TL import qualified Data.Text.IO            as T import           System.IO               (hSetEncoding, utf8) @@ -21,6 +24,13 @@ -- immediately. withLazyFile :: MonadUnliftIO m => FilePath -> (BL.ByteString -> m a) -> m a withLazyFile fp inner = withBinaryFile fp ReadMode $ inner <=< liftIO . BL.hGetContents++-- | Lazily read a file in UTF8 encoding.+--+-- @since 0.1.13+withLazyFileUtf8 :: MonadUnliftIO m => FilePath -> (TL.Text -> m a) -> m a+withLazyFileUtf8 fp inner = withFile fp ReadMode $ \h ->+  inner =<< liftIO (hSetEncoding h utf8 >> TL.hGetContents h)  -- | Write a file in UTF8 encoding --

@@ -1,3 +1,7 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -50,6 +54,17 @@   , noLogging     -- ** Accessors   , logFuncUseColorL+    -- * Type-generic logger+    -- $type-generic-intro+  , glog+  , GLogFunc+  , gLogFuncClassic+  , mkGLogFunc+  , contramapMaybeGLogFunc+  , contramapGLogFunc+  , HasGLogFunc(..)+  , HasLogLevel(..)+  , HasLogSource(..)   ) where  import RIO.Prelude.Reexports hiding ((<>))@@ -73,6 +88,10 @@ import           GHC.Foreign                (peekCString, withCString) import Data.Semigroup (Semigroup (..)) +#if MIN_VERSION_base(4,12,0)+import Data.Functor.Contravariant+#endif+ -- | The log level of a message. -- -- @since 0.0.0.0@@ -506,7 +525,7 @@ -- -- Default: `id` ----- @since 0.1.12.0+-- @since 0.1.13.0 setLogFormat :: (Utf8Builder -> Utf8Builder) -> LogOptions -> LogOptions setLogFormat f options = options { logFormat = f } @@ -659,3 +678,190 @@ -- @since 0.1.5.0 noLogging :: (HasLogFunc env, MonadReader env m) => m a -> m a noLogging = local (set logFuncL mempty)++--------------------------------------------------------------------------------+--+-- $type-generic-intro+--+-- When logging takes on a more semantic meaning and the logs need to+-- be digested, acted upon, translated or serialized upstream (to+-- e.g. a JSON logging server), we have 'GLogFunc' (as in "generic log+-- function"), and is accessed via 'HasGLogFunc'.+--+-- There is only one function to log in this system: the 'glog'+-- function, which can log any message. You determine the log levels+-- or severity of messages when needed.+--+-- Using 'RIO.Prelude.mapRIO' and 'contramapGLogFunc' (or+-- 'contramapMaybeGLogFunc'), you can build hierarchies of loggers.+--+-- Example:+--+-- @+-- import RIO+--+-- data DatabaseMsg = Connected String | Query String | Disconnected deriving Show+-- data WebMsg = Request String | Error String | DatabaseMsg DatabaseMsg deriving Show+-- data AppMsg = InitMsg String | WebMsg WebMsg deriving Show+--+-- main :: IO ()+-- main =+--   runRIO+--     (mkGLogFunc (\stack msg -> print msg))+--     (do glog (InitMsg "Ready to go!")+--         runWeb+--           (do glog (Request "/foo")+--               runDB (do glog (Connected "127.0.0.1")+--                         glog (Query "SELECT 1"))+--               glog (Error "Oh noes!")))+--+-- runDB :: RIO (GLogFunc DatabaseMsg) () -> RIO (GLogFunc WebMsg) ()+-- runDB = mapRIO (contramapGLogFunc DatabaseMsg)+--+-- runWeb :: RIO (GLogFunc WebMsg) () -> RIO (GLogFunc AppMsg) ()+-- runWeb = mapRIO (contramapGLogFunc WebMsg)+-- @+--+-- If we instead decided that we only wanted to log database queries,+-- and not bother the upstream with connect/disconnect messages, we+-- could simplify the constructor to @DatabaseQuery String@:+--+-- @+-- data WebMsg = Request String | Error String | DatabaseQuery String deriving Show+-- @+--+-- And then @runDB@ could use 'contramapMaybeGLogFunc' to parse only queries:+--+-- @+-- runDB =+--   mapRIO+--     (contramapMaybeGLogFunc+--        (\msg ->+--           case msg of+--             Query string -> pure (DatabaseQuery string)+--             _ -> Nothing))+-- @+--+-- This way, upstream only has to care about queries and not+-- connect/disconnect constructors.++-- | An app is capable of generic logging if it implements this.+--+-- @since 0.1.13.0+class HasGLogFunc env where+  type GMsg env+  gLogFuncL :: Lens' env (GLogFunc (GMsg env))++-- | Quick way to run a RIO that only has a logger in its environment.+--+-- @since 0.1.13.0+instance HasGLogFunc (GLogFunc msg) where+  type GMsg (GLogFunc msg) = msg+  gLogFuncL = id++-- | A generic logger of some type @msg@.+--+-- Your 'GLocFunc' can re-use the existing classical logging framework+-- of RIO, and/or implement additional transforms,+-- filters. Alternatively, you may log to a JSON source in a database,+-- or anywhere else as needed. You can decide how to log levels or+-- severities based on the constructors in your type. You will+-- normally determine this in your main app entry point.+--+-- @since 0.1.13.0+newtype GLogFunc msg = GLogFunc (CallStack -> msg -> IO ())++#if MIN_VERSION_base(4,12,0)+-- https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Functor-Contravariant.html++-- | Use this instance to wrap sub-loggers via 'RIO.mapRIO'.+--+-- The 'Contravariant' class is available in base 4.12.0.+--+-- @since 0.1.13.0+instance Contravariant GLogFunc where+  contramap = contramapGLogFunc+  {-# INLINABLE contramap #-}+#endif++-- | Perform both sets of actions per log entry.+--+-- @since 0.1.13.0+instance Semigroup (GLogFunc msg) where+  GLogFunc f <> GLogFunc g = GLogFunc (\a b -> f a b *> g a b)++-- | 'mempty' peforms no logging.+--+-- @since 0.1.13.0+instance Monoid (GLogFunc msg) where+  mempty = mkGLogFunc $ \_ _ -> return ()+  mappend = (<>)++-- | A vesion of 'contramapMaybeGLogFunc' which supports filering.+--+-- @since 0.1.13.0+contramapMaybeGLogFunc :: (a -> Maybe b) -> GLogFunc b -> GLogFunc a+contramapMaybeGLogFunc f (GLogFunc io) =+  GLogFunc (\stack msg -> maybe (pure ()) (io stack) (f msg))+{-# INLINABLE contramapMaybeGLogFunc #-}++-- | A contramap. Use this to wrap sub-loggers via 'RIO.mapRIO'.+--+-- If you are on base > 4.12.0, you can just use 'contramap'.+--+-- @since 0.1.13.0+contramapGLogFunc :: (a -> b) -> GLogFunc b -> GLogFunc a+contramapGLogFunc f (GLogFunc io) = GLogFunc (\stack msg -> io stack (f msg))+{-# INLINABLE contramapGLogFunc #-}++-- | Make a custom generic logger. With this you could, for example,+-- write to a database or a log digestion service. For example:+--+-- > mkGLogFunc (\stack msg -> send (Data.Aeson.encode (JsonLog stack msg)))+--+-- @since 0.1.13.0+mkGLogFunc :: (CallStack -> msg -> IO ()) -> GLogFunc msg+mkGLogFunc = GLogFunc++-- | Log a value generically.+--+-- @since 0.1.13.0+glog ::+     (MonadIO m, HasCallStack, HasGLogFunc env, MonadReader env m)+  => GMsg env+  -> m ()+glog t = do+  GLogFunc gLogFunc <- view gLogFuncL+  liftIO (gLogFunc callStack t)+{-# INLINABLE glog #-}++--------------------------------------------------------------------------------+-- Integration with classical logger framework++-- | Level, if any, of your logs. If unknown, use 'LogOther'. Use for+-- your generic log data types that want to sit inside the classic log+-- framework.+--+-- @since 0.1.13.0+class HasLogLevel msg where+  getLogLevel :: msg -> LogLevel++-- | Source of a log. This can be whatever you want. Use for your+-- generic log data types that want to sit inside the classic log+-- framework.+--+-- @since 0.1.13.0+class HasLogSource msg where+  getLogSource :: msg -> LogSource++-- | Make a 'GLogFunc' via classic 'LogFunc'. Use this if you'd like+-- to log your generic data type via the classic RIO terminal logger.+--+-- @since 0.1.13.0+gLogFuncClassic ::+     (HasLogLevel msg, HasLogSource msg, Display msg) => LogFunc -> GLogFunc msg+gLogFuncClassic (LogFunc {unLogFunc = io}) =+  mkGLogFunc+    (\theCallStack msg ->+       liftIO+         (io theCallStack (getLogSource msg) (getLogLevel msg) (display msg)))

@@ -8,6 +8,7 @@   ( RIO (..)   , runRIO   , liftRIO+  , mapRIO   -- SomeRef for Writer/State interfaces   , SomeRef   , HasStateRef (..)@@ -57,6 +58,14 @@ liftRIO rio = do   env <- ask   runRIO env rio++-- | Lift one RIO env to another.+--+-- @since 0.1.13.0+mapRIO :: (outer -> inner) -> RIO inner a -> RIO outer a+mapRIO f m = do+  outer <- ask+  runRIO (f outer) m  instance MonadUnliftIO (RIO env) where     askUnliftIO = RIO $ ReaderT $ \r ->

@@ -72,6 +72,7 @@     -- * Utilities   , doesExecutableExist   , findExecutable+  , exeExtensions   , augmentPath   , augmentPathMap   , showProcessArgDebug@@ -225,6 +226,13 @@   EVFNotWindows #endif +-- Don't use CPP so that the Windows code path is at least type checked+-- regularly+isWindows :: Bool+isWindows = case currentEnvVarFormat of+              EVFWindows -> True+              EVFNotWindows -> False+ -- | Override the working directory processes run in. @Nothing@ means -- the current process's working directory. --@@ -271,10 +279,9 @@         , pcExeCache = ref         , pcExeExtensions =             if isWindows-                then let pathext = fromMaybe-                           ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"-                           (Map.lookup "PATHEXT" tm)-                      in map T.unpack $ "" : T.splitOn ";" pathext+                then let pathext = fromMaybe defaultPATHEXT+                                             (Map.lookup "PATHEXT" tm)+                      in map T.unpack $ T.splitOn ";" pathext                 else [""]         , pcWorkingDir = Nothing         }@@ -283,13 +290,11 @@     tm         | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'         | otherwise = tm'--    -- Don't use CPP so that the Windows code path is at least type checked-    -- regularly-    isWindows =-        case currentEnvVarFormat of-            EVFWindows -> True-            EVFNotWindows -> False+    -- Default value for PATHTEXT on Windows versions after Windows XP. (The+    -- documentation of the default at+    -- https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/start+    -- is incomplete.)+    defaultPATHEXT = ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"  -- | Reset the executable cache. --@@ -299,7 +304,10 @@   pc <- view processContextL   atomicModifyIORef (pcExeCache pc) (const mempty) --- | Load up an 'EnvOverride' from the standard environment.+-- | Same as 'mkProcessContext' but uses the system environment (from+-- 'System.Environment.getEnvironment').+--+-- @since 0.0.3.0 mkDefaultProcessContext :: MonadIO m => m ProcessContext mkDefaultProcessContext =     liftIO $@@ -307,10 +315,8 @@           mkProcessContext         . Map.fromList . map (T.pack *** T.pack) --- | Modify the environment variables of a 'ProcessContext'.------ This will keep other settings unchanged, in particular the working--- directory.+-- | Modify the environment variables of a 'ProcessContext'. This will not+-- change the working directory. -- -- Note that this requires 'MonadIO', as it will create a new 'IORef' -- for the cache.@@ -554,50 +560,89 @@   -> m Bool doesExecutableExist = liftM isRight . findExecutable --- | Find the complete path for the executable.+-- | Find the complete path for the given executable name. --+-- On POSIX systems, filenames that match but are not exectuables are excluded.+--+-- On Windows systems, the executable names tried, in turn, are the supplied+-- name (only if it has an extension) and that name extended by each of the+-- 'exeExtensions'. Also, this function may behave differently from+-- 'RIO.Directory.findExecutable'. The latter excludes as executables filenames+-- without a @.bat@, @.cmd@, @.com@ or @.exe@ extension (case-insensitive).+-- -- @since 0.0.3.0 findExecutable   :: (MonadIO m, MonadReader env m, HasProcessContext env)-  => String            -- ^ Name of executable-  -> m (Either ProcessException FilePath) -- ^ Full path to that executable on success-findExecutable name0 | any FP.isPathSeparator name0 = do-    pc <- view processContextL-    let names0 = map (name0 ++) (pcExeExtensions pc)-        testNames [] = return $ Left $ ExecutableNotFoundAt name0-        testNames (name:names) = do-            exists <- liftIO $ D.doesFileExist name-            if exists-                then do-                    path <- liftIO $ D.canonicalizePath name-                    return $ return path-                else testNames names-    testNames names0+  => String+  -- ^ Name of executable+  -> m (Either ProcessException FilePath)+  -- ^ Full path to that executable on success+findExecutable name | any FP.isPathSeparator name = do+  names <- addPcExeExtensions name+  testFPs (pure $ Left $ ExecutableNotFoundAt name) D.canonicalizePath names findExecutable name = do-    pc <- view processContextL-    m <- readIORef $ pcExeCache pc-    epath <- case Map.lookup name m of-        Just epath -> return epath-        Nothing -> do-            let loop [] = return $ Left $ ExecutableNotFound name (pcPath pc)-                loop (dir:dirs) = do-                    let fp0 = dir FP.</> name-                        fps0 = map (fp0 ++) (pcExeExtensions pc)-                        testFPs [] = loop dirs-                        testFPs (fp:fps) = do-                            exists <- D.doesFileExist fp-                            existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False-                            if existsExec-                                then do-                                    fp' <- D.makeAbsolute fp-                                    return $ return fp'-                                else testFPs fps-                    testFPs fps0-            epath <- liftIO $ loop $ pcPath pc-            () <- atomicModifyIORef (pcExeCache pc) $ \m' ->-                (Map.insert name epath m', ())-            return epath-    return epath+  pc <- view processContextL+  m <- readIORef $ pcExeCache pc+  case Map.lookup name m of+    Just epath -> pure epath+    Nothing -> do+      let loop [] = pure $ Left $ ExecutableNotFound name (pcPath pc)+          loop (dir:dirs) = do+            fps <- addPcExeExtensions $ dir FP.</> name+            testFPs (loop dirs) D.makeAbsolute fps+      epath <- loop $ pcPath pc+      () <- atomicModifyIORef (pcExeCache pc) $ \m' ->+          (Map.insert name epath m', ())+      pure epath++-- | A helper function to add the executable extensions of the process context+-- to a file path. On Windows, the original file path is included, if it has an+-- existing extension.+addPcExeExtensions+  :: (MonadIO m, MonadReader env m, HasProcessContext env)+  => FilePath -> m [FilePath]+addPcExeExtensions fp = do+  pc <- view processContextL+  pure $ (if isWindows && FP.hasExtension fp then (fp:) else id)+         (map (fp ++) (pcExeExtensions pc))++-- | A helper function to test whether file paths are to an executable+testFPs+  :: (MonadIO m, MonadReader env m, HasProcessContext env)+  => m (Either ProcessException FilePath)+  -- ^ Default if no executable exists at any file path+  -> (FilePath -> IO FilePath)+  -- ^ Modification to apply to a file path, if an executable exists there+  -> [FilePath]+  -- ^ File paths to test, in turn+  -> m (Either ProcessException FilePath)+testFPs ifNone _ [] = ifNone+testFPs ifNone modify (fp:fps) = do+  exists <- liftIO $ D.doesFileExist fp+  existsExec <- liftIO $ if exists+    then if isWindows then pure True else isExecutable+    else pure False+  if existsExec then liftIO $ Right <$> modify fp else testFPs ifNone modify fps+ where+  isExecutable = D.executable <$> D.getPermissions fp++-- | Get the filename extensions for executable files, including the dot (if+-- any).+--+-- On POSIX systems, this is @[""]@.+--+-- On Windows systems, the list is determined by the value of the @PATHEXT@+-- environment variable, if it present in the environment. If the variable is+-- absent, this is its default value on a Windows system. This function may,+-- therefore, behave differently from 'RIO.Directory.exeExtension',+-- which returns only @".exe"@.+--+-- @since 0.1.13.0+exeExtensions :: (MonadIO m, MonadReader env m, HasProcessContext env)+              => m [String]+exeExtensions = do+  pc <- view processContextL+  return $ pcExeExtensions pc  -- | Augment the PATH environment variable with the given extra paths. --