-- built-in pages like \"404 Not Found\".
, cnfServerHost :: !Strict.ByteString
- -- |A port ID to listen to HTTP clients.
- , cnfServerPort :: !PortID
+ -- |A port number (or service name) to listen to HTTP clients.
+ , cnfServerPort :: !ServiceName
-- |Local IPv4 address to listen to HTTP clients. Set this to
-- @('Just' "0.0.0.0")@ if you want to accept any IPv4
-- |A port ID to listen to HTTPS clients. Local addresses
-- (both for IPv4 and IPv6) will be derived from the parent
-- 'Config'.
- sslServerPort :: !PortID
+ sslServerPort :: !ServiceName
-- |An SSL context for accepting connections.
, sslContext :: !SSLContext
defaultConfig = Config {
cnfServerSoftware = C8.pack "Lucu/1.0"
, cnfServerHost = C8.pack (unsafePerformIO getHostName)
- , cnfServerPort = Service "http"
+ , cnfServerPort = "http"
, cnfServerV4Addr = Just "0.0.0.0"
, cnfServerV6Addr = Just "::"
, cnfSSLConfig = Nothing
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Maybe
-import Network
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Headers
sig = C8.unpack (cnfServerSoftware conf)
++ " at "
++ C8.unpack (cnfServerHost conf)
- ++ ( case cnfServerPort conf of
- Service serv -> ", service " ++ serv
- PortNumber num -> ", port " ++ show num
- UnixSocket path -> ", unix socket " ++ show path
- )
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
where
import Control.Concurrent
-import Network hiding (accept)
+import Control.Exception
+import Control.Monad
+import Network.BSD
+import Network.Socket
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.RequestReader
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.ResponseWriter
-import Network.HTTP.Lucu.SocketLike
+import Network.HTTP.Lucu.SocketLike as SL
import System.Posix.Signals
-- |This is the entry point of Lucu httpd. It listens to a socket and
= withSocketsDo $
do _ <- installHandler sigPIPE Ignore Nothing
+ -- FIXME: TERRIBLE CODE. NEED MAJOR REWRITE.
case cnfSSLConfig cnf of
Nothing
-> return ()
Just scnf
- -> do so <- listenOn (sslServerPort scnf)
- _loopTID <- forkIO $ httpLoop (sslContext scnf, so)
- return ()
+ -> do case cnfServerV4Addr cnf of
+ Nothing
+ -> return ()
+ Just v4addr
+ -> do so <- listenOn AF_INET v4addr (sslServerPort scnf)
+ p <- socketPort so
+ -- FIXME: Don't throw away the thread
+ -- ID as we can't kill it later
+ -- then. [1]
+ _ <- forkIO $ httpLoop p (sslContext scnf, so)
+ return ()
+
+ case cnfServerV6Addr cnf of
+ Nothing
+ -> return ()
+ Just v6addr
+ -> do so <- listenOn AF_INET6 v6addr (sslServerPort scnf)
+ p <- socketPort so
+ -- FIXME: [1]
+ _ <- forkIO $ httpLoop p (sslContext scnf, so)
+ return ()
- httpLoop =<< listenOn (cnfServerPort cnf)
+ case cnfServerV4Addr cnf of
+ Nothing
+ -> return ()
+ Just v4addr
+ -> do so <- listenOn AF_INET v4addr (cnfServerPort cnf)
+ p <- socketPort so
+ -- FIXME: [1]
+ _ <- forkIO $ httpLoop p so
+ return ()
+
+ case cnfServerV6Addr cnf of
+ Nothing
+ -> return ()
+ Just v6addr
+ -> do so <- listenOn AF_INET6 v6addr (cnfServerPort cnf)
+ p <- socketPort so
+ -- FIXME: [1]
+ _ <- forkIO $ httpLoop p so
+ return ()
+
+ waitForever
where
- httpLoop :: SocketLike s => s -> IO ()
- httpLoop so
- = do (h, addr) <- accept so
+ listenOn :: Family -> HostName -> ServiceName -> IO Socket
+ listenOn fam host srv
+ = do proto <- getProtocolNumber "tcp"
+ let hints = defaultHints {
+ addrFlags = [AI_PASSIVE]
+ , addrFamily = fam
+ , addrSocketType = Stream
+ , addrProtocol = proto
+ }
+ addrs <- getAddrInfo (Just hints) (Just host) (Just srv)
+ let addr = head addrs
+ bracketOnError
+ (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+ (sClose)
+ (\ sock ->
+ do setSocketOption sock ReuseAddr 1
+ bindSocket sock (addrAddress addr)
+ listen sock maxListenQueue
+ return sock
+ )
+
+ httpLoop :: SocketLike s => PortNumber -> s -> IO ()
+ httpLoop port so
+ = do (h, addr) <- SL.accept so
tQueue <- newInteractionQueue
- readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue
+ readerTID <- forkIO $ requestReader cnf tree fbs h port addr tQueue
_writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
- httpLoop so
+ httpLoop port so
+
+ waitForever :: IO ()
+ waitForever = forever (threadDelay 1000000)
data Interaction = Interaction {
itrConfig :: !Config
+ , itrLocalPort :: !PortNumber
, itrRemoteAddr :: !SockAddr
, itrRemoteCert :: !(Maybe X509)
, itrResourcePath :: !(Maybe [String])
defaultPageContentType = C8.pack "application/xhtml+xml"
-newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
-newInteraction !conf !addr !cert !req
+newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
+newInteraction !conf !port !addr !cert !req
= do request <- newTVarIO req
responce <- newTVarIO Response {
resVersion = HttpVersion 1 1
return Interaction {
itrConfig = conf
+ , itrLocalPort = port
, itrRemoteAddr = addr
, itrRemoteCert = cert
, itrResourcePath = Nothing
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import Network
import Network.URI
{-
preprocessHeader req
where
setStatus :: StatusCode -> STM ()
- setStatus status
- = status `seq`
- updateItr itr itrResponse
+ setStatus !status
+ = updateItr itr itrResponse
$! \ res -> res {
resStatus = status
}
completeAuthority :: Request -> STM ()
- completeAuthority req
- = req `seq`
- when (uriAuthority (reqURI req) == Nothing)
+ completeAuthority !req
+ = when (uriAuthority (reqURI req) == Nothing)
$ if reqVersion req == HttpVersion 1 0 then
-- HTTP/1.0 なので Config から補完
do let conf = itrConfig itr
host = cnfServerHost conf
- port = case cnfServerPort conf of
- PortNumber n -> Just (fromIntegral n :: Int)
- _ -> Nothing
+ port = itrLocalPort itr
portStr
= case port of
- Just 80 -> Just ""
- Just n -> Just $ ':' : show n
- Nothing -> Nothing
- case portStr of
- Just str -> updateAuthority host (C8.pack str)
- -- FIXME: このエラーの原因は、listen してゐるソ
- -- ケットが INET でない故にポート番號が分からな
- -- い事だが、その事をどうにかして通知した方が良
- -- いと思ふ。stderr？
- Nothing -> setStatus InternalServerError
+ 80 -> ""
+ n -> ':' : show n
+ updateAuthority host (C8.pack portStr)
else
case getHeader (C8.pack "Host") req of
Just str -> let (host, portStr) = parseHost str
import System.IO (stderr)
-requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO ()
-requestReader !cnf !tree !fbs !h !addr !tQueue
+requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO ()
+requestReader !cnf !tree !fbs !h !port !addr !tQueue
= do input <- hGetLBS h
acceptRequest input
`catches`
acceptNonparsableRequest :: StatusCode -> IO ()
acceptNonparsableRequest status
= {-# SCC "acceptNonparsableRequest" #-}
- do itr <- newInteraction cnf addr Nothing Nothing
+ do itr <- newInteraction cnf port addr Nothing Nothing
atomically $ do updateItr itr itrResponse
$ \ res -> res {
resStatus = status
acceptParsableRequest req input
= {-# SCC "acceptParsableRequest" #-}
do cert <- hGetPeerCert h
- itr <- newInteraction cnf addr cert (Just req)
+ itr <- newInteraction cnf port addr cert (Just req)
action
<- atomically $
do preprocess itr
-import Network
import Network.HTTP.Lucu
main :: IO ()
-main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
+main = let config = defaultConfig { cnfServerPort = "9999" }
resources = mkResTree [ ( []
, helloWorld )
import MiseRafturai
-import Network
import Network.HTTP.Lucu
main :: IO ()
-main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
+main = let config = defaultConfig { cnfServerPort = "9999" }
resources = mkResTree [ ([], miseRafturai) ]
in
do putStrLn "Access http://localhost:9999/ with your browser."
-import Network
import Network.HTTP.Lucu
import SmallFile
main :: IO ()
-main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
+main = let config = defaultConfig { cnfServerPort = "9999" }
resources = mkResTree [ ([], smallFile) ]
in
do putStrLn "Access http://localhost:9999/ with your browser."
ImplantedSmall \
Multipart \
SSL \
- StaticDir \
$(NULL)
build: $(TARGETS)
MiseRafturai.hs: mise-rafturai.html
lucu-implant-file -m MiseRafturai -o $@ $<
+ImplantedSmall.hs: SmallFile.hs
+
SmallFile.hs: small-file.txt
lucu-implant-file -m SmallFile -o $@ $<
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.List
import Data.Maybe
-import Network
import Network.HTTP.Lucu
main :: IO ()
-main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
+main = let config = defaultConfig { cnfServerPort = "9999" }
resources = mkResTree [ ([], resMain) ]
in
do putStrLn "Access http://localhost:9999/ with your browser."
import Control.Monad
import "mtl" Control.Monad.Trans
import Data.Time.Clock
-import Network
import Network.HTTP.Lucu
import OpenSSL
import OpenSSL.EVP.PKey
SSL.contextSetDefaultCiphers ctx
let config = defaultConfig {
- cnfServerPort = PortNumber 9000
+ cnfServerPort = "9000"
, cnfSSLConfig = Just SSLConfig {
- sslServerPort = PortNumber 9001
+ sslServerPort = "9001"
, sslContext = ctx
}
}
projects / Lucu.git / commitdiff