    {-# LANGUAGE CPP #-}
    {-# LANGUAGE UndecidableInstances #-}
    {-# LANGUAGE OverlappingInstances #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE TypeSynonymInstances #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE PatternGuards #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    {-# OPTIONS -fno-warn-orphans #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Happstack.Server.SimpleHTTP
    -- Copyright   :  (c) Happstack.com 2010; (c) HAppS Inc 2007
    -- License     :  BSD-like
    --
    -- Maintainer  :  Happstack team <happs@googlegroups.com>
    -- Stability   :  provisional
    -- Portability :  requires mtl
    --
    -- 'simpleHTTP' is a self-contained HTTP server which can be used to
    -- run a 'ServerPart'.
    --
    -- A very simple, \"Hello World!\" web app looks like:
    --
    -- > import Happstack.Server
    -- > main = simpleHTTP nullConf $ ok "Hello World!"
    --
    -- By default the server will listen on port 8000. Run the app and point your browser at: <http:\/\/localhost:8000\/>
    --
    -- For FastCGI support see: <http:\/\/hackage.haskell.org\/package\/happstack-fastcgi>
    -----------------------------------------------------------------------------
    module Happstack.Server.SimpleHTTP
        ( -- * SimpleHTTP
          simpleHTTP
        , simpleHTTP'
        , simpleHTTP''
        , simpleHTTPWithSocket
        , simpleHTTPWithSocket'
        , bindPort
        , bindIPv4
        , parseConfig
        , runWebT
        , waitForTermination
        -- * Re-exported modules
        -- ** Basic ServerMonad functionality
        , module Happstack.Server.Monads
        -- ** HTTP Realm Authentication
        , module Happstack.Server.Auth
        -- ** Create and Set Cookies (see also "Happstack.Server.RqData")
        , module Happstack.Server.Cookie
        -- ** Error Handling
        , module Happstack.Server.Error
        -- ** Creating Responses
        , module Happstack.Server.Response
        -- ** Request Routing
        , module Happstack.Server.Routing
        -- ** Looking up values in Query String, Request Body, and Cookies
        , module Happstack.Server.RqData
        -- ** Output Validation
        , module Happstack.Server.Validation
        , module Happstack.Server.Types
    --    , module Happstack.Server.Internal.Monads

        ) where

    -- re-exports

    import Happstack.Server.Auth
    import Happstack.Server.Monads
    import Happstack.Server.Cookie
    import Happstack.Server.Error
    import Happstack.Server.Types
    import Happstack.Server.Routing
    import Happstack.Server.RqData
    import Happstack.Server.Response
    import Happstack.Server.Validation

    import Control.Monad
    import Data.Maybe                                (fromMaybe)
    import qualified Data.Version                    as DV
    import Happstack.Server.Internal.Monads          (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT)
    import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen'
    import Network.Socket                            (Socket)
    import qualified Paths_happstack_server          as Cabal
    import System.Console.GetOpt                     ( OptDescr(Option)
                                                     , ArgDescr(ReqArg)
                                                     , ArgOrder(Permute)
                                                     , getOpt
                                                     )
    #ifdef UNIX
    import Control.Concurrent.MVar
    import System.Posix.Signals hiding (Handler)
    import System.Posix.IO ( stdInput )
    import System.Posix.Terminal ( queryTerminal )
    #endif

    -- | An array of 'OptDescr', useful for processing command line
    -- options into an 'Conf' for 'simpleHTTP'.
    ho :: [OptDescr (Conf -> Conf)]
    ho :: [OptDescr (Conf -> Conf)]
    ho = [[Char]
    -> [[Char]]
    -> ArgDescr (Conf -> Conf)
    -> [Char]
    -> OptDescr (Conf -> Conf)
    forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
    Option [] [[Char]
    "http-port"] (([Char] -> Conf -> Conf) -> [Char] -> ArgDescr (Conf -> Conf)
    forall a. ([Char] -> a) -> [Char] -> ArgDescr a
    ReqArg (\[Char]
    h Conf
    c -> Conf
    c { port = readDec' h }) [Char]
    "port") [Char]
    "port to bind http server"]

    -- | Parse command line options into a 'Conf'.
    parseConfig :: [String] -> Either [String] Conf
    parseConfig :: [[Char]] -> Either [[Char]] Conf
    parseConfig [[Char]]
    args
        = case ArgOrder (Conf -> Conf)
    -> [OptDescr (Conf -> Conf)]
    -> [[Char]]
    -> ([Conf -> Conf], [[Char]], [[Char]])
    forall a.
    ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
    getOpt ArgOrder (Conf -> Conf)
    forall a. ArgOrder a
    Permute [OptDescr (Conf -> Conf)]
    ho [[Char]]
    args of
            ([Conf -> Conf]
    flags,[[Char]]
    _,[]) -> Conf -> Either [[Char]] Conf
    forall a b. b -> Either a b
    Right (Conf -> Either [[Char]] Conf) -> Conf -> Either [[Char]] Conf
    forall a b. (a -> b) -> a -> b
    $ ((Conf -> Conf) -> Conf -> Conf) -> Conf -> [Conf -> Conf] -> Conf
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (Conf -> Conf) -> Conf -> Conf
    forall a b. (a -> b) -> a -> b
    ($) Conf
    nullConf [Conf -> Conf]
    flags
            ([Conf -> Conf]
    _,[[Char]]
    _,[[Char]]
    errs)   -> [[Char]] -> Either [[Char]] Conf
    forall a b. a -> Either a b
    Left [[Char]]
    errs

    -- |start the server, and handle requests using the supplied
    -- 'ServerPart'.
    --
    -- This function will not return, though it may throw an exception.
    --
    -- NOTE: The server will only listen on IPv4 due to portability issues
    -- in the "Network" module. For IPv6 support, use
    -- 'simpleHTTPWithSocket' with custom socket.
    simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()
    simpleHTTP :: forall a. ToMessage a => Conf -> ServerPartT IO a -> IO ()
    simpleHTTP = (UnWebT IO a -> UnWebT IO a) -> Conf -> ServerPartT IO a -> IO ()
    forall b (m :: * -> *) a.
    (ToMessage b, Monad m, Functor m) =>
    (UnWebT m a -> UnWebT IO b) -> Conf -> ServerPartT m a -> IO ()
    simpleHTTP' UnWebT IO a -> UnWebT IO a
    forall a. a -> a
    id

    -- | A combination of 'simpleHTTP''' and 'mapServerPartT'.  See
    -- 'mapServerPartT' for a discussion of the first argument of this
    -- function.
    --
    -- NOTE: This function always binds to IPv4 ports until Network
    -- module is fixed to support IPv6 in a portable way. Use
    -- 'simpleHTTPWithSocket' with custom socket if you want different
    -- behaviour.
    simpleHTTP' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)
                -> Conf -> ServerPartT m a -> IO ()
    simpleHTTP' :: forall b (m :: * -> *) a.
    (ToMessage b, Monad m, Functor m) =>
    (UnWebT m a -> UnWebT IO b) -> Conf -> ServerPartT m a -> IO ()
    simpleHTTP' UnWebT m a -> UnWebT IO b
    toIO Conf
    conf ServerPartT m a
    hs =
        Conf -> (Request -> IO Response) -> IO ()
    Listen.listen Conf
    conf (\Request
    req -> (Response -> IO Response) -> Response -> IO Response
    runValidator ((Response -> IO Response)
    -> Maybe (Response -> IO Response) -> Response -> IO Response
    forall a. a -> Maybe a -> a
    fromMaybe Response -> IO Response
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Conf -> Maybe (Response -> IO Response)
    validator Conf
    conf)) (Response -> IO Response) -> IO Response -> IO Response
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (ServerPartT IO b -> Request -> IO Response
    forall b (m :: * -> *).
    (ToMessage b, Monad m, Functor m) =>
    ServerPartT m b -> Request -> m Response
    simpleHTTP'' ((UnWebT m a -> UnWebT IO b) -> ServerPartT m a -> ServerPartT IO b
    forall (m :: * -> *) a (n :: * -> *) b.
    (UnWebT m a -> UnWebT n b) -> ServerPartT m a -> ServerPartT n b
    mapServerPartT UnWebT m a -> UnWebT IO b
    toIO ServerPartT m a
    hs) Request
    req))

    -- | Generate a result from a 'ServerPartT' and a 'Request'. This is
    -- mainly used by CGI (and fast-cgi) wrappers.
    simpleHTTP'' :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response
    simpleHTTP'' :: forall b (m :: * -> *).
    (ToMessage b, Monad m, Functor m) =>
    ServerPartT m b -> Request -> m Response
    simpleHTTP'' ServerPartT m b
    hs Request
    req =  (WebT m b -> m (Maybe Response)
    forall (m :: * -> *) b.
    (Functor m, ToMessage b) =>
    WebT m b -> m (Maybe Response)
    runWebT (WebT m b -> m (Maybe Response)) -> WebT m b -> m (Maybe Response)
    forall a b. (a -> b) -> a -> b
    $ ServerPartT m b -> Request -> WebT m b
    forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
    runServerPartT ServerPartT m b
    hs Request
    req) m (Maybe Response) -> (Maybe Response -> m Response) -> m Response
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Response -> m Response
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Response -> m Response)
    -> (Maybe Response -> Response) -> Maybe Response -> m Response
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Response -> (Response -> Response) -> Maybe Response -> Response
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Response
    standardNotFound Response -> Response
    forall a. a -> a
    id))
        where
            standardNotFound :: Response
    standardNotFound = [Char] -> [Char] -> Response -> Response
    forall r. HasHeaders r => [Char] -> [Char] -> r -> r
    setHeader [Char]
    "Content-Type" [Char]
    "text/html" (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $ ([Char] -> Response
    forall a. ToMessage a => a -> Response
    toResponse [Char]
    notFoundHtml){rsCode=404}

    -- | Run 'simpleHTTP' with a previously bound socket. Useful if you
    -- want to run happstack as user on port 80. Use something like this:
    --
    -- > import System.Posix.User (setUserID, UserEntry(..), getUserEntryForName)
    -- >
    -- > main = do
    -- >     let conf = nullConf { port = 80 }
    -- >     socket <- bindPort conf
    -- >     -- do other stuff as root here
    -- >     getUserEntryForName "www" >>= setUserID . userID
    -- >     -- finally start handling incoming requests
    -- >     tid <- forkIO $ simpleHTTPWithSocket socket Nothing conf impl
    --
    -- Note: It's important to use the same conf (or at least the same
    -- port) for 'bindPort' and 'simpleHTTPWithSocket'.
    --
    -- see also: 'bindPort', 'bindIPv4'
    simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()
    simpleHTTPWithSocket :: forall a.
    ToMessage a =>
    Socket -> Conf -> ServerPartT IO a -> IO ()
    simpleHTTPWithSocket = (UnWebT IO a -> UnWebT IO a)
    -> Socket -> Conf -> ServerPartT IO a -> IO ()
    forall b (m :: * -> *) a.
    (ToMessage b, Monad m, Functor m) =>
    (UnWebT m a -> UnWebT IO b)
    -> Socket -> Conf -> ServerPartT m a -> IO ()
    simpleHTTPWithSocket' UnWebT IO a -> UnWebT IO a
    forall a. a -> a
    id

    -- | Like 'simpleHTTP'' with a socket.
    simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)
                          -> Socket -> Conf -> ServerPartT m a -> IO ()
    simpleHTTPWithSocket' :: forall b (m :: * -> *) a.
    (ToMessage b, Monad m, Functor m) =>
    (UnWebT m a -> UnWebT IO b)
    -> Socket -> Conf -> ServerPartT m a -> IO ()
    simpleHTTPWithSocket' UnWebT m a -> UnWebT IO b
    toIO Socket
    socket Conf
    conf ServerPartT m a
    hs =
        Socket -> Conf -> (Request -> IO Response) -> IO ()
    Listen.listen' Socket
    socket Conf
    conf (\Request
    req -> (Response -> IO Response) -> Response -> IO Response
    runValidator ((Response -> IO Response)
    -> Maybe (Response -> IO Response) -> Response -> IO Response
    forall a. a -> Maybe a -> a
    fromMaybe Response -> IO Response
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Conf -> Maybe (Response -> IO Response)
    validator Conf
    conf)) (Response -> IO Response) -> IO Response -> IO Response
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (ServerPartT IO b -> Request -> IO Response
    forall b (m :: * -> *).
    (ToMessage b, Monad m, Functor m) =>
    ServerPartT m b -> Request -> m Response
    simpleHTTP'' ((UnWebT m a -> UnWebT IO b) -> ServerPartT m a -> ServerPartT IO b
    forall (m :: * -> *) a (n :: * -> *) b.
    (UnWebT m a -> UnWebT n b) -> ServerPartT m a -> ServerPartT n b
    mapServerPartT UnWebT m a -> UnWebT IO b
    toIO ServerPartT m a
    hs) Request
    req))

    -- | Bind port and return the socket for use with 'simpleHTTPWithSocket'. This
    -- function always binds to IPv4 ports until Network module is fixed
    -- to support IPv6 in a portable way.
    bindPort :: Conf -> IO Socket
    bindPort :: Conf -> IO Socket
    bindPort Conf
    conf = Int -> IO Socket
    Listen.listenOn (Conf -> Int
    port Conf
    conf)

    -- | Bind to ip and port and return the socket for use with 'simpleHTTPWithSocket'.
    --
    -- >
    -- > import Happstack.Server
    -- >
    -- > main = do let conf = nullConf
    -- >               addr = "127.0.0.1"
    -- >           s <- bindIPv4 addr (port conf)
    -- >           simpleHTTPWithSocket s conf $ ok $ toResponse $
    -- >             "now listening on ip addr " ++ addr ++
    -- >             " and port " ++ show (port conf)
    --
    bindIPv4 :: String  -- ^ IP address to bind to (must be an IP address and not a host name)
             -> Int     -- ^ port number to bind to
             -> IO Socket
    bindIPv4 :: [Char] -> Int -> IO Socket
    bindIPv4 [Char]
    addr Int
    prt = [Char] -> Int -> IO Socket
    Listen.listenOnIPv4 [Char]
    addr Int
    prt

    -- | Takes your 'WebT', if it is 'mempty' it returns 'Nothing' else it
    -- converts the value to a 'Response' and applies your filter to it.
    runWebT :: forall m b. (Functor m, ToMessage b) => WebT m b -> m (Maybe Response)
    runWebT :: forall (m :: * -> *) b.
    (Functor m, ToMessage b) =>
    WebT m b -> m (Maybe Response)
    runWebT = ((Maybe (Either Response b, FilterFun Response) -> Maybe Response)
    -> m (Maybe (Either Response b, FilterFun Response))
    -> m (Maybe Response)
    forall a b. (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Maybe (Either Response b, FilterFun Response) -> Maybe Response)
     -> m (Maybe (Either Response b, FilterFun Response))
     -> m (Maybe Response))
    -> (((Either Response b, FilterFun Response) -> Response)
        -> Maybe (Either Response b, FilterFun Response) -> Maybe Response)
    -> ((Either Response b, FilterFun Response) -> Response)
    -> m (Maybe (Either Response b, FilterFun Response))
    -> m (Maybe Response)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Either Response b, FilterFun Response) -> Response)
    -> Maybe (Either Response b, FilterFun Response) -> Maybe Response
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap) (Either Response b, FilterFun Response) -> Response
    appFilterToResp (m (Maybe (Either Response b, FilterFun Response))
     -> m (Maybe Response))
    -> (WebT m b -> m (Maybe (Either Response b, FilterFun Response)))
    -> WebT m b
    -> m (Maybe Response)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . WebT m b -> m (Maybe (Either Response b, FilterFun Response))
    forall (m :: * -> *) a. WebT m a -> UnWebT m a
    ununWebT
        where
          appFilterToResp :: (Either Response b, FilterFun Response) -> Response
          appFilterToResp :: (Either Response b, FilterFun Response) -> Response
    appFilterToResp (Either Response b
    e, FilterFun Response
    ff) = FilterFun Response -> Response -> Response
    forall a. FilterFun a -> a -> a
    unFilterFun FilterFun Response
    ff (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $ (Response -> Response)
    -> (b -> Response) -> Either Response b -> Response
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Response -> Response
    forall a. a -> a
    id b -> Response
    forall a. ToMessage a => a -> Response
    toResponse Either Response b
    e

    notFoundHtml :: String
    notFoundHtml :: [Char]
    notFoundHtml =
        [Char]
    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "<html><head><title>Happstack "
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ver [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    " File not found</title></head>"
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "<body><h1>Happstack " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ver [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "</h1>"
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "<p>Your file is not found<br>"
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "To try again is useless<br>"
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "It is just not here</p>"
        [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "</body></html>"
        where ver :: [Char]
    ver = Version -> [Char]
    DV.showVersion Version
    Cabal.version

    -- | Wait for a signal.
    --   On unix, a signal is sigINT or sigTERM (aka Control-C).
    --
    -- On windows, the signal is entering: e <return>
    waitForTermination :: IO ()
    waitForTermination :: IO ()
    waitForTermination
        = do
    #ifdef UNIX
             istty <- Fd -> IO Bool
    queryTerminal Fd
    stdInput
             mv <- newEmptyMVar
             void $ installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing
             void $ installHandler lostConnection      (CatchOnce (putMVar mv ())) Nothing
             case istty of
               Bool
    True  -> IO Handler -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO Handler -> IO ()) -> IO Handler -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Signal -> Handler -> Maybe SignalSet -> IO Handler
    installHandler Signal
    keyboardSignal (IO () -> Handler
    CatchOnce (MVar () -> () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar ()
    mv ())) Maybe SignalSet
    forall a. Maybe a
    Nothing
               Bool
    False -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
             takeMVar mv
    #else
             let loop 'e' = return ()
                 loop _   = getChar >>= loop
             loop 'c'
    #endif