{-# 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
(
simpleHTTP
, simpleHTTP'
, simpleHTTP''
, simpleHTTPWithSocket
, simpleHTTPWithSocket'
, bindPort
, bindIPv4
, parseConfig
, waitForTermination
, module Happstack.Server.Monads
, module Happstack.Server.Auth
, module Happstack.Server.Cookie
, module Happstack.Server.Error
, module Happstack.Server.Response
, module Happstack.Server.Routing
, module Happstack.Server.RqData
, module Happstack.Server.Validation
, module Happstack.Server.Types
) where
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)
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
ho :: [OptDescr (Conf -> Conf)]
ho :: [OptDescr (Conf -> Conf)]
ho = [forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"http-port"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
h Conf
c -> Conf
c { port :: Int
port = forall a. (Num a, Eq a) => [Char] -> a
readDec' [Char]
h }) [Char]
"port") [Char]
"port to bind http server"]
parseConfig :: [String] -> Either [String] Conf
parseConfig :: [[Char]] -> Either [[Char]] Conf
parseConfig [[Char]]
args
= case forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
getOpt forall a. ArgOrder a
Permute [OptDescr (Conf -> Conf)]
ho [[Char]]
args of
([Conf -> Conf]
flags,[[Char]]
_,[]) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) Conf
nullConf [Conf -> Conf]
flags
([Conf -> Conf]
_,[[Char]]
_,[[Char]]
errs) -> forall a b. a -> Either a b
Left [[Char]]
errs
simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()
simpleHTTP :: forall a. ToMessage a => Conf -> ServerPartT IO 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' forall a. a -> a
id
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 (forall a. a -> Maybe a -> a
fromMaybe forall (m :: * -> *) a. Monad m => a -> m a
return (Conf -> Maybe (Response -> IO Response)
validator Conf
conf)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall b (m :: * -> *).
(ToMessage b, Monad m, Functor m) =>
ServerPartT m b -> Request -> m Response
simpleHTTP'' (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))
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 = (forall (m :: * -> *) b.
(Functor m, ToMessage b) =>
WebT m b -> m (Maybe Response)
runWebT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m b
hs Request
req) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Response
standardNotFound forall a. a -> a
id))
where
standardNotFound :: Response
standardNotFound = forall r. HasHeaders r => [Char] -> [Char] -> r -> r
setHeader [Char]
"Content-Type" [Char]
"text/html" forall a b. (a -> b) -> a -> b
$ (forall a. ToMessage a => a -> Response
toResponse [Char]
notFoundHtml){rsCode :: Int
rsCode=Int
404}
simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()
simpleHTTPWithSocket :: forall a.
ToMessage a =>
Socket -> Conf -> ServerPartT IO 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' forall a. a -> a
id
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 (forall a. a -> Maybe a -> a
fromMaybe forall (m :: * -> *) a. Monad m => a -> m a
return (Conf -> Maybe (Response -> IO Response)
validator Conf
conf)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall b (m :: * -> *).
(ToMessage b, Monad m, Functor m) =>
ServerPartT m b -> Request -> m Response
simpleHTTP'' (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))
bindPort :: Conf -> IO Socket
bindPort :: Conf -> IO Socket
bindPort Conf
conf = Int -> IO Socket
Listen.listenOn (Conf -> Int
port Conf
conf)
bindIPv4 :: String
-> Int
-> IO Socket
bindIPv4 :: [Char] -> Int -> IO Socket
bindIPv4 [Char]
addr Int
prt = [Char] -> Int -> IO Socket
Listen.listenOnIPv4 [Char]
addr Int
prt
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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Either Response b, FilterFun Response) -> Response
appFilterToResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. FilterFun a -> a -> a
unFilterFun FilterFun Response
ff forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id 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\">"
forall a. [a] -> [a] -> [a]
++ [Char]
"<html><head><title>Happstack "
forall a. [a] -> [a] -> [a]
++ [Char]
ver forall a. [a] -> [a] -> [a]
++ [Char]
" File not found</title></head>"
forall a. [a] -> [a] -> [a]
++ [Char]
"<body><h1>Happstack " forall a. [a] -> [a] -> [a]
++ [Char]
ver forall a. [a] -> [a] -> [a]
++ [Char]
"</h1>"
forall a. [a] -> [a] -> [a]
++ [Char]
"<p>Your file is not found<br>"
forall a. [a] -> [a] -> [a]
++ [Char]
"To try again is useless<br>"
forall a. [a] -> [a] -> [a]
++ [Char]
"It is just not here</p>"
forall a. [a] -> [a] -> [a]
++ [Char]
"</body></html>"
where ver :: [Char]
ver = Version -> [Char]
DV.showVersion Version
Cabal.version
waitForTermination :: IO ()
waitForTermination :: IO ()
waitForTermination
= do
#ifdef UNIX
Bool
istty <- Fd -> IO Bool
queryTerminal Fd
stdInput
MVar ()
mv <- forall a. IO (MVar a)
newEmptyMVar
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
softwareTermination (IO () -> Handler
CatchOnce (forall a. MVar a -> a -> IO ()
putMVar MVar ()
mv ())) forall a. Maybe a
Nothing
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
lostConnection (IO () -> Handler
CatchOnce (forall a. MVar a -> a -> IO ()
putMVar MVar ()
mv ())) forall a. Maybe a
Nothing
case Bool
istty of
Bool
True -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
keyboardSignal (IO () -> Handler
CatchOnce (forall a. MVar a -> a -> IO ()
putMVar MVar ()
mv ())) forall a. Maybe a
Nothing
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. MVar a -> IO a
takeMVar MVar ()
mv
#else
let loop 'e' = return ()
loop _ = getChar >>= loop
loop 'c'
#endif