diff --git a/Lucu.cabal b/Lucu.cabal --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.2.1 +Version: 0.3 License: PublicDomain License-File: COPYING Author: PHO @@ -25,7 +25,13 @@ 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 @@ -65,6 +71,7 @@ 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 diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,13 @@ +Changes from 0.2.1 to 0.3 +------------------------- +* Added SSL support: + - Network.HTTP.Lucu.Config.Config has a new member: + # cnfSSLConfig + - Network.HTTP.Lucu.Resource has a new action: + # getRemoteCertificate + - examples/SSL.hs: + an example for accepting HTTPS connections. + Changes from 0.2 to 0.2.1 ------------------------- * Fixed incorrect dependency declaration in Lucu.cabal. No semantical diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -10,6 +10,12 @@ -- 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 @@ -19,8 +25,6 @@ -- -- [/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. -- diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -1,6 +1,7 @@ -- |Configurations for the Lucu httpd like a port to listen. module Network.HTTP.Lucu.Config ( Config(..) + , SSLConfig(..) , defaultConfig ) where @@ -11,6 +12,7 @@ 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 @@ -23,6 +25,9 @@ , 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 @@ -56,14 +61,24 @@ , 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 diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Lucu/HandleLike.hs @@ -0,0 +1,68 @@ +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 diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -25,10 +25,10 @@ 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 @@ -205,15 +205,15 @@ 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") diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -9,9 +9,9 @@ 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 @@ -45,15 +45,15 @@ ] -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) diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -13,6 +13,7 @@ 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 @@ -53,21 +54,42 @@ 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 - accept' :: Socket -> IO (Handle, So.SockAddr) - accept' soSelf + 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 + + 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) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -27,10 +27,12 @@ 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) @@ -80,10 +82,9 @@ 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 @@ -117,6 +118,7 @@ return $ Interaction { itrConfig = conf , itrRemoteAddr = addr + , itrRemoteCert = cert , itrResourcePath = Nothing , itrRequest = request , itrResponse = responce diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -16,6 +16,7 @@ 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 @@ -24,12 +25,12 @@ 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 ()) @@ -58,7 +59,7 @@ 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 @@ -72,7 +73,8 @@ 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 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -73,6 +73,7 @@ , getConfig , getRemoteAddr , getRemoteAddr' + , getRemoteCertificate , getRequest , getMethod , getRequestURI @@ -163,6 +164,7 @@ 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' @@ -224,6 +226,19 @@ _ -> 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. diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -19,9 +19,9 @@ 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 @@ -97,23 +97,23 @@ 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@. diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -12,16 +12,17 @@ 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` @@ -135,11 +136,11 @@ 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 @@ -150,7 +151,7 @@ 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 diff --git a/examples/Implanted.hs b/examples/Implanted.hs new file mode 100644 --- /dev/null +++ b/examples/Implanted.hs @@ -0,0 +1,11 @@ +import MiseRafturai +import Network +import Network.HTTP.Lucu + +main :: IO () +main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } + resources = mkResTree [ ([], miseRafturai) ] + in + do putStrLn "Access http://localhost:9999/ with your browser." + runHttpd config resources [] + diff --git a/examples/ImplantedSmall.hs b/examples/ImplantedSmall.hs new file mode 100644 --- /dev/null +++ b/examples/ImplantedSmall.hs @@ -0,0 +1,11 @@ +import Network +import Network.HTTP.Lucu +import SmallFile + +main :: IO () +main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } + resources = mkResTree [ ([], smallFile) ] + in + do putStrLn "Access http://localhost:9999/ with your browser." + runHttpd config resources [] + diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,14 +1,15 @@ -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 $@ $< diff --git a/examples/Multipart.hs b/examples/Multipart.hs new file mode 100644 --- /dev/null +++ b/examples/Multipart.hs @@ -0,0 +1,35 @@ +import Data.List +import Data.Maybe +import Network +import Network.HTTP.Lucu + +main :: IO () +main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } + resources = mkResTree [ ([], resMain) ] + in + do putStrLn "Access http://localhost:9999/ with your browser." + runHttpd config resources [] + + +resMain :: ResourceDef +resMain + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet + = Just $ do setContentType $ read "text/html" + output ("Multipart Form Test" ++ + "
" ++ + " Enter some value:" ++ + " " ++ + " " ++ + "
") + , resHead = Nothing + , resPost + = Just $ do form <- inputForm defaultLimit + let value = fromMaybe "" $ fmap snd $ find ((== "val") . fst) form + setContentType $ read "text/plain" + output ("You entered: " ++ value) + , resPut = Nothing + , resDelete = Nothing + } diff --git a/examples/SSL.hs b/examples/SSL.hs new file mode 100644 --- /dev/null +++ b/examples/SSL.hs @@ -0,0 +1,67 @@ +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 diff --git a/examples/mise-rafturai.html b/examples/mise-rafturai.html new file mode 100644 --- /dev/null +++ b/examples/mise-rafturai.html @@ -0,0 +1,30 @@ + + + + Mise Rafturaí + + +

Mise Rafturaí

+ +

+ Mise Rafturaí an file
+ Lán dúċais is gráḋ
+ Le súile gan solas
+ Le ciúnas gan crá
+

+ +

+ Ag dul síar ar m'aistear
+ Le solas mo ċroí
+ Fann agus tuirseaċ
+ Go deireaḋ mo ṡlí
+

+ +

+ Féaċ anois mé
+ Is mo ċúl le ḃfalla
+ Ag seinm ceoil
+ Do ṗócaí folaṁ
+

+ + diff --git a/examples/small-file.txt b/examples/small-file.txt new file mode 100644 --- /dev/null +++ b/examples/small-file.txt @@ -0,0 +1,1 @@ +Hello, world!