warp-tls-uid 0.2.0.1 → 0.2.0.3

raw patch · 2 files changed

+29/−7 lines, 2 files

Files

• src/Network/Wai/Handler/WarpTLS/UserId.hs +27/−5
• warp-tls-uid.cabal +2/−2

@@ -1,10 +1,12 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings, BangPatterns #-}  module Network.Wai.Handler.WarpTLS.UserId ( 	GroupName, UserName, runTlsWithGroupUserName ) where +import Control.Arrow ((***), (&&&)) import Control.Exception (bracket)+import Data.List (unfoldr) import Data.Streaming.Network (bindPortTCP) import System.Posix ( 	groupID, getGroupEntryForName, setGroupID,@@ -13,19 +15,22 @@ import Network.Wai (Application) import Network.Wai.Handler.Warp ( 	Settings, HostPreference, getPort, getHost )-import Network.Wai.Handler.WarpTLS (runTLSSocket, tlsSettingsMemory)+import Network.Wai.Handler.WarpTLS (runTLSSocket, tlsSettingsChainMemory)  import qualified Data.ByteString as BS +type CertFile = FilePath+type KeyFile = FilePath+ type GroupName = String type UserName = String -runTlsWithGroupUserName :: (FilePath, FilePath) ->+runTlsWithGroupUserName :: (CertFile, KeyFile) -> 	(GroupName, UserName) -> Settings -> Application -> IO () runTlsWithGroupUserName (crt, key) (g, u) set app = do-	!c <- BS.readFile crt+	(!c, !cs) <- separateChain <$> BS.readFile crt 	!k <- BS.readFile key-	let	tset = tlsSettingsMemory c k+	let	tset = tlsSettingsChainMemory c cs k 	withSocketsDo $ bracket 		(bindPortTCPWithName (g, u) (getPort set) (getHost set)) 		close@@ -36,3 +41,20 @@ bindPortTCPWithName (g, u) p h = (bindPortTCP p h <*) $ do 	getGroupEntryForName g >>= setGroupID . groupID 	getUserEntryForName u >>= setUserID . userID++separateChain :: BS.ByteString -> (BS.ByteString, [BS.ByteString])+separateChain = (head &&& tail) . separate++endCertificate :: BS.ByteString+endCertificate = "-----END CERTIFICATE-----"++separate :: BS.ByteString -> [BS.ByteString]+separate = unfoldr separateOne++separateOne :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)+separateOne "" = Nothing+separateOne "\n" = Nothing+separateOne ccs = Just (c <> ec, cs)+	where+	(c, (ec, cs)) = id *** BS.splitAt (BS.length endCertificate)+		$ BS.breakSubstring endCertificate ccs

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 5375fa274dcbc84761aafff0f4ca02b64728f578ae6d3ceb842e41b8b93cf338+-- hash: df4da9c6b167a85ea51e282d41e7250768ca1fbde66c674a874eef4a4c5cab5a  name:           warp-tls-uid-version:        0.2.0.1+version:        0.2.0.3 synopsis:       set group and user id before running server description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/warp-tls-uid#readme> category:       Web