packages feed

warp-tls-uid (empty) → 0.1.0.0

raw patch · 8 files changed

+346/−0 lines, 8 filesdep +basedep +bytestringdep +certificatesetup-changed

Dependencies added: base, bytestring, certificate, conduit, crypto-random, http-types, network, network-conduit, pem, tls, tls-extra, unix, wai, warp, warp-tls-uid

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2011, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ src-lib/Network/Wai/Handler/WarpTLS/Getter.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RankNTypes, KindSignatures, PackageImports, ScopedTypeVariables #-}++module Network.Wai.Handler.WarpTLS.Getter (getter) where++import Prelude hiding (mapM_)++import Network.Wai.Handler.WarpTLS.TLS (+	Params,+	Backend(Backend, backendSend, backendRecv, backendFlush, backendClose),+	contextNew, handshake, sendData, recvData, bye)++import Data.Maybe+import Data.IORef+import Control.Applicative+import Control.Monad (unless)+import Control.Exception+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++import "crypto-random" Crypto.Random++import Data.Conduit (+	ConduitM, ResumableSource, Sink,+	runResourceT, yield, await, leftover, ($$), ($$+), ($$++))+import Data.Conduit.List (peek, mapM_)+import Data.Conduit.Binary (sourceFileRange)+import Data.Conduit.Network (sourceSocket, sinkSocket)++import Network.Socket (Socket, SockAddr, accept, sClose)+import Network.Wai.Handler.Warp (+	Connection(+		Connection, connSendMany, connSendAll, connSendFile,+		connSendFileOverride, connBufferSize, connBuffer,+		connRecv, connClose),+	ConnSendFileOverride(NotOverride),+	socketConnection)+import Network.Wai.Handler.Warp.Buffer (allocateBuffer, freeBuffer)++getter :: Params -> Socket -> IO (Connection, SockAddr)+getter params sock = do+	(s, sa) <- accept sock+	buf <- allocateBuffer 256+	handle (\(_ :: SomeException) -> sClose s >> getter params sock) $ do+		(fromClient, firstBS) <- sourceSocket s $$+ peek+		ifromClient <- newIORef fromClient+		if maybe False ((== 0x16) . fst) (firstBS >>= B.uncons)+		then do	gen <- cprgCreate <$> createEntropyPool+			ctx <- contextNew Backend {+				backendFlush = return (),+				backendClose = return (),+				backendSend = \bs -> yield bs $$ mkToClient s,+				backendRecv = getNext ifromClient . takeMost+			 } params (gen :: SystemRNG)+			handshake ctx+			let conn = Connection {+				connSendMany = sendData ctx . L.fromChunks,+				connSendAll = sendData ctx . L.fromChunks . return,+				connSendFile = \fp offset len _th headers -> do+					sendData ctx $ L.fromChunks headers+					runResourceT $ sourceFileRange fp (Just offset) (Just len) $$ mapM_ (sendData ctx . L.fromChunks . return),+				connSendFileOverride = NotOverride,+				connBufferSize = 256,+				connBuffer = buf,+				connClose = bye ctx >> sClose s,+				connRecv = recvData ctx+			 }+			return (conn, sa)+		else do	cs <- socketConnection s+			let conn = cs {+				connRecv = getNext ifromClient $+					fmap (fromMaybe B.empty) await+			 }+			return (conn, sa)++getNext :: IORef (ResumableSource IO a) -> Sink a IO b -> IO b+getNext ifromClient sink = do+	fromClient <- readIORef ifromClient+	(fromClient', bs) <- fromClient $$++ sink+	writeIORef ifromClient fromClient'+	return bs++takeMost :: forall (m :: * -> *) o . Monad m =>+	Int -> ConduitM B.ByteString o m B.ByteString+takeMost i = await >>= maybe (return B.empty) go+	where+	go bs = do+		unless (B.null y) $ leftover y+		return x+		where+		(x, y) = B.splitAt i bs++mkToClient :: Socket -> ConduitM B.ByteString o IO ()+mkToClient = sinkSocket
+ src-lib/Network/Wai/Handler/WarpTLS/Params.hs view
@@ -0,0 +1,51 @@+module Network.Wai.Handler.WarpTLS.Params (makeParams) where++import Network.Wai.Handler.WarpTLS.TLS (+	Params(pCiphers, pCertificates, pAllowedVersions), defaultParamsServer,+	ServerParams(serverWantClientCert), updateServerParams,+	Version(SSL3, TLS10, TLS11, TLS12), PrivateKey(PrivRSA),+	cipher_AES128_SHA1, cipher_AES256_SHA1,+	cipher_RC4_128_MD5, cipher_RC4_128_SHA1)++import Data.Either+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++-- import Control.Applicative+import Control.Arrow ((>>>), (|||))++import Data.PEM (PEM, pemParseBS, pemName, pemContent)+import Data.Certificate.X509 (X509, decodeCertificate)+import Data.Certificate.KeyRSA (decodePrivate)++makeParams :: B.ByteString -> B.ByteString -> Params+makeParams crts pk = initParam { pCertificates =+	zip (parseCrts crts) $ Just (parsePK pk) : repeat Nothing }++initParam :: Params+initParam = updateServerParams (\sp -> sp { serverWantClientCert = False }) $+	defaultParamsServer {+		pAllowedVersions = [SSL3, TLS10, TLS11, TLS12],+		pCiphers = [+			cipher_AES128_SHA1, cipher_AES256_SHA1,+			cipher_RC4_128_MD5, cipher_RC4_128_SHA1 ] }++parseCrts :: B.ByteString -> [X509]+parseCrts = pemParseBS >>>+	error . ("Cannot parse PEM file: " ++) |||+	rights . map (decodeCertificate . pemToLazy) .+		filterPem ["CERTIFICATE", "TRUSTED CERTIFICATE"]++parsePK :: B.ByteString -> PrivateKey+parsePK = pemParseBS >>>+	error . ("Cannot parse PEM file: " ++) |||+	head . rights . map (privRSA . pemToLazy) . filterPem ["RSA PRIVATE KEY"]++privRSA :: L.ByteString -> Either String PrivateKey+privRSA = fmap (PrivRSA . snd) . decodePrivate++pemToLazy :: PEM -> L.ByteString+pemToLazy = L.fromChunks . (: []) . pemContent++filterPem :: [String] -> [PEM] -> [PEM]+filterPem ns = filter $ (`elem` ns) . pemName
+ src-lib/Network/Wai/Handler/WarpTLS/TLS.hs view
@@ -0,0 +1,16 @@+module Network.Wai.Handler.WarpTLS.TLS (+	Params(pCiphers, pCertificates, pAllowedVersions),+	Backend(Backend, backendSend, backendRecv, backendFlush, backendClose),+	contextNew, handshake, sendData, recvData, bye,++	Cipher,+	ServerParams(serverWantClientCert), PrivateKey(PrivRSA),+	Version(SSL3, TLS10, TLS11, TLS12),++	defaultParamsServer, updateServerParams,+	cipher_AES128_SHA1, cipher_AES256_SHA1,+	cipher_RC4_128_MD5, cipher_RC4_128_SHA1+) where++import Network.TLS+import Network.TLS.Extra
+ src-lib/Network/Wai/Handler/WarpTLS/UID.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Handler.WarpTLS.UID (runTLSSocket, runTLSSocketWithID, tlsSettings, Group, User) where++import Network.Wai.Handler.WarpTLS.Params (makeParams)+import Network.Wai.Handler.WarpTLS.Getter (getter)++import Control.Applicative+import qualified Data.ByteString as B++import Network.Socket (Socket)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (Settings, runSettingsConnection)++import System.Posix++data TLSSettings = TLSSettings FilePath FilePath++tlsSettings :: FilePath -> FilePath -> TLSSettings+tlsSettings = TLSSettings++runTLSSocket ::+	FilePath -> FilePath -> Settings -> Socket -> Application -> IO ()+runTLSSocket crt key set sock app = do+	params <- makeParams <$> B.readFile crt <*> B.readFile key+	runSettingsConnection set (getter params sock) app++type Group = String+type User = String++runTLSSocketWithID :: TLSSettings -> Settings -> Socket ->+	(Group, User) -> Application -> IO ()+runTLSSocketWithID (TLSSettings crt key) set sock (gid, uid) app = do+	!c <- B.readFile crt+	!k <- B.readFile key+	getGroupEntryForName gid >>= setGroupID . groupID+	getUserEntryForName uid >>= setUserID . userID+	runSettingsConnection set (getter (makeParams c k) sock) app++runTLSSocketCnt ::+	B.ByteString -> B.ByteString -> Settings -> Socket -> Application -> IO ()+runTLSSocketCnt crt key set sock app =+	runSettingsConnection set (getter (makeParams crt key) sock) app
+ src-test/testWarpTLS.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE PackageImports, OverloadedStrings, RankNTypes, KindSignatures #-}++import Data.Function (on)++import Network.Wai.Handler.WarpTLS.UID (runTLSSocketWithID, tlsSettings, Group, User)+-- import Network.Wai.Handler.WarpTLS (runTLSSocket, tlsSettings)++import Data.Char+import Control.Applicative+import Control.Exception+import System.Environment++import Data.Conduit.Network (bindPort)++import Network.Socket (sClose)+import Network.HTTP.Types.Status (status200)+import Network.Wai (responseLBS) -- (Response, responseLBS, Application)+import Network.Wai.Handler.Warp (HostPreference(HostAny), defaultSettings)++cutSpaces :: String -> String+cutSpaces = takeWhile $ not . isSpace++guid :: (Group, User)+guid = ("yesod", "yesod")++main :: IO ()+main = do+	args <- getArgs+	tlss <- case args of+		[crt, key] -> return $ tlsSettings crt key+		[] -> (tlsSettings `on` cutSpaces)+			<$> readFile "crt.path"+			<*> readFile "key.path"+		_ -> error "wrong argument number"+	bracket (bindPort 3000 HostAny) sClose $ \sock ->+		runTLSSocketWithID tlss defaultSettings sock guid $ \_ -> do+				print ("hello" :: String)+				return $ responseLBS status200+					[("Content-Type", "text/plain")] "PONG"
+ warp-tls-uid.cabal view
@@ -0,0 +1,73 @@+build-type: Simple+cabal-version: >= 1.8++category: Yesod++name: warp-tls-uid+version: 0.1.0.0+stability: Experimental++author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+license: BSD3+license-file: LICENSE++synopsis: set group and user id before running server+description:+    > runTLSSocketWithID tlss settings sock ("user", "bob") app++source-repository head+    type: git+    location: git://github.com/YoshikuniJujo/warp-tls-uid++source-repository this+    type: git+    location: git://github.com/YoshikuniJujo/warp-tls-uid+    tag: 0.1.0.0++Flag test+    Description: test+    Default:     False++library+    hs-source-dirs: src-lib+    exposed-modules: Network.Wai.Handler.WarpTLS.UID+    other-modules:+        Network.Wai.Handler.WarpTLS.TLS+        Network.Wai.Handler.WarpTLS.Params+        Network.Wai.Handler.WarpTLS.Getter+    build-depends:+        base > 3 && < 5, unix, warp == 2.0.*, wai == 2.0.*, network == 2.4.*,+        bytestring == 0.10.*, network-conduit == 1.0.*, conduit == 1.0.*,+        tls-extra == 0.6.*, tls == 1.1.*, certificate == 1.3.*, pem == 0.2.*,+        crypto-random == 0.0.7+    extensions: DoAndIfThenElse+    ghc-options: -Wall++executable testServer+    if flag(test)+        Buildable: True+    else+        Buildable: False++    hs-source-dirs: src-test+    main-is: testWarpTLS.hs+    build-depends:+        warp-tls-uid,+        base > 3 && < 5, unix, warp == 2.0.*, wai == 2.0.*, network == 2.4.*,+        bytestring == 0.10.*, network-conduit == 1.0.*, conduit == 1.0.*,+        tls-extra == 0.6.*, tls == 1.1.*, certificate == 1.3.*, pem == 0.2.*,+        crypto-random == 0.0.7,+        http-types == 0.8.*+    extensions: DoAndIfThenElse+    ghc-options: -Wall++-- test-suite test+--    type: exitcode-stdio-1.0+--    main-is: testWarpTLS.hs+--    build-depends:+--        base > 3 && < 5, warp-tls-uid, warp == 2.0.*, wai == 2.0.*,+--        http-types == 0.8.*, network == 2.4.*, network-conduit == 1.0.*,+--        unix == 2.6.*, bytestring == 0.10.*, conduit == 1.0.*, tls-extra == 0.6.*,+--        tls == 1.1.*, certificate == 1.3.*, pem == 0.2.*, crypto-random == 0.0.7+--    extensions: DoAndIfThenElse