{-# 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
    , 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 :: Int
port = [Char] -> Int
forall a. (Num a, Eq a) => [Char] -> a
readDec' [Char]
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 (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 :: 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' :: (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 (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'' :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Response -> m Response
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 :: Int
rsCode=Int
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 :: 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' :: (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 (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 :: 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 (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 (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
         Bool
istty <- Fd -> IO Bool
queryTerminal Fd
stdInput
         MVar ()
mv <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
         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
softwareTermination (IO () -> Handler
CatchOnce (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mv ())) Maybe SignalSet
forall a. Maybe a
Nothing
         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
lostConnection      (IO () -> Handler
CatchOnce (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mv ())) Maybe SignalSet
forall a. Maybe a
Nothing
         case Bool
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 (m :: * -> *) a. Monad m => a -> m a
return ()
         MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mv
#else
         let loop 'e' = return ()
             loop _   = getChar >>= loop
         loop 'c'
#endif