]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Postprocess.hs
hlint
[Lucu.git] / Network / HTTP / Lucu / Postprocess.hs
1 {-# LANGUAGE
2     DoAndIfThenElse
3   , OverloadedStrings
4   , RecordWildCards
5   , UnicodeSyntax
6   #-}
7 module Network.HTTP.Lucu.Postprocess
8     ( postprocess
9     )
10     where
11 import Control.Applicative
12 import Control.Concurrent.STM
13 import Control.Monad
14 import Control.Monad.Unicode
15 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
16 import qualified Data.Ascii as A
17 import Data.Maybe
18 import Data.Monoid.Unicode
19 import GHC.Conc (unsafeIOToSTM)
20 import Network.HTTP.Lucu.Abortion
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.DefaultPage
23 import Network.HTTP.Lucu.Headers
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
27 import Prelude.Unicode
28
29 postprocess ∷ NormalInteraction → STM ()
30 postprocess ni@(NI {..})
31     = do void $ tryPutTMVar niSendContinue False
32          abortOnCertainConditions ni
33          postprocessWithRequest ni
34          completeUnconditionalHeaders ni
35
36 abortOnCertainConditions ∷ NormalInteraction → STM ()
37 abortOnCertainConditions (NI {..})
38     = readTVar niResponse ≫= go
39     where
40       go ∷ Response → STM ()
41       go res@(Response {..})
42           = do unless (any (\ p → p resStatus) [ isSuccessful
43                                                , isRedirection
44                                                , isError
45                                                ])
46                    $ abort'
47                    $ A.toAsciiBuilder "Inappropriate status code for a response: "
48                    ⊕ printStatusCode resStatus
49
50                when ( resStatus ≈ MethodNotAllowed ∧
51                       hasHeader "Allow" res        )
52                    $ abort'
53                    $ A.toAsciiBuilder "The status was "
54                    ⊕ printStatusCode resStatus
55                    ⊕ A.toAsciiBuilder " but no \"Allow\" header."
56
57                when ( resStatus ≉ NotModified  ∧
58                       isRedirection resStatus  ∧
59                       hasHeader "Location" res )
60                    $ abort'
61                    $ A.toAsciiBuilder "The status code was "
62                    ⊕ printStatusCode resStatus
63                    ⊕ A.toAsciiBuilder " but no Location header."
64
65       abort' ∷ AsciiBuilder → STM ()
66       abort' = throwSTM
67                ∘ mkAbortion' InternalServerError
68                ∘ A.toText
69                ∘ A.fromAsciiBuilder
70
71 postprocessWithRequest ∷ NormalInteraction → STM ()
72 postprocessWithRequest ni@(NI {..})
73     = do willDiscardBody ← readTVar niWillDiscardBody
74          canHaveBody     ← if willDiscardBody then
75                                return False
76                            else
77                                resCanHaveBody <$> readTVar niResponse
78
79          updateRes ni
80              $ deleteHeader "Content-Length"
81              ∘ deleteHeader "Transfer-Encoding"
82
83          if canHaveBody then
84              do when niWillChunkBody $
85                     writeHeader ni "Transfer-Encoding" (Just "chunked")
86                 writeDefaultPageIfNeeded ni
87          else
88              do writeTVar niWillDiscardBody True
89                 -- These headers make sense for HEAD requests even
90                 -- when there won't be a response entity body.
91                 when (reqMethod niRequest ≢ HEAD)
92                     $ updateRes ni
93                     $ deleteHeader "Content-Type"
94                     ∘ deleteHeader "Etag"
95                     ∘ deleteHeader "Last-Modified"
96
97          hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
98          willClose    ← readTVar niWillClose
99          when (hasConnClose ∧ (¬) willClose)
100              $ writeTVar niWillClose True
101          when ((¬) hasConnClose ∧ willClose)
102              $ writeHeader ni "Connection" (Just "close")
103
104 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
105 writeDefaultPageIfNeeded ni@(NI {..})
106     = do resHasCType ← readTVar niResponseHasCType
107          unless resHasCType
108              $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
109                   writeHeader ni "Content-Encoding" Nothing
110                   res ← readTVar niResponse
111                   let body = getDefaultPage niConfig (Just niRequest) res
112                   putTMVar niBodyToSend body
113
114 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
115 completeUnconditionalHeaders ni@(NI {..})
116     = do srv ← readHeader ni "Server"
117          when (isNothing srv) $
118              writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
119
120          date ← readHeader ni "Date"
121          when (isNothing date) $
122              do date' ← unsafeIOToSTM getCurrentDate
123                 writeHeader ni "Date" $ Just date'
124
125 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
126 {-# INLINE writeHeader #-}
127 writeHeader ni k v
128     = case v of
129         Just v' → updateRes ni $ setHeader    k v'
130         Nothing → updateRes ni $ deleteHeader k
131
132 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
133 {-# INLINE readHeader #-}
134 readHeader (NI {..}) k
135     = getHeader k <$> readTVar niResponse
136
137 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
138 {-# INLINE readCIHeader #-}
139 readCIHeader (NI {..}) k
140     = getCIHeader k <$> readTVar niResponse
141
142 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
143 {-# INLINE updateRes #-}
144 updateRes (NI {..}) f
145     = do old ← readTVar niResponse
146          writeTVar niResponse $ f old