-- | 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 = 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 :: forall (m :: * -> *) r.
(Monad m, ToMessage r) =>
(Response -> IO Response) -> m r -> m Response
setValidatorSP Response -> IO Response
v m r
sp = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> IO Response) -> Response -> Response
setValidator Response -> IO Response
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMessage a => a -> Response
toResponse 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 = forall a. a -> Maybe a
Just 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 :: forall (m :: * -> *) r. (MonadIO m, ToMessage r) => r -> m Response
wdgHTMLValidator = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> (Maybe ByteString -> Bool)
-> Response
-> IO Response
lazyProcValidator String
"validate" [String
"-w",String
"--verbose",String
"--charset=utf-8"] forall a. Maybe a
Nothing forall a. Maybe a
Nothing Maybe ByteString -> Bool
handledContentTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMessage a => a -> Response
toResponse
    where
      handledContentTypes :: Maybe ByteString -> Bool
handledContentTypes (Just ByteString
ct) = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
' ') (ByteString -> String
B.unpack ByteString
ct)) [ String
"text/html", String
"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 = 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 :: String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> (Maybe ByteString -> Bool)
-> Response
-> IO Response
lazyProcValidator String
exec [String]
args Maybe String
wd Maybe [(String, String)]
env Maybe ByteString -> Bool
mimeTypePred Response
response
    | Maybe ByteString -> Bool
mimeTypePred (forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"content-type" Response
response) =
        do (Handle
inh, Handle
outh, Handle
errh, ProcessHandle
ph) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
exec [String]
args Maybe String
wd Maybe [(String, String)]
env
           String
out <- Handle -> IO String
hGetContents Handle
outh
           String
err <- Handle -> IO String
hGetContents Handle
errh
           forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO 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
           forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
out) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
err) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
           case ExitCode
ec of
             ExitCode
ExitSuccess     -> forall (m :: * -> *) a. Monad m => a -> m a
return Response
response
             (ExitFailure Int
_) ->
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ([String] -> String
unlines ([ String
"ExitCode: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ExitCode
ec
                                               , String
"stdout:"
                                               , String
out
                                               , String
"stderr:"
                                               , String
err
                                               , String
"input:"
                                               ] forall a. [a] -> [a] -> [a]
++
                                               ByteString -> [String]
showLines (Response -> ByteString
rsBody Response
response)))
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Response
response
    where
      column :: String
column = String
"  " forall a. [a] -> [a] -> [a]
++ (forall a. Int -> [a] -> [a]
take Int
120 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap  (\Int
n -> String
"         " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n) (forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
cycle [Int
0..Int
9::Int]))
      showLines :: L.ByteString -> [String]
      showLines :: ByteString -> [String]
showLines ByteString
string = String
column forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Integer
n -> \ByteString
l  -> forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ (ByteString -> String
L.unpack ByteString
l)) [Integer
1::Integer ..] (ByteString -> [ByteString]
L.lines ByteString
string)