keter 1.3.3 → 1.3.4
raw patch · 8 files changed
+109/−63 lines, 8 files
Files
- Keter/App.hs +18/−4
- Keter/HostManager.hs +7/−6
- Keter/LabelMap.hs +39/−25
- Keter/Main.hs +2/−1
- Keter/Proxy.hs +4/−2
- Keter/Types/Common.hs +9/−8
- Keter/Types/V10.hs +27/−16
- keter.cabal +3/−1
Keter/App.hs view
@@ -19,6 +19,7 @@ import Control.Exception (bracketOnError, throwIO) import Control.Exception (IOException, try) import Control.Monad (void, when)+import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.LogFile as LogFile import Data.Conduit.LogFile (RotatingLog) import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,@@ -76,7 +77,14 @@ unpackBundle AppStartConfig {..} bundle aid = do ascLog $ UnpackingBundle bundle unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do- let configFP = dir F.</> "config" F.</> "keter.yaml"+ -- Get the FilePath for the keter yaml configuration. Tests for+ -- keter.yml and defaults to keter.yaml.+ configFP <- do+ let yml = dir F.</> "config" F.</> "keter.yml"+ exists <- isFile yml+ return $ if exists then yml+ else dir F.</> "config" F.</> "keter.yaml"+ mconfig <- decodeFileRelative configFP config <- case mconfig of@@ -156,7 +164,7 @@ loop (StanzaReverseProxy rev:stanzas) wacs backs actions0 = loop stanzas wacs backs actions where- actions = Map.insert (reversingHost rev) (PAReverseProxy rev) actions0+ actions = Map.insert (CI.mk $ reversingHost rev) (PAReverseProxy rev) actions0 loop (StanzaBackground back:stanzas) wacs backs actions = loop stanzas wacs (back:backs) actions @@ -259,8 +267,14 @@ -> IO a launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins- let env = ("PORT", pack $ show waconfigPort)- : ("APPROOT", (if waconfigSsl then "https://" else "http://") <> waconfigApprootHost)+ let httpPort = kconfigExternalHttpPort ascKeterConfig+ httpsPort = kconfigExternalHttpsPort ascKeterConfig+ (scheme, extport) =+ if waconfigSsl+ then ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)+ else ("http://", if httpPort == 80 then "" else ':' : show httpPort)+ env = ("PORT", pack $ show waconfigPort)+ : ("APPROOT", scheme <> CI.original waconfigApprootHost <> pack extport) : Map.toList waconfigEnvironment ++ otherEnv exec <- canonicalizePath waconfigExec bracketOnError
Keter/HostManager.hs view
@@ -20,6 +20,7 @@ import Control.Applicative import Control.Exception (assert, throwIO) +import qualified Data.CaseInsensitive as CI import Data.Either (partitionEithers) import Data.IORef import qualified Data.Map as Map @@ -81,13 +82,13 @@ Just (HVActive aid' _) | aid == aid' -> Right Set.empty | otherwise -> Left (host, aid') - where hostBS = encodeUtf8 host + where hostBS = encodeUtf8 $ CI.original host hvres = HVReserved aid reserve host es = assert (not $ LabelMap.labelAssigned hostBS es) $ LabelMap.insert hostBS hvres es where - hostBS = encodeUtf8 host + hostBS = encodeUtf8 $ CI.original host -- | Forget previously made reservations. forgetReservations :: (LogMessage -> IO ()) @@ -103,7 +104,7 @@ forget host state = assert isReservedByMe $ LabelMap.delete hostBS state where - hostBS = encodeUtf8 host + hostBS = encodeUtf8 $ CI.original host isReservedByMe = LabelMap.labelAssigned hostBS state && case LabelMap.lookup hostBS state of Nothing -> False @@ -128,7 +129,7 @@ activate host action state = assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action) state where - hostBS = encodeUtf8 host + hostBS = encodeUtf8 $ CI.original host isOwnedByMe = LabelMap.labelAssigned hostBS state && case LabelMap.lookup hostBS state of Nothing -> False @@ -152,7 +153,7 @@ deactivate host state = assert isOwnedByMe $ LabelMap.delete hostBS state where - hostBS = encodeUtf8 host + hostBS = encodeUtf8 $ CI.original host isOwnedByMe = LabelMap.labelAssigned hostBS state && case LabelMap.lookup hostBS state of Nothing -> False @@ -175,7 +176,7 @@ -> IO (Maybe ProxyAction) lookupAction (HostManager mstate) host = do state <- readIORef mstate - return $ case LabelMap.lookup host state of + return $ case LabelMap.lookup (CI.original host) state of Nothing -> Nothing Just (HVActive _ action) -> Just action Just (HVReserved _) -> Nothing
Keter/LabelMap.hs view
@@ -20,8 +20,10 @@ import Data.Map (Map) import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString)+import qualified Data.CaseInsensitive as CI+import Data.CaseInsensitive (CI) -type LabelTree a = Map ByteString (LabelEntry a)+type LabelTree a = Map (CI ByteString) (LabelEntry a) -- | A data structure for storing a hierarchical set of domain labels -- from TLD down, supporting wildcards.@@ -112,40 +114,48 @@ insertTree [] _ _ = error "Cannot assign empty label in hostname." insertTree ["*"] e EmptyLabelMap = Wildcard (Assigned e EmptyLabelMap)-insertTree [l] e EmptyLabelMap = Static (Map.insert l (Assigned e EmptyLabelMap) Map.empty)+insertTree [l] e EmptyLabelMap = Static (Map.insert (CI.mk l) (Assigned e EmptyLabelMap) Map.empty) insertTree ["*"] e (Static t) = WildcardExcept (Assigned e EmptyLabelMap) t-insertTree [l] e (Static t) =+insertTree [l'] e (Static t) = case Map.lookup l t of Nothing -> Static (Map.insert l (Assigned e EmptyLabelMap) t) Just le -> Static (Map.insert l (Assigned e (labelEntryMap le)) t)+ where+ l = CI.mk l' insertTree ["*"] e (Wildcard w) = Wildcard (Assigned e (labelEntryMap w))-insertTree [l] e (Wildcard w) = WildcardExcept w (Map.insert l (Assigned e EmptyLabelMap) Map.empty)+insertTree [l] e (Wildcard w) = WildcardExcept w (Map.insert (CI.mk l) (Assigned e EmptyLabelMap) Map.empty) insertTree ["*"] e (WildcardExcept w t) = WildcardExcept (Assigned e (labelEntryMap w)) t-insertTree [l] e (WildcardExcept w t) =+insertTree [l'] e (WildcardExcept w t) = case Map.lookup l t of Nothing -> WildcardExcept w (Map.insert l (Assigned e EmptyLabelMap) t) Just le -> WildcardExcept w (Map.insert l (Assigned e (labelEntryMap le)) t)+ where+ l = CI.mk l' insertTree ("*":ls) e EmptyLabelMap = Wildcard (Unassigned (insertTree ls e EmptyLabelMap))-insertTree (l:ls) e EmptyLabelMap = Static (Map.insert l (Unassigned $ insertTree ls e EmptyLabelMap) Map.empty)+insertTree (l:ls) e EmptyLabelMap = Static (Map.insert (CI.mk l) (Unassigned $ insertTree ls e EmptyLabelMap) Map.empty) insertTree ("*":ls) e (Static t) = WildcardExcept (Unassigned (insertTree ls e EmptyLabelMap)) t-insertTree (l:ls) e (Static t) =+insertTree (l':ls) e (Static t) = case Map.lookup l t of Nothing -> Static (Map.insert l (Unassigned (insertTree ls e EmptyLabelMap)) t) Just le -> Static (Map.insert l (lemap (insertTree ls e) le) t)+ where+ l = CI.mk l' insertTree ("*":ls) e (Wildcard w) = Wildcard (lemap (insertTree ls e) w)-insertTree (l:ls) e (Wildcard w) = WildcardExcept w (Map.insert l (Assigned e (insertTree ls e EmptyLabelMap)) Map.empty)+insertTree (l:ls) e (Wildcard w) = WildcardExcept w (Map.insert (CI.mk l) (Assigned e (insertTree ls e EmptyLabelMap)) Map.empty) insertTree ("*":ls) e (WildcardExcept w t) = WildcardExcept (lemap (insertTree ls e) w) t insertTree (l:ls) e (WildcardExcept w t) =- case Map.lookup l t of- Nothing -> WildcardExcept w (Map.insert l (Unassigned (insertTree ls e EmptyLabelMap)) t)- Just le -> WildcardExcept w (Map.insert l (lemap (insertTree ls e) le) t)+ case Map.lookup l' t of+ Nothing -> WildcardExcept w (Map.insert l' (Unassigned (insertTree ls e EmptyLabelMap)) t)+ Just le -> WildcardExcept w (Map.insert l' (lemap (insertTree ls e) le) t)+ where+ l' = CI.mk l cleanup :: LabelMap a -> LabelMap a cleanup EmptyLabelMap = EmptyLabelMap@@ -185,28 +195,32 @@ deleteTree _ EmptyLabelMap = EmptyLabelMap deleteTree ["*"] (Static t) = Static t-deleteTree [l] (Static t) = cleanup $ Static (Map.delete l t)+deleteTree [l] (Static t) = cleanup $ Static (Map.delete (CI.mk l) t) deleteTree ["*"] (Wildcard w) = cleanup $ Wildcard (Unassigned (labelEntryMap w)) deleteTree [_] (Wildcard w) = Wildcard w deleteTree ["*"] (WildcardExcept w t) = cleanup $ WildcardExcept (Unassigned (labelEntryMap w)) t-deleteTree [l] (WildcardExcept w t) = cleanup $ WildcardExcept w (Map.delete l t)+deleteTree [l] (WildcardExcept w t) = cleanup $ WildcardExcept w (Map.delete (CI.mk l) t) deleteTree ("*":_) (Static t) = Static t deleteTree (l:ls) (Static t) = cleanup $- case Map.lookup l t of+ case Map.lookup l' t of Nothing -> Static t- Just le -> Static (Map.insert l (lemap (deleteTree ls) le) t)+ Just le -> Static (Map.insert l' (lemap (deleteTree ls) le) t)+ where+ l' = CI.mk l deleteTree ("*":ls) (Wildcard w) = cleanup $ Wildcard (lemap (deleteTree ls) w) deleteTree (_:_) (Wildcard w) = Wildcard w deleteTree ("*":ls) (WildcardExcept w t) = cleanup $ WildcardExcept (lemap (deleteTree ls) w) t deleteTree (l:ls) (WildcardExcept w t) = cleanup $- case Map.lookup l t of+ case Map.lookup l' t of Nothing -> WildcardExcept w t- Just le -> WildcardExcept w (Map.insert l (lemap (deleteTree ls) le) t)+ Just le -> WildcardExcept w (Map.insert l' (lemap (deleteTree ls) le) t)+ where+ l' = CI.mk l lookup :: ByteString -> LabelMap a -> Maybe a lookup h m = lookupTree (hostToLabels h) m@@ -223,20 +237,20 @@ lookupTree _ EmptyLabelMap = Nothing -lookupTree [l] (Static t) = Map.lookup l t >>= getPortEntry+lookupTree [l] (Static t) = Map.lookup (CI.mk l) t >>= getPortEntry --lookupTree (_:_) (Wildcard w) = getPortEntry $ w lookupTree [l] (WildcardExcept w t) =- case Map.lookup l t >>= getPortEntry of+ case Map.lookup (CI.mk l) t >>= getPortEntry of Just e -> Just e Nothing -> getPortEntry w lookupTree (l:ls) (Static t) =- case Map.lookup l t of+ case Map.lookup (CI.mk l) t of Just le -> lookupTree ls $ labelEntryMap le Nothing -> Nothing lookupTree (_:ls) (Wildcard w) = lookupTree ls $ labelEntryMap w lookupTree (l:ls) (WildcardExcept w t) =- case Map.lookup l t of+ case Map.lookup (CI.mk l) t of Just le -> case lookupTree ls $ labelEntryMap le of Just e -> Just e@@ -270,17 +284,17 @@ memberTree [] _ = False memberTree ["*"] (Static _) = False-memberTree [l] (Static t) = isJust $ Map.lookup l t >>= getPortEntry+memberTree [l] (Static t) = isJust $ Map.lookup (CI.mk l) t >>= getPortEntry memberTree ["*"] (Wildcard _) = True memberTree [_] (Wildcard _) = False memberTree ["*"] (WildcardExcept w _) = isJust $ getPortEntry w-memberTree [l] (WildcardExcept _ t) = isJust $ Map.lookup l t >>= getPortEntry+memberTree [l] (WildcardExcept _ t) = isJust $ Map.lookup (CI.mk l) t >>= getPortEntry memberTree ("*":_) (Static _) = False memberTree (l:ls) (Static t) =- case Map.lookup l t of+ case Map.lookup (CI.mk l) t of Just le -> memberTree ls $ labelEntryMap le Nothing -> False @@ -289,7 +303,7 @@ memberTree ("*":ls) (WildcardExcept w _) = memberTree ls $ labelEntryMap w memberTree (l:ls) (WildcardExcept _ t) =- case Map.lookup l t of+ case Map.lookup (CI.mk l) t of Just le -> memberTree ls $ labelEntryMap le Nothing -> False
Keter/Main.hs view
@@ -11,6 +11,7 @@ import qualified Codec.Archive.TempTarball as TempFolder import Control.Concurrent.Async (waitAny, withAsync) import Control.Monad (unless)+import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.LogFile as LogFile import Data.Monoid (mempty) import qualified Data.Vector as V@@ -179,7 +180,7 @@ runAndBlock kconfigListeners $ Proxy.reverseProxy kconfigIpFromHeader manager- (HostMan.lookupAction hostman)+ (HostMan.lookupAction hostman . CI.mk) runAndBlock :: NonEmptyVector a -> (a -> IO ())
Keter/Proxy.hs view
@@ -11,6 +11,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.CaseInsensitive as CI import Data.Default import Data.Monoid (mappend) import Data.Text.Encoding (encodeUtf8)@@ -92,7 +93,8 @@ processHost :: Wai.Request -> S.ByteString -> IO WaiProxyResponse processHost req host = do- mport <- liftIO $ portLookup host+ -- Take the host name up until the port number.+ mport <- liftIO $ portLookup $ S.takeWhile (/= 58) host case mport of Nothing -> return $ WPRResponse $ unknownHostResponse host Just action -> performAction req action@@ -144,7 +146,7 @@ mkUrl (RDUrl url) = encodeUtf8 url mkUrl (RDPrefix isSecure host mport) = S.concat [ if isSecure then "https://" else "http://"- , encodeUtf8 host+ , encodeUtf8 $ CI.original host , case mport of Nothing -> "" Just port
Keter/Types/Common.hs view
@@ -15,6 +15,7 @@ import Control.Exception (Exception, SomeException) import Data.Aeson (Object) import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, original) import Data.Map (Map) import Data.Set (Set) import qualified Data.Set as Set@@ -49,9 +50,9 @@ type Port = Int -- | A virtual host we want to serve content from.-type Host = Text+type Host = CI Text -type HostBS = ByteString+type HostBS = CI ByteString getAppname :: FilePath -> Text getAppname = either id id . toText . basename@@ -117,17 +118,17 @@ , show e ] show SanityChecksPassed = "Sanity checks passed"- show (ReservingHosts app hosts) = "Reserving hosts for app " ++ show app ++ ": " ++ unwords (map unpack $ Set.toList hosts)- show (ForgetingReservations app hosts) = "Forgeting host reservations for app " ++ show app ++ ": " ++ unwords (map unpack $ Set.toList hosts)- show (ActivatingApp app hosts) = "Activating app " ++ show app ++ " with hosts: " ++ unwords (map unpack $ Set.toList hosts)- show (DeactivatingApp app hosts) = "Deactivating app " ++ show app ++ " with hosts: " ++ unwords (map unpack $ Set.toList hosts)+ show (ReservingHosts app hosts) = "Reserving hosts for app " ++ show app ++ ": " ++ unwords (map (unpack . original) $ Set.toList hosts)+ show (ForgetingReservations app hosts) = "Forgeting host reservations for app " ++ show app ++ ": " ++ unwords (map (unpack . original) $ Set.toList hosts)+ show (ActivatingApp app hosts) = "Activating app " ++ show app ++ " with hosts: " ++ unwords (map (unpack . original) $ Set.toList hosts)+ show (DeactivatingApp app hosts) = "Deactivating app " ++ show app ++ " with hosts: " ++ unwords (map (unpack . original) $ Set.toList hosts) show (ReactivatingApp app old new) = concat [ "Reactivating app " , show app , ". Old hosts: "- , unwords (map unpack $ Set.toList old)+ , unwords (map (unpack . original) $ Set.toList old) , ". New hosts: "- , unwords (map unpack $ Set.toList new)+ , unwords (map (unpack . original) $ Set.toList new) , "." ] show (WatchedFile action fp) = concat
Keter/Types/V10.hs view
@@ -8,6 +8,7 @@ import Prelude hiding (FilePath) import System.Posix.Types (EpochTime) import Data.Aeson (Object, ToJSON (..))+import qualified Data.CaseInsensitive as CI import Keter.Types.Common import qualified Keter.Types.V04 as V04 import Data.Yaml.FilePath@@ -88,6 +89,10 @@ , kconfigSetuid :: Maybe Text , kconfigBuiltinStanzas :: !(V.Vector (Stanza ())) , kconfigIpFromHeader :: Bool+ , kconfigExternalHttpPort :: !Int+ -- ^ External HTTP port when generating APPROOTs.+ , kconfigExternalHttpsPort :: !Int+ -- ^ External HTTPS port when generating APPROOTs. } instance ToCurrent KeterConfig where@@ -99,6 +104,8 @@ , kconfigSetuid = setuid , kconfigBuiltinStanzas = V.fromList $ map StanzaReverseProxy $ Set.toList rproxy , kconfigIpFromHeader = ipFromHeader+ , kconfigExternalHttpPort = 80+ , kconfigExternalHttpsPort = 443 } where getSSL Nothing = V.empty@@ -116,6 +123,8 @@ , kconfigSetuid = Nothing , kconfigBuiltinStanzas = V.empty , kconfigIpFromHeader = False+ , kconfigExternalHttpPort = 80+ , kconfigExternalHttpsPort = 443 } instance ParseYamlFile KeterConfig where@@ -132,6 +141,8 @@ <*> o .:? "setuid" <*> return V.empty <*> o .:? "ip-from-header" .!= False+ <*> o .:? "external-http-port" .!= 80+ <*> o .:? "external-https-port" .!= 443 data Stanza port = StanzaStaticFiles !StaticFilesConfig@@ -191,20 +202,20 @@ type Previous StaticFilesConfig = V04.StaticHost toCurrent (V04.StaticHost host root) = StaticFilesConfig { sfconfigRoot = root- , sfconfigHosts = Set.singleton host+ , sfconfigHosts = Set.singleton $ CI.mk host , sfconfigListings = True } instance ParseYamlFile StaticFilesConfig where parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig <$> lookupBase basedir o "root"- <*> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))+ <*> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))) <*> o .:? "directory-listing" .!= False instance ToJSON StaticFilesConfig where toJSON StaticFilesConfig {..} = object [ "root" .= F.encodeString sfconfigRoot- , "hosts" .= sfconfigHosts+ , "hosts" .= Set.map CI.original sfconfigHosts , "directory-listing" .= sfconfigListings ] @@ -218,21 +229,21 @@ instance ToCurrent RedirectConfig where type Previous RedirectConfig = V04.Redirect toCurrent (V04.Redirect from to) = RedirectConfig- { redirconfigHosts = Set.singleton from+ { redirconfigHosts = Set.singleton $ CI.mk from , redirconfigStatus = 301 , redirconfigActions = V.singleton $ RedirectAction SPAny- $ RDPrefix False to Nothing+ $ RDPrefix False (CI.mk to) Nothing } instance ParseYamlFile RedirectConfig where parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig- <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))+ <$> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))) <*> o .:? "status" .!= 303 <*> o .: "actions" instance ToJSON RedirectConfig where toJSON RedirectConfig {..} = object- [ "hosts" .= redirconfigHosts+ [ "hosts" .= Set.map CI.original redirconfigHosts , "status" .= redirconfigStatus , "actions" .= redirconfigActions ]@@ -269,14 +280,14 @@ url o = RDUrl <$> o .: "url" prefix o = RDPrefix <$> o .:? "secure" .!= False- <*> o .: "host"+ <*> (CI.mk <$> o .: "host") <*> o .:? "port" instance ToJSON RedirectDest where toJSON (RDUrl url) = object ["url" .= url] toJSON (RDPrefix secure host mport) = object $ catMaybes [ Just $ "secure" .= secure- , Just $ "host" .= host+ , Just $ "host" .= CI.original host , case mport of Nothing -> Nothing Just port -> Just $ "port" .= port@@ -288,8 +299,8 @@ { waconfigExec :: !F.FilePath , waconfigArgs :: !(Vector Text) , waconfigEnvironment :: !(Map Text Text)- , waconfigApprootHost :: !Text -- ^ primary host, used for approot- , waconfigHosts :: !(Set Text) -- ^ all hosts, not including the approot host+ , waconfigApprootHost :: !Host -- ^ primary host, used for approot+ , waconfigHosts :: !(Set Host) -- ^ all hosts, not including the approot host , waconfigSsl :: !Bool , waconfigPort :: !port }@@ -301,8 +312,8 @@ { waconfigExec = exec , waconfigArgs = V.fromList args , waconfigEnvironment = Map.empty- , waconfigApprootHost = host- , waconfigHosts = hosts+ , waconfigApprootHost = CI.mk host+ , waconfigHosts = Set.map CI.mk hosts , waconfigSsl = ssl , waconfigPort = () }@@ -312,12 +323,12 @@ (ahost, hosts) <- (do h <- o .: "host"- return (h, Set.empty)) <|>+ return (CI.mk h, Set.empty)) <|> (do hs <- o .: "hosts" case hs of [] -> fail "Must provide at least one host"- h:hs' -> return (h, Set.fromList hs'))+ h:hs' -> return (CI.mk h, Set.fromList $ map CI.mk hs')) WebAppConfig <$> lookupBase basedir o "exec" <*> o .:? "args" .!= V.empty@@ -332,7 +343,7 @@ [ "exec" .= F.encodeString waconfigExec , "args" .= waconfigArgs , "env" .= waconfigEnvironment- , "hosts" .= (waconfigApprootHost : Set.toList waconfigHosts)+ , "hosts" .= map CI.original (waconfigApprootHost : Set.toList waconfigHosts) , "ssl" .= waconfigSsl ]
keter.cabal view
@@ -1,10 +1,12 @@ Name: keter-Version: 1.3.3+Version: 1.3.4 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> . Release history:+ .+ [1.3.4] Support for overriding external ports. Support for keter.yml in addition to keter.yaml. Case insensitive hostname lookups. . [1.3.3] Set the X-Forwarded-Proto header .