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