diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,4 @@ +### 1.5 + +- Auto-generate haddocks for generated functions. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright 2022, Alexey Radkov. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/NgxExport/Log.hs b/NgxExport/Log.hs new file mode 100644 --- /dev/null +++ b/NgxExport/Log.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : NgxExport.Log +-- Copyright : (c) Alexey Radkov 2022 +-- License : BSD-style +-- +-- Maintainer : alexey.radkov@gmail.com +-- Stability : stable +-- Portability : non-portable (requires Template Haskell) +-- +-- Native Nginx logging from configuration files and Haskell handlers. +-- +----------------------------------------------------------------------------- + +module NgxExport.Log (module NgxExport.Log.Base + ,module Gen + ) where + +import NgxExport + +import NgxExport.Log.Base +import NgxExport.Log.Gen as Gen hiding (logFuncs) +import NgxExport.Log.Gen (logFuncs) + +import Language.Haskell.TH + +concat <$> mapM (ngxExportIOYY . mkName) logFuncs + diff --git a/NgxExport/Log/Base.hs b/NgxExport/Log/Base.hs new file mode 100644 --- /dev/null +++ b/NgxExport/Log/Base.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} + +module NgxExport.Log.Base (LogLevel (..) + ,logG + ,logM + ,logR + ) where + +import NgxExport +import NgxExport.Tools + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Unsafe as B +import Foreign.C.Types +import Foreign.C.String +import Foreign.Ptr +import Control.Arrow +import Data.Char + +-- | Log severity levels. +-- +-- Being applied to a certain constructor, function 'fromEnum' returns the value +-- of the corresponding macro definition from /ngx_log.h/. +data LogLevel = LogStderr + | LogEmerg + | LogAlert + | LogCrit + | LogErr + | LogWarn + | LogNotice + | LogInfo + | LogDebug deriving Enum + +foreign import ccall unsafe "plugin_ngx_http_haskell_log" + c_log :: Ptr () -> CUIntPtr -> CString -> CSize -> IO () + +-- | Logs a message to the global Nginx log. +logG :: LogLevel -- ^ Log severity level + -> ByteString -- ^ Log message + -> IO () +logG _ "" = return () +logG l msg = do + c <- ngxCyclePtr + B.unsafeUseAsCStringLen msg $ + \(x, i) -> c_log c (fromIntegral $ fromEnum l) x $ fromIntegral i + +foreign import ccall unsafe "plugin_ngx_http_haskell_log_r" + c_log_r :: Ptr () -> CUIntPtr -> CString -> CSize -> IO () + +-- | Logs a message to the request's Nginx log. +-- +-- This function accepts a pointer to the Nginx request object supposedly +-- unmarshalled from Nginx variable /$_r_ptr/. +logM :: LogLevel -- ^ Log severity level + -> Ptr () -- ^ Pointer to the Nginx request object + -> ByteString -- ^ Log message + -> IO () +logM l r msg = B.unsafeUseAsCStringLen msg $ + \(x, i) -> c_log_r r (fromIntegral $ fromEnum l) x $ fromIntegral i + +-- | Logs a message to the request's Nginx log. +-- +-- This function expects that the log message contains the value of Nginx +-- variable /$_r_ptr/ at the beginning of the log message. All whitespace +-- characters following the value of /$_r_ptr/ are skipped. +logR :: LogLevel -- ^ Log severity level + -> ByteString -- ^ Log message + -> IO () +logR _ "" = return () +logR l msg = do + let (r, v) = ngxRequestPtr &&& skipRPtr $ msg + logM l r $ C8.dropWhile isSpace v + diff --git a/NgxExport/Log/Gen.hs b/NgxExport/Log/Gen.hs new file mode 100644 --- /dev/null +++ b/NgxExport/Log/Gen.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP, TemplateHaskell, TupleSections, LambdaCase #-} + +module NgxExport.Log.Gen where + +import NgxExport.Log.Base + +import Language.Haskell.TH +import Control.Arrow +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Char + +#if MIN_VERSION_template_haskell(2,18,0) +#define FUND funD_doc +#else +#define FUND funD +#endif + +do + TyConI (DataD _ _ _ _ lCs _) <- reify ''LogLevel + let lCons = map (\case + NormalC con [] -> con + _ -> undefined + ) lCs + flr = mkName "logR" + lCons' = map ((, 'logG) . (id &&& toFuncName . nameBase)) lCons ++ + map ((, flr) . (id &&& toFuncName . (++ "R") . nameBase)) lCons + toFuncName (h : t) = toLower h : t + toFuncName _ = undefined + flf = mkName "logFuncs" + sequence $ + [sigD flf [t|[String]|] + ,funD flf [clause [] + (normalB $ + listE $ map (litE . stringL . snd . fst) lCons' + ) [] + ] + ] + ++ + concatMap + (\((con, fn), f) -> + let fl = mkName fn + in [sigD fl [t|ByteString -> IO L.ByteString|] + ,FUND fl [clause [varP $ mkName "msg"] + (normalB + [|$(varE f) $(conE con) msg >> return L.empty|] + ) [] + ] +#if MIN_VERSION_template_haskell(2,18,0) + (Just $ "Logs a message with severity '" ++ + nameBase con ++ "' to the " ++ + (if f == flr + then "request's " + else "global " + ) ++ "Nginx log.\n\n" ++ + "This is the core function of the /" ++ fn ++ + "/ handler." + ) [Just "Log message"] +#endif + ] + ) lCons' + diff --git a/ngx-export-log.cabal b/ngx-export-log.cabal new file mode 100644 --- /dev/null +++ b/ngx-export-log.cabal @@ -0,0 +1,33 @@ +name: ngx-export-log +version: 1.5 +synopsis: Native Nginx logging from configuration files and Haskell handlers +description: Native Nginx logging from configuration files and Haskell handlers. + . + This is a part of . Custom + libraries are required to be linked against C module /ngx_log_plugin/. +homepage: http://github.com/lyokha/nginx-log-plugin +license: BSD3 +license-file: LICENSE +extra-source-files: Changelog.md +author: Alexey Radkov +maintainer: Alexey Radkov +stability: stable +copyright: 2022 Alexey Radkov +category: Network +build-type: Simple +cabal-version: 1.20 + +library + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , template-haskell >= 2.11.0 + , ngx-export >= 1.7.1 + , ngx-export-tools >= 0.4.9.0 + , bytestring + + exposed-modules: NgxExport.Log + other-modules: NgxExport.Log.Base + , NgxExport.Log.Gen + + ghc-options: -Wall +