-- | Support for validating server output on-the-fly. Validators can be configured on a per content-type basis.
module Happstack.Server.Validation where

import Control.Concurrent                        (forkIO)
import Control.Exception                         (evaluate)
import Control.Monad
import Control.Monad.Trans                       (MonadIO(liftIO))
import qualified Data.ByteString.Char8           as B
import qualified Data.ByteString.Lazy.Char8      as L
import Happstack.Server.Types                    (Conf(..), Response(..), getHeader, nullConf)
import Happstack.Server.Response                 (ToMessage, toResponse)
import System.Exit                               (ExitCode(ExitSuccess, ExitFailure))
import System.IO                                 (hGetContents, hClose)
import System.Process                            (runInteractiveProcess, waitForProcess)

-- | Set the validator which should be used for this particular
-- 'Response' when validation is enabled.
--
-- Calling this function does not enable validation. That can only be
-- done by enabling the validation in the 'Conf' that is passed to
-- 'simpleHTTP'.
--
-- You do not need to call this function if the validator set in
-- 'Conf' does what you want already.
--
-- Example: (use 'noopValidator' instead of the default supplied by
-- 'validateConf')
--
-- > simpleHTTP validateConf $ ok . setValidator noopValidator =<< htmlPage
--
-- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator',
-- 'lazyProcValidator'.
setValidator :: (Response -> IO Response) -> Response -> Response
setValidator :: (Response -> IO Response) -> Response -> Response
setValidator Response -> IO Response
v Response
r = Response
r { rsValidator :: Maybe (Response -> IO Response)
rsValidator = (Response -> IO Response) -> Maybe (Response -> IO Response)
forall a. a -> Maybe a
Just Response -> IO Response
v }

-- | 'ServerPart' version of 'setValidator'.
--
-- Example: (Set validator to 'noopValidator')
--
-- >  simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... )
--
setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response
setValidatorSP :: (Response -> IO Response) -> m r -> m Response
setValidatorSP Response -> IO Response
v m r
sp = Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> (r -> Response) -> r -> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> IO Response) -> Response -> Response
setValidator Response -> IO Response
v (Response -> Response) -> (r -> Response) -> r -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall a. ToMessage a => a -> Response
toResponse (r -> m Response) -> m r -> m Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m r
sp

-- | Extend 'nullConf' by enabling validation and setting
-- 'wdgHTMLValidator' as the default validator for @text\/html@.
--
-- Example:
--
-- > simpleHTTP validateConf . anyRequest $ ok htmlPage
--
validateConf :: Conf
validateConf :: Conf
validateConf = Conf
nullConf { validator :: Maybe (Response -> IO Response)
validator = (Response -> IO Response) -> Maybe (Response -> IO Response)
forall a. a -> Maybe a
Just Response -> IO Response
forall (m :: * -> *) r. (MonadIO m, ToMessage r) => r -> m Response
wdgHTMLValidator }

-- | Actually perform the validation on a 'Response'.
--
-- Run the validator specified in the 'Response'. If none is provide
-- use the supplied default instead.
--
-- Note: This function will run validation unconditionally. You
-- probably want 'setValidator' or 'validateConf'.
runValidator :: (Response -> IO Response) -> Response -> IO Response
runValidator :: (Response -> IO Response) -> Response -> IO Response
runValidator Response -> IO Response
defaultValidator Response
r =
    case Response -> Maybe (Response -> IO Response)
rsValidator Response
r of
      Maybe (Response -> IO Response)
Nothing -> Response -> IO Response
defaultValidator Response
r
      (Just Response -> IO Response
altValidator) -> Response -> IO Response
altValidator Response
r

-- | Validate @text\/html@ content with @WDG HTML Validator@.
--
-- This function expects the executable to be named @validate@ and it
-- must be in the default @PATH@.
--
-- See also: 'setValidator', 'validateConf', 'lazyProcValidator'.
wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response
wdgHTMLValidator :: r -> m Response
wdgHTMLValidator = IO Response -> m Response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> m Response)
-> (r -> IO Response) -> r -> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> (Maybe ByteString -> Bool)
-> Response
-> IO Response
lazyProcValidator FilePath
"validate" [FilePath
"-w",FilePath
"--verbose",FilePath
"--charset=utf-8"] Maybe FilePath
forall a. Maybe a
Nothing Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing Maybe ByteString -> Bool
handledContentTypes (Response -> IO Response) -> (r -> Response) -> r -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Response
forall a. ToMessage a => a -> Response
toResponse
    where
      handledContentTypes :: Maybe ByteString -> Bool
handledContentTypes (Just ByteString
ct) = FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (ByteString -> FilePath
B.unpack ByteString
ct)) [ FilePath
"text/html", FilePath
"application/xhtml+xml" ]
      handledContentTypes Maybe ByteString
Nothing = Bool
False

-- | A validator which always succeeds.
--
-- Useful for selectively disabling validation. For example, if you
-- are sending down HTML fragments to an AJAX application and the
-- default validator only understands complete documents.
noopValidator :: Response -> IO Response
noopValidator :: Response -> IO Response
noopValidator = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Validate the 'Response' using an external application.
--
-- If the external application returns 0, the original response is
-- returned unmodified. If the external application returns non-zero,
-- a 'Response' containing the error messages and original response
-- body is returned instead.
--
-- This function also takes a predicate filter which is applied to the
-- content-type of the response. The filter will only be applied if
-- the predicate returns true.
--
-- NOTE: This function requires the use of -threaded to avoid
-- blocking.  However, you probably need that for Happstack anyway.
--
-- See also: 'wdgHTMLValidator'.
lazyProcValidator :: FilePath -- ^ name of executable
               -> [String] -- ^ arguments to pass to the executable
               -> Maybe FilePath -- ^ optional path to working directory
               -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit)
               -> (Maybe B.ByteString -> Bool) -- ^ content-type filter
               -> Response -- ^ Response to validate
               -> IO Response
lazyProcValidator :: FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> (Maybe ByteString -> Bool)
-> Response
-> IO Response
lazyProcValidator FilePath
exec [FilePath]
args Maybe FilePath
wd Maybe [(FilePath, FilePath)]
env Maybe ByteString -> Bool
mimeTypePred Response
response
    | Maybe ByteString -> Bool
mimeTypePred (FilePath -> Response -> Maybe ByteString
forall r. HasHeaders r => FilePath -> r -> Maybe ByteString
getHeader FilePath
"content-type" Response
response) =
        do (Handle
inh, Handle
outh, Handle
errh, ProcessHandle
ph) <- FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess FilePath
exec [FilePath]
args Maybe FilePath
wd Maybe [(FilePath, FilePath)]
env
           FilePath
out <- Handle -> IO FilePath
hGetContents Handle
outh
           FilePath
err <- Handle -> IO FilePath
hGetContents Handle
errh
           IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do Handle -> ByteString -> IO ()
L.hPut Handle
inh (Response -> ByteString
rsBody Response
response)
                              Handle -> IO ()
hClose Handle
inh
           IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
evaluate (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
out) IO Int -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
evaluate (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
err) IO Int -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
           case ExitCode
ec of
             ExitCode
ExitSuccess     -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response
             (ExitFailure Int
_) ->
                 Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ FilePath -> Response
forall a. ToMessage a => a -> Response
toResponse ([FilePath] -> FilePath
unlines ([ FilePath
"ExitCode: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
ec
                                               , FilePath
"stdout:"
                                               , FilePath
out
                                               , FilePath
"stderr:"
                                               , FilePath
err
                                               , FilePath
"input:"
                                               ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                                               ByteString -> [FilePath]
showLines (Response -> ByteString
rsBody Response
response)))
    | Bool
otherwise = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response
    where
      column :: FilePath
column = FilePath
"  " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
120 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Int -> FilePath) -> [Int] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap  (\Int
n -> FilePath
"         " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
cycle [Int
0..Int
9::Int]))
      showLines :: L.ByteString -> [String]
      showLines :: ByteString -> [FilePath]
showLines ByteString
string = FilePath
column FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (Integer -> ByteString -> FilePath)
-> [Integer] -> [ByteString] -> [FilePath]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Integer
n -> \ByteString
l  -> Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (ByteString -> FilePath
L.unpack ByteString
l)) [Integer
1::Integer ..] (ByteString -> [ByteString]
L.lines ByteString
string)