wai-logger (empty) → 0.0.0
raw patch · 13 files changed
+540/−0 lines, 13 filesdep +basedep +byteorderdep +bytestringsetup-changed
Dependencies added: base, byteorder, bytestring, case-insensitive, deepseq, directory, filepath, http-types, network, old-locale, time, unix, wai
Files
- LICENSE +29/−0
- Network/Wai/Logger.hs +51/−0
- Network/Wai/Logger/Date.hs +50/−0
- Network/Wai/Logger/File.hs +42/−0
- Network/Wai/Logger/Format.hs +40/−0
- Network/Wai/Logger/IO.hs +69/−0
- Network/Wai/Logger/Prefork.hs +39/−0
- Network/Wai/Logger/Prefork/File.hs +96/−0
- Network/Wai/Logger/Prefork/Stdout.hs +20/−0
- Network/Wai/Logger/Prefork/Types.hs +17/−0
- Network/Wai/Logger/Utils.hs +54/−0
- Setup.hs +2/−0
- wai-logger.cabal +31/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.+ * Neither the name of the copyright holders nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Network/Wai/Logger.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Logging system for WAI applications.+--+-- Sample code:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > module Main where+-- > import Blaze.ByteString.Builder (fromByteString)+-- > import Control.Monad.IO.Class (liftIO)+-- > import Data.ByteString.Char8+-- > import Network.HTTP.Types (status200)+-- > import Network.Wai+-- > import Network.Wai.Handler.Warp+-- > import Network.Wai.Logger+-- > import System.IO+-- >+-- > main :: IO ()+-- > main = do+-- > dref <- dateInit+-- > run 3000 $ logapp dref+-- >+-- > logapp :: DateRef -> Application+-- > logapp dref req = do+-- > date <- liftIO $ getDate dref+-- > let status = status200+-- > len = 4+-- > liftIO $ hPutLogStr stdout $ apacheFormat date req status (Just len)+-- > liftIO $ hFlush stdout+-- > return $ ResponseBuilder status+-- > [("Content-Type", "text/plain")+-- > ,("Content-Length", pack (show len))]+-- > $ fromByteString "PONG"++module Network.Wai.Logger (+ -- * Low level modules+ module Network.Wai.Logger.Date+ , module Network.Wai.Logger.File+ , module Network.Wai.Logger.Format+ , module Network.Wai.Logger.Utils+ , module Network.Wai.Logger.IO+ -- * High level modules+ -- | See "Network.Wai.Logger.Prefork".+ ) where++import Network.Wai.Logger.Date+import Network.Wai.Logger.File+import Network.Wai.Logger.Format+import Network.Wai.Logger.IO+import Network.Wai.Logger.Utils+
+ Network/Wai/Logger/Date.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Logger.Date (+ ZonedDate+ , dateInit+ , getDate+ , DateRef+ ) where++import Control.Concurrent+import Control.DeepSeq+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.IORef+import Data.Time+import System.Locale++-- | A type for zoned date.+type ZonedDate = ByteString++-- | Reference to the cache of 'ZoneDate'.+newtype DateRef = DateRef (IORef ByteString)++-- | Getting 'ZonedDate' from the cache.+getDate :: DateRef -> IO ZonedDate+getDate (DateRef ref) = readIORef ref++-- | Start caching 'ZonedDate' every second.+dateInit :: IO DateRef+dateInit = do+ ref <- formatDate >>= newIORef+ let dateref = DateRef ref+ forkIO $ date dateref+ return dateref++date :: DateRef -> IO ()+date dateref@(DateRef !ref) = do+ !tmstr <- formatDate+ x <- atomicModifyIORef ref (\_ -> (tmstr, ()))+ -- atomicModifyIORef is prone to leak spaces.+ x `seq` return ()+ threadDelay 1000000+ date dateref++formatDate :: IO ByteString+formatDate = do+ tm <- getZonedTime+ let !str = formatTime defaultTimeLocale "%d/%b/%Y:%T %z" tm+ !tmstr = str `deepseq` BS.pack str+ return tmstr
+ Network/Wai/Logger/File.hs view
@@ -0,0 +1,42 @@+module Network.Wai.Logger.File where++import Control.Monad+import System.Directory+import System.FilePath++-- | The spec for logging files+data FileLogSpec = FileLogSpec {+ log_file :: String+ , log_file_size :: Integer+ , log_backup_number :: Int+ }++-- | Checking if a log file can be written.+check :: FileLogSpec -> IO ()+check spec = do+ dirExist <- doesDirectoryExist dir+ unless dirExist $ fail $ dir ++ " does not exist or is not a directory."+ dirPerm <- getPermissions dir+ unless (writable dirPerm) $ fail $ dir ++ " is not writable."+ exist <- doesFileExist file+ when exist $ do+ perm <- getPermissions file+ unless (writable perm) $ fail $ file ++ " is not writable."+ where+ file = log_file spec+ dir = takeDirectory file++-- | Rotating log files.+rotate :: FileLogSpec -> IO ()+rotate spec = mapM_ move srcdsts+ where+ path = log_file spec+ n = log_backup_number spec+ dsts' = reverse . ("":) . map (('.':). show) $ [0..n-1]+ dsts = map (path++) dsts'+ srcs = tail dsts+ srcdsts = zip srcs dsts+ move (src,dst) = do+ exist <- doesFileExist src+ when exist $ renameFile src dst+
+ Network/Wai/Logger/Format.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Logger.Format (apacheFormat) where++import Data.ByteString.Char8 ()+import Data.CaseInsensitive+import Data.Maybe+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Logger.Date+import Network.Wai.Logger.IO+import Network.Wai.Logger.Utils++-- | Apache style log format.+apacheFormat :: ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr]+apacheFormat tmstr req st msize = [+ LS addr+ , LB " - - ["+ , LB tmstr+ , LB "] \""+ , LB $ requestMethod req+ , LB " "+ , LB $ rawPathInfo req+ , LB " "+ , LS $ show . httpVersion $ req+ , LB "\" "+ , LS . show . statusCode $ st+ , LB " "+ , LS $ maybe "-" show msize+ , LB " \""+ , LB $ lookupRequestField' "referer" req+ , LB "\" \""+ , LB $ lookupRequestField' "user-agent" req+ , LB "\"\n"+ ]+ where+ addr = showSockAddr (remoteHost req)++lookupRequestField' :: CI Ascii -> Request -> Ascii+lookupRequestField' k req = fromMaybe "" . lookup k $ requestHeaders req
+ Network/Wai/Logger/IO.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DoAndIfThenElse, BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-}++module Network.Wai.Logger.IO (+ LogStr(..)+ , hPutLogStr+ ) where++import qualified Data.ByteString as BS+import Data.ByteString.Internal (ByteString(..), c2w)+import Data.List+import Foreign+import GHC.Base+import GHC.IO.Buffer+import qualified GHC.IO.BufferedIO as Buffered+import GHC.IO.Handle.Internals+import GHC.IO.Handle.Text+import GHC.IO.Handle.Types+import GHC.IORef+import GHC.Num+import GHC.Real++-- | A date type to contain 'String' and 'ByteString'.+data LogStr = LS !String | LB !ByteString++-- | The 'hPut' function directory to copy a lift of 'LogStr' to the buffer.+hPutLogStr :: Handle -> [LogStr] -> IO ()+hPutLogStr handle bss =+ wantWritableHandle "hPutLogStr" handle $ \h_ -> bufsWrite h_ bss++bufsWrite :: Handle__-> [LogStr] -> IO ()+bufsWrite h_@Handle__{..} bss = do+ old_buf@Buffer{+ bufRaw = old_raw+ , bufR = w+ , bufSize = size+ } <- readIORef haByteBuffer+ if size - w > len then do+ withRawBuffer old_raw $ \ptr ->+ go (ptr `plusPtr` w) bss+ writeIORef haByteBuffer old_buf{ bufR = w + len }+ else do+ old_buf' <- Buffered.flushWriteBuffer haDevice old_buf+ writeIORef haByteBuffer old_buf'+ bufsWrite h_ bss+ where+ len = foldl' (\x y -> x + getLength y) 0 bss+ getLength (LB s) = BS.length s+ getLength (LS s) = length s+ go :: Ptr Word8 -> [LogStr] -> IO ()+ go _ [] = return ()+ go dst (LB b:bs) = do+ dst' <- copy dst b+ go dst' bs+ go dst (LS s:ss) = do+ dst' <- copy' dst s+ go dst' ss++copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)+copy dst (PS ptr off len) = withForeignPtr ptr $ \s -> do+ let src = s `plusPtr` off+ memcpy dst src (fromIntegral len)+ return (dst `plusPtr` len)++copy' :: Ptr Word8 -> String -> IO (Ptr Word8)+copy' dst [] = return dst+copy' dst (x:xs) = do+ poke dst (c2w x)+ copy' (dst `plusPtr` 1) xs
+ Network/Wai/Logger/Prefork.hs view
@@ -0,0 +1,39 @@+module Network.Wai.Logger.Prefork (+ logCheck+ , logInit+ , logController+ , ApacheLogger+ , LogType(..)+ , FileLogSpec(..)+ , LogController+ ) where++import Control.Concurrent+import Control.Monad+import Network.Wai.Logger.File+import Network.Wai.Logger.Prefork.File+import Network.Wai.Logger.Prefork.Stdout+import Network.Wai.Logger.Prefork.Types++logCheck :: LogType -> IO ()+logCheck LogNone = return ()+logCheck LogStdout = return ()+logCheck (LogFile spec) = check spec++logInit :: LogType -> IO ApacheLogger+logInit LogNone = noLoggerInit+logInit LogStdout = stdoutLoggerInit+logInit (LogFile spec) = fileLoggerInit spec++noLoggerInit :: IO ApacheLogger+noLoggerInit = return noLogger+ where+ noLogger _ _ _ = return ()++logController :: LogType -> LogController+logController LogNone = noLoggerController+logController LogStdout = noLoggerController+logController (LogFile spec) = fileLoggerController spec++noLoggerController :: LogController+noLoggerController _ = forever $ threadDelay 10000000
+ Network/Wai/Logger/Prefork/File.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DoAndIfThenElse #-}++module Network.Wai.Logger.Prefork.File where++import Control.Applicative+import Control.Concurrent+import Control.Exception (handle, SomeException, catch)+import Control.Monad+import Data.IORef+import Network.Wai.Logger.Date+import Network.Wai.Logger.File+import Network.Wai.Logger.Format+import Network.Wai.Logger.IO+import Network.Wai.Logger.Prefork.Types+import Prelude hiding (catch)+import System.IO+import System.Posix++----------------------------------------------------------------++logBufSize :: Int+logBufSize = 4096++----------------------------------------------------------------++newtype HandleRef = HandleRef (IORef Handle)++getHandle :: HandleRef -> IO Handle+getHandle (HandleRef ref) = readIORef ref++----------------------------------------------------------------++fileLoggerInit :: FileLogSpec -> IO ApacheLogger+fileLoggerInit spec = do+ hdl <- open spec+ hdlref <- HandleRef <$> newIORef hdl+ forkIO $ fileFlusher hdlref+ dateref <- dateInit+ installHandler sigUSR1 (Catch $ reopen spec hdlref) Nothing+ return $ fileLogger dateref hdlref++{-+ For BlockBuffering, hPut flushes the buffer before writing+ the target string. In other words, hPut does not split+ the target string. So, to implment multiple line buffering,+ just use BlockBuffering.+-}+open :: FileLogSpec -> IO Handle+open spec = do+ hdl <- openFile file AppendMode+ hSetBuffering hdl (BlockBuffering (Just logBufSize))+ return hdl+ where+ file = log_file spec++reopen :: FileLogSpec -> HandleRef -> IO ()+reopen spec (HandleRef ref) = do+ hdl <- open spec+ oldhdl <- atomicModifyIORef ref (\oh -> (hdl,oh))+ hClose oldhdl++----------------------------------------------------------------++fileLogger :: DateRef -> HandleRef -> ApacheLogger+fileLogger dateref hdlref req status msiz = do+ date <- getDate dateref+ hdl <- getHandle hdlref+ hPutLogStr hdl $ apacheFormat date req status msiz++fileFlusher :: HandleRef -> IO ()+fileFlusher hdlref = forever $ do+ threadDelay 10000000+ getHandle hdlref >>= hFlush++----------------------------------------------------------------++fileLoggerController :: FileLogSpec -> LogController+fileLoggerController spec pids = forever $ do+ isOver <- over+ when isOver $ do+ rotate spec+ mapM_ sendSignal pids+ threadDelay 10000000+ where+ file = log_file spec+ over = handle handler $ do+ siz <- fromIntegral . fileSize <$> getFileStatus file+ if siz > log_file_size spec then+ return True+ else+ return False+ sendSignal pid = signalProcess sigUSR1 pid `catch` ignore+ handler :: SomeException -> IO Bool+ handler _ = return False+ ignore :: SomeException -> IO ()+ ignore _ = return ()
+ Network/Wai/Logger/Prefork/Stdout.hs view
@@ -0,0 +1,20 @@+module Network.Wai.Logger.Prefork.Stdout (stdoutLoggerInit) where++import Control.Applicative+import Data.ByteString.Char8 (pack)+import Network.Wai.Logger.Date+import Network.Wai.Logger.Format+import Network.Wai.Logger.IO+import Network.Wai.Logger.Prefork.Types+import qualified Data.ByteString as BS++stdoutLoggerInit :: IO ApacheLogger+stdoutLoggerInit = stdoutLogger <$> dateInit++stdoutLogger :: DateRef -> ApacheLogger+stdoutLogger dateref req status msiz = do+ date <- getDate dateref+ BS.putStr $ BS.concat $ map toBS $ apacheFormat date req status msiz+ where+ toBS (LS s) = pack s+ toBS (LB s) = s
+ Network/Wai/Logger/Prefork/Types.hs view
@@ -0,0 +1,17 @@+module Network.Wai.Logger.Prefork.Types (+ ApacheLogger+ , FileLogSpec(..)+ , LogType(..)+ , LogController+ ) where++import Network.HTTP.Types+import Network.Wai+import Network.Wai.Logger.File+import System.Posix (ProcessID)++data LogType = LogNone | LogStdout | LogFile FileLogSpec++type ApacheLogger = Request -> Status -> Maybe Integer -> IO ()++type LogController = [ProcessID] -> IO ()
+ Network/Wai/Logger/Utils.hs view
@@ -0,0 +1,54 @@+module Network.Wai.Logger.Utils (+ NumericAddress, showSockAddr+ ) where++import Data.Bits+import Data.Word+import Network.Socket (SockAddr(..))+import System.ByteOrder+import Text.Printf++{-|+ A type for IP address in numeric string representation.+-}+type NumericAddress = String++showIPv4 :: Word32 -> Bool -> NumericAddress+showIPv4 w32 little+ | little = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4+ | otherwise = show b4 ++ "." ++ show b3 ++ "." ++ show b2 ++ "." ++ show b1+ where+ t1 = w32+ t2 = shift t1 (-8)+ t3 = shift t2 (-8)+ t4 = shift t3 (-8)+ b1 = t1 .&. 0x000000ff+ b2 = t2 .&. 0x000000ff+ b3 = t3 .&. 0x000000ff+ b4 = t4 .&. 0x000000ff++showIPv6 :: (Word32,Word32,Word32,Word32) -> String+showIPv6 (w1,w2,w3,w4) =+ printf "%x:%x:%x:%x:%x:%x:%x:%x" s1 s2 s3 s4 s5 s6 s7 s8+ where+ (s1,s2) = foo w1+ (s3,s4) = foo w2+ (s5,s6) = foo w3+ (s7,s8) = foo w4+ foo w = (h1,h2)+ where+ h1 = w .&. 0x0000ffff+ h2 = shift w (-16) .&. 0x0000ffff+{-|+ Convert 'SockAddr' to 'NumericAddress'. If the address is+ an IPv4-embedded IPv6 address, the IPv4 is extracted.+-}+-- HostAddr is network byte order.+-- HostAddr6 is host byte order.+showSockAddr :: SockAddr -> NumericAddress+showSockAddr (SockAddrInet _ addr4) = showIPv4 addr4 (byteOrder == LittleEndian)+showSockAddr (SockAddrInet6 _ _ (0,0,0x0000ffff,addr4) _) = showIPv4 addr4 False+showSockAddr (SockAddrInet6 _ _ (0,0,0,1) _) = "::1"+showSockAddr (SockAddrInet6 _ _ addr6 _) = showIPv6 addr6+showSockAddr _ = "unknownSocket"+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ wai-logger.cabal view
@@ -0,0 +1,31 @@+Name: wai-logger+Version: 0.0.0+Author: Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+License: BSD3+License-File: LICENSE+Synopsis: A logging system for WAI+Description: A logging system for WAI+Category: Web, Yesod+Cabal-Version: >= 1.6+Build-Type: Simple+library+ GHC-Options: -Wall -fno-warn-unused-do-bind+ Exposed-Modules: Network.Wai.Logger+ Network.Wai.Logger.Date+ Network.Wai.Logger.File+ Network.Wai.Logger.Format+ Network.Wai.Logger.IO+ Network.Wai.Logger.Utils+ Network.Wai.Logger.Prefork+ Other-Modules: Network.Wai.Logger.Prefork.File+ Network.Wai.Logger.Prefork.Stdout+ Network.Wai.Logger.Prefork.Types+ Build-Depends: base >= 4 && < 5, wai,+ http-types, bytestring, filepath,+ directory, old-locale, case-insensitive,+ time, deepseq, unix, byteorder, network+Source-Repository head+ Type: git+ Location: git://github.com/kazu-yamamoto/wai-logger.git+