-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright notice,
--    this list of conditions and the following disclaimer.
--
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--
--  * Neither the name of the copyright holder(s) nor the names of
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}
module Network.MoHWS.Server (main, mainWithOptions, ) where

import qualified Network.MoHWS.Server.Request as ServerRequest
import qualified Network.MoHWS.Server.Environment as ServerEnv
import qualified Network.MoHWS.Server.Context as ServerContext
import Network.MoHWS.Logger.Error (debug, logError, logInfo, )
import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.Logger.Access as AccessLogger
import qualified Network.MoHWS.Logger.Error as ErrorLogger
import qualified Network.MoHWS.Configuration.Parser as ConfigParser
import Network.MoHWS.Configuration as Config
import qualified Network.MoHWS.Initialization as Init
import qualified Network.MoHWS.HTTP.MimeType as MimeType
import qualified Network.MoHWS.Server.Options as Options
import Network.MoHWS.ParserUtility (getUntilEmptyLine, )
import qualified Network.MoHWS.HTTP.Version as Version
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Request  as Request
import qualified Network.MoHWS.HTTP.Response as Response
import qualified Network.MoHWS.Stream as Stream
import qualified Network.MoHWS.Utility as Util

import Data.Monoid (mempty, )
import Data.Maybe (catMaybes, )
import Data.Tuple.HT (swap, )
import Data.List.HT (viewR, )
import qualified Data.Set as Set

import qualified Control.Monad.Exception.Synchronous as Exc
import qualified Control.Exception as Exception
import Control.Monad.Exception.Synchronous (ExceptionalT, runExceptionalT, )
import Control.Monad.Trans.State (StateT, runStateT, modify, )
import Control.Monad.Trans.Class (lift, )

import qualified Network.Socket as Socket
import qualified Network.BSD as BSD
import Control.Concurrent (myThreadId, ThreadId, throwTo, killThread, forkIO, )
import Control.Exception (ErrorCall(ErrorCall), finally, mask, )
import Control.Monad (liftM, when, )
import Network.BSD (HostEntry, hostName, )
import Network.Socket (Socket, HostAddress, Family(AF_INET), )
import Network.URI (uriPath, )

import qualified System.Posix as Posix
import qualified System.IO as IO
import System.IO.Error (isAlreadyInUseError, isEOFError, catchIOError, )
import System.Environment (getArgs, )
import System.Posix (installHandler, sigHUP, sigPIPE, )
import Text.ParserCombinators.Parsec (parse, choice, )


{- -----------------------------------------------------------------------------
ToDo:

- MAJOR:

- deal with http version numbers
- timeouts (partly done)
- languages
- per-directory permissions (ala apache)
- error logging levels
- per-directory config options.
- languages (content-language, accept-language)
- multipart/byteranges

- MINOR:

- access logging (various bits left)
- implement user & group setting
- log time to serve request
- terminate & restart signal (like Apache's SIGHUP)
- don't die if the new configuration file contains errors after a restart
- reading config file may block, unsafe if we receive another SIGHUP
- common up headers with same name (eg. accept).
- implement if-modified-since (need to parse time)

- MAYBE:

- throttling if too many open connections (config: MaxClients)

-}


-----------------------------------------------------------------------------
-- Top-level server

main :: (Stream.C body) =>
   Init.T body ext -> IO ()
main :: T body ext -> IO ()
main T body ext
initExt =
    do [String]
args <- IO [String]
getArgs
       case [String] -> Either String T
Options.parse [String]
args of
         Left String
err   -> String -> IO ()
Util.die String
err
         Right T
opts -> T body ext -> T -> IO ()
forall body ext. C body => T body ext -> T -> IO ()
mainWithOptions T body ext
initExt T
opts

mainWithOptions :: (Stream.C body) =>
   Init.T body ext -> Options.T -> IO ()
mainWithOptions :: T body ext -> T -> IO ()
mainWithOptions T body ext
initExt T
opts =
    do ThreadId
main_thread <- IO ThreadId
myThreadId
       Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigPIPE Handler
Posix.Ignore Maybe SignalSet
forall a. Maybe a
Nothing
       Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigHUP (IO () -> Handler
Posix.Catch (ThreadId -> IO ()
hupHandler ThreadId
main_thread)) Maybe SignalSet
forall a. Maybe a
Nothing
       ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
readConfig T body ext
initExt T
opts)

type Unblock a = IO a -> IO a

hupHandler :: ThreadId -> IO ()
hupHandler :: ThreadId -> IO ()
hupHandler ThreadId
main_thread =
   ThreadId -> ErrorCall -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
main_thread (String -> ErrorCall
ErrorCall String
"**restart**")

sigsToBlock :: Posix.SignalSet
sigsToBlock :: SignalSet
sigsToBlock = Signal -> SignalSet -> SignalSet
Posix.addSignal Signal
sigHUP SignalSet
Posix.emptySignalSet

-- Async exceptions should be blocked on entry to readConfig (so that
-- multiple SIGHUPs close together can't kill us).  Make sure that
-- there aren't any interruptible operations until we've blocked signals.
readConfig :: (Stream.C body) =>
   Init.T body ext -> Options.T -> (forall a. Unblock a) -> IO ()
readConfig :: T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
readConfig T body ext
initExt T
opts forall a. IO a -> IO a
unblock = do
    SignalSet -> IO ()
Posix.blockSignals SignalSet
sigsToBlock
    Either ParseError (Builder ext)
r <- T () ext -> String -> IO (Either ParseError (Builder ext))
forall ext.
T () ext -> String -> IO (Either ParseError (Builder ext))
ConfigParser.run
            ([T () ext] -> T () ext
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([T () ext] -> T () ext) -> [T () ext] -> T () ext
forall a b. (a -> b) -> a -> b
$ (T body ext -> T () ext) -> [T body ext] -> [T () ext]
forall a b. (a -> b) -> [a] -> [b]
map T body ext -> T () ext
forall body ext. T body ext -> T () ext
ModuleDesc.configParser ([T body ext] -> [T () ext]) -> [T body ext] -> [T () ext]
forall a b. (a -> b) -> a -> b
$ T body ext -> [T body ext]
forall body ext. T body ext -> [T body ext]
Init.moduleList T body ext
initExt)
            (T -> String
Options.configPath T
opts)
    case Either ParseError (Builder ext)
r of
      Left ParseError
err ->
         String -> IO ()
Util.die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
         String
"Failed to parse configuration file" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ParseError -> String
forall a. Show a => a -> String
show ParseError
err String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []
      Right Builder ext
b  -> do
        let updates :: [ext -> ext]
updates = (T body ext -> ext -> ext) -> [T body ext] -> [ext -> ext]
forall a b. (a -> b) -> [a] -> [b]
map T body ext -> ext -> ext
forall body ext. T body ext -> ext -> ext
ModuleDesc.setDefltConfig ([T body ext] -> [ext -> ext]) -> [T body ext] -> [ext -> ext]
forall a b. (a -> b) -> a -> b
$ T body ext -> [T body ext]
forall body ext. T body ext -> [T body ext]
Init.moduleList T body ext
initExt
            confExtDeflt :: ext
confExtDeflt =
               (ext -> (ext -> ext) -> ext) -> ext -> [ext -> ext] -> ext
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((ext -> ext) -> ext -> ext) -> ext -> (ext -> ext) -> ext
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ext -> ext) -> ext -> ext
forall a b. (a -> b) -> a -> b
($)) (T body ext -> ext
forall body ext. T body ext -> ext
Init.configurationExtensionDefault T body ext
initExt) [ext -> ext]
updates
            conf :: T ext
conf = Builder ext
b (ext -> T ext
forall ext. ext -> T ext
Config.deflt ext
confExtDeflt)
        T ext
st <- T -> T ext -> IO (T ext)
forall ext. T -> T ext -> IO (T ext)
initServerState T
opts T ext
conf
        [T body]
mods <- ([Maybe (T body)] -> [T body])
-> IO [Maybe (T body)] -> IO [T body]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (T body)] -> [T body]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (T body)] -> IO [T body])
-> IO [Maybe (T body)] -> IO [T body]
forall a b. (a -> b) -> a -> b
$ (T body ext -> IO (Maybe (T body)))
-> [T body ext] -> IO [Maybe (T body)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (T ext -> T body ext -> IO (Maybe (T body))
forall body ext.
C body =>
T ext -> T body ext -> IO (Maybe (T body))
loadModule T ext
st) ([T body ext] -> IO [Maybe (T body)])
-> [T body ext] -> IO [Maybe (T body)]
forall a b. (a -> b) -> a -> b
$ T body ext -> [T body ext]
forall body ext. T body ext -> [T body ext]
Init.moduleList T body ext
initExt
        T ext
-> [T body] -> T body ext -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T ext
-> [T body] -> T body ext -> (forall a. IO a -> IO a) -> IO ()
topServer T ext
st [T body]
mods T body ext
initExt forall a. IO a -> IO a
unblock

rereadConfig :: (Stream.C body) =>
   ServerContext.T ext -> Init.T body ext -> (forall a. Unblock a) -> IO ()
rereadConfig :: T ext -> T body ext -> (forall a. IO a -> IO a) -> IO ()
rereadConfig T ext
st T body ext
initExt forall a. IO a -> IO a
unblock =
    do (Handle -> IO ()) -> [Handle] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
AccessLogger.stop (T ext -> [Handle]
forall ext. T ext -> [Handle]
ServerContext.accessLoggers T ext
st)
       Handle -> IO ()
ErrorLogger.stop (T ext -> Handle
forall ext. T ext -> Handle
ServerContext.errorLogger T ext
st)
       T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
readConfig T body ext
initExt (T ext -> T
forall ext. T ext -> T
ServerContext.options T ext
st) forall a. IO a -> IO a
unblock


initServerState :: Options.T -> Config.T ext -> IO (ServerContext.T ext)
initServerState :: T -> T ext -> IO (T ext)
initServerState T
opts T ext
conf =
    do HostEntry
host <- do HostEntry
ent <- IO HostEntry
BSD.getHostEntry
                  case T ext -> String
forall ext. T ext -> String
serverName T ext
conf of
                    String
"" -> HostEntry -> IO HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return HostEntry
ent
                    String
n  -> HostEntry -> IO HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return HostEntry
ent { hostName :: String
hostName = String
n }
       Dictionary
mimeTypes
           <- String -> IO Dictionary
MimeType.loadDictionary (T -> String -> String
Options.inServerRoot T
opts (T ext -> String
forall ext. T ext -> String
typesConfig T ext
conf))
       Handle
errorLogger
           <- String -> T -> IO Handle
ErrorLogger.start (T -> String -> String
Options.inServerRoot T
opts (T ext -> String
forall ext. T ext -> String
errorLogFile T ext
conf)) (T ext -> T
forall ext. T ext -> T
logLevel T ext
conf)
       [Handle]
accessLoggers
          <- [IO Handle] -> IO [Handle]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [String -> String -> IO Handle
AccessLogger.start String
format (T -> String -> String
Options.inServerRoot T
opts String
file)
                       | (String
file,String
format) <- T ext -> [(String, String)]
forall ext. T ext -> [(String, String)]
customLogs T ext
conf]

       let st :: T ext
st = Cons :: forall ext.
T
-> T ext -> HostEntry -> Dictionary -> Handle -> [Handle] -> T ext
ServerContext.Cons
                {
                 options :: T
ServerContext.options = T
opts,
                 config :: T ext
ServerContext.config = T ext
conf,
                 hostName :: HostEntry
ServerContext.hostName = HostEntry
host,
                 mimeTypes :: Dictionary
ServerContext.mimeTypes = Dictionary
mimeTypes,
                 errorLogger :: Handle
ServerContext.errorLogger = Handle
errorLogger,
                 accessLoggers :: [Handle]
ServerContext.accessLoggers = [Handle]
accessLoggers
                }

       T ext -> IO (T ext)
forall (m :: * -> *) a. Monad m => a -> m a
return T ext
st

loadModule :: (Stream.C body) =>
   ServerContext.T ext -> ModuleDesc.T body ext -> IO (Maybe (Module.T body))
loadModule :: T ext -> T body ext -> IO (Maybe (T body))
loadModule T ext
st T body ext
md =
    (do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logInfo T ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Loading module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ T body ext -> String
forall body ext. T body ext -> String
ModuleDesc.name T body ext
md String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
        (T body -> Maybe (T body)) -> IO (T body) -> IO (Maybe (T body))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T body -> Maybe (T body)
forall a. a -> Maybe a
Just (IO (T body) -> IO (Maybe (T body)))
-> IO (T body) -> IO (Maybe (T body))
forall a b. (a -> b) -> a -> b
$ T body ext -> T ext -> IO (T body)
forall body ext. T body ext -> T ext -> IO (T body)
ModuleDesc.load T body ext
md T ext
st)
    IO (Maybe (T body))
-> (SomeException -> IO (Maybe (T body))) -> IO (Maybe (T body))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
    \(Exception.SomeException e
e) ->
          do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Error loading module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ T body ext -> String
forall body ext. T body ext -> String
ModuleDesc.name T body ext
md,
                                    e -> String
forall a. Show a => a -> String
show e
e]
             Maybe (T body) -> IO (Maybe (T body))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (T body)
forall a. Maybe a
Nothing

-- We catch exceptions from the main server thread, and restart the
-- server.  If we receive a restart signal (from a SIGHUP), then we
-- re-read the configuration file.
topServer :: (Stream.C body) =>
   ServerContext.T ext -> [Module.T body] -> Init.T body ext -> (forall a. Unblock a) -> IO ()
topServer :: T ext
-> [T body] -> T body ext -> (forall a. IO a -> IO a) -> IO ()
topServer T ext
st [T body]
mods T body ext
initExt forall a. IO a -> IO a
unblock =
   let startServers :: IO ()
startServers =
          do [ThreadId]
ts <- T ext -> [T body] -> IO [ThreadId]
forall body ext. C body => T ext -> [T body] -> IO [ThreadId]
servers T ext
st [T body]
mods
             (IO ()
forall a. IO a
Util.wait IO () -> (ErrorCall -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
              (\ErrorCall
e -> case ErrorCall
e of
                       ErrorCall String
"**restart**" ->
                           do (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
ts
                              T ext -> T body ext -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T ext -> T body ext -> (forall a. IO a -> IO a) -> IO ()
rereadConfig T ext
st T body ext
initExt forall a. IO a -> IO a
unblock
                       ErrorCall
_ -> ErrorCall -> IO ()
forall a e. Exception e => e -> a
Exception.throw ErrorCall
e))
       loop :: IO ()
loop =
          (do SignalSet -> IO ()
Posix.unblockSignals SignalSet
sigsToBlock
              Unblock ()
forall a. IO a -> IO a
unblock IO ()
startServers)
          IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
          (\(Exception.SomeException e
e) ->
                 do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st (String
"server: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
                    IO ()
loop)
   in  IO ()
loop

servers :: (Stream.C body) =>
   ServerContext.T ext -> [Module.T body] -> IO [ThreadId]
servers :: T ext -> [T body] -> IO [ThreadId]
servers T ext
st [T body]
mods =
   let mkEnv :: PortNumber -> T body ext
mkEnv PortNumber
port =
          Cons :: forall body ext. T ext -> PortNumber -> [T body] -> T body ext
ServerEnv.Cons {
             context :: T ext
ServerEnv.context = T ext
st,
             modules :: [T body]
ServerEnv.modules = [T body]
mods,
             port :: PortNumber
ServerEnv.port    = PortNumber
port
          }

       mkAddr :: (Maybe String, PortNumber) -> IO (T body ext, SockAddr)
mkAddr (Maybe String
maddr,PortNumber
port) =
          do HostAddress
addr <- case Maybe String
maddr of
                       Maybe String
Nothing -> HostAddress -> IO HostAddress
forall (m :: * -> *) a. Monad m => a -> m a
return HostAddress
Socket.iNADDR_ANY
                       Just String
ip -> String -> IO HostAddress
Socket.inet_addr String
ip
             (T body ext, SockAddr) -> IO (T body ext, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (PortNumber -> T body ext
mkEnv PortNumber
port, PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet PortNumber
port HostAddress
addr)

   in  do [(T body ext, SockAddr)]
addrs <- ((Maybe String, PortNumber) -> IO (T body ext, SockAddr))
-> [(Maybe String, PortNumber)] -> IO [(T body ext, SockAddr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe String, PortNumber) -> IO (T body ext, SockAddr)
mkAddr (T ext -> [(Maybe String, PortNumber)]
forall ext. T ext -> [(Maybe String, PortNumber)]
listen (T ext -> T ext
forall ext. T ext -> T ext
ServerContext.config T ext
st))
          ((T body ext, SockAddr) -> IO ThreadId)
-> [(T body ext, SockAddr)] -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (T body ext
env,SockAddr
addr) -> IO () -> IO ThreadId
forkIO (T body ext -> SockAddr -> IO ()
forall body ext. C body => T body ext -> SockAddr -> IO ()
server T body ext
env SockAddr
addr)) [(T body ext, SockAddr)]
addrs


-- open the server socket and start accepting connections
server :: (Stream.C body) =>
   ServerEnv.T body ext -> Socket.SockAddr -> IO ()
server :: T body ext -> SockAddr -> IO ()
server T body ext
st SockAddr
addr = do
  T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logInfo T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting server thread on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
addr
  Signal
proto <- String -> IO Signal
BSD.getProtocolNumber String
"tcp"
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
     (Family -> SocketType -> Signal -> IO Socket
Socket.socket Family
AF_INET SocketType
Socket.Stream Signal
proto)
     (\Socket
sock -> Socket -> IO ()
Socket.sClose Socket
sock)
     (\Socket
sock -> do Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sock SocketOption
Socket.ReuseAddr Int
1
                  Bool
ok <- (IOError -> Bool) -> IO Bool -> (IOError -> IO Bool) -> IO Bool
forall a. (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a
Util.catchSomeIOErrors IOError -> Bool
isAlreadyInUseError
                        (Socket -> SockAddr -> IO ()
Socket.bindSocket Socket
sock SockAddr
addr IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
                        (\IOError
e -> do T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"server: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
                                  Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall a. Show a => a -> String
show IOError
e
                                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
                  Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok Unblock () -> Unblock ()
forall a b. (a -> b) -> a -> b
$ do Socket -> Int -> IO ()
Socket.listen Socket
sock Int
Socket.maxListenQueue
                               T body ext -> Socket -> IO ()
forall body ext. C body => T body ext -> Socket -> IO ()
acceptConnections T body ext
st Socket
sock)

-- accept connections, and fork off a new thread to handle each one
acceptConnections :: (Stream.C body) =>
   ServerEnv.T body ext -> Socket -> IO ()
acceptConnections :: T body ext -> Socket -> IO ()
acceptConnections T body ext
st Socket
sock = do
  T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Calling accept..."
  (Handle
h, Socket.SockAddrInet PortNumber
port HostAddress
haddr) <- Socket -> IO (Handle, SockAddr)
Util.accept Socket
sock
  HostAddress -> IO String
Socket.inet_ntoa HostAddress
haddr IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \String
ip -> T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got connection from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ip String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (
          (T body ext -> Handle -> HostAddress -> IO ()
forall body ext.
C body =>
T body ext -> Handle -> HostAddress -> IO ()
talk T body ext
st Handle
h HostAddress
haddr  IO () -> Unblock ()
forall a b. IO a -> IO b -> IO a
`finally`  Handle -> IO ()
IO.hClose Handle
h)
            IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
          (\(Exception.SomeException e
e) ->
              T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String
"servlet died: "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e))
        )
  T body ext -> Socket -> IO ()
forall body ext. C body => T body ext -> Socket -> IO ()
acceptConnections T body ext
st Socket
sock

talk :: (Stream.C body) =>
   ServerEnv.T body ext -> IO.Handle -> HostAddress -> IO ()
talk :: T body ext -> Handle -> HostAddress -> IO ()
talk T body ext
st Handle
h HostAddress
haddr = do
  T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Started"
  Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
h BufferMode
IO.LineBuffering
  T body ext -> Bool -> Handle -> HostAddress -> IO ()
forall body ext.
C body =>
T body ext -> Bool -> Handle -> HostAddress -> IO ()
run T body ext
st Bool
True Handle
h HostAddress
haddr
  T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Done"

run :: (Stream.C body) =>
   ServerEnv.T body ext -> Bool -> IO.Handle -> HostAddress -> IO ()
run :: T body ext -> Bool -> Handle -> HostAddress -> IO ()
run T body ext
st Bool
first Handle
h HostAddress
haddr = do
    let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
    -- read a request up to the first empty line.  If we
    -- don't get a request within the alloted time, issue
    -- a "Request Time-out" response and close the connection.
    let time_allowed :: Int
time_allowed =
           if Bool
first
             then T ext -> Int
forall ext. T ext -> Int
requestTimeout T ext
conf
             else T ext -> Int
forall ext. T ext -> Int
keepAliveTimeout T ext
conf

    T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Waiting for request..."
    Maybe String
req <- IO (Maybe String)
-> (IOError -> IO (Maybe String)) -> IO (Maybe String)
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (
             do Bool
ok <- Handle -> Int -> IO Bool
IO.hWaitForInput Handle
h (Int
time_allowed Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
                if Bool
ok then (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (Handle -> IO String
getUntilEmptyLine Handle
h)
                  -- only send a "request timed out" response if this
                  -- was the first request on the socket.  Subsequent
                  -- requests time-out and close the socket silently.
                  -- ToDo: if we get a partial request, still emit the
                  -- the timeout response.
                      else do T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Request timeout (after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
time_allowed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s)"
                              Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
first (T body ext -> Handle -> T body -> IO ()
forall body ext. C body => T body ext -> Handle -> T body -> IO ()
response T body ext
st Handle
h (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeRequestTimeOut T ext
conf))
                              Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                              )
           (\IOError
e ->
                if IOError -> Bool
isEOFError IOError
e
                     then T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"EOF from client" IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                     else do T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
                             Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing )

    case Maybe String
req of { Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ();  Just String
r -> do
    case Parsec String () (T body)
-> String -> String -> Either ParseError (T body)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (T body)
forall body. Monoid body => Parser (T body)
Request.pHeaders String
"Request" String
r of

         -- close the connection after a badly formatted request
         Left ParseError
err -> do
              T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
              T body ext -> Handle -> T body -> IO ()
forall body ext. C body => T body ext -> Handle -> T body -> IO ()
response T body ext
st Handle
h (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeBadRequest T ext
conf)
              () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

         Right T body
req_no_body  -> do
              T body
reqt <- Handle -> T body -> IO (T body)
forall body. C body => Handle -> T body -> IO (T body)
getBody Handle
h T body
req_no_body
              T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ T body -> String
forall a. Show a => a -> String
show T body
reqt
              T body
resp <- T body ext -> T body -> HostAddress -> IO (T body)
forall body ext.
C body =>
T body ext -> T body -> HostAddress -> IO (T body)
request T body ext
st T body
reqt HostAddress
haddr
              T body ext -> Handle -> T body -> IO ()
forall body ext. C body => T body ext -> Handle -> T body -> IO ()
response T body ext
st Handle
h T body
resp

              -- Persistent Connections
              --
              -- We close the connection if
              --   (a) client specified "connection: close"
              --   (b) client is pre-HTTP/1.1, and didn't
              --       specify "connection: keep-alive"

              let connection_headers :: [Connection]
connection_headers = Group -> [Connection]
forall a. HasHeaders a => a -> [Connection]
Request.getConnection (T body -> Group
forall body. T body -> Group
Request.headers T body
reqt)
              if Connection
Request.ConnectionClose Connection -> [Connection] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Connection]
connection_headers
                 Bool -> Bool -> Bool
|| (T body -> T
forall body. T body -> T
Request.httpVersion T body
reqt T -> T -> Bool
forall a. Ord a => a -> a -> Bool
< T
Version.http1_1
                     Bool -> Bool -> Bool
&& Connection
Request.ConnectionKeepAlive Connection -> [Connection] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Connection]
connection_headers)
                   then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   else T body ext -> Bool -> Handle -> HostAddress -> IO ()
forall body ext.
C body =>
T body ext -> Bool -> Handle -> HostAddress -> IO ()
run T body ext
st Bool
False Handle
h HostAddress
haddr
   }


getBody :: (Stream.C body) =>
   IO.Handle -> Request.T body -> IO (Request.T body)
getBody :: Handle -> T body -> IO (T body)
getBody Handle
h T body
req =
   let -- FIXME: handled chunked input
       readBody :: IO body
readBody =
          case T body -> Maybe Integer
forall a. HasHeaders a => a -> Maybe Integer
Header.getContentLength T body
req of
             Maybe Integer
Nothing  -> body -> IO body
forall (m :: * -> *) a. Monad m => a -> m a
return body
forall a. Monoid a => a
mempty
             -- FIXME: what if input is huge?
             Just Integer
len -> Handle -> Integer -> IO body
forall stream. C stream => Handle -> Integer -> IO stream
Stream.read Handle
h Integer
len
   in  do body
b <- IO body
readBody
          T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$ T body
req { body :: body
Request.body = body
b}

-----------------------------------------------------------------------------
-- Dealing with requests

request :: (Stream.C body) =>
   ServerEnv.T body ext -> Request.T body -> HostAddress -> IO (Response.T body)
request :: T body ext -> T body -> HostAddress -> IO (T body)
request T body ext
st T body
req HostAddress
haddr =
    do (T body
sreq,Maybe (T body)
merr) <- T body ext -> T body -> HostAddress -> IO (T body, Maybe (T body))
forall body ext.
C body =>
T body ext -> T body -> HostAddress -> IO (T body, Maybe (T body))
serverRequest T body ext
st T body
req HostAddress
haddr
       T body
resp <- case Maybe (T body)
merr of
                 Maybe (T body)
Nothing  -> do T body
sreq' <- T body ext -> T body -> IO (T body)
forall body ext. C body => T body ext -> T body -> IO (T body)
tweakRequest T body ext
st T body
sreq
                                T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Handling request..."
                                T body ext -> T body -> IO (T body)
forall body ext. C body => T body ext -> T body -> IO (T body)
handleRequest T body ext
st T body
sreq'
                 Just T body
err -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return T body
err
       T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (T body -> String
forall body. T body -> String
Response.showStatusLine T body
resp)
       T body ext -> T body -> T body -> TimeDiff -> IO ()
forall body ext.
T body ext -> T body -> T body -> TimeDiff -> IO ()
ServerEnv.logAccess T body ext
st T body
sreq T body
resp (String -> TimeDiff
forall a. HasCallStack => String -> a
error String
"noTimeDiff"){-FIXME-}
       T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return T body
resp

serverRequest :: (Stream.C body) =>
   ServerEnv.T body ext -> Request.T body -> HostAddress ->
   IO (ServerRequest.T body, Maybe (Response.T body))
serverRequest :: T body ext -> T body -> HostAddress -> IO (T body, Maybe (T body))
serverRequest T body ext
st T body
req HostAddress
haddr =
   let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
       sreq :: T body
sreq =
          Cons :: forall body.
T body
-> HostAddress
-> Maybe HostEntry
-> HostEntry
-> String
-> String
-> PortNumber
-> T body
ServerRequest.Cons {
             clientRequest :: T body
ServerRequest.clientRequest   = T body
req,
             clientAddress :: HostAddress
ServerRequest.clientAddress   = HostAddress
haddr,
             clientName :: Maybe HostEntry
ServerRequest.clientName      = Maybe HostEntry
forall a. Maybe a
Nothing,
             requestHostName :: HostEntry
ServerRequest.requestHostName = T body ext -> HostEntry
forall body ext. T body ext -> HostEntry
ServerEnv.hostName T body ext
st,
             serverURIPath :: String
ServerRequest.serverURIPath   = String
"-",
             serverFilename :: String
ServerRequest.serverFilename  = String
"-",
             serverPort :: PortNumber
ServerRequest.serverPort      = T body ext -> PortNumber
forall body ext. T body ext -> PortNumber
ServerEnv.port T body ext
st
          }
       maybeExc :: Exceptional a a -> Maybe a
maybeExc Exceptional a a
x =
          case Exceptional a a
x of
             Exc.Success   a
_ -> Maybe a
forall a. Maybe a
Nothing
             Exc.Exception a
e -> a -> Maybe a
forall a. a -> Maybe a
Just a
e
   in  ((Maybe (T body), T body) -> (T body, Maybe (T body)))
-> IO (Maybe (T body), T body) -> IO (T body, Maybe (T body))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (T body), T body) -> (T body, Maybe (T body))
forall a b. (a, b) -> (b, a)
swap (StateT (T body) IO (Maybe (T body))
-> T body -> IO (Maybe (T body), T body)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
          ((Exceptional (T body) () -> Maybe (T body))
-> StateT (T body) IO (Exceptional (T body) ())
-> StateT (T body) IO (Maybe (T body))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exceptional (T body) () -> Maybe (T body)
forall a a. Exceptional a a -> Maybe a
maybeExc (StateT (T body) IO (Exceptional (T body) ())
 -> StateT (T body) IO (Maybe (T body)))
-> StateT (T body) IO (Exceptional (T body) ())
-> StateT (T body) IO (Maybe (T body))
forall a b. (a -> b) -> a -> b
$ ExceptionalT (T body) (StateT (T body) IO) ()
-> StateT (T body) IO (Exceptional (T body) ())
forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
runExceptionalT (ExceptionalT (T body) (StateT (T body) IO) ()
 -> StateT (T body) IO (Exceptional (T body) ()))
-> ExceptionalT (T body) (StateT (T body) IO) ()
-> StateT (T body) IO (Exceptional (T body) ())
forall a b. (a -> b) -> a -> b
$ T body ext
-> T body
-> HostAddress
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall body ext.
C body =>
T body ext
-> T body
-> HostAddress
-> ExceptionalT (T body) (StateT (T body) IO) ()
serverRequestExc T body ext
st T body
req HostAddress
haddr) T body
sreq)
       IO (T body, Maybe (T body))
-> (SomeException -> IO (T body, Maybe (T body)))
-> IO (T body, Maybe (T body))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
       ( \(Exception.SomeException e
exception) -> do
            T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
exception)
            (T body, Maybe (T body)) -> IO (T body, Maybe (T body))
forall (m :: * -> *) a. Monad m => a -> m a
return (T body
sreq, T body -> Maybe (T body)
forall a. a -> Maybe a
Just (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeInternalServerError T ext
conf))
       )

serverRequestExc :: (Stream.C body) =>
   ServerEnv.T body ext -> Request.T body -> HostAddress ->
   ExceptionalT (Response.T body) (StateT (ServerRequest.T body) IO) ()
serverRequestExc :: T body ext
-> T body
-> HostAddress
-> ExceptionalT (T body) (StateT (T body) IO) ()
serverRequestExc T body ext
st T body
req HostAddress
haddr =
   let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
       use :: ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use = (IO (Exceptional e1 b) -> StateT (T body) IO (Exceptional e1 b))
-> ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
forall (m :: * -> *) e0 a (n :: * -> *) e1 b.
(m (Exceptional e0 a) -> n (Exceptional e1 b))
-> ExceptionalT e0 m a -> ExceptionalT e1 n b
Exc.mapExceptionalT IO (Exceptional e1 b) -> StateT (T body) IO (Exceptional e1 b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
       update :: (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update = StateT s IO () -> ExceptionalT (T body) (StateT s IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT s IO () -> ExceptionalT (T body) (StateT s IO) ())
-> ((s -> s) -> StateT s IO ())
-> (s -> s)
-> ExceptionalT (T body) (StateT s IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s) -> StateT s IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify
   in  do Maybe HostEntry
remoteName <- ExceptionalT (T body) IO (Maybe HostEntry)
-> ExceptionalT (T body) (StateT (T body) IO) (Maybe HostEntry)
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO (Maybe HostEntry)
 -> ExceptionalT (T body) (StateT (T body) IO) (Maybe HostEntry))
-> ExceptionalT (T body) IO (Maybe HostEntry)
-> ExceptionalT (T body) (StateT (T body) IO) (Maybe HostEntry)
forall a b. (a -> b) -> a -> b
$ IO (Maybe HostEntry) -> ExceptionalT (T body) IO (Maybe HostEntry)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe HostEntry)
 -> ExceptionalT (T body) IO (Maybe HostEntry))
-> IO (Maybe HostEntry)
-> ExceptionalT (T body) IO (Maybe HostEntry)
forall a b. (a -> b) -> a -> b
$ T ext -> HostAddress -> IO (Maybe HostEntry)
forall ext. T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname T ext
conf HostAddress
haddr
          (T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
 -> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { clientName :: Maybe HostEntry
ServerRequest.clientName = Maybe HostEntry
remoteName }
          HostEntry
host <- ExceptionalT (T body) IO HostEntry
-> ExceptionalT (T body) (StateT (T body) IO) HostEntry
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO HostEntry
 -> ExceptionalT (T body) (StateT (T body) IO) HostEntry)
-> ExceptionalT (T body) IO HostEntry
-> ExceptionalT (T body) (StateT (T body) IO) HostEntry
forall a b. (a -> b) -> a -> b
$ T body ext -> T body -> ExceptionalT (T body) IO HostEntry
forall body ext.
C body =>
T body ext -> T body -> EIO body HostEntry
getServerHostName T body ext
st T body
req
          (T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
 -> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { requestHostName :: HostEntry
ServerRequest.requestHostName = HostEntry
host }
          String
path <- ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO String
 -> ExceptionalT (T body) (StateT (T body) IO) String)
-> ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall a b. (a -> b) -> a -> b
$ T body ext -> T body -> ExceptionalT (T body) IO String
forall body ext. C body => T body ext -> T body -> EIO body String
requestAbsPath T body ext
st T body
req
          (T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
 -> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { serverURIPath :: String
ServerRequest.serverURIPath = String
path }
          String
file <- ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO String
 -> ExceptionalT (T body) (StateT (T body) IO) String)
-> ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall a b. (a -> b) -> a -> b
$ T body ext -> String -> String -> ExceptionalT (T body) IO String
forall body ext.
C body =>
T body ext -> String -> String -> EIO body String
translatePath T body ext
st (HostEntry -> String
hostName HostEntry
host) String
path
          (T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
 -> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { serverFilename :: String
ServerRequest.serverFilename = String
file }



maybeLookupHostname :: Config.T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname :: T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname T ext
conf HostAddress
haddr =
    if T ext -> Bool
forall ext. T ext -> Bool
hostnameLookups T ext
conf
      then IO (Maybe HostEntry)
-> (IOError -> IO (Maybe HostEntry)) -> IO (Maybe HostEntry)
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError
              ((HostEntry -> Maybe HostEntry)
-> IO HostEntry -> IO (Maybe HostEntry)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HostEntry -> Maybe HostEntry
forall a. a -> Maybe a
Just (Family -> HostAddress -> IO HostEntry
BSD.getHostByAddr Family
AF_INET HostAddress
haddr))
              (\IOError
_ -> Maybe HostEntry -> IO (Maybe HostEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HostEntry
forall a. Maybe a
Nothing)
      else Maybe HostEntry -> IO (Maybe HostEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HostEntry
forall a. Maybe a
Nothing

type EIO body = ExceptionalT (Response.T body) IO

-- make sure we've got a host field
-- if the request version is >= HTTP/1.1
getServerHostName :: (Stream.C body) =>
   ServerEnv.T body ext -> Request.T body -> EIO body HostEntry
getServerHostName :: T body ext -> T body -> EIO body HostEntry
getServerHostName T body ext
st T body
req =
   let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
       isServerHost :: String -> Bool
isServerHost String
host =
          String
host String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert (T ext -> String
forall ext. T ext -> String
serverName T ext
conf) (Set String -> Set String) -> Set String -> Set String
forall a b. (a -> b) -> a -> b
$ T ext -> Set String
forall ext. T ext -> Set String
serverAlias T ext
conf) Bool -> Bool -> Bool
||
          (T body -> Bool) -> [T body] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((T body -> String -> Bool) -> String -> T body -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip T body -> String -> Bool
forall body. T body -> String -> Bool
Module.isServerHost String
host) (T body ext -> [T body]
forall body ext. T body ext -> [T body]
ServerEnv.modules T body ext
st)
   in  case T body -> Maybe (String, Maybe Int)
forall a. HasHeaders a => a -> Maybe (String, Maybe Int)
Request.getHost T body
req of
          Maybe (String, Maybe Int)
Nothing ->
             if T body -> T
forall body. T body -> T
Request.httpVersion T body
req T -> T -> Bool
forall a. Ord a => a -> a -> Bool
< T
Version.http1_1
               then HostEntry -> EIO body HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (HostEntry -> EIO body HostEntry)
-> HostEntry -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ T body ext -> HostEntry
forall body ext. T body ext -> HostEntry
ServerEnv.hostName T body ext
st
               else T body -> EIO body HostEntry
forall (m :: * -> *) e a. Monad m => e -> ExceptionalT e m a
Exc.throwT (T body -> EIO body HostEntry) -> T body -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeBadRequest T ext
conf
          Just (String
host,Maybe Int
_) ->
             if String -> Bool
isServerHost String
host
               then HostEntry -> EIO body HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (HostEntry -> EIO body HostEntry)
-> HostEntry -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ (T body ext -> HostEntry
forall body ext. T body ext -> HostEntry
ServerEnv.hostName T body ext
st) { hostName :: String
hostName = String
host }
               else do IO () -> ExceptionalT (T body) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptionalT (T body) IO ())
-> IO () -> ExceptionalT (T body) IO ()
forall a b. (a -> b) -> a -> b
$ T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"Unknown host: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
host)
                       T body -> EIO body HostEntry
forall (m :: * -> *) e a. Monad m => e -> ExceptionalT e m a
Exc.throwT (T body -> EIO body HostEntry) -> T body -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeNotFound T ext
conf


-- | Get the absolute path from the request.
requestAbsPath :: (Stream.C body) =>
   ServerEnv.T body ext -> Request.T body -> EIO body String
requestAbsPath :: T body ext -> T body -> EIO body String
requestAbsPath T body ext
_ T body
req = String -> EIO body String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> EIO body String) -> String -> EIO body String
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ T body -> URI
forall body. T body -> URI
Request.uri T body
req


-- Path translation

translatePath :: (Stream.C body) =>
   ServerEnv.T body ext -> String -> String -> EIO body FilePath
translatePath :: T body ext -> String -> String -> EIO body String
translatePath T body ext
st String
host String
pth =
  do Maybe String
m_file <- IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String))
-> IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ T body ext -> (T body -> MaybeT IO String) -> IO (Maybe String)
forall body ext a.
T body ext -> (T body -> MaybeT IO a) -> IO (Maybe a)
ServerEnv.tryModules T body ext
st (\T body
m -> T body -> String -> String -> MaybeT IO String
forall body. T body -> String -> String -> MaybeT IO String
Module.translatePath T body
m String
host String
pth)
     case Maybe String
m_file of
       Just String
file -> String -> EIO body String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> EIO body String) -> String -> EIO body String
forall a b. (a -> b) -> a -> b
$ String
file
       Maybe String
Nothing   -> T body ext -> String -> EIO body String
forall body ext. C body => T body ext -> String -> EIO body String
defaultTranslatePath T body ext
st String
pth

defaultTranslatePath :: (Stream.C body) =>
   ServerEnv.T body ext -> String -> EIO body FilePath
defaultTranslatePath :: T body ext -> String -> EIO body String
defaultTranslatePath T body ext
st String
pth =
   let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
   in  (Maybe String -> String)
-> ExceptionalT (T body) IO (Maybe String) -> EIO body String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
forall a. a -> a
id) (ExceptionalT (T body) IO (Maybe String) -> EIO body String)
-> ExceptionalT (T body) IO (Maybe String) -> EIO body String
forall a b. (a -> b) -> a -> b
$ IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> String -> IO (Maybe String)
Util.localPath (T ext -> String
forall ext. T ext -> String
documentRoot T ext
conf) String
pth)

-- Request tweaking

tweakRequest :: (Stream.C body) =>
   ServerEnv.T body ext -> ServerRequest.T body -> IO (ServerRequest.T body)
tweakRequest :: T body ext -> T body -> IO (T body)
tweakRequest T body ext
st =
   T body ext
-> (T body -> T body -> IO (T body)) -> T body -> IO (T body)
forall body ext a. T body ext -> (T body -> a -> IO a) -> a -> IO a
ServerEnv.foldModules T body ext
st (\T body
m T body
r -> T body -> T body -> IO (T body)
forall body. T body -> T body -> IO (T body)
Module.tweakRequest T body
m T body
r)

-- Request handling

handleRequest :: (Stream.C body) =>
   ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body)
handleRequest :: T body ext -> T body -> IO (T body)
handleRequest T body ext
st T body
req =
    do Maybe (T body)
m_resp <- T body ext -> (T body -> MaybeT IO (T body)) -> IO (Maybe (T body))
forall body ext a.
T body ext -> (T body -> MaybeT IO a) -> IO (Maybe a)
ServerEnv.tryModules T body ext
st (\T body
m -> T body -> T body -> MaybeT IO (T body)
forall body. T body -> T body -> MaybeT IO (T body)
Module.handleRequest T body
m T body
req)
       case Maybe (T body)
m_resp of
         Just T body
resp -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return T body
resp
         Maybe (T body)
Nothing   -> T body ext -> T body -> IO (T body)
forall body ext. C body => T body ext -> T body -> IO (T body)
defaultHandleRequest T body ext
st T body
req

defaultHandleRequest :: (Stream.C body) =>
   ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body)
defaultHandleRequest :: T body ext -> T body -> IO (T body)
defaultHandleRequest T body ext
st T body
_ =
   T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeNotFound (T ext -> T body) -> T ext -> T body
forall a b. (a -> b) -> a -> b
$ T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st

-- Sending response


response :: (Stream.C body) =>
   ServerEnv.T body ext ->
   IO.Handle ->
   Response.T body ->
   IO ()

response :: T body ext -> Handle -> T body -> IO ()
response T body ext
env Handle
h
   (Response.Cons {
      code :: forall body. T body -> Int
Response.code        = Int
code,
      description :: forall body. T body -> String
Response.description = String
desc,
      headers :: forall body. T body -> Group
Response.headers     = Group
headers,
      coding :: forall body. T body -> [TransferCoding]
Response.coding      = [TransferCoding]
tes,
      body :: forall body. T body -> Body body
Response.body        = Body body
body,
      doSendBody :: forall body. T body -> Bool
Response.doSendBody  = Bool
sendBody
   }) =
  do
  Handle -> String -> IO ()
Util.hPutStrCrLf Handle
h (Int -> String -> String
Response.statusLine Int
code String
desc)
  Handle -> T -> IO ()
hPutHeader Handle
h T
Response.serverHeader

  -- Date Header: required on all messages
  T
date <- IO T
Response.dateHeader
  Handle -> T -> IO ()
hPutHeader Handle
h T
date

  (T -> IO ()) -> [T] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> T -> IO ()
hPutHeader Handle
h) (Group -> [T]
forall x. HasHeaders x => x -> [T]
Header.list Group
headers)

  -- Output a Content-Length when the message body isn't
  -- encoded.  If it *is* encoded, then the last transfer
  -- coding must be "chunked", according to RFC2616 sec 3.6.  This
  -- allows the client to determine the message-length.
  let contentLength :: Maybe Integer
contentLength = Body body -> Maybe Integer
forall body. Body body -> Maybe Integer
Response.size Body body
body

  Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Body body -> Bool
forall body. C body => Body body -> Bool
Response.hasBody Body body
body Bool -> Bool -> Bool
&& [TransferCoding] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TransferCoding]
tes)
     (IO () -> (Integer -> IO ()) -> Maybe Integer -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Handle -> T -> IO ()
hPutHeader Handle
h (T -> IO ()) -> (Integer -> T) -> Integer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> T
Header.makeContentLength) Maybe Integer
contentLength)

  (TransferCoding -> IO ()) -> [TransferCoding] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> T -> IO ()
hPutHeader Handle
h (T -> IO ()) -> (TransferCoding -> T) -> TransferCoding -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferCoding -> T
Header.makeTransferCoding) [TransferCoding]
tes

  Handle -> String -> IO ()
Util.hPutStrCrLf Handle
h String
""
  -- ToDo: implement transfer codings

  let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
env

  Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sendBody Unblock () -> Unblock ()
forall a b. (a -> b) -> a -> b
$
     case [TransferCoding] -> Maybe ([TransferCoding], TransferCoding)
forall a. [a] -> Maybe ([a], a)
viewR [TransferCoding]
tes of
        Just ([TransferCoding]
_, TransferCoding
Header.ChunkedTransferCoding) ->
             Int -> Handle -> Body body -> IO ()
forall body. C body => Int -> Handle -> Body body -> IO ()
Response.sendBodyChunked (T ext -> Int
forall ext. T ext -> Int
Config.chunkSize T ext
conf) Handle
h Body body
body
        Maybe ([TransferCoding], TransferCoding)
_ -> Handle -> Body body -> IO ()
forall body. C body => Handle -> Body body -> IO ()
Response.sendBody Handle
h Body body
body

hPutHeader :: IO.Handle -> Header.T -> IO ()
hPutHeader :: Handle -> T -> IO ()
hPutHeader Handle
h =
   Handle -> String -> IO ()
IO.hPutStr Handle
h (String -> IO ()) -> (T -> String) -> T -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> String
forall a. Show a => a -> String
show
--   Util.hPutStrCrLf h . show