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 <kazu@iij.ad.jp>
Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>
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\<x\>\".
-- 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\<x\>).
--
-- 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 <kazu@iij.ad.jp>
author: Kazu Yamamoto <kazu@iij.ad.jp>
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 <kazu@iij.ad.jp>
author: Kazu Yamamoto <kazu@iij.ad.jp>
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 <kazu@iij.ad.jp>
Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>
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
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
Condensed preview — 44 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (103K chars).
[
{
"path": ".github/workflows/haskell.yml",
"chars": 1457,
"preview": "name: Haskell CI\n\non:\n push:\n branches: [ 'main', 'ci' ]\n pull_request:\n branches: [ 'main' ]\n\njobs:\n build:\n "
},
{
"path": ".gitignore",
"chars": 116,
"preview": "dist/\n.cabal-sandbox/\ncabal.sandbox.config\n.stack-work/\ntarballs/\ndist-newstyle/\n.ghc.environment.*\nstack.yaml.lock\n"
},
{
"path": ".travis.yml",
"chars": 7320,
"preview": "# This Travis job script has been generated by a script via\n#\n# haskell-ci '--output' 'travis.yml' '--no-cabal-check' "
},
{
"path": "README.md",
"chars": 495,
"preview": "Efficient, versatile logging tools for Haskell.\n\nfast-logger\n-----------\nlow-level and extremely fast logging tools.\nAll"
},
{
"path": "cabal.project",
"chars": 37,
"preview": "packages:\n fast-logger\n wai-logger\n"
},
{
"path": "date-cache/LICENSE",
"chars": 1525,
"preview": "Copyright (c) 2012, IIJ Innovation Institute Inc.\nAll rights reserved.\n\nRedistribution and use in source and binary form"
},
{
"path": "date-cache/System/Date/Cache.hs",
"chars": 2336,
"preview": "-- |\n-- Formatting time is slow.\n-- This package provides mechanisms to cache formatted date.\nmodule System.Date.Cache ("
},
{
"path": "date-cache/date-cache.cabal",
"chars": 852,
"preview": "Name: date-cache\nVersion: 0.3.0\nAuthor: Kazu Yamamoto <kazu@iij.ad.jp>\n"
},
{
"path": "fast-logger/ChangeLog.md",
"chars": 4147,
"preview": "## 3.2.6\n\n* Labeling the thread of SingleLogger.\n\n## 3.2.5\n\n* Giving names to threads.\n\n## 3.2.4\n\n* Avoid unnecessary co"
},
{
"path": "fast-logger/LICENSE",
"chars": 1525,
"preview": "Copyright (c) 2009, IIJ Innovation Institute Inc.\nAll rights reserved.\n\nRedistribution and use in source and binary form"
},
{
"path": "fast-logger/README.md",
"chars": 38,
"preview": "## fast-logger\n\nA fast logging system\n"
},
{
"path": "fast-logger/Setup.hs",
"chars": 47,
"preview": "import Distribution.Simple\n\nmain = defaultMain\n"
},
{
"path": "fast-logger/System/Log/FastLogger/Date.hs",
"chars": 1688,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n\n-- |\n-- Formatting time is slow.\n-- This package provides mecha"
},
{
"path": "fast-logger/System/Log/FastLogger/File.hs",
"chars": 2995,
"preview": "{-# LANGUAGE CPP #-}\n#if !MIN_VERSION_directory(1,3,8)\n{-# LANGUAGE Safe #-}\n#endif\n\nmodule System.Log.FastLogger.File ("
},
{
"path": "fast-logger/System/Log/FastLogger/FileIO.hs",
"chars": 929,
"preview": "module System.Log.FastLogger.FileIO where\n\nimport Foreign.Ptr (Ptr)\nimport GHC.IO.Device (close)\nimport GHC.IO.FD (openF"
},
{
"path": "fast-logger/System/Log/FastLogger/IO.hs",
"chars": 1318,
"preview": "{-# LANGUAGE CPP #-}\n\n#if __GLASGOW_HASKELL__ <= 708\n{-# LANGUAGE Trustworthy #-}\n#else\n{-# LANGUAGE Safe #-}\n#endif\n\nmo"
},
{
"path": "fast-logger/System/Log/FastLogger/Imports.hs",
"chars": 567,
"preview": "{-# LANGUAGE Trustworthy #-}\n\nmodule System.Log.FastLogger.Imports (\n ByteString (..),\n module Control.Applicative"
},
{
"path": "fast-logger/System/Log/FastLogger/Internal.hs",
"chars": 682,
"preview": "-- |\n-- The contents of this module can change at any time without warning.\nmodule System.Log.FastLogger.Internal (\n "
},
{
"path": "fast-logger/System/Log/FastLogger/LogStr.hs",
"chars": 5180,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE Trustworthy #-}\n\nmodule System.Log.FastLogger.LogSt"
},
{
"path": "fast-logger/System/Log/FastLogger/LoggerSet.hs",
"chars": 6742,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n\nmodule System.Log.FastLogger.LoggerSet (\n -- * C"
},
{
"path": "fast-logger/System/Log/FastLogger/MultiLogger.hs",
"chars": 4281,
"preview": "{-# LANGUAGE RecordWildCards #-}\n\nmodule System.Log.FastLogger.MultiLogger (\n MultiLogger,\n newMultiLogger,\n) wher"
},
{
"path": "fast-logger/System/Log/FastLogger/SingleLogger.hs",
"chars": 3623,
"preview": "{-# LANGUAGE RecordWildCards #-}\n\nmodule System.Log.FastLogger.SingleLogger (\n SingleLogger,\n newSingleLogger,\n) w"
},
{
"path": "fast-logger/System/Log/FastLogger/Types.hs",
"chars": 315,
"preview": "module System.Log.FastLogger.Types (\n -- * Types\n TimeFormat,\n FormattedTime,\n) where\n\nimport System.Log.FastLo"
},
{
"path": "fast-logger/System/Log/FastLogger/Write.hs",
"chars": 1422,
"preview": "{-# LANGUAGE RecordWildCards #-}\n\nmodule System.Log.FastLogger.Write (\n writeLogStr,\n writeBigLogStr,\n Loggers "
},
{
"path": "fast-logger/System/Log/FastLogger.hs",
"chars": 10576,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE OverloadedStrings #-}\n\n-- | This module provides a fast logging"
},
{
"path": "fast-logger/fast-logger.cabal",
"chars": 2176,
"preview": "cabal-version: >=1.10\nname: fast-logger\nversion: 3.2.6\nlicense: BSD3\nlicense-fi"
},
{
"path": "fast-logger/test/FastLoggerSpec.hs",
"chars": 3613,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule FastLoggerSpec (spec) where\n\n#if __GLASGOW_HASKELL__ < 7"
},
{
"path": "fast-logger/test/Spec.hs",
"chars": 44,
"preview": "{-# OPTIONS_GHC -F -pgmF hspec-discover #-}\n"
},
{
"path": "fourmolu.yaml",
"chars": 1454,
"preview": "# Number of spaces per indentation step\nindentation: 4\n\n# Max line length for automatic line breaking\ncolumn-limit: 80\n\n"
},
{
"path": "sources.txt",
"chars": 14,
"preview": "./fast-logger\n"
},
{
"path": "stack.yaml",
"chars": 89,
"preview": "resolver: lts-14.22\npackages:\n- wai-logger/\n- fast-logger/\nextra-deps:\n- unix-time-0.4.4\n"
},
{
"path": "wai-logger/.gitignore",
"chars": 6,
"preview": "dist/\n"
},
{
"path": "wai-logger/LICENSE",
"chars": 1525,
"preview": "Copyright (c) 2009, IIJ Innovation Institute Inc.\nAll rights reserved.\n\nRedistribution and use in source and binary form"
},
{
"path": "wai-logger/Network/Wai/Logger/Apache.hs",
"chars": 10913,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n\nmodule Network.Wai.Logger.Apache"
},
{
"path": "wai-logger/Network/Wai/Logger/IORef.hs",
"chars": 413,
"preview": "{-# LANGUAGE CPP #-}\n\nmodule Network.Wai.Logger.IORef (\n IORef,\n newIORef,\n readIORef,\n writeIORef,\n atom"
},
{
"path": "wai-logger/Network/Wai/Logger/IP.hs",
"chars": 1679,
"preview": "module Network.Wai.Logger.IP (\n NumericAddress,\n showSockAddr,\n) where\n\nimport Data.Bits (shift, (.&.))\nimport Dat"
},
{
"path": "wai-logger/Network/Wai/Logger.hs",
"chars": 6180,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE GADTs #-}\n\n-- | Apache style logger for WAI applications.\n--\n-- An example:\n--\n-- > {-"
},
{
"path": "wai-logger/Setup.hs",
"chars": 114,
"preview": "{-# OPTIONS_GHC -Wall #-}\n\nmodule Main (main) where\n\nimport Distribution.Simple\n\nmain :: IO ()\nmain = defaultMain\n"
},
{
"path": "wai-logger/wai-logger.cabal",
"chars": 1006,
"preview": "cabal-version: >=1.10\nname: wai-logger\nversion: 2.5.0\nlicense: BSD3\nlicense-file: LICENSE\nmaintain"
},
{
"path": "wai-logger-prefork/LICENSE",
"chars": 1525,
"preview": "Copyright (c) 2009, IIJ Innovation Institute Inc.\nAll rights reserved.\n\nRedistribution and use in source and binary form"
},
{
"path": "wai-logger-prefork/Network/Wai/Logger/Prefork/File.hs",
"chars": 2723,
"preview": "module Network.Wai.Logger.Prefork.File where\n\nimport Control.Applicative\nimport Control.Concurrent\nimport Control.Except"
},
{
"path": "wai-logger-prefork/Network/Wai/Logger/Prefork/Types.hs",
"chars": 373,
"preview": "module Network.Wai.Logger.Prefork.Types (\n FileLogSpec (..),\n LogType (..),\n LogController,\n) where\n\nimport Sys"
},
{
"path": "wai-logger-prefork/Network/Wai/Logger/Prefork.hs",
"chars": 1583,
"preview": "module Network.Wai.Logger.Prefork (\n logCheck,\n logInit,\n logController,\n LogController,\n LogType (..),\n "
},
{
"path": "wai-logger-prefork/wai-logger-prefork.cabal",
"chars": 1081,
"preview": "Name: wai-logger-prefork\nVersion: 0.3.0\nAuthor: Kazu Yamamoto <kazu@iij"
}
]
About this extraction
This page contains the full source code of the kazu-yamamoto/logger GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 44 files (94.5 KB), approximately 27.3k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.