@@ -0,0 +1,123 @@
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+ , getApprootMay
28+ ) where
29+
30+import Control.Exception (Exception, throw)
31+import Data.ByteString (ByteString)
32+import qualified Data.ByteString as S
33+import qualified Data.ByteString.Char8 as S8
34+import Data.Maybe (fromMaybe)
35+import Data.Typeable (Typeable)
36+import qualified Data.Vault.Lazy as V
37+import Network.Wai (Request, vault, Middleware, requestHeaderHost)
38+import Network.Wai.Request (appearsSecure, guessApproot)
39+import System.Environment (getEnvironment)
40+import System.IO.Unsafe (unsafePerformIO)
41+
42+approotKey :: V.Key ByteString
43+approotKey = unsafePerformIO V.newKey
44+{-# NOINLINE approotKey #-}
45+
46+-- | The most generic version of the middleware, allowing you to provide a
47+-- function to get the approot for each request. For many use cases, one of the
48+-- helper functions provided by this module will give the necessary
49+-- functionality more conveniently.
50+--
51+-- Since 3.0.7
52+approotMiddleware :: (Request -> IO ByteString) -- ^ get the approot
53+ -> Middleware
54+approotMiddleware getRoot app req respond = do
55+ ar <- getRoot req
56+ let req' = req { vault = V.insert approotKey ar $ vault req }
57+ app req' respond
58+
59+-- | Same as @'envFallbackNamed' "APPROOT"@.
60+--
61+-- The environment variable @APPROOT@ is used by Keter, School of Haskell, and yesod-devel.
62+--
63+-- Since 3.0.7
64+envFallback :: IO Middleware
65+envFallback = envFallbackNamed "APPROOT"
66+
67+-- | Produce a middleware that takes the approot from the given environment
68+-- variable, falling back to the behavior of 'fromRequest' if the variable is
69+-- not set.
70+--
71+-- Since 3.0.7
72+envFallbackNamed :: String -> IO Middleware
73+envFallbackNamed name = do
74+ env <- getEnvironment
75+ case lookup name env of
76+ Just s -> return $ hardcoded $ S8.pack s
77+ Nothing -> return fromRequest
78+
79+-- | Hard-code the given value as the approot.
80+--
81+-- Since 3.0.7
82+hardcoded :: ByteString -> Middleware
83+hardcoded ar = approotMiddleware (const $ return ar)
84+
85+-- | Get the approot by analyzing the request. This is not a full-proof
86+-- approach, but in many common cases will work. Situations that can break this
87+-- are:
88+--
89+-- * Requests which spoof headers and imply the connection is over HTTPS
90+--
91+-- * Reverse proxies that change ports in surprising ways
92+--
93+-- * Invalid Host headers
94+--
95+-- * Reverse proxies which modify the path info
96+--
97+-- Normally trusting headers in this way is insecure, however in the case of
98+-- approot, the worst that can happen is that the client will get an incorrect
99+-- URL. If you are relying on the approot for some security-sensitive purpose,
100+-- it is highly recommended to use @hardcoded@, which cannot be spoofed.
101+--
102+-- Since 3.0.7
103+fromRequest :: Middleware
104+fromRequest = approotMiddleware (return . guessApproot)
105+
106+data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup
107+ deriving (Show, Typeable)
108+instance Exception ApprootMiddlewareNotSetup
109+
110+-- | Get the approot set by the middleware. If the middleware is not in use,
111+-- then this function will return an exception. For a total version of the
112+-- function, see 'getApprootMay'.
113+--
114+-- Since 3.0.7
115+getApproot :: Request -> ByteString
116+getApproot = fromMaybe (throw ApprootMiddlewareNotSetup) . getApprootMay
117+
118+-- | A total version of 'getApproot', which returns 'Nothing' if the middleware
119+-- is not in use.
120+--
121+-- Since 3.0.7
122+getApprootMay :: Request -> Maybe ByteString
123+getApprootMay req = V.lookup approotKey $ vault req