@@ -0,0 +1,33 @@
1+module Network.Wai.Middleware.ForceDomain where
2+
3+import Data.ByteString (ByteString)
4+import Data.Monoid ((<>), mempty)
5+import Network.HTTP.Types (hLocation, methodGet, status301, status307)
6+import Prelude
7+
8+import Network.Wai
9+import Network.Wai.Request
10+
11+-- | Force a domain by redirecting.
12+-- The `checkDomain` function takes the current domain and checks whether it is correct.
13+-- It should return `Nothing` if the domain is correct, or `Just "domain.com"` if it is incorrect.
14+forceDomain :: (ByteString -> Maybe ByteString) -> Middleware
15+forceDomain checkDomain app req sendResponse =
16+ case requestHeaderHost req >>= checkDomain of
17+ Nothing ->
18+ app req sendResponse
19+ Just domain ->
20+ sendResponse $ redirectResponse domain
21+
22+ where
23+ -- From: Network.Wai.Middleware.ForceSSL
24+ redirectResponse domain =
25+ responseBuilder status [(hLocation, location domain)] mempty
26+
27+ location h =
28+ let p = if appearsSecure req then "https://" else "http://" in
29+ p <> h <> rawPathInfo req <> rawQueryString req
30+
31+ status
32+ | requestMethod req == methodGet = status301
33+ | otherwise = status307