Repository: kazu-yamamoto/logger Branch: main Commit: 4f0866d7585a Files: 44 Total size: 94.5 KB Directory structure: gitextract_5vwawpq7/ ├── .github/ │ └── workflows/ │ └── haskell.yml ├── .gitignore ├── .travis.yml ├── README.md ├── cabal.project ├── date-cache/ │ ├── LICENSE │ ├── System/ │ │ └── Date/ │ │ └── Cache.hs │ └── date-cache.cabal ├── fast-logger/ │ ├── ChangeLog.md │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── System/ │ │ └── Log/ │ │ ├── FastLogger/ │ │ │ ├── Date.hs │ │ │ ├── File.hs │ │ │ ├── FileIO.hs │ │ │ ├── IO.hs │ │ │ ├── Imports.hs │ │ │ ├── Internal.hs │ │ │ ├── LogStr.hs │ │ │ ├── LoggerSet.hs │ │ │ ├── MultiLogger.hs │ │ │ ├── SingleLogger.hs │ │ │ ├── Types.hs │ │ │ └── Write.hs │ │ └── FastLogger.hs │ ├── fast-logger.cabal │ └── test/ │ ├── FastLoggerSpec.hs │ └── Spec.hs ├── fourmolu.yaml ├── sources.txt ├── stack.yaml ├── wai-logger/ │ ├── .gitignore │ ├── LICENSE │ ├── Network/ │ │ └── Wai/ │ │ ├── Logger/ │ │ │ ├── Apache.hs │ │ │ ├── IORef.hs │ │ │ └── IP.hs │ │ └── Logger.hs │ ├── Setup.hs │ └── wai-logger.cabal └── wai-logger-prefork/ ├── LICENSE ├── Network/ │ └── Wai/ │ └── Logger/ │ ├── Prefork/ │ │ ├── File.hs │ │ └── Types.hs │ └── Prefork.hs └── wai-logger-prefork.cabal ================================================ FILE CONTENTS ================================================ ================================================ FILE: .github/workflows/haskell.yml ================================================ name: Haskell CI on: push: branches: [ 'main', 'ci' ] pull_request: branches: [ 'main' ] jobs: build: runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: os: [ 'ubuntu-latest', 'macOS-latest' ] ghc: [ '8.10', '9.0', '9.2', '9.4' ] steps: - uses: actions/checkout@v3 - uses: haskell/actions/setup@v2 with: ghc-version: ${{ matrix.ghc }} cabal-version: '3.8' - name: Cache uses: actions/cache@v3 env: cache-name: cache-cabal with: path: ~/.cabal key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} restore-keys: | ${{ runner.os }}-build-${{ env.cache-name }}- ${{ runner.os }}-build- ${{ runner.os }}- - name: Install dependencies run: | cabal update cabal build --only-dependencies --enable-tests --disable-benchmarks all - name: Build run: cabal build --enable-tests --disable-benchmarks all - name: Run tests run: cabal test --test-show-details=streaming all - name: Run doctest if: ${{ runner.os == 'Linux' }} run: | cabal install doctest --overwrite-policy=always for package in `cat cabal.project | sed 's/packages://g'` do cabal repl --build-depends=QuickCheck --with-ghc=doctest $package done ================================================ FILE: .gitignore ================================================ dist/ .cabal-sandbox/ cabal.sandbox.config .stack-work/ tarballs/ dist-newstyle/ .ghc.environment.* stack.yaml.lock ================================================ FILE: .travis.yml ================================================ # This Travis job script has been generated by a script via # # haskell-ci '--output' 'travis.yml' '--no-cabal-check' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.3.20190409 # language: c dist: xenial git: # whether to recursively clone submodules submodules: false cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} - compiler: ghc-8.2.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} - compiler: ghc-7.10.3 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}} - compiler: ghc-7.8.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}} before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH" - TOP=$(pwd) - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - echo $HCNUMVER - CABAL="$CABAL -vnormal+nowrap+markoutput" - set -o pipefail - | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk echo 'BEGIN { state = "output"; }' >> .colorful.awk echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk echo ' if (state == "cabal") {' >> .colorful.awk echo ' print blue($0)' >> .colorful.awk echo ' } else {' >> .colorful.awk echo ' print $0' >> .colorful.awk echo ' }' >> .colorful.awk echo '}' >> .colorful.awk - cat .colorful.awk - | color_cabal_output () { awk -f $TOP/.colorful.awk } - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - GHCHEAD=${GHCHEAD-false} - rm -f $CABALHOME/config - | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config echo "remote-build-reporting: anonymous" >> $CABALHOME/config echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config echo "world-file: $CABALHOME/world" >> $CABALHOME/config echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config echo "store-dir: $CABALHOME/store" >> $CABALHOME/config echo "install-dirs user" >> $CABALHOME/config echo " prefix: $CABALHOME" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo 'packages: "wai-logger"' >> cabal.project echo 'packages: "fast-logger"' >> cabal.project - | echo "write-ghc-environment-files: always" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(fast-logger|wai-logger)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "wai-logger/configure.ac" ]; then (cd "wai-logger" && autoreconf -i); fi - if [ -f "fast-logger/configure.ac" ]; then (cd "fast-logger" && autoreconf -i); fi - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo 'packages: "wai-logger-*/*.cabal"' >> cabal.project echo 'packages: "fast-logger-*/*.cabal"' >> cabal.project - | echo "write-ghc-environment-files: always" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(fast-logger|wai-logger)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # Building... # this builds all libraries and executables (without tests/benchmarks) - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output # Building with tests and benchmarks... # build & run tests, build benchmarks - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # Testing... - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # haddock... - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output # REGENDATA ["--output","travis.yml","--no-cabal-check","cabal.project"] # EOF ================================================ FILE: README.md ================================================ Efficient, versatile logging tools for Haskell. fast-logger ----------- low-level and extremely fast logging tools. All Haskell logging tools that log to a Handle or generate formatted dates should depend on these. wai-logger ---------- add logging to your webapp. fast Apache style logger date-cache & wai-logger-prefork ------------------------------- Obsoleted. Please see package documentation of individual packages for more details, e.g: http://hackage.haskell.org/package/fast-logger ================================================ FILE: cabal.project ================================================ packages: fast-logger wai-logger ================================================ FILE: date-cache/LICENSE ================================================ Copyright (c) 2012, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: date-cache/System/Date/Cache.hs ================================================ -- | -- Formatting time is slow. -- This package provides mechanisms to cache formatted date. module System.Date.Cache ( -- * Types DateCacheConf (..), DateCacheGetter, DateCacheCloser, -- * Date cacher ondemandDateCacher, clockDateCacher, ) where import Control.Applicative import Control.Concurrent import Data.ByteString (ByteString) import Data.IORef type DateCacheGetter = IO ByteString type DateCacheCloser = IO () data DateCache t = DateCache { timeKey :: !t , formattedDate :: !ByteString } deriving (Eq, Show) data DateCacheConf t = DateCacheConf { getTime :: IO t -- ^ A function to get a time. E.g 'epochTime' and 'getCurrentTime'. , formatDate :: t -> IO ByteString -- ^ A function to format a time. } newDate :: DateCacheConf t -> t -> IO (DateCache t) newDate setting tm = DateCache tm <$> formatDate setting tm -- | -- Date cacher which gets a time and formatted it only when -- returned getter is executed. ondemandDateCacher :: Eq t => DateCacheConf t -> IO (DateCacheGetter, DateCacheCloser) ondemandDateCacher setting = do ref <- getTime setting >>= newDate setting >>= newIORef return (getter ref, closer) where getter ref = do newTm <- getTime setting cache <- readIORef ref let oldTm = timeKey cache if oldTm == newTm then return $ formattedDate cache else do newCache <- newDate setting newTm writeIORef ref newCache return $ formattedDate newCache closer = return () -- | -- Date cacher which gets a time and formatted it every second. -- This returns a getter. clockDateCacher :: Eq t => DateCacheConf t -> IO (DateCacheGetter, DateCacheCloser) clockDateCacher setting = do ref <- getTime setting >>= newDate setting >>= newIORef tid <- forkIO $ clock ref return (getter ref, closer tid) where getter ref = formattedDate <$> readIORef ref clock ref = do threadDelay 1000000 tm <- getTime setting date <- formatDate setting tm let new = DateCache { timeKey = tm , formattedDate = date } writeIORef ref new clock ref closer tid = killThread tid ================================================ FILE: date-cache/date-cache.cabal ================================================ Name: date-cache Version: 0.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: Date cacher Description: Formatting time is slow. This package provides mechanisms to cache formatted date. Category: System Cabal-Version: >= 1.8 Build-Type: Simple tested-with: GHC ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.1 Library GHC-Options: -Wall Exposed-Modules: System.Date.Cache Build-Depends: base >= 4 && < 5 , bytestring Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/logger.git ================================================ FILE: fast-logger/ChangeLog.md ================================================ ## 3.2.6 * Labeling the thread of SingleLogger. ## 3.2.5 * Giving names to threads. ## 3.2.4 * Avoid unnecessary copy for Text values with text-2.0 [#219](https://github.com/kazu-yamamoto/logger/pull/219) ## 3.2.3 * Ensuring flush for single logger. [#214](https://github.com/kazu-yamamoto/logger/pull/214) ## 3.2.2 * Corrected handling of messages at the buffer boundary in the SingleLogger [#211](https://github.com/kazu-yamamoto/logger/pull/211) ## 3.2.1 * Fixing a bug where a single logger is not killed ## 3.2.0 * newFastLogger1 ensures the ordering of logs [#207](https://github.com/kazu-yamamoto/logger/pull/207) ## 3.1.2 * Require unix-compat >= 0.2 [#206](https://github.com/kazu-yamamoto/logger/pull/206) * Remove Safe if directory >= 1.3.8 [#199](https://github.com/kazu-yamamoto/logger/pull/199) ## 3.1.1 * More time-ordered logging functions [#199](https://github.com/kazu-yamamoto/logger/pull/199) ## 3.1.0 * Having a single Buffer in LoggerSet for locking [#197](https://github.com/kazu-yamamoto/logger/pull/197. This would have performance penalty. So, the major version bumps up. If you see performance regression, please register an issue on github. ## 3.0.5 * recovering backward compatibility for newFileLoggerSet. ## 3.0.4 * New API: `newFastLogger1` which use only one capability. * Making `FD` safer with `invalidFD`. ## 3.0.3 * Dropping support of GHC 7.x. * Add `ToLogStr` instance for `ShortByteString`. Add lower bound on `bytestring` dependency to ensure that `bytestring` exports `Data.ByteString.Short`. ## 3.0.2 * Fixing documentation. ## 3.0.1 * Creating the `Internal` module. [#185](https://github.com/kazu-yamamoto/logger/pull/185) ## 3.0.0 * Allowing the callback logger to be generic. [#182](https://github.com/kazu-yamamoto/logger/pull/180) This is a BREAKING CHANGE. Users should do: 1. Importing `LogType'` and related constructors because `LogType` is now a type alias. 2. Using `{-# LANGUAGE GADTs #-}`, even if you aren't using anything new, any time you try and `case` over values of type `LogType'`. ## 2.4.17 * Obtaining a fresh fd from IORef just before writing. [#180](https://github.com/kazu-yamamoto/logger/pull/180) ## 2.4.16 * Using strict language extensions. ## 2.4.15 * Rescuing GHC 7.8. ## 2.4.14 * Add `ToLogStr` instances for the following types: signed integers, unsigned integers, floating-point numbers. These instances all use decimal encodings. [#177](https://github.com/kazu-yamamoto/logger/pull/177) ## 2.4.11 * Give an explicit definition for (<>) in LogStr's Semigroup instance. [#155](https://github.com/kazu-yamamoto/logger/pull/155) ## 2.4.10 * Fix Windows build on GHC 7.8. [#121](https://github.com/kazu-yamamoto/logger/pull/121) ## 2.4.9 * Fixing build on Windows. [#118](https://github.com/kazu-yamamoto/logger/pull/118) ## 2.4.8 * Add Semigroup instance to LogStr [#115](https://github.com/kazu-yamamoto/logger/pull/115) * Added note on log message ordering [#116](https://github.com/kazu-yamamoto/logger/pull/116) ## 2.4.7 * Fixing interleaved log output when messages are larger than buffer size. [#103](https://github.com/kazu-yamamoto/logger/pull/103) ## 2.4.6 * Ensuring that stdio is flushed. [#92](https://github.com/kazu-yamamoto/logger/pull/92) ## 2.4.5 * Bringing backward compatibility back. ## 2.4.4 * New API: newFastLogger and newTimedFastLogger. * LogType and date cache are transferred from wai-logger. ## 2.4.3 * Opening files in the append mode on Windows. ## 2.4.2 * Fixing a buf of long log messages [#80](https://github.com/kazu-yamamoto/logger/pull/80) * Log rotation support for Windows [#79](https://github.com/kazu-yamamoto/logger/pull/79) * Unsupporting GHC 7.4. ## 2.4.1 * Restore compatibility with bytestring < 0.10 * Mark fast-logger modules as Safe/Trustworth [#68](https://github.com/kazu-yamamoto/logger/pull/68) ## 2.4.0 * Providing pushLogStrLn. [#64](https://github.com/kazu-yamamoto/logger/pull/64) ## 2.3.1 * No changes. ## 2.3.0 * Move from blaze-builder to `Data.ByteString.Builder` [#55](https://github.com/kazu-yamamoto/logger/pull/55) ================================================ FILE: fast-logger/LICENSE ================================================ Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: fast-logger/README.md ================================================ ## fast-logger A fast logging system ================================================ FILE: fast-logger/Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: fast-logger/System/Log/FastLogger/Date.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Formatting time is slow. -- This package provides mechanisms to cache formatted date. module System.Log.FastLogger.Date ( -- * Date cacher newTimeCache, simpleTimeFormat, simpleTimeFormat', ) where import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction, updateThreadName) import Data.UnixTime (formatUnixTime, fromEpochTime) import System.Log.FastLogger.Types (FormattedTime, TimeFormat) import System.PosixCompat.Time (epochTime) import System.PosixCompat.Types (EpochTime) ---------------------------------------------------------------- -- | Get date using UnixTime. getTime :: IO EpochTime getTime = epochTime -- | Format unix EpochTime date. formatDate :: TimeFormat -> EpochTime -> IO FormattedTime formatDate fmt = formatUnixTime fmt . fromEpochTime ---------------------------------------------------------------- -- | Make 'IO' action which get cached formatted local time. -- Use this to avoid the cost of frequently time formatting by caching an -- auto updating formatted time, this cache update every 1 second. -- more detail in "Control.AutoUpdate" newTimeCache :: TimeFormat -> IO (IO FormattedTime) newTimeCache fmt = mkAutoUpdate defaultUpdateSettings { updateAction = getTime >>= formatDate fmt , updateThreadName = "Date string cacher of FastLogger (AutoUpdate)" } -- | A simple time cache using format @"%d/%b/%Y:%T %z"@ simpleTimeFormat :: TimeFormat simpleTimeFormat = "%d/%b/%Y:%T %z" -- | A simple time cache using format @"%d-%b-%Y %T"@ simpleTimeFormat' :: TimeFormat simpleTimeFormat' = "%d-%b-%Y %T" ================================================ FILE: fast-logger/System/Log/FastLogger/File.hs ================================================ {-# LANGUAGE CPP #-} #if !MIN_VERSION_directory(1,3,8) {-# LANGUAGE Safe #-} #endif module System.Log.FastLogger.File ( FileLogSpec (..), TimedFileLogSpec (..), check, rotate, prefixTime, ) where import Data.ByteString.Char8 (unpack) import System.Directory ( doesDirectoryExist, doesFileExist, getPermissions, renameFile, writable, ) import System.FilePath (dropFileName, takeDirectory, takeFileName, ()) import System.Log.FastLogger.Imports import System.Log.FastLogger.Types (FormattedTime, TimeFormat) -- | The spec for logging files data FileLogSpec = FileLogSpec { log_file :: FilePath , log_file_size :: Integer -- ^ Max log file size (in bytes) before requiring rotation. , log_backup_number :: Int -- ^ Max number of rotated log files to keep around before overwriting the oldest one. } -- | The spec for time based rotation. It supports post processing of log files. Does -- not delete any logs. Example: -- -- @ -- timeRotate fname = LogFileTimedRotate -- (TimedFileLogSpec fname timeFormat sametime compressFile) -- defaultBufSize -- where -- timeFormat = "%FT%H%M%S" -- sametime = (==) `on` C8.takeWhile (/='T') -- compressFile fp = void . forkIO $ -- callProcess "tar" [ "--remove-files", "-caf", fp <> ".gz", fp ] -- @ data TimedFileLogSpec = TimedFileLogSpec { timed_log_file :: FilePath -- ^ base file path , timed_timefmt :: TimeFormat -- ^ time format to prepend , timed_same_timeframe :: FormattedTime -> FormattedTime -> Bool -- ^ function that compares two -- formatted times as specified by -- timed_timefmt and decides if a -- new rotation is supposed to -- begin , timed_post_process :: FilePath -> IO () -- ^ processing function called asynchronously after a file is added to the rotation } -- | Checking if a log file can be written. check :: FilePath -> IO () check file = do dirExist <- doesDirectoryExist dir unless dirExist $ fail $ dir ++ " does not exist or is not a directory." dirPerm <- getPermissions dir unless (writable dirPerm) $ fail $ dir ++ " is not writable." exist <- doesFileExist file when exist $ do perm <- getPermissions file unless (writable perm) $ fail $ file ++ " is not writable." where dir = takeDirectory file -- | Rotating log files. rotate :: FileLogSpec -> IO () rotate spec = mapM_ move srcdsts where path = log_file spec n = log_backup_number spec dsts' = reverse . ("" :) . map (('.' :) . show) $ [0 .. n - 1] dsts = map (path ++) dsts' srcs = drop 1 dsts srcdsts = zip srcs dsts move (src, dst) = do exist <- doesFileExist src when exist $ renameFile src dst -- | Prefix file name with formatted time prefixTime :: FormattedTime -> FilePath -> FilePath prefixTime time path = dropFileName path unpack time ++ "-" ++ takeFileName path ================================================ FILE: fast-logger/System/Log/FastLogger/FileIO.hs ================================================ module System.Log.FastLogger.FileIO where import Foreign.Ptr (Ptr) import GHC.IO.Device (close) import GHC.IO.FD (openFile, stderr, stdout, writeRawBufferPtr) import qualified GHC.IO.FD as POSIX (FD (..)) import GHC.IO.IOMode (IOMode (..)) import System.Log.FastLogger.Imports type FD = POSIX.FD closeFD :: FD -> IO () closeFD = close openFileFD :: FilePath -> IO FD openFileFD f = fst <$> openFile f AppendMode False getStderrFD :: IO FD getStderrFD = return stderr getStdoutFD :: IO FD getStdoutFD = return stdout writeRawBufferPtr2FD :: IORef FD -> Ptr Word8 -> Int -> IO Int writeRawBufferPtr2FD fdref bf len = do fd <- readIORef fdref if isFDValid fd then fromIntegral <$> writeRawBufferPtr "write" fd bf 0 (fromIntegral len) else return (-1) invalidFD :: POSIX.FD invalidFD = stdout{POSIX.fdFD = -1} isFDValid :: POSIX.FD -> Bool isFDValid fd = POSIX.fdFD fd /= -1 ================================================ FILE: fast-logger/System/Log/FastLogger/IO.hs ================================================ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Safe #-} #endif module System.Log.FastLogger.IO where import Data.ByteString.Builder.Extra (Next (..)) import qualified Data.ByteString.Builder.Extra as BBE import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Alloc (free, mallocBytes) import Foreign.Ptr (Ptr, plusPtr) import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr type Buffer = Ptr Word8 -- | The type for buffer size of each core. type BufSize = Int -- | The default buffer size (4,096 bytes). defaultBufSize :: BufSize defaultBufSize = 4096 getBuffer :: BufSize -> IO Buffer getBuffer = mallocBytes freeBuffer :: Buffer -> IO () freeBuffer = free toBufIOWith :: Buffer -> BufSize -> (Buffer -> Int -> IO ()) -> Builder -> IO () toBufIOWith buf size io builder = loop $ BBE.runBuilder builder where loop writer = do (len, next) <- writer buf size io buf len case next of Done -> return () More minSize writer' | size < minSize -> error "toBufIOWith: More: minSize" | otherwise -> loop writer' Chunk (PS fptr off siz) writer' -> withForeignPtr fptr $ \ptr -> io (ptr `plusPtr` off) siz >> loop writer' ================================================ FILE: fast-logger/System/Log/FastLogger/Imports.hs ================================================ {-# LANGUAGE Trustworthy #-} module System.Log.FastLogger.Imports ( ByteString (..), module Control.Applicative, module Control.Monad, module Data.IORef, module Data.List, module Data.Int, module Data.Monoid, module Data.Ord, module Data.Word, module Data.Maybe, module Numeric, ) where import Control.Applicative import Control.Monad import Data.ByteString.Internal (ByteString (..)) import Data.IORef import Data.Int import Data.List import Data.Maybe import Data.Monoid import Data.Ord import Data.Word import Numeric ================================================ FILE: fast-logger/System/Log/FastLogger/Internal.hs ================================================ -- | -- The contents of this module can change at any time without warning. module System.Log.FastLogger.Internal ( module System.Log.FastLogger.IO, module System.Log.FastLogger.FileIO, module System.Log.FastLogger.LogStr, module System.Log.FastLogger.SingleLogger, module System.Log.FastLogger.MultiLogger, module System.Log.FastLogger.Write, module System.Log.FastLogger.LoggerSet, ) where import System.Log.FastLogger.FileIO import System.Log.FastLogger.IO import System.Log.FastLogger.LogStr import System.Log.FastLogger.LoggerSet import System.Log.FastLogger.MultiLogger import System.Log.FastLogger.SingleLogger import System.Log.FastLogger.Write ================================================ FILE: fast-logger/System/Log/FastLogger/LogStr.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} module System.Log.FastLogger.LogStr ( Builder, LogStr (..), logStrLength, fromLogStr, ToLogStr (..), mempty, (<>), ) where import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Short as SBS #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semi (Semigroup(..)) #endif import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T #if MIN_VERSION_text(2,0,0) import qualified Data.Text.Foreign as T #endif import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import System.Log.FastLogger.Imports ---------------------------------------------------------------- toBuilder :: ByteString -> Builder toBuilder = B.byteString fromBuilder :: Builder -> ByteString #if MIN_VERSION_bytestring(0,10,0) fromBuilder = BL.toStrict . B.toLazyByteString #else fromBuilder = BS.concat . BL.toChunks . B.toLazyByteString #endif ---------------------------------------------------------------- -- | Log message builder. Use ('<>') to append two LogStr in O(1). data LogStr = LogStr !Int Builder #if MIN_VERSION_base(4,9,0) instance Semi.Semigroup LogStr where {-# INLINE (<>) #-} LogStr s1 b1 <> LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2) instance Monoid LogStr where mempty = LogStr 0 (toBuilder BS.empty) #else instance Monoid LogStr where mempty = LogStr 0 (toBuilder BS.empty) {-# INLINE mappend #-} LogStr s1 b1 `mappend` LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2) #endif instance IsString LogStr where {-# INLINE fromString #-} fromString = toLogStr . TL.pack -- | Types that can be converted to a 'LogStr'. Instances for -- types from the @text@ library use a UTF-8 encoding. Instances -- for numerical types use a decimal encoding. class ToLogStr msg where toLogStr :: msg -> LogStr instance ToLogStr LogStr where {-# INLINE toLogStr #-} toLogStr = id instance ToLogStr S8.ByteString where {-# INLINE toLogStr #-} toLogStr bs = LogStr (BS.length bs) (toBuilder bs) instance ToLogStr BL.ByteString where {-# INLINE toLogStr #-} toLogStr b = LogStr (fromIntegral (BL.length b)) (B.lazyByteString b) instance ToLogStr Builder where {-# INLINE toLogStr #-} toLogStr x = let b = B.toLazyByteString x in LogStr (fromIntegral (BL.length b)) (B.lazyByteString b) instance ToLogStr SBS.ShortByteString where {-# INLINE toLogStr #-} toLogStr b = LogStr (SBS.length b) (B.shortByteString b) instance ToLogStr String where {-# INLINE toLogStr #-} toLogStr = toLogStr . TL.pack instance ToLogStr T.Text where {-# INLINE toLogStr #-} #if MIN_VERSION_text(2,0,0) toLogStr t = LogStr (T.lengthWord8 t) (T.encodeUtf8Builder t) #else toLogStr = toLogStr . T.encodeUtf8 #endif instance ToLogStr TL.Text where {-# INLINE toLogStr #-} #if MIN_VERSION_text(2,0,0) toLogStr t = LogStr (TL.foldlChunks (\n c -> T.lengthWord8 c + n) 0 t) (TL.encodeUtf8Builder t) #else toLogStr = toLogStr . TL.encodeUtf8 #endif -- | @since 2.4.14 instance ToLogStr Int where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.intDec -- | @since 2.4.14 instance ToLogStr Int8 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.int8Dec -- | @since 2.4.14 instance ToLogStr Int16 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.int16Dec -- | @since 2.4.14 instance ToLogStr Int32 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.int32Dec -- | @since 2.4.14 instance ToLogStr Int64 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.int64Dec -- | @since 2.4.14 instance ToLogStr Word where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.wordDec -- | @since 2.4.14 instance ToLogStr Word8 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.word8Dec -- | @since 2.4.14 instance ToLogStr Word16 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.word16Dec -- | @since 2.4.14 instance ToLogStr Word32 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.word32Dec -- | @since 2.4.14 instance ToLogStr Word64 where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.word64Dec -- | @since 2.4.14 instance ToLogStr Integer where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.integerDec -- | @since 2.4.14 instance ToLogStr Float where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.floatDec -- | @since 2.4.14 instance ToLogStr Double where {-# INLINE toLogStr #-} toLogStr = toLogStr . B.doubleDec instance Show LogStr where show = show . T.decodeUtf8 . fromLogStr instance Eq LogStr where a == b = fromLogStr a == fromLogStr b -- | Obtaining the length of 'LogStr'. logStrLength :: LogStr -> Int logStrLength (LogStr n _) = n -- | Converting 'LogStr' to 'ByteString'. fromLogStr :: LogStr -> ByteString fromLogStr (LogStr _ builder) = fromBuilder builder ================================================ FILE: fast-logger/System/Log/FastLogger/LoggerSet.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module System.Log.FastLogger.LoggerSet ( -- * Creating a logger set LoggerSet, newFileLoggerSet, newFileLoggerSetN, newStdoutLoggerSet, newStdoutLoggerSetN, newStderrLoggerSet, newStderrLoggerSetN, newLoggerSet, newFDLoggerSet, -- * Renewing and removing a logger set renewLoggerSet, rmLoggerSet, -- * Writing a log message pushLogStr, pushLogStrLn, -- * Flushing buffered log messages flushLogStr, -- * Misc replaceLoggerSet, ) where import Control.Concurrent (getNumCapabilities) import Control.Debounce (debounceAction, defaultDebounceSettings, mkDebounce, debounceThreadName) import System.Log.FastLogger.FileIO import System.Log.FastLogger.IO import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr import System.Log.FastLogger.MultiLogger (MultiLogger) import qualified System.Log.FastLogger.MultiLogger as M import System.Log.FastLogger.SingleLogger (SingleLogger) import qualified System.Log.FastLogger.SingleLogger as S import System.Log.FastLogger.Write ---------------------------------------------------------------- data Logger = SL SingleLogger | ML MultiLogger ---------------------------------------------------------------- -- | A set of loggers. -- The number of loggers is the capabilities of GHC RTS. -- You can specify it with \"+RTS -N\\". -- A buffer is prepared for each capability. data LoggerSet = LoggerSet { lgrsetFilePath :: Maybe FilePath , lgrsetFdRef :: IORef FD , lgrsetLogger :: Logger , lgrsetDebounce :: IO () } -- | Creating a new 'LoggerSet' using a file. -- -- Uses `numCapabilties` many buffers, which will result in log -- output that is not ordered by time (see `newFileLoggerSetN`). newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet newFileLoggerSet size file = openFileFD file >>= newFDLoggerSet size Nothing (Just file) -- | Creating a new 'LoggerSet' using a file, using only the given number of capabilites. -- -- Giving @mn = Just 1@ scales less well on multi-core machines, -- but provides time-ordered output. newFileLoggerSetN :: BufSize -> Maybe Int -> FilePath -> IO LoggerSet newFileLoggerSetN size mn file = openFileFD file >>= newFDLoggerSet size mn (Just file) -- | Creating a new 'LoggerSet' using stdout. newStdoutLoggerSet :: BufSize -> IO LoggerSet newStdoutLoggerSet size = getStdoutFD >>= newFDLoggerSet size Nothing Nothing -- | Creating a new 'LoggerSet' using stdout, with the given number of buffers -- (see `newFileLoggerSetN`). newStdoutLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet newStdoutLoggerSetN size mn = getStdoutFD >>= newFDLoggerSet size mn Nothing -- | Creating a new 'LoggerSet' using stderr. newStderrLoggerSet :: BufSize -> IO LoggerSet newStderrLoggerSet size = getStderrFD >>= newFDLoggerSet size Nothing Nothing -- | Creating a new 'LoggerSet' using stderr, with the given number of buffers -- (see `newFileLoggerSetN`). newStderrLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet newStderrLoggerSetN size mn = getStderrFD >>= newFDLoggerSet size mn Nothing {-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-} -- | Creating a new 'LoggerSet'. -- If 'Nothing' is specified to the second argument, -- stdout is used. -- Please note that the minimum 'BufSize' is 1. newLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> IO LoggerSet newLoggerSet size mn = maybe (newStdoutLoggerSet size) (newFileLoggerSetN size mn) -- | Creating a new 'LoggerSet' using a FD. newFDLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet newFDLoggerSet size mn mfile fd = do n <- case mn of Just n' -> return n' Nothing -> getNumCapabilities fdref <- newIORef fd let bufsiz = max 1 size logger <- if n == 1 && mn == Just 1 then SL <$> S.newSingleLogger bufsiz fdref else do ML <$> M.newMultiLogger n bufsiz fdref flush <- mkDebounce defaultDebounceSettings { debounceAction = flushLogStrRaw logger , debounceThreadName = "Loggerset of FastLogger (Debounce)" } return $ LoggerSet { lgrsetFilePath = mfile , lgrsetFdRef = fdref , lgrsetLogger = logger , lgrsetDebounce = flush } -- | Writing a log message to the corresponding buffer. -- If the buffer becomes full, the log messages in the buffer -- are written to its corresponding file, stdout, or stderr. pushLogStr :: LoggerSet -> LogStr -> IO () pushLogStr LoggerSet{..} logmsg = case lgrsetLogger of SL sl -> do pushLog sl logmsg lgrsetDebounce ML ml -> do pushLog ml logmsg lgrsetDebounce -- | Same as 'pushLogStr' but also appends a newline. pushLogStrLn :: LoggerSet -> LogStr -> IO () pushLogStrLn loggerSet logStr = pushLogStr loggerSet (logStr <> "\n") -- | Flushing log messages in buffers. -- This function must be called explicitly when the program is -- being terminated. -- -- Note: Since version 2.1.6, this function does not need to be -- explicitly called, as every push includes an auto-debounced flush -- courtesy of the auto-update package. Since version 2.2.2, this -- function can be used to force flushing outside of the debounced -- flush calls. flushLogStr :: LoggerSet -> IO () flushLogStr LoggerSet{..} = flushLogStrRaw lgrsetLogger flushLogStrRaw :: Logger -> IO () flushLogStrRaw (SL sl) = flushAllLog sl flushLogStrRaw (ML ml) = flushAllLog ml -- | Renewing the internal file information in 'LoggerSet'. -- This does nothing for stdout and stderr. renewLoggerSet :: LoggerSet -> IO () renewLoggerSet LoggerSet{..} = case lgrsetFilePath of Nothing -> return () Just file -> do newfd <- openFileFD file oldfd <- atomicModifyIORef' lgrsetFdRef (\fd -> (newfd, fd)) closeFD oldfd -- | Flushing the buffers, closing the internal file information -- and freeing the buffers. rmLoggerSet :: LoggerSet -> IO () rmLoggerSet LoggerSet{..} = do fd <- readIORef lgrsetFdRef when (isFDValid fd) $ do case lgrsetLogger of SL sl -> stopLoggers sl ML ml -> stopLoggers ml when (isJust lgrsetFilePath) $ closeFD fd writeIORef lgrsetFdRef invalidFD -- | Replacing the file path in 'LoggerSet' and returning a new -- 'LoggerSet' and the old file path. replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath) replaceLoggerSet lgrset@LoggerSet{..} new_file_path = (lgrset{lgrsetFilePath = Just new_file_path}, lgrsetFilePath) ================================================ FILE: fast-logger/System/Log/FastLogger/MultiLogger.hs ================================================ {-# LANGUAGE RecordWildCards #-} module System.Log.FastLogger.MultiLogger ( MultiLogger, newMultiLogger, ) where import Control.Concurrent ( MVar, myThreadId, newMVar, takeMVar, threadCapability, withMVar, ) import Data.Array (Array, bounds, listArray, (!)) import System.Log.FastLogger.FileIO import System.Log.FastLogger.IO import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr import System.Log.FastLogger.Write ---------------------------------------------------------------- newtype MLogger = MLogger { lgrRef :: IORef LogStr } -- | A scale but non-time-ordered logger. data MultiLogger = MultiLogger { mlgrArray :: Array Int MLogger , mlgrMBuffer :: MVar Buffer , mlgrBufSize :: BufSize , mlgrFdRef :: IORef FD } instance Loggers MultiLogger where stopLoggers = System.Log.FastLogger.MultiLogger.stopLoggers pushLog = System.Log.FastLogger.MultiLogger.pushLog flushAllLog = System.Log.FastLogger.MultiLogger.flushAllLog ---------------------------------------------------------------- newMLogger :: IO MLogger newMLogger = MLogger <$> newIORef mempty -- | Creating `MultiLogger`. -- The first argument is the number of the internal builders. newMultiLogger :: Int -> BufSize -> IORef FD -> IO MultiLogger newMultiLogger n bufsize fdref = do mbuf <- getBuffer bufsize >>= newMVar arr <- listArray (0, n - 1) <$> replicateM n newMLogger return $ MultiLogger { mlgrArray = arr , mlgrMBuffer = mbuf , mlgrBufSize = bufsize , mlgrFdRef = fdref } ---------------------------------------------------------------- pushLog :: MultiLogger -> LogStr -> IO () pushLog ml@MultiLogger{..} logmsg = do (i, _) <- myThreadId >>= threadCapability -- The number of capability could be dynamically changed. -- So, let's check the upper boundary of the array. let u = snd $ bounds mlgrArray lim = u + 1 j | i < lim = i | otherwise = i `mod` lim let logger = mlgrArray ! j pushLog' logger logmsg where pushLog' logger@MLogger{..} nlogmsg@(LogStr nlen _) | nlen > mlgrBufSize = do flushLog ml logger -- Make sure we have a large enough buffer to hold the entire -- contents, thereby allowing for a single write system call and -- avoiding interleaving. This does not address the possibility -- of write not writing the entire buffer at once. writeBigLogStr' ml nlogmsg | otherwise = do action <- atomicModifyIORef' lgrRef checkBuf action where checkBuf ologmsg@(LogStr olen _) | mlgrBufSize < olen + nlen = (nlogmsg, writeLogStr' ml ologmsg) | otherwise = (ologmsg <> nlogmsg, return ()) ---------------------------------------------------------------- flushAllLog :: MultiLogger -> IO () flushAllLog ml@MultiLogger{..} = do let flushIt i = flushLog ml (mlgrArray ! i) (l, u) = bounds mlgrArray nums = [l .. u] mapM_ flushIt nums flushLog :: MultiLogger -> MLogger -> IO () flushLog ml MLogger{..} = do -- If a special buffer is prepared for flusher, this MVar could -- be removed. But such a code does not contribute logging speed -- according to experiment. And even with the special buffer, -- there is no grantee that this function is exclusively called -- for a buffer. So, we use MVar here. -- This is safe and speed penalty can be ignored. old <- atomicModifyIORef' lgrRef (\old -> (mempty, old)) writeLogStr' ml old ---------------------------------------------------------------- stopLoggers :: MultiLogger -> IO () stopLoggers ml@MultiLogger{..} = do System.Log.FastLogger.MultiLogger.flushAllLog ml takeMVar mlgrMBuffer >>= freeBuffer ---------------------------------------------------------------- writeLogStr' :: MultiLogger -> LogStr -> IO () writeLogStr' MultiLogger{..} logstr = withMVar mlgrMBuffer $ \buf -> writeLogStr buf mlgrFdRef logstr writeBigLogStr' :: MultiLogger -> LogStr -> IO () writeBigLogStr' MultiLogger{..} logstr = withMVar mlgrMBuffer $ \_ -> writeBigLogStr mlgrFdRef logstr ================================================ FILE: fast-logger/System/Log/FastLogger/SingleLogger.hs ================================================ {-# LANGUAGE RecordWildCards #-} module System.Log.FastLogger.SingleLogger ( SingleLogger, newSingleLogger, ) where import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM import GHC.Conc.Sync (labelThread) import System.Log.FastLogger.FileIO import System.Log.FastLogger.IO import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr import System.Log.FastLogger.Write ---------------------------------------------------------------- data Ent = F (MVar ()) Bool | L LogStr type Q = [Ent] -- writer queue -- | A non-scale but time-ordered logger. data SingleLogger = SingleLogger { slgrRef :: IORef (LogStr, Q) , slgrFlush :: Bool -> IO () -- teminate if False , slgrWakeup :: IO () , slgrBuffer :: Buffer , slgrBufSize :: BufSize , slgrFdRef :: IORef FD } instance Loggers SingleLogger where stopLoggers = System.Log.FastLogger.SingleLogger.stopLoggers pushLog = System.Log.FastLogger.SingleLogger.pushLog flushAllLog = System.Log.FastLogger.SingleLogger.flushAllLog ---------------------------------------------------------------- writer :: BufSize -> Buffer -> IORef FD -> TVar Int -> IORef (LogStr, Q) -> IO () writer bufsize buf fdref tvar ref = loop (0 :: Int) where loop cnt = do cnt' <- atomically $ do n <- readTVar tvar check (n /= cnt) return n msgs <- reverse <$> atomicModifyIORef' ref (\(msg, q) -> ((msg, []), q)) cont <- go msgs when cont $ loop cnt' go [] = return True go (F mvar cont : msgs) = do putMVar mvar () if cont then go msgs else return False go (L msg@(LogStr len _) : msgs) | len <= bufsize = writeLogStr buf fdref msg >> go msgs | otherwise = writeBigLogStr fdref msg >> go msgs ---------------------------------------------------------------- -- | Creating `SingleLogger`. newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger newSingleLogger bufsize fdref = do tvar <- newTVarIO 0 ref <- newIORef (mempty, []) buf <- getBuffer bufsize tid <- forkIO $ writer bufsize buf fdref tvar ref labelThread tid "FastLogger single logger's writer" let wakeup = atomically $ modifyTVar' tvar (+ 1) flush cont = do mvar <- newEmptyMVar let fin = F mvar cont atomicModifyIORef' ref (\(old, q) -> ((mempty, fin : L old : q), ())) wakeup takeMVar mvar return $ SingleLogger { slgrRef = ref , slgrFlush = flush , slgrWakeup = wakeup , slgrBuffer = buf , slgrBufSize = bufsize , slgrFdRef = fdref } ---------------------------------------------------------------- pushLog :: SingleLogger -> LogStr -> IO () pushLog SingleLogger{..} nlogmsg@(LogStr nlen _) | nlen > slgrBufSize = do atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L nlogmsg : L old : q), ())) slgrWakeup | otherwise = do wake <- atomicModifyIORef' slgrRef checkBuf when wake slgrWakeup where checkBuf (ologmsg@(LogStr olen _), q) | slgrBufSize < olen + nlen = ((nlogmsg, L ologmsg : q), True) | otherwise = ((ologmsg <> nlogmsg, q), False) flushAllLog :: SingleLogger -> IO () flushAllLog SingleLogger{..} = do atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L old : q), ())) slgrFlush True stopLoggers :: SingleLogger -> IO () stopLoggers SingleLogger{..} = do slgrFlush False freeBuffer slgrBuffer ================================================ FILE: fast-logger/System/Log/FastLogger/Types.hs ================================================ module System.Log.FastLogger.Types ( -- * Types TimeFormat, FormattedTime, ) where import System.Log.FastLogger.Imports ---------------------------------------------------------------- -- | Type aliaes for date format and formatted date. type FormattedTime = ByteString type TimeFormat = ByteString ================================================ FILE: fast-logger/System/Log/FastLogger/Write.hs ================================================ {-# LANGUAGE RecordWildCards #-} module System.Log.FastLogger.Write ( writeLogStr, writeBigLogStr, Loggers (..), ) where import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (plusPtr) import System.Log.FastLogger.FileIO import System.Log.FastLogger.IO import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr ---------------------------------------------------------------- -- | Writting 'LogStr' using a buffer in blocking mode. -- The size of 'LogStr' must be smaller or equal to -- the size of buffer. writeLogStr :: Buffer -> IORef FD -> LogStr -> IO () writeLogStr buf fdref (LogStr len builder) = toBufIOWith buf len (write fdref) builder -- | Writting 'LogStr' using a temporary buffer. writeBigLogStr :: IORef FD -> LogStr -> IO () writeBigLogStr fdref (LogStr len builder) = allocaBytes len $ \buf -> toBufIOWith buf len (write fdref) builder write :: IORef FD -> Buffer -> Int -> IO () write fdref buf len' = loop buf (fromIntegral len') where loop bf len = do written <- writeRawBufferPtr2FD fdref bf len when (0 <= written && written < len) $ loop (bf `plusPtr` fromIntegral written) (len - written) ---------------------------------------------------------------- -- | A class for internal loggers. class Loggers a where stopLoggers :: a -> IO () pushLog :: a -> LogStr -> IO () flushAllLog :: a -> IO () ================================================ FILE: fast-logger/System/Log/FastLogger.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides a fast logging system which -- scales on multicore environments (i.e. +RTS -N\). -- -- Note: This library does not guarantee correct ordering of log messages -- when program is run on more than one core thus users -- should rely more on message timestamps than on their order in the -- log. module System.Log.FastLogger ( -- * FastLogger FastLogger, LogType, LogType' (..), newFastLogger, newFastLogger1, withFastLogger, -- * Timed FastLogger TimedFastLogger, newTimedFastLogger, withTimedFastLogger, -- * Log messages LogStr, ToLogStr (..), fromLogStr, logStrLength, -- * Buffer size BufSize, defaultBufSize, -- * LoggerSet module System.Log.FastLogger.LoggerSet, -- * Date cache module System.Log.FastLogger.Date, -- * File rotation module System.Log.FastLogger.File, -- * Types module System.Log.FastLogger.Types, ) where import Control.Concurrent (MVar, newMVar, putMVar, tryTakeMVar) import Control.Exception (SomeException (..), bracket, handle) import System.EasyFile (getFileSize) import System.Log.FastLogger.Date import System.Log.FastLogger.File import System.Log.FastLogger.IO import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr import System.Log.FastLogger.LoggerSet import System.Log.FastLogger.Types ---------------------------------------------------------------- -- | 'FastLogger' simply log 'logStr'. type FastLogger = LogStr -> IO () -- | 'TimedFastLogger' pass 'FormattedTime' to callback and simply log its result. -- this can be used to customize how to log timestamp. -- -- Usually, one would write a wrapper on top of 'TimedFastLogger', for example: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > log :: TimedFastLogger -> LogStr -> IO () -- > log logger msg = logger (\time -> toLogStr (show time) <> " " <> msg <> "\n") type TimedFastLogger = (FormattedTime -> LogStr) -> IO () type LogType = LogType' LogStr -- | Logger Type. data LogType' a where LogNone :: LogType' LogStr -- ^ No logging. LogStdout :: BufSize -> LogType' LogStr -- ^ Logging to stdout. -- 'BufSize' is a buffer size -- for each capability. LogStderr :: BufSize -> LogType' LogStr -- ^ Logging to stderr. -- 'BufSize' is a buffer size -- for each capability. LogFileNoRotate :: FilePath -> BufSize -> LogType' LogStr -- ^ Logging to a file. -- 'BufSize' is a buffer size -- for each capability. LogFile :: FileLogSpec -> BufSize -> LogType' LogStr -- ^ Logging to a file. -- 'BufSize' is a buffer size -- for each capability. -- File rotation is done on-demand. LogFileTimedRotate :: TimedFileLogSpec -> BufSize -> LogType' LogStr -- ^ Logging to a file. -- 'BufSize' is a buffer size -- for each capability. -- Rotation happens based on check specified -- in 'TimedFileLogSpec'. LogCallback :: (v -> IO ()) -> IO () -> LogType' v -- ^ Logging with a log and flush action. -- run flush after log each message. -- | Initialize a 'FastLogger' without attaching timestamp -- a tuple of logger and clean up action are returned. -- This type signature should be read as: -- -- > newFastLogger :: LogType -> IO (FastLogger, IO ()) -- -- This logger uses `numCapabilities` many buffers, and thus -- does not provide time-ordered output. -- For time-ordered output, use `newFastLogger1`. newFastLogger :: LogType' v -> IO (v -> IO (), IO ()) newFastLogger typ = newFastLoggerCore Nothing typ -- | Like `newFastLogger`, but creating a logger that uses only 1 -- internal builder. This scales less on multi-core machines and -- consumes more memory because of an internal queue but provides -- time-ordered output. newFastLogger1 :: LogType' v -> IO (v -> IO (), IO ()) newFastLogger1 typ = newFastLoggerCore (Just 1) typ newFastLoggerCore :: Maybe Int -> LogType' v -> IO (v -> IO (), IO ()) newFastLoggerCore mn typ = case typ of LogNone -> return (const noOp, noOp) LogStdout bsize -> newStdoutLoggerSetN bsize mn >>= stdLoggerInit LogStderr bsize -> newStderrLoggerSetN bsize mn >>= stdLoggerInit LogFileNoRotate fp bsize -> newFileLoggerSetN bsize mn fp >>= fileLoggerInit LogFile fspec bsize -> rotateLoggerInit fspec bsize LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize LogCallback cb flush -> return (\str -> cb str >> flush, noOp) where stdLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset) fileLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset) rotateLoggerInit fspec bsize = do lgrset <- newFileLoggerSetN bsize mn $ log_file fspec ref <- newIORef (0 :: Int) mvar <- newMVar () let logger str = do cnt <- decrease ref pushLogStr lgrset str when (cnt <= 0) $ tryRotate lgrset fspec ref mvar return (logger, rmLoggerSet lgrset) timedRotateLoggerInit fspec bsize = do cache <- newTimeCache $ timed_timefmt fspec now <- cache lgrset <- newFileLoggerSetN bsize mn $ prefixTime now $ timed_log_file fspec ref <- newIORef now mvar <- newMVar lgrset let logger str = do ct <- cache updated <- updateTime (timed_same_timeframe fspec) ref ct when updated $ tryTimedRotate fspec ct mvar pushLogStr lgrset str return (logger, rmLoggerSet lgrset) -- | 'bracket' version of 'newFastLogger' withFastLogger :: LogType -> (FastLogger -> IO a) -> IO a withFastLogger typ log' = bracket (newFastLogger typ) snd (log' . fst) -- | Initialize a 'FastLogger' with timestamp attached to each message. -- a tuple of logger and clean up action are returned. newTimedFastLogger :: IO FormattedTime -- ^ How do we get 'FormattedTime'? -- "System.Log.FastLogger.Date" provide cached formatted time. -> LogType -> IO (TimedFastLogger, IO ()) newTimedFastLogger tgetter typ = case typ of LogNone -> return (const noOp, noOp) LogStdout bsize -> newStdoutLoggerSet bsize >>= stdLoggerInit LogStderr bsize -> newStderrLoggerSet bsize >>= stdLoggerInit LogFileNoRotate fp bsize -> newFileLoggerSet bsize fp >>= fileLoggerInit LogFile fspec bsize -> rotateLoggerInit fspec bsize LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize LogCallback cb flush -> return (\f -> tgetter >>= cb . f >> flush, noOp) where stdLoggerInit lgrset = return (\f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset) fileLoggerInit lgrset = return (\f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset) rotateLoggerInit fspec bsize = do lgrset <- newFileLoggerSet bsize $ log_file fspec ref <- newIORef (0 :: Int) mvar <- newMVar () let logger f = do cnt <- decrease ref t <- tgetter pushLogStr lgrset (f t) when (cnt <= 0) $ tryRotate lgrset fspec ref mvar return (logger, rmLoggerSet lgrset) timedRotateLoggerInit fspec bsize = do cache <- newTimeCache $ timed_timefmt fspec now <- cache lgrset <- newFileLoggerSet bsize $ prefixTime now $ timed_log_file fspec ref <- newIORef now mvar <- newMVar lgrset let logger f = do ct <- cache updated <- updateTime (timed_same_timeframe fspec) ref ct when updated $ tryTimedRotate fspec ct mvar t <- tgetter pushLogStr lgrset (f t) return (logger, rmLoggerSet lgrset) -- | 'bracket' version of 'newTimeFastLogger' withTimedFastLogger :: IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a withTimedFastLogger tgetter typ log' = bracket (newTimedFastLogger tgetter typ) snd (log' . fst) ---------------------------------------------------------------- noOp :: IO () noOp = return () decrease :: IORef Int -> IO Int decrease ref = atomicModifyIORef' ref (\x -> (x - 1, x - 1)) -- updateTime returns whether the timeframe has changed updateTime :: (FormattedTime -> FormattedTime -> Bool) -> IORef FormattedTime -> FormattedTime -> IO Bool updateTime cmp ref newTime = atomicModifyIORef' ref (\x -> (newTime, not $ cmp x newTime)) tryRotate :: LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO () tryRotate lgrset spec ref mvar = bracket lock unlock rotateFiles where lock = tryTakeMVar mvar unlock Nothing = return () unlock _ = putMVar mvar () rotateFiles Nothing = return () rotateFiles _ = do msiz <- getSize case msiz of -- A file is not available. -- So, let's set a big value to the counter so that -- this function is not called frequently. Nothing -> writeIORef ref 1000000 Just siz | siz > limit -> do rotate spec renewLoggerSet lgrset writeIORef ref $ estimate limit | otherwise -> writeIORef ref $ estimate (limit - siz) file = log_file spec limit = log_file_size spec getSize = handle (\(SomeException _) -> return Nothing) $ -- The log file is locked by GHC. -- We need to get its file size by the way not using locks. Just . fromIntegral <$> getFileSize file -- 200 is an ad-hoc value for the length of log line. estimate x = fromInteger (x `div` 200) tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO () tryTimedRotate spec now mvar = bracket lock unlock rotateFiles where lock = tryTakeMVar mvar unlock Nothing = return () unlock (Just lgrset) = do let (newlgrset, current_path) = replaceLoggerSet lgrset new_file_path putMVar mvar newlgrset case current_path of Nothing -> return () Just path -> timed_post_process spec path rotateFiles Nothing = return () rotateFiles (Just lgrset) = do let (newlgrset, _) = replaceLoggerSet lgrset new_file_path renewLoggerSet newlgrset new_file_path = prefixTime now $ timed_log_file spec ================================================ FILE: fast-logger/fast-logger.cabal ================================================ cabal-version: >=1.10 name: fast-logger version: 3.2.6 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto author: Kazu Yamamoto tested-with: ghc ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3 homepage: https://github.com/kazu-yamamoto/logger synopsis: A fast logging system description: A fast logging system for Haskell category: System build-type: Simple extra-source-files: README.md ChangeLog.md source-repository head type: git location: https://github.com/kazu-yamamoto/logger.git library exposed-modules: System.Log.FastLogger System.Log.FastLogger.Date System.Log.FastLogger.File System.Log.FastLogger.Internal System.Log.FastLogger.LoggerSet System.Log.FastLogger.Types other-modules: System.Log.FastLogger.Imports System.Log.FastLogger.FileIO System.Log.FastLogger.IO System.Log.FastLogger.LogStr System.Log.FastLogger.MultiLogger System.Log.FastLogger.SingleLogger System.Log.FastLogger.Write default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.9 && <5, array, auto-update >=0.2.2, easy-file >=0.2, bytestring >=0.10.4, directory, filepath, stm, text, unix-time >=0.4.4, unix-compat >=0.2 if impl(ghc <7.8) build-depends: bytestring-builder if impl(ghc >=8) default-extensions: Strict StrictData test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs build-tools: hspec-discover >=2.6 hs-source-dirs: test other-modules: FastLoggerSpec default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4 && <5, async, bytestring >=0.10.4, directory, fast-logger, hspec if impl(ghc >=8) default-extensions: Strict StrictData ================================================ FILE: fast-logger/test/FastLoggerSpec.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module FastLoggerSpec (spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Concurrent (getNumCapabilities) import Control.Concurrent.Async (forConcurrently_) import Control.Exception (finally) import Control.Monad (forM_, when) import qualified Data.ByteString.Char8 as BS import Data.List (sort) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.String (IsString (fromString)) import System.Directory (doesFileExist, removeFile) import Text.Printf (printf) import Test.Hspec import Test.Hspec.QuickCheck (prop) import System.Log.FastLogger spec :: Spec spec = do describe "instance Show LogStr" $ do prop "it should be consistent with instance IsString" $ \str -> let logstr :: LogStr logstr = fromString str in show logstr == show str describe "instance Eq LogStr" $ do prop "it should be consistent with instance IsString" $ \str1 str2 -> let logstr1, logstr2 :: LogStr logstr1 = fromString str1 logstr2 = fromString str2 in (logstr1 == logstr2) == (str1 == str2) describe "pushLogMsg" $ do it "is safe for a large message" $ safeForLarge [ 100 , 1000 , 10000 , 100000 , 1000000 ] it "logs all messages" logAllMsgs describe "fastlogger 1" $ do it "maintains the ordering of log messages" logOrdering tempFile :: FilePath tempFile = "test/temp.txt" safeForLarge :: [Int] -> IO () safeForLarge = mapM_ safeForLarge' safeForLarge' :: Int -> IO () safeForLarge' n = flip finally (cleanup tempFile) $ do cleanup tempFile lgrset <- newFileLoggerSet defaultBufSize tempFile let xs = toLogStr $ BS.pack $ take (abs n) (cycle ['a' .. 'z']) lf = "x" pushLogStr lgrset $ xs <> lf flushLogStr lgrset rmLoggerSet lgrset bs <- BS.readFile tempFile bs `shouldBe` BS.pack (take (abs n) (cycle ['a' .. 'z']) <> "x") cleanup :: FilePath -> IO () cleanup file = do exist <- doesFileExist file when exist $ removeFile file logAllMsgs :: IO () logAllMsgs = logAll "LICENSE" `finally` cleanup tempFile where logAll file = do cleanup tempFile lgrset <- newFileLoggerSet 512 tempFile src <- BS.readFile file let bs = (<> "\n") . toLogStr <$> BS.lines src mapM_ (pushLogStr lgrset) bs flushLogStr lgrset rmLoggerSet lgrset dst <- BS.readFile tempFile dst `shouldBe` src logOrdering :: IO () logOrdering = flip finally (cleanup tempFile) $ do cleanup tempFile -- 128 is small enough for out-of-ordering (pushlog, teardown) <- newFastLogger1 $ LogFileNoRotate tempFile 128 numCapabilities <- getNumCapabilities let concurrency = numCapabilities * 200 :: Int logEntriesCount = 100 :: Int forConcurrently_ [0 .. concurrency - 1] $ \t -> forM_ [0 .. logEntriesCount - 1] $ \i -> do let tag = mktag t cnt = printf "%02d" i :: String logmsg = toLogStr tag <> "log line nr: " <> toLogStr cnt <> "\n" pushlog logmsg teardown xs <- BS.lines <$> BS.readFile tempFile forM_ [0 .. concurrency - 1] $ \t -> do let tag = BS.pack $ mktag t msgs = filter (tag `BS.isPrefixOf`) xs sort msgs `shouldBe` msgs where mktag :: Int -> String mktag t = "thread id: " <> show t <> " " ================================================ FILE: fast-logger/test/Spec.hs ================================================ {-# OPTIONS_GHC -F -pgmF hspec-discover #-} ================================================ FILE: fourmolu.yaml ================================================ # Number of spaces per indentation step indentation: 4 # Max line length for automatic line breaking column-limit: 80 # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) function-arrows: leading # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) comma-style: leading # Styling of import/export lists (choices: leading, trailing, or diff-friendly) import-export-style: diff-friendly # Whether to full-indent or half-indent 'where' bindings past the preceding body indent-wheres: false # Whether to leave a space before an opening record brace record-brace-space: false # Number of spaces between top-level declarations newlines-between-decls: 1 # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) haddock-style: single-line # How to print module docstring haddock-style-module: null # Styling of let blocks (choices: auto, inline, newline, or mixed) let-style: inline # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) in-style: right-align # Whether to put parentheses around a single constraint (choices: auto, always, or never) single-constraint-parens: never # Output Unicode syntax (choices: detect, always, or never) unicode: never # Give the programmer more choice on where to insert blank lines respectful: true # Fixity information for operators fixities: [] ================================================ FILE: sources.txt ================================================ ./fast-logger ================================================ FILE: stack.yaml ================================================ resolver: lts-14.22 packages: - wai-logger/ - fast-logger/ extra-deps: - unix-time-0.4.4 ================================================ FILE: wai-logger/.gitignore ================================================ dist/ ================================================ FILE: wai-logger/LICENSE ================================================ Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: wai-logger/Network/Wai/Logger/Apache.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Network.Wai.Logger.Apache ( IPAddrSource (..), apacheLogStr, serverpushLogStr, ) where #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_wai #define MIN_VERSION_wai(x,y,z) 1 #endif import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import Data.List (find) import Data.Maybe (fromMaybe) #if MIN_VERSION_base(4,5,0) import Data.Monoid ((<>), First (..)) #else import Data.Monoid (mappend) #endif import Network.HTTP.Types (Status, statusCode) import Network.HTTP.Types.Header (HeaderName) import Network.Wai (Request (..)) import Network.Wai.Logger.IP import System.Log.FastLogger -- $setup -- >>> :set -XOverloadedStrings -- >>> import Network.Wai (defaultRequest) -- | Source from which the IP source address of the client is obtained. data IPAddrSource = -- | From the peer address of the HTTP connection. FromSocket | -- | From @X-Real-IP@ or @X-Forwarded-For@ in the HTTP header. -- -- This picks either @X-Real-IP@ or @X-Forwarded-For@ depending on which of these -- headers comes first in the ordered list of request headers. -- -- If the @X-Forwarded-For@ header is picked, the value will be assumed to be a -- comma-separated list of IP addresses. The value will be parsed, and the -- left-most IP address will be used (which is mostly likely to be the actual -- client IP address). FromHeader | -- | From a custom HTTP header, useful in proxied environment. -- -- The header value will be assumed to be a comma-separated list of IP -- addresses. The value will be parsed, and the left-most IP address will be -- used (which is mostly likely to be the actual client IP address). -- -- Note that this still works as expected for a single IP address. FromHeaderCustom [HeaderName] | -- | Just like 'FromHeader', but falls back on the peer address if header is not found. FromFallback | -- | This gives you the most flexibility to figure out the IP source address -- from the 'Request'. The returned 'ByteString' is used as the IP source -- address. FromRequest (Request -> ByteString) -- | Apache style log format. apacheLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr apacheLogStr ipsrc userget tmstr req status msize = toLogStr (getSourceIP ipsrc req) <> " - " <> maybe "-" toLogStr (userget req) <> " [" <> toLogStr tmstr <> "] \"" <> toLogStr (requestMethod req) <> " " <> toLogStr path <> " " <> toLogStr (show (httpVersion req)) <> "\" " <> toLogStr (show (statusCode status)) <> " " <> toLogStr (maybe "-" show msize) <> " \"" <> toLogStr (fromMaybe "" mr) <> "\" \"" <> toLogStr (fromMaybe "" mua) <> "\"\n" where path = rawPathInfo req <> rawQueryString req #if !MIN_VERSION_base(4,5,0) (<>) = mappend #endif #if MIN_VERSION_wai(3,2,0) mr = requestHeaderReferer req mua = requestHeaderUserAgent req #else mr = lookup "referer" $ requestHeaders req mua = lookup "user-agent" $ requestHeaders req #endif -- | HTTP/2 Push log format in the Apache style. serverpushLogStr :: ToLogStr user => IPAddrSource -> (Request -> Maybe user) -> FormattedTime -> Request -> ByteString -> Integer -> LogStr serverpushLogStr ipsrc userget tmstr req path size = toLogStr (getSourceIP ipsrc req) <> " - " <> maybe "-" toLogStr (userget req) <> " [" <> toLogStr tmstr <> "] \"PUSH " <> toLogStr path <> " HTTP/2\" 200 " <> toLogStr (show size) <> " \"" <> toLogStr ref <> "\" \"" <> toLogStr (fromMaybe "" mua) <> "\"\n" where ref = rawPathInfo req #if !MIN_VERSION_base(4,5,0) (<>) = mappend #endif #if MIN_VERSION_wai(3,2,0) mua = requestHeaderUserAgent req #else mua = lookup "user-agent" $ requestHeaders req #endif getSourceIP :: IPAddrSource -> Request -> ByteString getSourceIP FromSocket = getSourceFromSocket getSourceIP FromHeader = getSourceFromHeader getSourceIP FromFallback = getSourceFromFallback getSourceIP (FromHeaderCustom hs) = fromMaybe "-" . getSourceFromHeaderCustom hs getSourceIP (FromRequest fromReq) = fromReq -- | -- >>> getSourceFromSocket defaultRequest -- "0.0.0.0" getSourceFromSocket :: Request -> ByteString getSourceFromSocket = BS.pack . showSockAddr . remoteHost -- | -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] } -- "127.0.0.1" -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] } -- "127.0.0.1" -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] } -- "-" -- >>> getSourceFromHeader defaultRequest { requestHeaders = [] } -- "-" -- -- 'getSourceFromHeader' uses the first instance of either @"X-Real-IP"@ or -- @"X-Forwarded-For"@ that it finds in the ordered header list: -- -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Real-IP", "1.2.3.4"), ("X-Forwarded-For", "5.6.7.8") ] } -- "1.2.3.4" -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8"), ("X-Real-IP", "1.2.3.4") ] } -- "5.6.7.8" -- -- 'getSourceFromHeader' handles pulling out the first IP in the -- comma-separated IP list in X-Forwarded-For: -- -- >>> getSourceFromHeader defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } -- "5.6.7.8" getSourceFromHeader :: Request -> ByteString getSourceFromHeader = fromMaybe "-" . getSource -- | -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] } -- "127.0.0.1" -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] } -- "127.0.0.1" -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] } -- "0.0.0.0" -- >>> getSourceFromFallback defaultRequest { requestHeaders = [] } -- "0.0.0.0" -- -- 'getSourceFromFallback' uses the first instance of either @"X-Real-IP"@ or -- @"X-Forwarded-For"@ that it finds in the ordered header list: -- -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Real-IP", "1.2.3.4"), ("X-Forwarded-For", "5.6.7.8") ] } -- "1.2.3.4" -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8"), ("X-Real-IP", "1.2.3.4") ] } -- "5.6.7.8" -- -- 'getSourceFromFallback' handles pulling out the first IP in the -- comma-separated IP list in X-Forwarded-For: -- -- >>> getSourceFromFallback defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } -- "5.6.7.8" getSourceFromFallback :: Request -> ByteString getSourceFromFallback req = fromMaybe (getSourceFromSocket req) $ getSource req -- | -- >>> getSource defaultRequest { requestHeaders = [ ("X-Real-IP", "127.0.0.1") ] } -- Just "127.0.0.1" -- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "127.0.0.1") ] } -- Just "127.0.0.1" -- >>> getSource defaultRequest { requestHeaders = [ ("Something", "127.0.0.1") ] } -- Nothing -- >>> getSource defaultRequest -- Nothing -- -- 'getSource' uses the first instance of either @"X-Real-IP"@ or -- @"X-Forwarded-For"@ that it finds in the ordered header list: -- -- >>> getSource defaultRequest { requestHeaders = [ ("X-Real-IP", "1.2.3.4"), ("X-Forwarded-For", "5.6.7.8") ] } -- Just "1.2.3.4" -- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8"), ("X-Real-IP", "1.2.3.4") ] } -- Just "5.6.7.8" -- -- 'getSource' handles pulling out the first IP in the comma-separated IP list -- in X-Forwarded-For: -- -- >>> getSource defaultRequest { requestHeaders = [ ("X-Forwarded-For", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } -- Just "5.6.7.8" getSource :: Request -> Maybe ByteString getSource = getSourceFromHeaders [("x-real-ip", id), ("x-forwarded-for", firstIpInXFF)] -- | Pull out the first IP in a comma-separated list of X-Forwarded-For IPs. -- -- >>> firstIpInXFF "1.2.3.4, 5.6.7.8, 10.11.12.13" -- "1.2.3.4" -- -- If there are no commas, just return the whole input ByteString: -- -- >>> firstIpInXFF "5.6.7.8" -- "5.6.7.8" -- -- Note that this function doesn't make sure the input is actually an IP address: -- -- >>> firstIpInXFF "hello, world" -- "hello" firstIpInXFF :: ByteString -> ByteString firstIpInXFF = BS.takeWhile (/= ',') getSourceFromHeaders :: [(HeaderName, ByteString -> ByteString)] -> Request -> Maybe ByteString getSourceFromHeaders headerNamesAndPostProc req = getFirst $ foldMap f $ requestHeaders req where -- Take a header name and value from the request, and try match it against -- the list of headers and post-processing functions. If it matches, -- return the ByteString resulting from applying the post-processing function -- to the header value. f :: (HeaderName, ByteString) -> First ByteString f (headerNameFromReq, headerValFromReq) = let maybePostProc = find (\(headerNameFromPostProc, _) -> headerNameFromReq == headerNameFromPostProc) headerNamesAndPostProc in First $ fmap (\(_, postProc) -> postProc headerValFromReq) maybePostProc -- | -- >>> getSourceFromHeaderCustom ["x-foobar"] defaultRequest { requestHeaders = [ ("X-catdog", "1.2.3.4"), ("X-Foobar", "5.6.7.8"), ("Other", "1.1.1.1") ] } -- Just "5.6.7.8" -- -- If none of the headers in the passed-in list are in the 'Request', then return 'Nothing': -- -- >>> getSourceFromHeaderCustom ["x-foobar", "baz"] defaultRequest { requestHeaders = [ ("abb", "1.2.3.4"), ("xyz", "5.6.7.8") ] } -- Nothing -- -- 'getSourceFromHeaderCustom' uses the first instance of any header in the -- passed in list that it finds in the ordered header list from the request: -- -- >>> getSourceFromHeaderCustom ["x-foobar", "baz"] defaultRequest { requestHeaders = [ ("baz", "1.2.3.4"), ("x-foobar", "5.6.7.8") ] } -- Just "1.2.3.4" -- -- 'getSourceFromHeaderCustom' splits the value of the header it finds by @,@ -- and uses the first item. This makes it easy to use with headers like -- @X-Forwarded-For@, which are expected to have a comma-separated list of IP -- addresses: -- -- >>> getSourceFromHeaderCustom ["x-foobar"] defaultRequest { requestHeaders = [ ("X-Foobar", "5.6.7.8, 10.11.12.13, 1.2.3.4") ] } -- Just "5.6.7.8" getSourceFromHeaderCustom :: [HeaderName] -> Request -> Maybe ByteString getSourceFromHeaderCustom hs = getSourceFromHeaders (fmap (,firstIpInXFF) hs) ================================================ FILE: wai-logger/Network/Wai/Logger/IORef.hs ================================================ {-# LANGUAGE CPP #-} module Network.Wai.Logger.IORef ( IORef, newIORef, readIORef, writeIORef, atomicModifyIORef', ) where import Data.IORef #if !MIN_VERSION_base(4, 6, 0) atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b atomicModifyIORef' ref f = do b <- atomicModifyIORef ref (\x -> let (a, b) = f x in (a, a `seq` b)) b `seq` return b #endif ================================================ FILE: wai-logger/Network/Wai/Logger/IP.hs ================================================ module Network.Wai.Logger.IP ( NumericAddress, showSockAddr, ) where import Data.Bits (shift, (.&.)) import Data.Word (Word32) import Network.Socket (SockAddr (..)) import System.ByteOrder (ByteOrder (..), byteOrder) import Text.Printf (printf) -- | A type for IP address in numeric string representation. type NumericAddress = String showIPv4 :: Word32 -> Bool -> NumericAddress showIPv4 w32 little | little = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4 | otherwise = show b4 ++ "." ++ show b3 ++ "." ++ show b2 ++ "." ++ show b1 where t1 = w32 t2 = shift t1 (-8) t3 = shift t2 (-8) t4 = shift t3 (-8) b1 = t1 .&. 0x000000ff b2 = t2 .&. 0x000000ff b3 = t3 .&. 0x000000ff b4 = t4 .&. 0x000000ff showIPv6 :: (Word32, Word32, Word32, Word32) -> String showIPv6 (w1, w2, w3, w4) = printf "%x:%x:%x:%x:%x:%x:%x:%x" s1 s2 s3 s4 s5 s6 s7 s8 where (s1, s2) = split16 w1 (s3, s4) = split16 w2 (s5, s6) = split16 w3 (s7, s8) = split16 w4 split16 w = (h1, h2) where h1 = shift w (-16) .&. 0x0000ffff h2 = w .&. 0x0000ffff -- | Convert 'SockAddr' to 'NumericAddress'. If the address is -- IPv4-embedded IPv6 address, the IPv4 is extracted. showSockAddr :: SockAddr -> NumericAddress -- HostAddr is network byte order. showSockAddr (SockAddrInet _ addr4) = showIPv4 addr4 (byteOrder == LittleEndian) -- HostAddr6 is host byte order. showSockAddr (SockAddrInet6 _ _ (0, 0, 0x0000ffff, addr4) _) = showIPv4 addr4 False showSockAddr (SockAddrInet6 _ _ (0, 0, 0, 1) _) = "::1" showSockAddr (SockAddrInet6 _ _ addr6 _) = showIPv6 addr6 showSockAddr (SockAddrUnix _) = "-" ================================================ FILE: wai-logger/Network/Wai/Logger.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -- | Apache style logger for WAI applications. -- -- An example: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- > -- > import Data.ByteString.Builder (byteString) -- > import Control.Monad.IO.Class (liftIO) -- > import qualified Data.ByteString.Char8 as BS -- > import Network.HTTP.Types (status200) -- > import Network.Wai (Application, responseBuilder) -- > import Network.Wai.Handler.Warp (run) -- > import Network.Wai.Logger (withStdoutLogger, ApacheLogger) -- > -- > main :: IO () -- > main = withStdoutLogger $ \aplogger -> -- > run 3000 $ logApp aplogger -- > -- > logApp :: ApacheLogger -> Application -- > logApp aplogger req response = do -- > liftIO $ aplogger req status (Just len) -- > response $ responseBuilder status hdr msg -- > where -- > status = status200 -- > hdr = [("Content-Type", "text/plain")] -- > pong = "PONG" -- > msg = byteString pong -- > len = fromIntegral $ BS.length pong module Network.Wai.Logger ( -- * High level functions ApacheLogger, withStdoutLogger, ServerPushLogger, -- * Creating a logger ApacheLoggerActions, apacheLogger, serverpushLogger, logRotator, logRemover, initLoggerUser, initLogger, -- * Types IPAddrSource (..), LogType' (..), LogType, FileLogSpec (..), -- * Utilities showSockAddr, logCheck, -- * Backward compability clockDateCacher, ZonedDate, DateCacheGetter, DateCacheUpdater, ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Exception (bracket) import Control.Monad (void) import Data.ByteString (ByteString) import Network.HTTP.Types (Status) import Network.Wai (Request) import System.Log.FastLogger import Network.Wai.Logger.Apache import Network.Wai.Logger.IP (showSockAddr) ---------------------------------------------------------------- -- | Executing a function which takes 'ApacheLogger'. -- This 'ApacheLogger' writes log message to stdout. -- Each buffer (4K bytes) is flushed every second. withStdoutLogger :: (ApacheLogger -> IO a) -> IO a withStdoutLogger app = bracket setup teardown $ \(aplogger, _) -> app aplogger where setup = do tgetter <- newTimeCache simpleTimeFormat apf <- initLogger FromFallback (LogStdout 4096) tgetter let aplogger = apacheLogger apf remover = logRemover apf return (aplogger, remover) teardown (_, remover) = void remover ---------------------------------------------------------------- -- | Apache style logger. type ApacheLogger = Request -> Status -> Maybe Integer -> IO () -- | HTTP/2 server push logger in Apache style. type ServerPushLogger = Request -> ByteString -> Integer -> IO () -- | Function set of Apache style logger. data ApacheLoggerActions = ApacheLoggerActions { apacheLogger :: ApacheLogger -- ^ The Apache logger. , serverpushLogger :: ServerPushLogger -- ^ The HTTP/2 server push logger. , logRotator :: IO () -- ^ This is obsoleted. Rotation is done on-demand. -- So, this is now an empty action. , logRemover :: IO () -- ^ Removing resources relating to Apache logger. -- E.g. flushing and deallocating internal buffers. } ---------------------------------------------------------------- -- | Creating 'ApacheLogger' according to 'LogType'. initLoggerUser :: ToLogStr user => Maybe (Request -> Maybe user) -> IPAddrSource -> LogType -> IO FormattedTime -> IO ApacheLoggerActions initLoggerUser ugetter ipsrc typ tgetter = do (fl, cleanUp) <- newFastLogger typ return $ ApacheLoggerActions { apacheLogger = apache fl ipsrc ugetter tgetter , serverpushLogger = serverpush fl ipsrc ugetter tgetter , logRotator = return () , logRemover = cleanUp } initLogger :: IPAddrSource -> LogType -> IO FormattedTime -> IO ApacheLoggerActions initLogger = initLoggerUser nouser where nouser :: Maybe (Request -> Maybe ByteString) nouser = Nothing --- | Checking if a log file can be written if 'LogType' is 'LogFileNoRotate' or 'LogFile'. logCheck :: LogType -> IO () logCheck LogNone = return () logCheck (LogStdout _) = return () logCheck (LogStderr _) = return () logCheck (LogFileNoRotate fp _) = check fp logCheck (LogFile spec _) = check (log_file spec) logCheck (LogFileTimedRotate spec _) = check (timed_log_file spec) logCheck (LogCallback _ _) = return () ---------------------------------------------------------------- apache :: ToLogStr user => (LogStr -> IO ()) -> IPAddrSource -> Maybe (Request -> Maybe user) -> IO FormattedTime -> ApacheLogger apache cb ipsrc userget dateget req st mlen = do zdata <- dateget cb (apacheLogStr ipsrc (justGetUser userget) zdata req st mlen) serverpush :: ToLogStr user => (LogStr -> IO ()) -> IPAddrSource -> Maybe (Request -> Maybe user) -> IO FormattedTime -> ServerPushLogger serverpush cb ipsrc userget dateget req path size = do zdata <- dateget cb (serverpushLogStr ipsrc (justGetUser userget) zdata req path size) --------------------------------------------------------------- -- | Getting cached 'ZonedDate'. type DateCacheGetter = IO ZonedDate -- | Updateing cached 'ZonedDate'. This should be called every second. -- See the source code of 'withStdoutLogger'. type DateCacheUpdater = IO () -- | A type for zoned date. type ZonedDate = FormattedTime -- | -- Returning 'DateCacheGetter' and 'DateCacheUpdater'. -- -- Note: Since version 2.1.2, this function uses the auto-update package -- internally, and therefore the @DateCacheUpdater@ value returned need -- not be called. To wit, the return value is in fact an empty action. clockDateCacher :: IO (DateCacheGetter, DateCacheUpdater) clockDateCacher = do tgetter <- newTimeCache simpleTimeFormat return (tgetter, return ()) justGetUser :: Maybe (Request -> Maybe user) -> (Request -> Maybe user) justGetUser (Just getter) = getter justGetUser Nothing = \_ -> Nothing ================================================ FILE: wai-logger/Setup.hs ================================================ {-# OPTIONS_GHC -Wall #-} module Main (main) where import Distribution.Simple main :: IO () main = defaultMain ================================================ FILE: wai-logger/wai-logger.cabal ================================================ cabal-version: >=1.10 name: wai-logger version: 2.5.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto author: Kazu Yamamoto tested-with: ghc ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3 synopsis: A logging system for WAI description: A logging system for WAI(Web Application Interface) category: Web, Yesod build-type: Simple source-repository head type: git location: https://github.com/kazu-yamamoto/logger.git library exposed-modules: Network.Wai.Logger other-modules: Network.Wai.Logger.Apache Network.Wai.Logger.IP Network.Wai.Logger.IORef default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4 && <5, byteorder, bytestring, fast-logger >=3, http-types, network, wai >=2.0.0 if impl(ghc >=8) default-extensions: Strict StrictData ================================================ FILE: wai-logger-prefork/LICENSE ================================================ Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: wai-logger-prefork/Network/Wai/Logger/Prefork/File.hs ================================================ module Network.Wai.Logger.Prefork.File where import Control.Applicative import Control.Concurrent import Control.Exception (SomeException, catch, handle) import Control.Monad import Data.IORef import Network.Wai.Logger import Network.Wai.Logger.Prefork.Types import System.Date.Cache import System.IO import System.Log.FastLogger import System.Posix import Prelude hiding (catch) ---------------------------------------------------------------- newtype LoggerRef = LoggerRef (IORef Logger) getLogger :: LoggerRef -> IO Logger getLogger (LoggerRef ref) = readIORef ref setLogger :: LoggerRef -> Logger -> IO () setLogger (LoggerRef ref) = writeIORef ref ---------------------------------------------------------------- type LogFlusher = IO () fileLoggerInit :: IPAddrSource -> FileLogSpec -> Signal -> IO (ApacheLogger, LogFlusher) fileLoggerInit ipsrc spec signal = do hdl <- open spec dc <- clockDateCacher zonedDateCacheConf logger <- mkLogger2 False hdl dc logref <- LoggerRef <$> newIORef logger void . forkIO $ fileFlusher logref void $ installHandler signal (Catch $ reopen spec logref) Nothing return (fileLogger ipsrc logref, fileFlusher' logref) open :: FileLogSpec -> IO Handle open spec = openFile (log_file spec) AppendMode reopen :: FileLogSpec -> LoggerRef -> IO () reopen spec logref = do oldlogger <- getLogger logref newlogger <- open spec >>= renewLogger oldlogger setLogger logref newlogger ---------------------------------------------------------------- fileLogger :: IPAddrSource -> LoggerRef -> ApacheLogger fileLogger ipsrc logref req status msiz = do logger <- getLogger logref date <- loggerDate logger loggerPutStr logger $ apacheFormat ipsrc date req status msiz fileFlusher :: LoggerRef -> IO () fileFlusher logref = forever $ do threadDelay 10000000 fileFlusher' logref fileFlusher' :: LoggerRef -> IO () fileFlusher' logref = getLogger logref >>= loggerFlush ---------------------------------------------------------------- fileLoggerController :: FileLogSpec -> Signal -> LogController fileLoggerController spec signal pids = forever $ do isOver <- over when isOver $ do rotate spec mapM_ sendSignal pids threadDelay 10000000 where file = log_file spec over = handle handler $ do siz <- fromIntegral . fileSize <$> getFileStatus file if siz > log_file_size spec then return True else return False sendSignal pid = signalProcess signal pid `catch` ignore handler :: SomeException -> IO Bool handler _ = return False ignore :: SomeException -> IO () ignore _ = return () ================================================ FILE: wai-logger-prefork/Network/Wai/Logger/Prefork/Types.hs ================================================ module Network.Wai.Logger.Prefork.Types ( FileLogSpec (..), LogType (..), LogController, ) where import System.Log.FastLogger import System.Posix (ProcessID, Signal) data LogType = LogNone | LogStdout | -- | 'Signal' is used to tell child processes to reopen a log file. LogFile FileLogSpec Signal type LogController = [ProcessID] -> IO () ================================================ FILE: wai-logger-prefork/Network/Wai/Logger/Prefork.hs ================================================ module Network.Wai.Logger.Prefork ( logCheck, logInit, logController, LogController, LogType (..), FileLogSpec (..), LogFlusher, ) where import Control.Concurrent import Control.Monad import Network.Wai.Logger import Network.Wai.Logger.Prefork.File import Network.Wai.Logger.Prefork.Types import System.Date.Cache import System.Log.FastLogger -- | -- Checking if a log file can be written if 'LogType' is 'LogFile'. logCheck :: LogType -> IO () logCheck LogNone = return () logCheck LogStdout = return () logCheck (LogFile spec _) = check spec -- | -- Creating 'ApacheLogger' according to 'LogType'. logInit :: IPAddrSource -> LogType -> IO (ApacheLogger, LogFlusher) logInit _ LogNone = noLoggerInit logInit ipsrc LogStdout = stdoutLoggerInit ipsrc logInit ipsrc (LogFile spec signal) = fileLoggerInit ipsrc spec signal noLoggerInit :: IO (ApacheLogger, LogFlusher) noLoggerInit = return $! (noLogger, noFlusher) where noLogger _ _ _ = return () noFlusher = return () stdoutLoggerInit :: IPAddrSource -> IO (ApacheLogger, LogFlusher) stdoutLoggerInit ipsrc = do dc <- clockDateCacher zonedDateCacheConf lgr <- stdoutApacheLoggerInit2 ipsrc True dc return $! (lgr, return ()) -- | -- Creating a log controller against child processes. logController :: LogType -> LogController logController LogNone = noLoggerController logController LogStdout = noLoggerController logController (LogFile spec signal) = fileLoggerController spec signal noLoggerController :: LogController noLoggerController _ = forever $ threadDelay maxBound ================================================ FILE: wai-logger-prefork/wai-logger-prefork.cabal ================================================ Name: wai-logger-prefork Version: 0.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: A logging system for preforked WAI apps Description: A logging system for preforked WAI apps Category: Web, Yesod Cabal-Version: >= 1.6 Build-Type: Simple Library GHC-Options: -Wall Exposed-Modules: Network.Wai.Logger.Prefork Other-Modules: Network.Wai.Logger.Prefork.File Network.Wai.Logger.Prefork.Types Build-Depends: base >= 4 && < 5 , bytestring , date-cache , fast-logger , http-types , unix , wai , wai-logger >= 0.3 Source-Repository head Type: git Location: git clone git://github.com/kazu-yamamoto/logger.git