@@ -0,0 +1,120 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-- | Middleware for establishing the root of the application.
4+--
5+-- Many application need the ability to create URLs referring back to the
6+-- application itself. For example: generate RSS feeds or sitemaps, giving
7+-- users copy-paste links, or sending emails. In many cases, the approot can be
8+-- determined correctly from the request headers. However, some things can
9+-- prevent this, especially reverse proxies. This module provides multiple ways
10+-- of configuring approot discovery, and functions for applications to get that
11+-- approot.
12+--
13+-- Approots are structured such that they can be prepended to a string such as
14+-- @/foo/bar?baz=bin@. For example, if your application is hosted on
15+-- example.com using HTTPS, the approot would be @https://example.com@. Note
16+-- the lack of a trailing slash.
17+module Network.Wai.Middleware.Approot
18+ ( -- * Middleware
19+ approotMiddleware
20+ -- * Common providers
21+ , envFallback
22+ , envFallbackNamed
23+ , hardcoded
24+ , fromRequest
25+ -- * Functions for applications
26+ , getApproot
27+ ) where
28+
29+import Control.Exception (Exception, throw)
30+import Data.ByteString (ByteString)
31+import qualified Data.ByteString as S
32+import qualified Data.ByteString.Char8 as S8
33+import Data.Maybe (fromMaybe)
34+import Data.Typeable (Typeable)
35+import qualified Data.Vault.Lazy as V
36+import Network.Wai (Request, vault, Middleware, requestHeaderHost)
37+import Network.Wai.Request (appearsSecure)
38+import System.Environment (getEnvironment)
39+import System.IO.Unsafe (unsafePerformIO)
40+
41+approotKey :: V.Key ByteString
42+approotKey = unsafePerformIO V.newKey
43+{-# NOINLINE approotKey #-}
44+
45+-- | The most generic version of the middleware, allowing you to provide a
46+-- function to get the approot for each request. For many use cases, one of the
47+-- helper functions provided by this module will give the necessary
48+-- functionality more conveniently.
49+--
50+-- Since 3.0.7
51+approotMiddleware :: (Request -> IO ByteString) -- ^ get the approot
52+ -> Middleware
53+approotMiddleware getRoot app req respond = do
54+ ar <- getRoot req
55+ let req' = req { vault = V.insert approotKey ar $ vault req }
56+ app req' respond
57+
58+-- | Same as @'envFallbackNamed' "APPROOT"@.
59+--
60+-- The environment variable @APPROOT@ is used by Keter, School of Haskell, and yesod-devel.
61+--
62+-- Since 3.0.7
63+envFallback :: IO Middleware
64+envFallback = envFallbackNamed "APPROOT"
65+
66+-- | Produce a middleware that takes the approot from the given environment
67+-- variable, falling back to the behavior of 'fromRequest' if the variable is
68+-- not set.
69+--
70+-- Since 3.0.7
71+envFallbackNamed :: String -> IO Middleware
72+envFallbackNamed name = do
73+ env <- getEnvironment
74+ case lookup name env of
75+ Just s -> return $ hardcoded $ S8.pack s
76+ Nothing -> return fromRequest
77+
78+-- | Hard-code the given value as the approot.
79+--
80+-- Since 3.0.7
81+hardcoded :: ByteString -> Middleware
82+hardcoded ar = approotMiddleware (const $ return ar)
83+
84+-- | Get the approot by analyzing the request. This is not a full-proof
85+-- approach, but in many common cases will work. Situations that can break this
86+-- are:
87+--
88+-- * Requests which spoof headers and imply the connection is over HTTPS
89+--
90+-- * Reverse proxies that change ports in surprising ways
91+--
92+-- * Invalid Host headers
93+--
94+-- * Reverse proxies which modify the path info
95+--
96+-- Normally trusting headers in this way is insecure, however in the case of
97+-- approot, the worst that can happen is that the client will get an incorrect
98+-- URL. If you are relying on the approot for some security-sensitive purpose,
99+-- it is highly recommended to use @hardcoded@, which cannot be spoofed.
100+--
101+-- Since 3.0.7
102+fromRequest :: Middleware
103+fromRequest = approotMiddleware (return . extract)
104+
105+extract :: Request -> ByteString
106+extract req =
107+ (if appearsSecure req then "https://" else "http://") `S.append`
108+ (fromMaybe "localhost" (requestHeaderHost req))
109+
110+data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup
111+ deriving (Show, Typeable)
112+instance Exception ApprootMiddlewareNotSetup
113+
114+-- | Get the approot set by the middleware. If the middleware is not in use,
115+-- then this function will return an exception.
116+--
117+-- Since 3.0.7
118+getApproot :: Request -> ByteString
119+getApproot req = fromMaybe (throw ApprootMiddlewareNotSetup)
120+ $ V.lookup approotKey $ vault req