keter 0.2.0.1 → 0.2.0.2
raw patch · 4 files changed
+31/−12 lines, 4 files
Files
- Keter/App.hs +3/−1
- Keter/Proxy.hs +19/−2
- Keter/SSL.hs +7/−7
- keter.cabal +2/−2
Keter/App.hs view
@@ -31,6 +31,7 @@ , configArgs :: [Text] , configHost :: String , configPostgres :: Bool+ , configSsl :: Bool } instance FromJSON Config where@@ -39,6 +40,7 @@ <*> o .:? "args" .!= [] <*> o .: "host" <*> o .:? "postgres" .!= False+ <*> o .:? "ssl" .!= False parseJSON _ = fail "Wanted an object" data Command = Reload | Terminate@@ -103,7 +105,7 @@ ] Nothing -> [] let env = ("PORT", show port)- : ("APPROOT", "http://" ++ configHost config)+ : ("APPROOT", (if configSsl config then "https://" else "http://") ++ configHost config) : otherEnv run ("config" </> configExec config)
Keter/Proxy.hs view
@@ -12,7 +12,6 @@ import Keter.Prelude ((++)) import Prelude hiding ((++), FilePath) import Data.Conduit-import Data.Conduit.List (peek) import Data.Conduit.Network import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8@@ -57,9 +56,27 @@ y <- takeMVar x killThread $ if y then tid2 else tid1 +getHeaders :: Monad m => Sink ByteString m ByteString+getHeaders =+ go id+ where+ go front =+ await >>= maybe close push+ where+ close = leftover bs >> return bs+ where+ bs = front S8.empty+ push bs'+ | "\r\n\r\n" `S8.isInfixOf` bs+ || "\n\n" `S8.isInfixOf` bs+ || S8.length bs > 1000 = leftover bs >> return bs+ | otherwise = go $ S8.append bs+ where+ bs = front bs'+ getVhost :: Monad m => Sink ByteString m (Maybe ByteString) getVhost =- peek >>= maybe (return Nothing) (return . go . drop 1 . S8.lines)+ getHeaders >>= return . go . drop 1 . S8.lines where go [] = Nothing go (bs:bss)
Keter/SSL.hs view
@@ -55,14 +55,14 @@ runTCPServerSsl :: SslConfig -> Application IO -> IO () runTCPServerSsl SslConfig{..} app = do- cert <- readCertificate sslCertificate+ certs <- readCertificates sslCertificate key <- readPrivateKey sslKey bracket (bindPort sslPort sslHost) sClose- (forever . serve cert key)+ (forever . serve certs key) where- serve cert key lsocket = do+ serve certs key lsocket = do (socket, _addr) <- accept lsocket -- FIXME exception safety _ <- forkIO $ handle socket return ()@@ -102,7 +102,7 @@ { TLS.pWantClientCert = False , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] , TLS.pCiphers = ciphers- , TLS.pCertificates = [(cert, Just key)]+ , TLS.pCertificates = zip certs $ Just key : repeat Nothing } -- taken from stunnel example in tls-extra@@ -114,12 +114,12 @@ , TLSExtra.cipher_RC4_128_SHA1 ] -readCertificate :: FilePath -> IO X509.X509-readCertificate filepath = do+readCertificates :: FilePath -> IO [X509.X509]+readCertificates filepath = do certs <- rights . parseCerts . PEM.pemParseBS <$> readFile filepath case certs of [] -> error "no valid certificate found"- (x:_) -> return x+ (_:_) -> return certs where parseCerts (Right pems) = map (X509.decodeCertificate . L.fromChunks . (:[]) . PEM.pemContent) $ filter (flip elem ["CERTIFICATE", "TRUSTED CERTIFICATE"] . PEM.pemName) pems parseCerts (Left err) = error $ "cannot parse PEM file: " ++ err
keter.cabal view
@@ -1,7 +1,7 @@ Name: keter-Version: 0.2.0.1+Version: 0.2.0.2 Synopsis: Web application deployment manager, focusing on Haskell web frameworks-Description: Handles deployment of web apps, using Nginx as a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme>+Description: Handles deployment of web apps, providing a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme> Homepage: http://www.yesodweb.com/ License: MIT License-file: LICENSE