keter 0.1.0.1 → 0.2.0

raw patch · 7 files changed

+438/−244 lines, 7 filesdep +certificatedep +conduitdep +crypto-apiPVP ok

version bump matches the API change (PVP)

Dependencies added: certificate, conduit, crypto-api, network-conduit, pem, tls, tls-extra

API changes (from Hackage documentation)

Files

• Keter/App.hs +11/−11
• Keter/Main.hs +37/−6
• Keter/Nginx.hs +0/−224
• Keter/PortManager.hs +163/−0
• Keter/Proxy.hs +79/−0
• Keter/SSL.hs +136/−0
• keter.cabal +12/−3

@@ -14,7 +14,7 @@ import Keter.Postgres import Keter.Process import Keter.Logger (Logger, detach)-import Keter.Nginx hiding (start)+import Keter.PortManager hiding (start) import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip (decompress) import qualified Filesystem.Path.CurrentOS as F@@ -66,14 +66,14 @@                     liftIO $ rest `onException` removeTree dir  start :: TempFolder-      -> Nginx+      -> PortManager       -> Postgres       -> Logger       -> Appname       -> F.FilePath -- ^ app bundle       -> KIO () -- ^ action to perform to remove this App from list of actives       -> KIO (App, KIO ())-start tf nginx postgres logger appname bundle removeFromList = do+start tf portman postgres logger appname bundle removeFromList = do     chan <- newChan     return (App $ writeChan chan, rest chan)   where@@ -119,7 +119,7 @@                 $logEx e                 removeFromList             Right (dir, config) -> do-                eport <- getPort nginx+                eport <- getPort portman                 case eport of                     Left e -> do                         $logEx e@@ -129,11 +129,11 @@                         b <- testApp port                         if b                             then do-                                addEntry nginx (configHost config) $ AppEntry port+                                addEntry portman (configHost config) port                                 loop chan dir process port config                             else do                                 removeFromList-                                releasePort nginx port+                                releasePort portman port                                 Keter.Process.terminate process      loop chan dirOld processOld portOld configOld = do@@ -141,7 +141,7 @@         case command of             Terminate -> do                 removeFromList-                removeEntry nginx $ configHost configOld+                removeEntry portman $ configHost configOld                 log $ TerminatingApp appname                 terminateOld                 detach logger@@ -152,7 +152,7 @@                         log $ InvalidBundle bundle e                         loop chan dirOld processOld portOld configOld                     Right (dir, config) -> do-                        eport <- getPort nginx+                        eport <- getPort portman                         case eport of                             Left e -> $logEx e                             Right port -> do@@ -160,14 +160,14 @@                                 b <- testApp port                                 if b                                     then do-                                        addEntry nginx (configHost config) $ AppEntry port+                                        addEntry portman (configHost config) port                                         when (configHost config /= configHost configOld) $-                                            removeEntry nginx $ configHost configOld+                                            removeEntry portman $ configHost configOld                                         log $ FinishedReloading appname                                         terminateOld                                         loop chan dir process port config                                     else do-                                        releasePort nginx port+                                        releasePort portman port                                         Keter.Process.terminate process                                         log $ ProcessDidNotStart bundle                                         loop chan dirOld processOld portOld configOld

@@ -7,14 +7,17 @@     ) where  import Keter.Prelude hiding (getCurrentTime)-import qualified Keter.Nginx as Nginx import qualified Keter.TempFolder as TempFolder import qualified Keter.App as App import qualified Keter.Postgres as Postgres import qualified Keter.LogFile as LogFile import qualified Keter.Logger as Logger+import qualified Keter.PortManager as PortMan+import qualified Keter.Proxy as Proxy +import Data.Conduit.Network (ServerSettings (ServerSettings), HostPreference) import qualified Control.Concurrent.MVar as M+import Control.Concurrent (forkIO) import qualified Data.Map as Map import qualified System.INotify as I import Control.Monad (forever, mzero)@@ -28,16 +31,31 @@ import Data.Maybe (fromMaybe) import Data.Yaml (decodeFile, FromJSON (parseJSON), Value (Object), (.:), (.:?), (.!=)) import Control.Applicative ((<$>), (<*>))+import Data.String (fromString)  data Config = Config     { configDir :: F.FilePath-    , configNginx :: Nginx.Settings+    , configPortMan :: PortMan.Settings+    , configHost :: HostPreference+    , configPort :: PortMan.Port+    , configSsl :: Maybe Proxy.SslConfig     }+instance Default Config where+    def = Config+        { configDir = "."+        , configPortMan = def+        , configHost = "*"+        , configPort = 80+        , configSsl = Nothing+        }  instance FromJSON Config where     parseJSON (Object o) = Config         <$> (F.fromText <$> o .: "root")-        <*> o .:? "nginx" .!= def+        <*> o .:? "port-manager" .!= def+        <*> (fmap fromString <$> o .:? "host") .!= configHost def+        <*> o .:? "port" .!= configPort def+        <*> o .:? "ssl"     parseJSON _ = mzero  keter :: P.FilePath -- ^ root directory or config file@@ -47,10 +65,10 @@     Config{..} <-         if exists             then decodeFile input' >>= maybe (P.error "Invalid config file") return-            else return $ Config input def+            else return def { configDir = input }     let dir = F.directory input F.</> configDir -    nginx <- runThrow $ Nginx.start configNginx+    portman <- runThrow $ PortMan.start configPortMan     tf <- runThrow $ TempFolder.setup $ dir </> "temp"     postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"     mainlog <- runThrow $ LogFile.start $ dir </> "log" </> "keter"@@ -66,6 +84,19 @@             runKIOPrint $ LogFile.addChunk mainlog bs         runKIOPrint = runKIO P.print +    _ <- forkIO $ Proxy.reverseProxy+            (ServerSettings configPort configHost)+            (runKIOPrint . PortMan.lookupPort portman)+            (runKIOPrint $ PortMan.hostList portman)+    case configSsl of+        Nothing -> return ()+        Just ssl -> do+            _ <- forkIO $ Proxy.reverseProxySsl+                    (Proxy.setDir dir ssl)+                    (runKIOPrint . PortMan.lookupPort portman)+                    (runKIOPrint $ PortMan.hostList portman)+            return ()+     mappMap <- M.newMVar Map.empty     let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname         addApp bundle = do@@ -95,7 +126,7 @@                         let logger = fromMaybe Logger.dummy mlogger                         (app, rest) <- App.start                             tf-                            nginx+                            portman                             postgres                             logger                             appname

@@ -1,224 +0,0 @@-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Keter.Nginx
-    ( -- * Types
-      Port
-    , Host
-    , Entry (..)
-    , Nginx
-      -- ** Settings
-    , Settings
-    , configFile
-    , reloadAction
-    , startAction
-    , portRange
-      -- * Actions
-    , getPort
-    , releasePort
-    , addEntry
-    , removeEntry
-      -- * Initialize
-    , start
-    ) where
-
-import Keter.Prelude
-import System.Cmd (rawSystem)
-import qualified Control.Monad.Trans.State as S
-import Control.Monad.Trans.Class (lift)
-import qualified Data.Map as Map
-import Control.Monad (forever, mzero)
-import qualified Data.ByteString.Lazy as L
-import Blaze.ByteString.Builder (copyByteString, toLazyByteString)
-import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow)
-import Data.Monoid (Monoid, mconcat)
-import Data.ByteString.Char8 ()
-import qualified Network
-import qualified Data.ByteString as S
-import System.Exit (ExitCode (ExitSuccess))
-import Data.Yaml (FromJSON (parseJSON), Value (Object), (.:?), (.!=))
-import Control.Applicative ((<$>), (<*>))
-
--- | A port for an individual app to listen on.
-type Port = Int
-
--- | A virtual host we want to serve content from.
-type Host = String
-
-data Command = GetPort (Either SomeException Port -> KIO ())
-             | ReleasePort Port
-             | AddEntry Host Entry
-             | RemoveEntry Host
-
--- | An individual virtual host may either be a reverse proxy to an app
--- (@AppEntry@), or may serve static files (@StaticEntry@).
-data Entry = AppEntry Port
-           | StaticEntry FilePath
-
--- | An abstract type which can accept commands and sends them to a background
--- nginx thread.
-newtype Nginx = Nginx (Command -> KIO ())
-
--- | Controls execution of the nginx thread. Follows the settings type pattern.
--- See: <http://www.yesodweb.com/book/settings-types>.
-data Settings = Settings
-    { configFile :: FilePath
-      -- ^ Location of config file. Default: \/etc\/nginx\/sites-enabled\/keter
-    , reloadAction :: KIO (Either SomeException ())
-      -- ^ How to tell Nginx to reload config file. Default: \/etc\/init.d\/nginx reload
-    , startAction :: KIO (Either SomeException ())
-      -- ^ How to tell Nginx to start running. Default: \/etc\/init.d\/nginx start
-    , portRange :: [Port]
-      -- ^ Which ports to assign to apps. Default: 4000-4999
-    }
-
-instance Default Settings where
-    def = Settings
-        { configFile = "/etc/nginx/sites-enabled/keter"
-        , reloadAction = rawSystem' "/etc/init.d/nginx" ["reload"]
-        , startAction = rawSystem' "/etc/init.d/nginx" ["start"]
-        , portRange = [4000..4999]
-        }
-
-instance FromJSON Settings where
-    parseJSON (Object o) = Settings
-        <$> (fmap fromText <$> o .:? "config") .!= configFile def
-        <*> (runRawSystem (reloadAction def) <$> (o .:? "reload"))
-        <*> (runRawSystem (startAction def) <$> (o .:? "start"))
-        <*> return (portRange def)
-      where
-        runRawSystem :: KIO (Either SomeException ()) -> Maybe [Text] -> KIO (Either SomeException ())
-        runRawSystem _ (Just (command:args)) = rawSystem' (fromText command) args
-        runRawSystem _ (Just []) = fail "Command with empty list"
-        runRawSystem k Nothing = k
-    parseJSON _ = mzero
-
-rawSystem' :: FilePath -> [String] -> KIO (Either SomeException ())
-rawSystem' fp args = do
-    eec <- liftIO $ rawSystem (toString fp) (map toString args)
-    case eec of
-        Left e -> return $ Left e
-        Right ec
-            | ec == ExitSuccess -> return $ Right ()
-            | otherwise -> return $ Left $ toException $ ExitCodeFailure fp ec
-
--- | Start running a separate thread which will accept commands and modify
--- Nginx's behavior accordingly.
-start :: Settings -> KIO (Either SomeException Nginx)
-start Settings{..} = do
-    -- Start off by ensuring we can read and write the config file and reload
-    eres <- liftIO $ do
-        exists <- isFile configFile
-        config0 <-
-            if exists
-                then S.readFile $ toString configFile
-                else return ""
-        let tmp = configFile <.> "tmp"
-        S.writeFile (toString tmp) config0
-        rename tmp configFile
-    case eres of
-        Left e -> return $ Left e
-        Right () -> do
-            eres2 <- reloadAction
-            case eres2 of
-                Left e -> return $ Left e
-                Right () -> go
-
- where
-    go :: KIO (Either SomeException Nginx)
-    go = do
-        chan <- newChan
-        forkKIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do
-            command <- lift $ readChan chan
-            case command of
-                GetPort f -> do
-                    ns0 <- S.get
-                    let loop :: NState -> KIO (Either SomeException Port, NState)
-                        loop ns =
-                            case nsAvail ns of
-                                p:ps -> do
-                                    res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p
-                                    case res of
-                                        Left (_ :: SomeException) -> do
-                                            log $ RemovingPort p
-                                            loop ns { nsAvail = ps }
-                                        Right socket -> do
-                                            res' <- liftIO $ Network.sClose socket
-                                            case res' of
-                                                Left e -> do
-                                                    $logEx e
-                                                    log $ RemovingPort p
-                                                    loop ns { nsAvail = ps }
-                                                Right () -> return (Right p, ns { nsAvail = ps })
-                                [] ->
-                                    case reverse $ nsRecycled ns of
-                                        [] -> return (Left $ toException NoPortsAvailable, ns)
-                                        ps -> loop ns { nsAvail = ps, nsRecycled = [] }
-                    (eport, ns) <- lift $ loop ns0
-                    S.put ns
-                    lift $ f eport
-                ReleasePort p ->
-                    S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns }
-                AddEntry h e -> change $ Map.insert h e
-                RemoveEntry h -> change $ Map.delete h
-        return $ Right $ Nginx $ writeChan chan
-
-    change f = do
-        ns <- S.get
-        let entries = f $ nsEntries ns
-        S.put $ ns { nsEntries = entries }
-        let tmp = configFile <.> "tmp"
-        lift $ do
-            res1 <- liftIO $ do
-                L.writeFile (toString tmp) $ mkConfig entries
-                rename tmp configFile
-            res2 <- case res1 of
-                Left e -> return $ Left e
-                Right () -> reloadAction
-            case res2 of
-                Left e -> $logEx e
-                Right () -> return ()
-    mkConfig = toLazyByteString . mconcat . map mkConfig' . Map.toList
-    mkConfig' (host, entry) =
-        copyByteString "server {\n    listen 80;\n    server_name " ++
-        fromText host ++ copyByteString ";\n" ++
-        mkConfigEntry entry ++
-        copyByteString "}\n"
-    mkConfigEntry (AppEntry port) =
-        copyByteString "    location / {\n        proxy_pass http://127.0.0.1:" ++
-        fromShow port ++ copyByteString ";\n        proxy_set_header X-Real-IP $remote_addr;\n    }\n"
-    mkConfigEntry (StaticEntry fp) =
-        copyByteString "    root " ++ fromString (toString fp) ++ copyByteString ";\n    expires max;\n"
-
-data NState = NState
-    { nsAvail :: [Port]
-    , nsRecycled :: [Port]
-    , nsEntries :: Map.Map Host Entry
-    }
-
--- | Gets an unassigned port number.
-getPort :: Nginx -> KIO (Either SomeException Port)
-getPort (Nginx f) = do
-    x <- newEmptyMVar
-    f $ GetPort $ \p -> putMVar x p
-    takeMVar x
-
--- | Inform the nginx thread that the given port number is no longer being
--- used, and may be reused by a new process. Note that recycling puts the new
--- ports at the end of the queue (FIFO), so that if an application holds onto
--- the port longer than expected, there should be no issues.
-releasePort :: Nginx -> Port -> KIO ()
-releasePort (Nginx f) p = f $ ReleasePort p
-
--- | Add a new entry to the configuration for the given hostname and reload
--- nginx. Will overwrite any existing configuration for the given host. The
--- second point is important: it is how we achieve zero downtime transitions
--- between an old and new version of an app.
-addEntry :: Nginx -> Host -> Entry -> KIO ()
-addEntry (Nginx f) h e = f $ AddEntry h e
-
--- | Remove an entry from the configuration and reload nginx.
-removeEntry :: Nginx -> Host -> KIO ()
-removeEntry (Nginx f) h = f $ RemoveEntry h

@@ -0,0 +1,163 @@+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Keter.PortManager
+    ( -- * Types
+      Port
+    , Host
+    , PortManager
+      -- ** Settings
+    , Settings
+    , portRange
+      -- * Actions
+    , getPort
+    , releasePort
+    , addEntry
+    , removeEntry
+    , lookupPort
+    , hostList
+      -- * Initialize
+    , start
+    ) where
+
+import Keter.Prelude
+import qualified Control.Monad.Trans.State as S
+import Control.Monad.Trans.Class (lift)
+import qualified Data.Map as Map
+import Control.Monad (forever, mzero)
+import Data.ByteString.Char8 ()
+import qualified Network
+import qualified Data.ByteString as S
+import Data.Text.Encoding (encodeUtf8)
+import Data.Yaml (FromJSON (parseJSON), Value (Object))
+import Control.Applicative ((<$>))
+
+-- | A port for an individual app to listen on.
+type Port = Int
+
+-- | A virtual host we want to serve content from.
+type Host = String
+
+data Command = GetPort (Either SomeException Port -> KIO ())
+             | ReleasePort Port
+             | AddEntry Host Port
+             | RemoveEntry Host
+             | LookupPort S.ByteString (Maybe Port -> KIO ())
+             | HostList ([S.ByteString] -> KIO ())
+
+-- | An abstract type which can accept commands and sends them to a background
+-- nginx thread.
+newtype PortManager = PortManager (Command -> KIO ())
+
+-- | Controls execution of the nginx thread. Follows the settings type pattern.
+-- See: <http://www.yesodweb.com/book/settings-types>.
+data Settings = Settings
+    { portRange :: [Port]
+      -- ^ Which ports to assign to apps. Default: 4000-4999
+    }
+
+instance Default Settings where
+    def = Settings
+        { portRange = [4000..4999]
+        }
+
+instance FromJSON Settings where
+    parseJSON (Object _) = Settings
+        <$> return (portRange def)
+    parseJSON _ = mzero
+
+-- | Start running a separate thread which will accept commands and modify
+-- Nginx's behavior accordingly.
+start :: Settings -> KIO (Either SomeException PortManager)
+start Settings{..} = do
+    chan <- newChan
+    forkKIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do
+        command <- lift $ readChan chan
+        case command of
+            GetPort f -> do
+                ns0 <- S.get
+                let loop :: NState -> KIO (Either SomeException Port, NState)
+                    loop ns =
+                        case nsAvail ns of
+                            p:ps -> do
+                                res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p
+                                case res of
+                                    Left (_ :: SomeException) -> do
+                                        log $ RemovingPort p
+                                        loop ns { nsAvail = ps }
+                                    Right socket -> do
+                                        res' <- liftIO $ Network.sClose socket
+                                        case res' of
+                                            Left e -> do
+                                                $logEx e
+                                                log $ RemovingPort p
+                                                loop ns { nsAvail = ps }
+                                            Right () -> return (Right p, ns { nsAvail = ps })
+                            [] ->
+                                case reverse $ nsRecycled ns of
+                                    [] -> return (Left $ toException NoPortsAvailable, ns)
+                                    ps -> loop ns { nsAvail = ps, nsRecycled = [] }
+                (eport, ns) <- lift $ loop ns0
+                S.put ns
+                lift $ f eport
+            ReleasePort p ->
+                S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns }
+            AddEntry h e -> change $ Map.insert (encodeUtf8 h) e
+            RemoveEntry h -> change $ Map.delete $ encodeUtf8 h
+            LookupPort h f -> do
+                NState {..} <- S.get
+                lift $ f $ Map.lookup h nsEntries
+            HostList f -> do
+                NState {..} <- S.get
+                lift $ f $ Map.keys nsEntries
+    return $ Right $ PortManager $ writeChan chan
+  where
+    change f = do
+        ns <- S.get
+        let entries = f $ nsEntries ns
+        S.put $ ns { nsEntries = entries }
+
+data NState = NState
+    { nsAvail :: [Port]
+    , nsRecycled :: [Port]
+    , nsEntries :: Map.Map S.ByteString Port
+    }
+
+-- | Gets an unassigned port number.
+getPort :: PortManager -> KIO (Either SomeException Port)
+getPort (PortManager f) = do
+    x <- newEmptyMVar
+    f $ GetPort $ \p -> putMVar x p
+    takeMVar x
+
+-- | Inform the nginx thread that the given port number is no longer being
+-- used, and may be reused by a new process. Note that recycling puts the new
+-- ports at the end of the queue (FIFO), so that if an application holds onto
+-- the port longer than expected, there should be no issues.
+releasePort :: PortManager -> Port -> KIO ()
+releasePort (PortManager f) p = f $ ReleasePort p
+
+-- | Add a new entry to the configuration for the given hostname and reload
+-- nginx. Will overwrite any existing configuration for the given host. The
+-- second point is important: it is how we achieve zero downtime transitions
+-- between an old and new version of an app.
+addEntry :: PortManager -> Host -> Port -> KIO ()
+addEntry (PortManager f) h p = f $ AddEntry h p
+
+-- | Remove an entry from the configuration and reload nginx.
+removeEntry :: PortManager -> Host -> KIO ()
+removeEntry (PortManager f) h = f $ RemoveEntry h
+
+lookupPort :: PortManager -> S.ByteString -> KIO (Maybe Port)
+lookupPort (PortManager f) h = do
+    x <- newEmptyMVar
+    f $ LookupPort h $ \p -> putMVar x p
+    takeMVar x
+
+hostList :: PortManager -> KIO [S.ByteString]
+hostList (PortManager f) = do
+    x <- newEmptyMVar
+    f $ HostList $ \p -> putMVar x p
+    takeMVar x

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+-- | A light-weight, minimalistic reverse HTTP proxy.+module Keter.Proxy+    ( reverseProxy+    , PortLookup+    , HostList+    , reverseProxySsl+    , setDir+    , SslConfig+    ) where++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+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar+import Data.Char (isSpace, toLower)+import Control.Exception (onException)+import Keter.PortManager (Port)+import Control.Monad.Trans.Class (lift)+import qualified Data.ByteString.Lazy as L+import Blaze.ByteString.Builder (fromByteString, toLazyByteString)+import Data.Monoid (mconcat)+import Keter.SSL++-- | Mapping from virtual hostname to port number.+type PortLookup = ByteString -> IO (Maybe Port)++type HostList = IO [ByteString]++reverseProxy :: ServerSettings -> PortLookup -> HostList -> IO ()+reverseProxy settings x = runTCPServer settings . withClient x++reverseProxySsl :: SslConfig -> PortLookup -> HostList -> IO ()+reverseProxySsl settings x = runTCPServerSsl settings . withClient x++withClient :: PortLookup+           -> HostList+           -> Source IO ByteString+           -> Sink ByteString IO ()+           -> IO ()+withClient portLookup hostList fromClient toClient = do+    (rsrc, mvhost) <- fromClient $$+ getVhost+    mport <- maybe (return Nothing) portLookup mvhost+    case mport of+        Nothing -> lift (fmap toResponse hostList) >>= mapM_ yield $$ toClient+        Just port -> runTCPClient (ClientSettings port "127.0.0.1") (withServer rsrc)+  where+    withServer rsrc fromServer toServer = do+        x <- newEmptyMVar+        tid1 <- forkIO $ (rsrc $$+- toServer) `onException` putMVar x True+        tid2 <- forkIO $ (fromServer $$ toClient) `onException` putMVar x False+        y <- takeMVar x+        killThread $ if y then tid2 else tid1++getVhost :: Monad m => Sink ByteString m (Maybe ByteString)+getVhost =+    peek >>= maybe (return Nothing) (return . go . drop 1 . S8.lines)+  where+    go [] = Nothing+    go (bs:bss)+        | S8.map toLower k == "host" = Just v+        | otherwise = go bss+      where+        (k, v') = S8.break (== ':') bs+        v = S8.takeWhile (not . isSpace) $ S8.dropWhile isSpace $ S8.drop 1 v'++toResponse :: [ByteString] -> [ByteString]+toResponse hosts =+    L.toChunks $ toLazyByteString $ front ++ mconcat (map go hosts) ++ end+  where+    front = fromByteString "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You may access the following sites:</p><ul>"+    end = fromByteString "</ul></body></html>"+    go host = fromByteString "<li><a href=\"http://" ++ fromByteString host ++ fromByteString "/\">" +++              fromByteString host ++ fromByteString "</a></li>"

@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Keter.SSL+    ( SslConfig (..)+    , setDir+    , runTCPServerSsl+    ) where++import Keter.Prelude ((++))+import Prelude hiding ((++), FilePath, readFile)+import Data.Yaml (FromJSON (parseJSON), (.:), (.:?), (.!=), Value (Object))+import Control.Applicative ((<$>), (<*>))+import Control.Monad (mzero, forever)+import Data.String (fromString)+import Filesystem.Path.CurrentOS ((</>), FilePath)+import Filesystem (readFile)+import qualified Data.ByteString.Lazy as L+import qualified Data.Certificate.KeyRSA as KeyRSA+import qualified Data.PEM as PEM+import qualified Network.TLS as TLS+import qualified Data.Certificate.X509 as X509+import Data.Conduit.Network (HostPreference, Application, bindPort, sinkSocket)+import Data.Conduit (($$), yield)+import qualified Data.Conduit.List as CL+import Data.Either (rights)+import Keter.PortManager (Port)+import Network.Socket (sClose, accept)+import Network.Socket.ByteString (recv)+import Control.Exception (bracket, finally)+import Control.Concurrent (forkIO)+import Control.Monad.Trans.Class (lift)+import qualified Network.TLS.Extra as TLSExtra+import Crypto.Random++data SslConfig = SslConfig+    { sslHost :: HostPreference+    , sslPort :: Port+    , sslCertificate :: FilePath+    , sslKey :: FilePath+    }++setDir :: FilePath -> SslConfig -> SslConfig+setDir dir ssl = ssl+    { sslCertificate = dir </> sslCertificate ssl+    , sslKey = dir </> sslKey ssl+    }++instance FromJSON SslConfig where+    parseJSON (Object o) = SslConfig+        <$> (fmap fromString <$> o .:? "host") .!= "*"+        <*> o .:? "port" .!= 443+        <*> (fromString <$> o .: "certificate")+        <*> (fromString <$> o .: "key")+    parseJSON _ = mzero++runTCPServerSsl :: SslConfig -> Application IO -> IO ()+runTCPServerSsl SslConfig{..} app = do+    cert <- readCertificate sslCertificate+    key <- readPrivateKey sslKey+    bracket+        (bindPort sslPort sslHost)+        sClose+        (forever . serve cert key)+  where+    serve cert key lsocket = do+        (socket, _addr) <- accept lsocket -- FIXME exception safety+        _ <- forkIO $ handle socket+        return ()+      where+        handle socket = do+            gen <- newGenIO+            ctx <- TLS.serverWith+                params+                (gen :: SystemRandom)+                socket+                (return ()) -- flush+                (\bs -> yield bs $$ sinkSocket socket)+                (recv socket)++            TLS.handshake ctx+            {-+            let conn = Connection+                    { connSendMany = TLS.sendData ctx . L.fromChunks+                    , connSendAll = TLS.sendData ctx . L.fromChunks . return+                    , connSendFile = \fp offset len _th headers -> do+                        TLS.sendData ctx $ L.fromChunks headers+                        C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)+                    , connClose = do+                        TLS.bye ctx+                        sClose s+                    , connRecv = TLS.recvData ctx+                    }+            return (conn, sa)+            -}++            let src = lift (TLS.recvData ctx) >>= yield >> src+                sink = CL.mapM_ $ TLS.sendData ctx . L.fromChunks . return++            app src sink `finally` sClose socket++        params = TLS.defaultParams+            { TLS.pWantClientCert = False+            , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]+            , TLS.pCiphers         = ciphers+            , TLS.pCertificates    = [(cert, Just key)]+            }++-- taken from stunnel example in tls-extra+ciphers :: [TLS.Cipher]+ciphers =+    [ TLSExtra.cipher_AES128_SHA1+    , TLSExtra.cipher_AES256_SHA1+    , TLSExtra.cipher_RC4_128_MD5+    , TLSExtra.cipher_RC4_128_SHA1+    ]++readCertificate :: FilePath -> IO X509.X509+readCertificate filepath = do+    certs <- rights . parseCerts . PEM.pemParseBS <$> readFile filepath+    case certs of+        []    -> error "no valid certificate found"+        (x:_) -> return x+    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++readPrivateKey :: FilePath -> IO TLS.PrivateKey+readPrivateKey filepath = do+    pk <- rights . parseKey . PEM.pemParseBS <$> readFile filepath+    case pk of+        []    -> error "no valid RSA key found"+        (x:_) -> return x++    where parseKey (Right pems) = map (fmap (TLS.PrivRSA . snd) . KeyRSA.decodePrivate . L.fromChunks . (:[]) . PEM.pemContent)+                                $ filter ((== "RSA PRIVATE KEY") . PEM.pemName) pems+          parseKey (Left err) = error $ "Cannot parse PEM file: " ++ err

@@ -1,5 +1,5 @@ Name:                keter-Version:             0.1.0.1+Version:             0.2.0 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> Homepage:            http://www.yesodweb.com/@@ -33,8 +33,14 @@                      , hinotify                  >= 0.3           && < 0.4                      , system-filepath           >= 0.4           && < 0.5                      , system-fileio             >= 0.3           && < 0.4-  Exposed-Modules:     Keter.Nginx-                       Keter.Process+                     , conduit                   >= 0.5           && < 0.6+                     , network-conduit           >= 0.5           && < 0.6+                     , pem                       >= 0.1           && < 0.2+                     , certificate               >= 1.2           && < 1.3+                     , tls                       >= 0.9.8         && < 0.10+                     , tls-extra                 >= 0.4           && < 0.5+                     , crypto-api                >= 0.10          && < 0.11+  Exposed-Modules:     Keter.Process                        Keter.Postgres                        Keter.TempFolder                        Keter.App@@ -42,6 +48,9 @@                        Keter.Prelude                        Keter.LogFile                        Keter.Logger+                       Keter.Proxy+                       Keter.PortManager+                       Keter.SSL   ghc-options:         -Wall  Executable keter