    -- | 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 = Just 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 = Response -> m Response
    forall a. a -> m a
    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 = Just 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 = IO Response -> m Response
    forall a. IO a -> m a
    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
    . String
    -> [String]
    -> Maybe String
    -> Maybe [(String, String)]
    -> (Maybe ByteString -> Bool)
    -> Response
    -> IO Response
    lazyProcValidator String
    "validate" [String
    "-w",String
    "--verbose",String
    "--charset=utf-8"] Maybe String
    forall a. Maybe a
    Nothing Maybe [(String, String)]
    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) = String -> [String] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem ((Char -> Bool) -> String -> String
    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 -> 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 = Response -> IO Response
    forall a. a -> IO a
    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 (String -> Response -> Maybe ByteString
    forall r. HasHeaders r => String -> r -> Maybe ByteString
    getHeader String
    "content-type" Response
    response) =
            do (inh, outh, errh, 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
               out <- hGetContents outh
               err <- hGetContents errh
               void $ forkIO $ do L.hPut inh (rsBody response)
                                  hClose inh
               void $ forkIO $ evaluate (length out) >> return ()
               void $ forkIO $ evaluate (length err) >> return ()
               ec <- waitForProcess ph
               case ec of
                 ExitCode
    ExitSuccess     -> Response -> IO Response
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Response
    response
                 (ExitFailure Int
    _) ->
                     Response -> IO Response
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Response -> IO Response) -> Response -> IO Response
    forall a b. (a -> b) -> a -> b
    $ String -> Response
    forall a. ToMessage a => a -> Response
    toResponse ([String] -> String
    unlines ([ String
    "ExitCode: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExitCode -> String
    forall a. Show a => a -> String
    show ExitCode
    ec
                                                   , String
    "stdout:"
                                                   , String
    out
                                                   , String
    "stderr:"
                                                   , String
    err
                                                   , String
    "input:"
                                                   ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
                                                   ByteString -> [String]
    showLines (Response -> ByteString
    rsBody Response
    response)))
        | Bool
    otherwise = Response -> IO Response
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Response
    response
        where
          column :: String
    column = String
    "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Int -> String -> String
    forall a. Int -> [a] -> [a]
    take Int
    120 (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ (Int -> String) -> [Int] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap  (\Int
    n -> String
    "         " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    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. HasCallStack => [a] -> [a]
    cycle [Int
    0..Int
    9::Int]))
          showLines :: L.ByteString -> [String]
          showLines :: ByteString -> [String]
    showLines ByteString
    string = String
    column String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : (Integer -> ByteString -> String)
    -> [Integer] -> [ByteString] -> [String]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Integer
    n -> \ByteString
    l  -> Integer -> String
    forall a. Show a => a -> String
    show Integer
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (ByteString -> String
    L.unpack ByteString
    l)) [Integer
    1::Integer ..] (ByteString -> [ByteString]
    L.lines ByteString
    string)