diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Hirotomo Moriwaki + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apiary-logger.cabal b/apiary-logger.cabal new file mode 100644 --- /dev/null +++ b/apiary-logger.cabal @@ -0,0 +1,37 @@ +name: apiary-logger +version: 0.8.0.0 +synopsis: fast-logger support for apiary web framework. +description: + example: +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/apiary +Bug-reports: https://github.com/philopon/apiary/issues +copyright: (c) 2014 Hirotomo Moriwaki +category: Web +build-type: Simple +stability: experimental +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Web.Apiary.Logger + other-modules: Web.Apiary.Logger.Internal + build-depends: base >=4.6 && <4.8 + , apiary >=0.8 && <0.9 + , fast-logger >=2.1 && <2.2 + , monad-logger >=0.3 && <0.4 + , reflection >=1.4 && <1.5 + , data-default-class >=0.0 && <0.1 + , monad-control >=0.3 && <0.4 + , mtl >=2.1 && <2.2 + , transformers-base >=0.4 && <0.5 + hs-source-dirs: src + ghc-options: -O2 -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/philopon/apiary.git diff --git a/src/Web/Apiary/Logger.hs b/src/Web/Apiary/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Logger.hs @@ -0,0 +1,17 @@ +module Web.Apiary.Logger ( + -- * configuration + LogDest(..), LogConfig(..), HasLogger + -- * initialize + , withLogger + , withLogger' + -- * action + , logging + -- * wrapper + , GivenLoggerT(..) + + -- * reexports + , module Data.Default.Class + ) where + +import Web.Apiary.Logger.Internal +import Data.Default.Class diff --git a/src/Web/Apiary/Logger/Internal.hs b/src/Web/Apiary/Logger/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Logger/Internal.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Web.Apiary.Logger.Internal where + +import Control.Applicative +import Web.Apiary hiding (Default(..)) +import System.Log.FastLogger +import Control.Monad +import Control.Monad.Base +import Control.Monad.Trans +import Control.Monad.Logger +import Control.Monad.Trans.Control +import Control.Exception +import Data.Reflection +import Data.Default.Class + +data LogDest + = File FilePath + | Stdout + | Stderr + | Null + +data LogConfig = LogConfig + { bufferSize :: BufSize + , logDest :: LogDest + } + +data Logger = Logger + { pushLog :: LogStr -> IO () + , closeLog :: IO () + } + +instance Default LogConfig where + def = LogConfig defaultBufSize Stderr + +type HasLogger = Given Logger + +newLogger :: BufSize -> LogDest -> IO Logger +newLogger s (File p) = newFileLoggerSet s p >>= \l -> + return $ Logger (pushLogStr l) (flushLogStr l) +newLogger s Stdout = newStdoutLoggerSet s >>= \l -> + return $ Logger (pushLogStr l) (flushLogStr l) +newLogger s Stderr = newStderrLoggerSet s >>= \l -> + return $ Logger (pushLogStr l) (flushLogStr l) +newLogger _ Null = return $ Logger (\_ -> return ()) (return ()) + +withLogger :: LogConfig -> (HasLogger => IO a) -> IO a +withLogger LogConfig{..} m = bracket + (newLogger bufferSize logDest) + closeLog + (\l -> give l m) + +withLogger' :: LogConfig + -> ((forall r. (HasLogger => r) -> r) -> IO a) -> IO a +withLogger' LogConfig{..} m = bracket + (newLogger bufferSize logDest) + closeLog + (\l -> m (give l)) + +logging :: (MonadIO m, HasLogger) => LogStr -> ActionT m () +logging msg = liftIO $ pushLog given msg + +newtype GivenLoggerT m a = GivenLoggerT { runGivenLoggerT :: m a } + deriving(Functor, Applicative, Monad, MonadIO) + +instance MonadBase b m => MonadBase b (GivenLoggerT m) where + liftBase = GivenLoggerT . liftBase + +instance MonadTrans GivenLoggerT where + lift = GivenLoggerT + +instance MonadBaseControl b m => MonadBaseControl b (GivenLoggerT m) where + newtype StM (GivenLoggerT m) a = StMGivenLogger { unStMGivenLogger :: ComposeSt GivenLoggerT m a } + liftBaseWith = defaultLiftBaseWith StMGivenLogger + restoreM = defaultRestoreM unStMGivenLogger + +instance MonadTransControl GivenLoggerT where + newtype StT GivenLoggerT a = StGivenLogger { unStGivenLogger :: a } + liftWith f = GivenLoggerT $ f $ liftM StGivenLogger . runGivenLoggerT + restoreT = GivenLoggerT . liftM unStGivenLogger + +instance (MonadIO m, HasLogger) => MonadLogger (GivenLoggerT m) where + monadLoggerLog loc src lv msg = GivenLoggerT . liftIO $ + pushLog given (defaultLogStr loc src lv (toLogStr msg)) + +instance (MonadIO m, HasLogger) => MonadLogger (ActionT m) where + monadLoggerLog loc src lv msg = + logging $ defaultLogStr loc src lv (toLogStr msg)