keter 0.3.1 → 0.3.2
raw patch · 7 files changed
+70/−51 lines, 7 filesdep +http-typesdep +wai
Dependencies added: http-types, wai
Files
- Keter/App.hs +29/−7
- Keter/Main.hs +0/−2
- Keter/PortManager.hs +8/−16
- Keter/Prelude.hs +1/−0
- Keter/Process.hs +1/−1
- Keter/Proxy.hs +28/−24
- keter.cabal +3/−1
Keter/App.hs view
@@ -36,6 +36,7 @@ import System.Posix.IO.ByteString (fdWriteBuf, closeFd, FdOption (CloseOnExec), setFdOption, createFile) import Foreign.Ptr (castPtr) import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.Text.Encoding (encodeUtf8) data Config = Config { configExec :: F.FilePath@@ -45,6 +46,7 @@ , configSsl :: Bool , configExtraHosts :: Set String , configStaticHosts :: Set StaticHost+ , configRedirects :: Set Redirect } instance FromJSON Config where@@ -56,6 +58,7 @@ <*> o .:? "ssl" .!= False <*> o .:? "extra-hosts" .!= Set.empty <*> o .:? "static-hosts" .!= Set.empty+ <*> o .:? "redirects" .!= Set.empty parseJSON _ = fail "Wanted an object" data StaticHost = StaticHost@@ -70,6 +73,18 @@ <*> (F.fromText <$> o .: "root") parseJSON _ = fail "Wanted an object" +data Redirect = Redirect+ { redFrom :: Text+ , redTo :: Text+ }+ deriving (Eq, Ord)++instance FromJSON Redirect where+ parseJSON (Object o) = Redirect+ <$> o .: "from"+ <*> o .: "to"+ parseJSON _ = fail "Wanted an object"+ data Command = Reload | Terminate newtype App = App (Command -> KIO ()) @@ -90,7 +105,11 @@ let rest = do unpackTar dir $ Tar.read $ decompress lbs let configFP = dir F.</> "config" F.</> "keter.yaml"- Just config <- decodeFile $ F.encodeString configFP+ mconfig <- decodeFile $ F.encodeString configFP+ config <-+ case mconfig of+ Just config -> return config+ Nothing -> throwIO InvalidConfigFile return (dir, config { configStaticHosts = Set.fromList $ mapMaybe (fixStaticHost dir)@@ -195,9 +214,10 @@ b <- testApp port if b then do- addEntry portman (configHost config) $ Left port- mapM_ (flip (addEntry portman) $ Left port) $ Set.toList $ configExtraHosts config- mapM_ (\StaticHost{..} -> addEntry portman shHost (Right shRoot)) $ Set.toList $ configStaticHosts config+ addEntry portman (configHost config) $ PEPort port+ mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ configExtraHosts config+ mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ configStaticHosts config+ mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ configRedirects config loop chan dir process port config else do removeFromList@@ -212,6 +232,7 @@ removeEntry portman $ configHost configOld mapM_ (removeEntry portman) $ Set.toList $ configExtraHosts configOld mapM_ (removeEntry portman) $ map shHost $ Set.toList $ configStaticHosts configOld+ mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ configRedirects configOld log $ TerminatingApp appname terminateOld detach logger@@ -230,9 +251,10 @@ b <- testApp port if b then do- addEntry portman (configHost config) $ Left port- mapM_ (flip (addEntry portman) $ Left port) $ Set.toList $ configExtraHosts config- mapM_ (\StaticHost{..} -> addEntry portman shHost (Right shRoot)) $ Set.toList $ configStaticHosts config+ addEntry portman (configHost config) $ PEPort port+ mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ configExtraHosts config+ mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ configStaticHosts config+ mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ configRedirects config when (configHost config /= configHost configOld) $ removeEntry portman $ configHost configOld log $ FinishedReloading appname
Keter/Main.hs view
@@ -87,14 +87,12 @@ _ <- 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
Keter/PortManager.hs view
@@ -8,6 +8,7 @@ Port , Host , PortManager + , PortEntry (..) -- ** Settings , Settings , portRange @@ -17,7 +18,6 @@ , addEntry , removeEntry , lookupPort - , hostList -- * Initialize , start ) where @@ -42,10 +42,9 @@ data Command = GetPort (Either SomeException Port -> KIO ()) | ReleasePort Port - | AddEntry Host (Either Port FilePath) + | AddEntry Host PortEntry | RemoveEntry Host - | LookupPort S.ByteString (Maybe (Either Port FilePath) -> KIO ()) - | HostList ([S.ByteString] -> KIO ()) + | LookupPort S.ByteString (Maybe PortEntry -> KIO ()) -- | An abstract type which can accept commands and sends them to a background -- nginx thread. @@ -109,9 +108,6 @@ 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 @@ -122,7 +118,7 @@ data NState = NState { nsAvail :: [Port] , nsRecycled :: [Port] - , nsEntries :: Map.Map S.ByteString (Either Port FilePath) + , nsEntries :: Map.Map S.ByteString PortEntry } -- | Gets an unassigned port number. @@ -143,21 +139,17 @@ -- 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 -> Either Port FilePath -> KIO () +addEntry :: PortManager -> Host -> PortEntry -> KIO () addEntry (PortManager f) h p = f $ AddEntry h p +data PortEntry = PEPort Port | PEStatic FilePath | PERedirect S.ByteString + -- | 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 (Either Port FilePath)) +lookupPort :: PortManager -> S.ByteString -> KIO (Maybe PortEntry) 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
Keter/Prelude.hs view
@@ -288,6 +288,7 @@ data KeterException = CannotParsePostgres F.FilePath | ExitCodeFailure F.FilePath ExitCode | NoPortsAvailable+ | InvalidConfigFile deriving (P.Show, Typeable) instance E.Exception KeterException
Keter/Process.hs view
@@ -59,7 +59,7 @@ attach logger $ LogPipes pout perr log $ ProcessCreated exec return (Running pid, do- liftIO $ waitForProcess pid `onException` killProcess pid+ _ <- liftIO $ waitForProcess pid `onException` killProcess pid loop (Just now)) next forkKIO $ loop Nothing
Keter/Proxy.hs view
@@ -3,59 +3,63 @@ module Keter.Proxy ( reverseProxy , PortLookup- , HostList , reverseProxySsl , setDir , TLSConfig , TLSConfigNoDir ) where -import Keter.Prelude ((++), FilePath) import Prelude hiding ((++), FilePath) import Data.Conduit import Data.Conduit.Network import Data.ByteString (ByteString)-import Keter.PortManager (Port)+import Keter.PortManager (PortEntry (..))+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import Blaze.ByteString.Builder (fromByteString, toLazyByteString)-import Data.Monoid (mconcat) import Keter.SSL import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw)-import Control.Applicative ((<$>)) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)+import qualified Network.Wai as Wai+import Network.HTTP.Types (status301) -- | Mapping from virtual hostname to port number.-type PortLookup = ByteString -> IO (Maybe (Either Port FilePath))--type HostList = IO [ByteString]+type PortLookup = ByteString -> IO (Maybe PortEntry) -reverseProxy :: ServerSettings IO -> PortLookup -> HostList -> IO ()-reverseProxy settings x = runTCPServer settings . withClient x+reverseProxy :: ServerSettings IO -> PortLookup -> IO ()+reverseProxy settings = runTCPServer settings . withClient -reverseProxySsl :: TLSConfig -> PortLookup -> HostList -> IO ()-reverseProxySsl settings x = runTCPServerTLS settings . withClient x+reverseProxySsl :: TLSConfig -> PortLookup -> IO ()+reverseProxySsl settings = runTCPServerTLS settings . withClient withClient :: PortLookup- -> HostList -> Application IO-withClient portLookup hostList =+withClient portLookup = rawProxyTo getDest where getDest headers = do mport <- maybe (return Nothing) portLookup $ lookup "host" headers case mport of- Nothing -> Left . srcToApp . toResponse <$> hostList- Just (Left port) -> return $ Right $ ProxyDest "127.0.0.1" port- Just (Right root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root+ Nothing -> return $ Left $ srcToApp $ toResponse []+ Just (PEPort port) -> return $ Right $ ProxyDest "127.0.0.1" port+ Just (PEStatic root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root+ Just (PERedirect host) -> return $ Left $ waiToRaw $ redirectApp host +redirectApp :: ByteString -> Wai.Application+redirectApp host req = return $ Wai.responseLBS+ status301+ [("Location", dest)]+ (L.fromChunks [dest])+ where+ dest = S.concat+ [ "http://"+ , host+ , Wai.rawPathInfo req+ , Wai.rawQueryString req+ ]+ srcToApp :: Monad m => Source m ByteString -> Application m srcToApp src appdata = src $$ appSink appdata toResponse :: Monad m => [ByteString] -> Source m ByteString toResponse hosts =- mapM_ yield $ 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>"+ yield "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>The hostname you have provided is not recognized.</p></body></html>"
keter.cabal view
@@ -1,5 +1,5 @@ Name: keter-Version: 0.3.1+Version: 0.3.2 Synopsis: Web application deployment manager, focusing on Haskell web frameworks 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/@@ -40,6 +40,8 @@ , unix-process-conduit >= 0.2 && < 0.3 , unix >= 2.5 && < 2.7 , wai-app-static >= 1.3 && < 1.4+ , wai >= 1.3 && < 1.4+ , http-types Exposed-Modules: Keter.Process Keter.Postgres Keter.TempFolder