7 module Network.HTTP.Lucu.Postprocess
9 , completeUnconditionalHeaders
12 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
13 import Control.Applicative
14 import Control.Concurrent.STM
16 import Control.Monad.Unicode
17 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
18 import qualified Data.Ascii as A
19 import Data.Monoid.Unicode
21 import qualified Data.Time.HTTP as HTTP
22 import GHC.Conc (unsafeIOToSTM)
23 import Network.HTTP.Lucu.Abortion
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.DefaultPage
26 import Network.HTTP.Lucu.Headers
27 import Network.HTTP.Lucu.HttpVersion
28 import Network.HTTP.Lucu.Interaction
29 import Network.HTTP.Lucu.Request
30 import Network.HTTP.Lucu.Response
31 import Prelude.Unicode
33 postprocess ∷ Interaction → STM ()
34 postprocess itr@(Interaction {..})
35 = do abortOnCertainConditions itr
36 writeDefaultPageIfNeeded itr
39 Just req → postprocessWithRequest itr req
42 updateResIO itr $ completeUnconditionalHeaders itrConfig
44 abortOnCertainConditions ∷ Interaction → STM ()
45 abortOnCertainConditions (Interaction {..})
46 = readTVar itrResponse ≫= go
48 go ∷ Response → STM ()
49 go res@(Response {..})
50 = do unless (any (\ p → p resStatus) [ isSuccessful
55 $ A.toAsciiBuilder "Inappropriate status code for a response: "
56 ⊕ printStatusCode resStatus
58 when ( resStatus ≡ MethodNotAllowed ∧
59 hasHeader "Allow" res )
61 $ A.toAsciiBuilder "The status was "
62 ⊕ printStatusCode resStatus
63 ⊕ A.toAsciiBuilder " but no \"Allow\" header."
65 when ( resStatus ≢ NotModified ∧
66 isRedirection resStatus ∧
67 hasHeader "Location" res )
69 $ A.toAsciiBuilder "The status code was "
70 ⊕ printStatusCode resStatus
71 ⊕ A.toAsciiBuilder " but no Location header."
73 abort' ∷ AsciiBuilder → STM ()
74 abort' = abortSTM InternalServerError []
79 postprocessWithRequest ∷ Interaction → Request → STM ()
80 postprocessWithRequest itr@(Interaction {..}) (Request {..})
81 = do willDiscardBody ← readTVar itrWillDiscardBody
82 canHaveBody ← if willDiscardBody then
85 resCanHaveBody <$> readTVar itrResponse
88 $ deleteHeader "Content-Length"
89 ∘ deleteHeader "Transfer-Encoding"
92 do when (reqVersion ≡ HttpVersion 1 1)
93 $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
94 writeTVar itrWillChunkBody True
95 writeDefaultPageIfNeeded itr
97 do writeTVar itrWillDiscardBody True
98 -- These headers make sense for HEAD requests even
99 -- when there won't be a response entity body.
100 when (reqMethod ≢ HEAD)
102 $ deleteHeader "Content-Type"
103 ∘ deleteHeader "Etag"
104 ∘ deleteHeader "Last-Modified"
106 hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
107 willClose ← readTVar itrWillClose
108 when (hasConnClose ∧ (¬) willClose)
109 $ writeTVar itrWillClose True
110 when ((¬) hasConnClose ∧ willClose)
111 $ writeHeader itr "Connection" (Just "close")
113 writeDefaultPageIfNeeded ∷ Interaction → STM ()
114 writeDefaultPageIfNeeded itr@(Interaction {..})
115 = do resHasCType ← readTVar itrResponseHasCType
117 $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
118 res ← readTVar itrResponse
119 let page = getDefaultPage itrConfig itrRequest res
120 putTMVar itrBodyToSend (BB.fromLazyText page)
122 writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
123 {-# INLINE writeHeader #-}
126 Just v' → updateRes itr $ setHeader k v'
127 Nothing → updateRes itr $ deleteHeader k
129 readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
130 {-# INLINE readCIHeader #-}
131 readCIHeader (Interaction {..}) k
132 = getCIHeader k <$> readTVar itrResponse
134 updateRes ∷ Interaction → (Response → Response) → STM ()
135 {-# INLINE updateRes #-}
136 updateRes (Interaction {..}) f
137 = do old ← readTVar itrResponse
138 writeTVar itrResponse (f old)
140 updateResIO ∷ Interaction → (Response → IO Response) → STM ()
141 {-# INLINE updateResIO #-}
142 updateResIO (Interaction {..}) f
143 = do old ← readTVar itrResponse
144 new ← unsafeIOToSTM $ f old
145 writeTVar itrResponse new
147 completeUnconditionalHeaders ∷ Config → Response → IO Response
148 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
151 = case getHeader "Server" res' of
152 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
156 = case getHeader "Date" res' of
157 Nothing → do date ← getCurrentDate
158 return $ setHeader "Date" date res'
161 getCurrentDate ∷ IO Ascii
162 getCurrentDate = HTTP.toAscii <$> getCurrentTime