{-# LANGUAGE CPP, 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

-- Some tools such as hls, haddock, and ghci run interactive linking against C
-- functions plugin_ngx_http_haskell_log() and plugin_ngx_http_haskell_log_r()
-- when loading Log.hs. In Log.hs, TH declarations from Log/Gen.hs, which make
-- calls to those C functions, get instantiated. Obviously, linking fails as
-- soon as we don't have a library to expose the functions because such a
-- library is built by Nginx and we don't want to use Nginx at this step.
--
-- In this workaround, the C functions get replaced by stubs when running by
-- hls or haddock. This prevents interactive linking in Log.hs. It's easy to
-- detect that the code is being run by hls or haddock: the tools define their
-- own C macro declarations __GHCIDE__ and __HADDOCK_VERSION__ respectively. To
-- prevent interactive linking in ghci, pass one of the two macro declarations
-- in an appropriate option, e.g.
--
-- cabal repl --ghc-options=-D__GHCIDE__ --repl-options=-fobject-code

#if defined(__GHCIDE__) || defined(__HADDOCK_VERSION__)
#define C_LOG_STUB(f) \
f :: Ptr () -> CUIntPtr -> CString -> CSize -> IO (); \
f _ _ _ _ = return ()
#endif

-- | 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 Int -> LogLevel
LogLevel -> Int
LogLevel -> [LogLevel]
LogLevel -> LogLevel
LogLevel -> LogLevel -> [LogLevel]
LogLevel -> LogLevel -> LogLevel -> [LogLevel]
(LogLevel -> LogLevel)
-> (LogLevel -> LogLevel)
-> (Int -> LogLevel)
-> (LogLevel -> Int)
-> (LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> LogLevel -> [LogLevel])
-> Enum LogLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LogLevel -> LogLevel
succ :: LogLevel -> LogLevel
$cpred :: LogLevel -> LogLevel
pred :: LogLevel -> LogLevel
$ctoEnum :: Int -> LogLevel
toEnum :: Int -> LogLevel
$cfromEnum :: LogLevel -> Int
fromEnum :: LogLevel -> Int
$cenumFrom :: LogLevel -> [LogLevel]
enumFrom :: LogLevel -> [LogLevel]
$cenumFromThen :: LogLevel -> LogLevel -> [LogLevel]
enumFromThen :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromTo :: LogLevel -> LogLevel -> [LogLevel]
enumFromTo :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
enumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
Enum

#if defined(__GHCIDE__) || defined(__HADDOCK_VERSION__)
C_LOG_STUB(c_log)
#else
foreign import ccall unsafe "plugin_ngx_http_haskell_log"
    c_log :: Ptr () -> CUIntPtr -> CString -> CSize -> IO ()
#endif

-- | Logs a message to the global Nginx log.
logG :: LogLevel        -- ^ Log severity level
     -> ByteString      -- ^ Log message
     -> IO ()
logG :: LogLevel -> ByteString -> IO ()
logG LogLevel
_ ByteString
"" = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
logG LogLevel
l ByteString
msg = do
    Ptr ()
c <- IO (Ptr ())
ngxCyclePtr
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
msg ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        \(CString
x, Int
i) -> Ptr () -> CUIntPtr -> CString -> CSize -> IO ()
c_log Ptr ()
c (Int -> CUIntPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUIntPtr) -> Int -> CUIntPtr
forall a b. (a -> b) -> a -> b
$ LogLevel -> Int
forall a. Enum a => a -> Int
fromEnum LogLevel
l) CString
x (CSize -> IO ()) -> CSize -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i

#if defined(__GHCIDE__) || defined(__HADDOCK_VERSION__)
C_LOG_STUB(c_log_r)
#else
foreign import ccall unsafe "plugin_ngx_http_haskell_log_r"
    c_log_r :: Ptr () -> CUIntPtr -> CString -> CSize -> IO ()
#endif

-- | 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 :: LogLevel -> Ptr () -> ByteString -> IO ()
logM LogLevel
l Ptr ()
r ByteString
msg = ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
msg ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \(CString
x, Int
i) -> Ptr () -> CUIntPtr -> CString -> CSize -> IO ()
c_log_r Ptr ()
r (Int -> CUIntPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUIntPtr) -> Int -> CUIntPtr
forall a b. (a -> b) -> a -> b
$ LogLevel -> Int
forall a. Enum a => a -> Int
fromEnum LogLevel
l) CString
x (CSize -> IO ()) -> CSize -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 :: LogLevel -> ByteString -> IO ()
logR LogLevel
_ ByteString
"" = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
logR LogLevel
l ByteString
msg = do
    let (Ptr ()
r, ByteString
v) = ByteString -> Ptr ()
ngxRequestPtr (ByteString -> Ptr ())
-> (ByteString -> ByteString) -> ByteString -> (Ptr (), ByteString)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ByteString -> ByteString
skipRPtr (ByteString -> (Ptr (), ByteString))
-> ByteString -> (Ptr (), ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
msg
    LogLevel -> Ptr () -> ByteString -> IO ()
logM LogLevel
l Ptr ()
r (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
C8.dropWhile Char -> Bool
isSpace ByteString
v