-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- 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 holder(s) nor the names of
--    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.
-- -----------------------------------------------------------------------------

module Network.MoHWS.Logger (
    Handle,
    start,
    stop,
    log,
   ) where

import Network.MoHWS.Utility (dirname, )

import qualified Control.Exception as Exception
import Control.Exception (SomeException(SomeException), )
import Control.Concurrent (Chan, ThreadId, newChan, forkIO, writeChan, readChan, )
import System.Directory (createDirectoryIfMissing, )
import System.IO (IOMode(AppendMode), hPutStrLn, stderr, hClose, hFlush, )
import qualified System.IO as IO

import Prelude hiding (log, )


data Handle a = Handle
    {
     Handle a -> Chan (Command a)
handleChan     :: Chan (Command a),
     Handle a -> ThreadId
handleThreadId :: ThreadId
    }

data T a = Cons
    {
     T a -> Chan (Command a)
chan     :: Chan (Command a),
     T a -> a -> IO String
format   :: (a -> IO String),
     T a -> String
file     :: FilePath
    }

data Command a = Stop | Log a

start ::
      (a -> IO String) -- ^ Message formatting function
   -> FilePath         -- ^ log file path
   -> IO (Handle a)
start :: (a -> IO String) -> String -> IO (Handle a)
start a -> IO String
format0 String
file0 =
    do Chan (Command a)
chan0 <- IO (Chan (Command a))
forall a. IO (Chan a)
newChan
       Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
dirname String
file0)
       let l :: T a
l = Cons :: forall a. Chan (Command a) -> (a -> IO String) -> String -> T a
Cons {
                chan :: Chan (Command a)
chan = Chan (Command a)
chan0,
                format :: a -> IO String
format = a -> IO String
format0,
                file :: String
file = String
file0
               }
       ThreadId
t <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
          T a -> IO ()
forall a. T a -> IO ()
run T a
l
          IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
          \(SomeException e
e) ->
              Handle -> String -> IO ()
hPutStrLn Handle
stderr
                 (String
"Error starting logger: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
       Handle a -> IO (Handle a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle a -> IO (Handle a)) -> Handle a -> IO (Handle a)
forall a b. (a -> b) -> a -> b
$
          Handle :: forall a. Chan (Command a) -> ThreadId -> Handle a
Handle {
             handleChan :: Chan (Command a)
handleChan = Chan (Command a)
chan0,
             handleThreadId :: ThreadId
handleThreadId = ThreadId
t
          }

stop :: Handle a -> IO ()
stop :: Handle a -> IO ()
stop Handle a
l = Chan (Command a) -> Command a -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Handle a -> Chan (Command a)
forall a. Handle a -> Chan (Command a)
handleChan Handle a
l) Command a
forall a. Command a
Stop

log :: Handle a -> a -> IO ()
log :: Handle a -> a -> IO ()
log Handle a
l a
x = Chan (Command a) -> Command a -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Handle a -> Chan (Command a)
forall a. Handle a -> Chan (Command a)
handleChan Handle a
l) (a -> Command a
forall a. a -> Command a
Log a
x)

-- Internals

run :: T a -> IO ()
run :: T a -> IO ()
run T a
l =
   T a -> IO ()
forall a. T a -> IO ()
run1 T a
l
   IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
   \(SomeException e
e) ->
      do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Logger died: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
         T a -> IO ()
forall a. T a -> IO ()
run T a
l

run1 :: T a -> IO ()
run1 :: T a -> IO ()
run1 T a
l =
    IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
      (String -> IO Handle
openFile (T a -> String
forall a. T a -> String
file T a
l))
      (\Handle
hdl -> Handle -> IO ()
hClose Handle
hdl)
      (\Handle
hdl -> T a -> Handle -> IO ()
forall a. T a -> Handle -> IO ()
handleCommands T a
l Handle
hdl)
  where
    openFile :: FilePath -> IO IO.Handle
    openFile :: String -> IO Handle
openFile String
f =
        String -> IOMode -> IO Handle
IO.openFile String
f IOMode
AppendMode
        IO Handle -> (SomeException -> IO Handle) -> IO Handle
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
        \(SomeException e
e) ->
           do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Failed to open log file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
              e -> IO Handle
forall a e. Exception e => e -> a
Exception.throw e
e

handleCommands :: T a -> IO.Handle -> IO ()
handleCommands :: T a -> Handle -> IO ()
handleCommands T a
l Handle
hdl =
    do Command a
comm <- Chan (Command a) -> IO (Command a)
forall a. Chan a -> IO a
readChan (T a -> Chan (Command a)
forall a. T a -> Chan (Command a)
chan T a
l)
       case Command a
comm of
         Command a
Stop -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Log a
x ->
            do Handle -> String -> IO ()
writeLine Handle
hdl (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T a -> a -> IO String
forall a. T a -> a -> IO String
format T a
l a
x
               T a -> Handle -> IO ()
forall a. T a -> Handle -> IO ()
handleCommands T a
l Handle
hdl
  where
    writeLine :: IO.Handle -> String -> IO ()
    writeLine :: Handle -> String -> IO ()
writeLine Handle
hndl String
str =
       do Handle -> String -> IO ()
hPutStrLn Handle
hndl String
str
          Handle -> IO ()
hFlush Handle
hndl