diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,10 @@
 # Changelog
 
+## 0.6.1.0
+
+- Add `EarlyHost`, a better `Servant.API.Host` that keeps each
+  virtual host to its own requests.
+
 ## 0.6.0.2
 
 - Relax upper bounds on `containers` and `time`.
diff --git a/om-http.cabal b/om-http.cabal
--- a/om-http.cabal
+++ b/om-http.cabal
@@ -1,6 +1,6 @@
 cabal-version:       3.0
 name:                om-http
-version:             0.6.0.3
+version:             0.6.1.0
 synopsis:            Http utilities.
 description:         Random HTTP utilities.
 homepage:            https://github.com/owensmurray/om-http
@@ -34,6 +34,7 @@
     , om-show            >= 0.1.2.10  && < 0.2
     , safe-exceptions    >= 0.1.7.4   && < 0.2
     , servant            >= 0.20.1    && < 0.21
+    , servant-server     >= 0.20.1    && < 0.21
     , template-haskell   >= 2.22.0.0  && < 2.25
     , text               >= 2.1.1     && < 2.2
     , time               >= 1.9.2     && < 1.16
@@ -52,7 +53,7 @@
 
 library
   import: warnings, dependencies
-  exposed-modules:     
+  exposed-modules:
     OM.HTTP
   hs-source-dirs: src
   default-language: Haskell2010
diff --git a/src/OM/HTTP.hs b/src/OM/HTTP.hs
--- a/src/OM/HTTP.hs
+++ b/src/OM/HTTP.hs
@@ -1,6 +1,18 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {- | Miscellaneous HTTP Utilities. -}
 module OM.HTTP (
@@ -17,6 +29,7 @@
   defaultIndex,
   BearerToken(..),
   emptyApp,
+  EarlyHost,
 ) where
 
 
@@ -37,6 +50,7 @@
 import Data.ByteString.Base64 (encodeBase64)
 import Data.List ((\\))
 import Data.Maybe (catMaybes)
+import Data.Proxy (Proxy(Proxy))
 import Data.Set (Set, member)
 import Data.String (IsString(fromString))
 import Data.Text (Text)
@@ -45,6 +59,7 @@
 import Data.UUID (UUID)
 import Data.UUID.V1 (nextUUID)
 import Data.Version (Version, showVersion)
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import Language.Haskell.TH (Code(examineCode), Q, TExp, runIO)
 import Language.Haskell.TH.Syntax (addDependentFile)
 import Network.HTTP.Types
@@ -61,7 +76,7 @@
 import Network.Wai
   ( Request
     ( isSecure, pathInfo, rawPathInfo, rawQueryString, remoteHost
-    , requestHeaders, requestMethod
+    , requestHeaderHost, requestHeaders, requestMethod
     )
   , Application, Middleware, Response, ResponseReceived, mapResponseHeaders
   , responseHeaders, responseLBS, responseRaw, responseStatus
@@ -78,7 +93,17 @@
   , (++), (.), (<$>), (=<<), FilePath, IO, Int, String, concat, drop, filter
   , fst, id, mapM_, otherwise, putStrLn, seq, zip
   )
-import Servant.API (ToHttpApiData(toUrlPiece))
+import Servant.API (ToHttpApiData(toUrlPiece), type (:>))
+import Servant.Server
+  ( ErrorFormatters(notFoundErrorFormatter), HasContextEntry(getContextEntry)
+  , HasServer(ServerT, hoistServerWithContext, route), ServerError(errBody)
+  , Context, NotFoundErrorFormatter, Server, err400
+  )
+import Servant.Server.Internal
+  ( RouteResult(Fail, FailFatal), Router'(RawRouter), Delayed
+  , MkContextWithErrorFormatter, Router, mkContextWithErrorFormatter
+  , runRouterEnv
+  )
 import System.Directory (getDirectoryContents)
 import System.FilePath.Posix ((</>), combine)
 import System.Posix.Files (getFileStatus, isDirectory, isRegularFile)
@@ -519,5 +544,100 @@
   case decodeUtf8' bytes of
     Left _err -> "<invalid utf8:" <> extractBase64 (encodeBase64 bytes) <> ">"
     Right val -> val
+
+
+{- | A better 'Servant.API.Host'.
+
+With 'Servant.API.Host', authentication runs before the host
+check, so an earlier app can reject a request that belongs to a
+later host. 'EarlyHost' keeps each virtual host to its own
+requests, and a request for another host stays available to that
+host.
+-}
+data EarlyHost (host :: Symbol)
+instance
+  ( KnownSymbol host
+  , HasServer api context
+  , HasContextEntry
+      (MkContextWithErrorFormatter context)
+      ErrorFormatters
+  )
+  => HasServer (EarlyHost host :> api) context
+  where
+  type ServerT (EarlyHost host :> api) m =
+    ServerT api m
+
+  hoistServerWithContext _ contextProxy nat =
+    hoistServerWithContext (Proxy @api) contextProxy nat
+
+  route
+    :: forall env
+     . Proxy (EarlyHost host :> api)
+    -> Context context
+    -> Delayed env (Server (EarlyHost host :> api))
+    -> Router env
+  route _ context delayed =
+    let
+      inner :: Router env
+      inner =
+        route (Proxy @api) context delayed
+
+      notFound :: NotFoundErrorFormatter
+      notFound =
+        notFoundErrorFormatter
+          (getContextEntry (mkContextWithErrorFormatter context))
+    in
+      RawRouter (dispatchHost (Proxy @host) notFound inner)
+    where
+      {- | Compare the Host header to the combinator's hostname.
+
+      The comparison is the same exact 'String' match as
+      'Servant.API.Host', including any port. A mismatch is 'Fail', so
+      the next virtual host can still run.
+      -}
+      dispatchHost
+        :: Proxy host
+        -> NotFoundErrorFormatter
+        -> Router env
+        -> env
+        -> Request
+        -> (RouteResult Response -> IO ResponseReceived)
+        -> IO ResponseReceived
+      dispatchHost
+          proxy
+          formatNotFound
+          router
+          env
+          request
+          respond
+        =
+          case requestHeaderHost request of
+            Just hostHeader
+              | BS8.unpack hostHeader == symbolVal proxy ->
+                  runRouterEnv
+                    formatNotFound
+                    router
+                    env
+                    request
+                    (respond . promoteHost)
+            _ ->
+              respond (Fail invalidHost)
+          where
+            {- | Keep a miss on the matched host from falling through.
+
+            'Fail' from the inner router becomes 'FailFatal' with the same
+            error. 'FailFatal' and 'Route' are unchanged.
+            -}
+            promoteHost :: RouteResult Response -> RouteResult Response
+            promoteHost (Fail err) =
+              FailFatal err
+            promoteHost result =
+              result
+
+            invalidHost :: ServerError
+            invalidHost =
+              err400
+                { errBody = "Invalid host"
+                }