^examples/ImplantedSmall$
^examples/MiseRafturai\.hs$
^examples/Multipart$
+^examples/SSL$
^examples/SmallFile\.hs$
data/CompileMimeTypes.hs
data/mime.types
examples/HelloWorld.hs
+ examples/Implanted.hs
+ examples/ImplantedSmall.hs
examples/Makefile
+ examples/Multipart.hs
+ examples/SSL.hs
+ examples/mise-rafturai.html
+ examples/small-file.txt
Source-Repository head
Type: darcs
Network.HTTP.Lucu.ContentCoding
Network.HTTP.Lucu.DefaultPage
Network.HTTP.Lucu.Format
+ Network.HTTP.Lucu.HandleLike
Network.HTTP.Lucu.Headers
Network.HTTP.Lucu.Interaction
Network.HTTP.Lucu.MultipartForm
-- CGI. It just spawns a new thread. Inter-process communication is
-- done with STM.
--
+-- [/Affinity for RESTafarians/] Lucu is a carefully designed
+-- web server for RESTful applications.
+--
+-- [/SSL connections/] Lucu can handle HTTP connections over SSL
+-- layer.
+--
-- Lucu is not a replacement for Apache. It is intended to be used to
-- create an efficient web-based application without messing around
-- FastCGI. It is also intended to be run behind a reverse-proxy so it
-- [/Client Filtering/] Lucu always accepts any clients. No IP
-- filter is implemented.
--
--- [/SSL Support/] Lucu can handle only HTTP.
---
-- [/Bandwidth Limitting/] Lucu doesn't limit bandwidth it consumes.
--
-- [/Protection Against Wicked Clients/] Lucu is fragile against
-- |Configurations for the Lucu httpd like a port to listen.
module Network.HTTP.Lucu.Config
( Config(..)
+ , SSLConfig(..)
, defaultConfig
)
where
import Network.BSD
import Network.HTTP.Lucu.MIMEType.Guess
import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
+import OpenSSL.Session
import System.IO.Unsafe
-- |Configuration record for the Lucu httpd. You need to use
, cnfServerHost :: !Strict.ByteString
-- |A port ID to listen to HTTP clients.
, cnfServerPort :: !PortID
+ -- |Configuration for HTTPS connections. Set this 'Nothing' to
+ -- disable HTTPS.
+ , cnfSSLConfig :: !(Maybe SSLConfig)
-- |The maximum number of requests to accept in one connection
-- simultaneously. If a client exceeds this limitation, its last
-- request won't be processed until a response for its earliest
, cnfExtToMIMEType :: !ExtMap
}
+-- |Configuration record for HTTPS connections.
+data SSLConfig
+ = SSLConfig {
+ -- |A port ID to listen to HTTPS clients.
+ sslServerPort :: !PortID
+ -- |An SSL context for accepting connections.
+ , sslContext :: !SSLContext
+ }
+
-- |The default configuration. Generally you can use this value as-is,
-- or possibly you just want to replace the 'cnfServerSoftware' and
--- 'cnfServerPort'.
+-- 'cnfServerPort'. SSL connections are disabled by default.
defaultConfig :: Config
defaultConfig = Config {
cnfServerSoftware = C8.pack "Lucu/1.0"
, cnfServerHost = C8.pack (unsafePerformIO getHostName)
, cnfServerPort = Service "http"
+ , cnfSSLConfig = Nothing
, cnfMaxPipelineDepth = 100
, cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
, cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB
--- /dev/null
+module Network.HTTP.Lucu.HandleLike
+ ( HandleLike(..)
+ )
+ where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified OpenSSL.Session as SSL
+import OpenSSL.X509
+import qualified System.IO as I
+
+
+class HandleLike h where
+ hGetLBS :: h -> IO L.ByteString
+ hPutLBS :: h -> L.ByteString -> IO ()
+
+ hGetBS :: h -> Int -> IO B.ByteString
+ hPutBS :: h -> B.ByteString -> IO ()
+
+ hPutChar :: h -> Char -> IO ()
+
+ hPutStr :: h -> String -> IO ()
+ hPutStrLn :: h -> String -> IO ()
+
+ hGetPeerCert :: h -> IO (Maybe X509)
+ hGetPeerCert = const $ return Nothing
+
+ hFlush :: h -> IO ()
+ hClose :: h -> IO ()
+
+
+instance HandleLike I.Handle where
+ hGetLBS = L.hGetContents
+ hPutLBS = L.hPut
+
+ hGetBS = B.hGet
+ hPutBS = B.hPut
+
+ hPutChar = I.hPutChar
+
+ hPutStr = I.hPutStr
+ hPutStrLn = I.hPutStrLn
+
+ hFlush = I.hFlush
+ hClose = I.hClose
+
+
+instance HandleLike SSL.SSL where
+ hGetLBS = SSL.lazyRead
+ hPutLBS = SSL.lazyWrite
+
+ hGetBS = SSL.read
+ hPutBS = SSL.write
+
+ hPutChar s = hPutLBS s . L.singleton
+
+ hPutStr s = hPutLBS s . L.pack
+ hPutStrLn s = hPutLBS s . L.pack . (++ "\n")
+
+ hGetPeerCert s
+ = do isValid <- SSL.getVerifyResult s
+ if isValid then
+ SSL.getPeerCertificate s
+ else
+ return Nothing
+
+ hFlush _ = return () -- unneeded
+ hClose s = SSL.shutdown s SSL.Bidirectional
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
-import System.IO
type Headers = Map NCBS Strict.ByteString
newtype NCBS = NCBS Strict.ByteString
else c)
-hPutHeaders :: Handle -> Headers -> IO ()
+hPutHeaders :: HandleLike h => h -> Headers -> IO ()
hPutHeaders h hds
= h `seq` hds `seq`
- mapM_ putH (M.toList hds) >> C8.hPut h (C8.pack "\r\n")
+ mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n")
where
putH :: (NCBS, Strict.ByteString) -> IO ()
putH (name, value)
= name `seq` value `seq`
- do C8.hPut h (fromNCBS name)
- C8.hPut h (C8.pack ": ")
- C8.hPut h value
- C8.hPut h (C8.pack "\r\n")
+ do hPutBS h (fromNCBS name)
+ hPutBS h (C8.pack ": ")
+ hPutBS h value
+ hPutBS h (C8.pack "\r\n")
where
import qualified Data.ByteString.Char8 as C8
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Parser
import Prelude hiding (min)
-import System.IO
-- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
data HttpVersion = HttpVersion !Int !Int
]
-hPutHttpVersion :: Handle -> HttpVersion -> IO ()
+hPutHttpVersion :: HandleLike h => h -> HttpVersion -> IO ()
hPutHttpVersion !h !v
= case v of
-- 頻出するので高速化
- HttpVersion 1 0 -> C8.hPut h (C8.pack "HTTP/1.0")
- HttpVersion 1 1 -> C8.hPut h (C8.pack "HTTP/1.1")
+ HttpVersion 1 0 -> hPutBS h (C8.pack "HTTP/1.0")
+ HttpVersion 1 1 -> hPutBS h (C8.pack "HTTP/1.1")
-- 一般の場合
HttpVersion !maj !min
- -> do C8.hPut h (C8.pack "HTTP/")
+ -> do hPutBS h (C8.pack "HTTP/")
hPutStr h (show maj)
hPutChar h '.'
hPutStr h (show min)
import Network.HTTP.Lucu.RequestReader
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.ResponseWriter
+import qualified OpenSSL.Session as SSL
import System.IO
import System.Posix.Signals
runHttpd cnf tree fbs
= withSocketsDo $
do installHandler sigPIPE Ignore Nothing
- so <- listenOn (cnfServerPort cnf)
- loop so
+
+ case cnfSSLConfig cnf of
+ Nothing
+ -> return ()
+ Just scnf
+ -> do so <- listenOn (sslServerPort scnf)
+ _loopTID <- forkIO $ httpsLoop (sslContext scnf) so
+ return ()
+
+ httpLoop =<< listenOn (cnfServerPort cnf)
where
- loop :: Socket -> IO ()
- loop so
- -- 本當は Network.accept を使ひたいが、このアクションは勝手に
- -- リモートのIPを逆引きするので、使へない。
- = do (h, addr) <- accept' so
+ httpLoop :: Socket -> IO ()
+ httpLoop so
+ = do (h, addr) <- acceptHTTP so
tQueue <- newInteractionQueue
readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue
_writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
- loop so
+ httpLoop so
+
+ httpsLoop :: SSL.SSLContext -> Socket -> IO ()
+ httpsLoop ctx so
+ = do (ssl, addr) <- acceptHTTPS ctx so
+ tQueue <- newInteractionQueue
+ readerTID <- forkIO $ requestReader cnf tree fbs ssl addr tQueue
+ _writerTID <- forkIO $ responseWriter cnf ssl tQueue readerTID
+ httpsLoop ctx so
- accept' :: Socket -> IO (Handle, So.SockAddr)
- accept' soSelf
+ acceptHTTP :: Socket -> IO (Handle, So.SockAddr)
+ acceptHTTP soSelf
= do (soPeer, addr) <- So.accept soSelf
hPeer <- So.socketToHandle soPeer ReadWriteMode
return (hPeer, addr)
+
+ acceptHTTPS :: SSL.SSLContext -> Socket -> IO (SSL.SSL, So.SockAddr)
+ acceptHTTPS ctx so
+ = do (so', addr) <- So.accept so
+ ssl <- SSL.connection ctx so'
+ SSL.accept ssl
+ return (ssl, addr)
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import OpenSSL.X509
data Interaction = Interaction {
itrConfig :: !Config
, itrRemoteAddr :: !SockAddr
+ , itrRemoteCert :: !(Maybe X509)
, itrResourcePath :: !(Maybe [String])
, itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
, itrResponse :: !(TVar Response)
defaultPageContentType = C8.pack "application/xhtml+xml"
-newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
-newInteraction conf addr req
- = conf `seq` addr `seq` req `seq`
- do request <- newTVarIO $ req
+newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
+newInteraction !conf !addr !cert !req
+ = do request <- newTVarIO $ req
responce <- newTVarIO $ Response {
resVersion = HttpVersion 1 1
, resStatus = Ok
return $ Interaction {
itrConfig = conf
, itrRemoteAddr = addr
+ , itrRemoteCert = cert
, itrResourcePath = Nothing
, itrRequest = request
, itrResponse = responce
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Tree
import Prelude hiding (catch)
-import System.IO
+import System.IO (stderr)
-requestReader :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()
+requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO ()
requestReader !cnf !tree !fbs !h !addr !tQueue
- = do input <- B.hGetContents h
+ = do input <- hGetLBS h
acceptRequest input
`catches`
[ Handler (( \ _ -> return () ) :: IOException -> IO ())
acceptNonparsableRequest :: StatusCode -> IO ()
acceptNonparsableRequest status
= {-# SCC "acceptNonparsableRequest" #-}
- do itr <- newInteraction cnf addr Nothing
+ do itr <- newInteraction cnf addr Nothing Nothing
atomically $ do updateItr itr itrResponse
$ \ res -> res {
resStatus = status
acceptParsableRequest :: Request -> ByteString -> IO ()
acceptParsableRequest req input
= {-# SCC "acceptParsableRequest" #-}
- do itr <- newInteraction cnf addr (Just req)
+ do cert <- hGetPeerCert h
+ itr <- newInteraction cnf addr cert (Just req)
action
<- atomically $
do preprocess itr
, getConfig
, getRemoteAddr
, getRemoteAddr'
+ , getRemoteCertificate
, getRequest
, getMethod
, getRequestURI
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
+import OpenSSL.X509
-- |The 'Resource' monad. This monad implements
-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
_
-> undefined
+-- | Return the X.509 certificate of the client, or 'Nothing' if:
+--
+-- * This request didn't came through an SSL stream.
+--
+-- * The client didn't send us its certificate.
+--
+-- * The 'OpenSSL.Session.VerificationMode' of
+-- 'OpenSSL.Session.SSLContext' in
+-- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
+-- 'OpenSSL.Session.VerifyPeer'.
+getRemoteCertificate :: Resource (Maybe X509)
+getRemoteCertificate = do itr <- getInteraction
+ return $! itrRemoteCert itr
-- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
-- the request header. In general you don't have to use this action.
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Dynamic
import Network.HTTP.Lucu.Format
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
-import System.IO
-- |This is the definition of HTTP status code.
-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses
setHeaders res hdr = res { resHeaders = hdr }
-hPutResponse :: Handle -> Response -> IO ()
+hPutResponse :: HandleLike h => h -> Response -> IO ()
hPutResponse h res
= h `seq` res `seq`
do hPutHttpVersion h (resVersion res)
hPutChar h ' '
hPutStatus h (resStatus res)
- C8.hPut h (C8.pack "\r\n")
+ hPutBS h (C8.pack "\r\n")
hPutHeaders h (resHeaders res)
-hPutStatus :: Handle -> StatusCode -> IO ()
+hPutStatus :: HandleLike h => h -> StatusCode -> IO ()
hPutStatus h sc
= h `seq` sc `seq`
case statusCode sc of
(# num, msg #)
-> do hPutStr h (fmtDec 3 num)
hPutChar h ' '
- C8.hPut h msg
+ hPutBS h msg
-- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Format
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Response
import Prelude hiding (catch)
-import System.IO
+import System.IO (stderr)
-responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
+responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
responseWriter !cnf !h !tQueue !readerTID
= awaitSomethingToWrite
`catches`
unless willDiscardBody
$ do if willChunkBody then
do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
- C8.hPut h (C8.pack "\r\n")
- C8.hPut h chunk
- C8.hPut h (C8.pack "\r\n")
+ hPutLBS h (C8.pack "\r\n")
+ hPutLBS h chunk
+ hPutLBS h (C8.pack "\r\n")
else
- C8.hPut h chunk
+ hPutLBS h chunk
hFlush h
awaitSomethingToWrite
do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
willChunkBody <- atomically $! readItr itr itrWillChunkBody id
when (not willDiscardBody && willChunkBody)
- $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
+ $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
finalize :: Interaction -> IO ()
finalize itr
-build: MiseRafturai.hs SmallFile.hs
+build: MiseRafturai.hs SmallFile.hs SSL.hs
ghc --make HelloWorld -threaded -O3 -fwarn-unused-imports
ghc --make Implanted -threaded -O3 -fwarn-unused-imports
ghc --make ImplantedSmall -threaded -O3 -fwarn-unused-imports
ghc --make Multipart -threaded -O3 -fwarn-unused-imports
+ ghc --make SSL -threaded -O3 -fwarn-unused-imports
run: build
./HelloWorld
clean:
- rm -f HelloWorld Implanted MiseRafturai.hs ImplantedSmall SmallFile.hs Multipart *.hi *.o
+ rm -f HelloWorld Implanted MiseRafturai.hs ImplantedSmall SmallFile.hs Multipart SSL *.hi *.o
MiseRafturai.hs: mise-rafturai.html
lucu-implant-file -m MiseRafturai -o $@ $<
--- /dev/null
+import Control.Monad
+import Control.Monad.Trans
+import Data.Time.Clock
+import Network
+import Network.HTTP.Lucu
+import OpenSSL
+import OpenSSL.EVP.PKey
+import OpenSSL.RSA
+import qualified OpenSSL.Session as SSL
+import OpenSSL.X509
+
+main :: IO ()
+main = withOpenSSL $
+ do ctx <- SSL.context
+
+ key <- generateRSAKey 1024 3 Nothing
+ cert <- genCert key
+ SSL.contextSetPrivateKey ctx key
+ SSL.contextSetCertificate ctx cert
+ SSL.contextSetDefaultCiphers ctx
+
+ let config = defaultConfig {
+ cnfServerPort = PortNumber 9000
+ , cnfSSLConfig = Just SSLConfig {
+ sslServerPort = PortNumber 9001
+ , sslContext = ctx
+ }
+ }
+ resources = mkResTree [ ( []
+ , helloWorld )
+ ]
+ putStrLn "Access https://localhost:9001/ with your browser."
+ runHttpd config resources []
+
+
+helloWorld :: ResourceDef
+helloWorld
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = False
+ , resGet
+ = Just $ do setContentType $ read "text/plain"
+ outputChunk "getRemoteCertificate = "
+ cert <- do c <- getRemoteCertificate
+ case c of
+ Just c -> liftIO $ printX509 c
+ Nothing -> return "Nothing"
+ outputChunk cert
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+
+genCert :: KeyPair k => k -> IO X509
+genCert pkey
+ = do cert <- newX509
+ setVersion cert 2
+ setSerialNumber cert 1
+ setIssuerName cert [("CN", "localhost")]
+ setSubjectName cert [("CN", "localhost")]
+ setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime
+ setNotAfter cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime
+ setPublicKey cert pkey
+ signX509 cert pkey Nothing
+ return cert
\ No newline at end of file
projects / Lucu.git / commitdiff