{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Program.Mighty.Report (
    Reporter
  , initReporter
  , report
  , reportDo
  , warpHandler
  , printStdout
  ) where

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.UnixTime
import GHC.IO.Exception (IOErrorType(..))
import Network.Wai
import Network.Wai.Handler.Warp (InvalidRequest)
import System.IO
import System.IO.Error (ioeGetErrorType)
import System.Posix (getProcessID)
import UnliftIO.Exception

import Program.Mighty.ByteString

data Method = FileOnly | FileAndStdout deriving Method -> Method -> Bool
(Method -> Method -> Bool)
-> (Method -> Method -> Bool) -> Eq Method
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq
data Reporter = Reporter Method FilePath

initReporter :: Bool -> FilePath -> Reporter
initReporter :: Bool -> FilePath -> Reporter
initReporter Bool
debug FilePath
reportFile = Method -> FilePath -> Reporter
Reporter Method
method FilePath
reportFile
  where
    method :: Method
method
      | Bool
debug     = Method
FileAndStdout
      | Bool
otherwise = Method
FileOnly

report :: Reporter -> ByteString -> IO ()
report :: Reporter -> ByteString -> IO ()
report (Reporter Method
method FilePath
reportFile) ByteString
msg = (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(SomeException e
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString
pid <- FilePath -> ByteString
BS.pack (FilePath -> ByteString)
-> (ProcessID -> FilePath) -> ProcessID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> FilePath
forall a. Show a => a -> FilePath
show (ProcessID -> ByteString) -> IO ProcessID -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ProcessID
getProcessID
    ByteString
tm <- IO UnixTime
getUnixTime IO UnixTime -> (UnixTime -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> UnixTime -> IO ByteString
formatUnixTime ByteString
"%d %b %Y %H:%M:%S"
    let logmsg :: ByteString
logmsg = [ByteString] -> ByteString
BS.concat [ByteString
tm, ByteString
": pid = ", ByteString
pid, ByteString
": ", ByteString
msg, ByteString
"\n"]
    FilePath -> ByteString -> IO ()
BS.appendFile FilePath
reportFile ByteString
logmsg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
FileAndStdout) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BS.putStr ByteString
logmsg

----------------------------------------------------------------

reportDo :: Reporter -> IO () -> IO ()
reportDo :: Reporter -> IO () -> IO ()
reportDo Reporter
rpt IO ()
act = IO ()
act IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` Reporter -> Maybe Request -> SomeException -> IO ()
warpHandler Reporter
rpt Maybe Request
forall a. Maybe a
Nothing

----------------------------------------------------------------

warpHandler :: Reporter -> Maybe Request -> SomeException -> IO ()
warpHandler :: Reporter -> Maybe Request -> SomeException -> IO ()
warpHandler Reporter
rpt Maybe Request
_ SomeException
se
  | Just (InvalidRequest
_ :: InvalidRequest) <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Just (IOException
e :: IOException)    <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se =
        if IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> [IOErrorType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IOErrorType
ResourceVanished,IOErrorType
InvalidArgument]
        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else Reporter -> ByteString -> IO ()
report Reporter
rpt (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> ByteString
forall a. Show a => a -> ByteString
bshow SomeException
se
  | Bool
otherwise = Reporter -> ByteString -> IO ()
report Reporter
rpt (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> ByteString
forall a. Show a => a -> ByteString
bshow SomeException
se

----------------------------------------------------------------

printStdout :: Maybe Request -> SomeException -> IO ()
printStdout :: Maybe Request -> SomeException -> IO ()
printStdout Maybe Request
_ SomeException
x = SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout