diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -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 diff --git a/Keter/HostManager.hs b/Keter/HostManager.hs --- a/Keter/HostManager.hs +++ b/Keter/HostManager.hs @@ -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 diff --git a/Keter/LabelMap.hs b/Keter/LabelMap.hs --- a/Keter/LabelMap.hs +++ b/Keter/LabelMap.hs @@ -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 diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -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 ()) diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -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 diff --git a/Keter/Types/Common.hs b/Keter/Types/Common.hs --- a/Keter/Types/Common.hs +++ b/Keter/Types/Common.hs @@ -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 diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -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 ] diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: . 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 .