-- | 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 v :: Response -> IO Response
v r :: 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 v :: Response -> IO Response
v sp :: 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 defaultValidator :: Response -> IO Response
defaultValidator r :: Response
r =
    case Response -> Maybe (Response -> IO Response)
rsValidator Response
r of
      Nothing -> Response -> IO Response
defaultValidator Response
r
      (Just altValidator :: 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 "validate" ["-w","--verbose","--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 ct :: 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 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ';' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ') (ByteString -> FilePath
B.unpack ByteString
ct)) [ "text/html", "application/xhtml+xml" ]
      handledContentTypes 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 exec :: FilePath
exec args :: [FilePath]
args wd :: Maybe FilePath
wd env :: Maybe [(FilePath, FilePath)]
env mimeTypePred :: Maybe ByteString -> Bool
mimeTypePred response :: Response
response
    | Maybe ByteString -> Bool
mimeTypePred (FilePath -> Response -> Maybe ByteString
forall r. HasHeaders r => FilePath -> r -> Maybe ByteString
getHeader "content-type" Response
response) =
        do (inh :: Handle
inh, outh :: Handle
outh, errh :: Handle
errh, ph :: 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
             ExitSuccess     -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response
             (ExitFailure _) ->
                 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 ([ "ExitCode: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
ec
                                               , "stdout:"
                                               , FilePath
out
                                               , "stderr:"
                                               , FilePath
err
                                               , "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
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take 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  (\n :: Int
n -> "         " 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 1 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
cycle [0..9::Int]))
      showLines :: L.ByteString -> [String]
      showLines :: ByteString -> [FilePath]
showLines string :: 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 (\n :: Integer
n -> \l :: ByteString
l  -> Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (ByteString -> FilePath
L.unpack ByteString
l)) [1::Integer ..] (ByteString -> [ByteString]
L.lines ByteString
string)