Network/HTTP/Lucu/Postprocess.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , DoAndIfThenElse
   4   , OverloadedStrings
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.Postprocess
   8     ( postprocess
   9     , completeUnconditionalHeaders
  10     )
  11     where
  12 import Control.Applicative
  13 import Control.Concurrent.STM
  14 import Control.Monad
  15 import Control.Monad.Unicode
  16 import Data.Ascii (Ascii, CIAscii)
  17 import qualified Data.Ascii as A
  18 import Data.Maybe
  19 import Data.Monoid.Unicode
  20 import Data.Time
  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.Headers
  26 import Network.HTTP.Lucu.HttpVersion
  27 import Network.HTTP.Lucu.Interaction
  28 import Network.HTTP.Lucu.Request
  29 import Network.HTTP.Lucu.Response
  30 import Prelude.Unicode
  31
  32 {-
  33
  34   * Response が未設定なら、200 OK にする。
  35
  36   * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
  37
  38   * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
  39
  40   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
  41     する。
  42
  43   * Content-Length があれば、それを削除する。Transfer-Encoding があって
  44     も削除する。
  45
  46   * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
  47     chunked に設定する。
  48
  49   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
  50     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
  51     する。
  52
  53   * body を持つ事が出來ない時、body 破棄フラグを立てる。
  54
  55   * Connection: close が設定されてゐる時、切斷フラグを立てる。
  56
  57   * 切斷フラグが立ってゐる時、Connection: close を設定する。
  58
  59   * Server が無ければ設定。
  60
  61   * Date が無ければ設定。
  62
  63 -}
  64
  65 postprocess ∷ Interaction → STM ()
  66 postprocess !itr
  67     = do reqM ← readItr itrRequest  id itr
  68          res  ← readItr itrResponse id itr
  69          let sc = resStatus res
  70
  71          unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
  72              $ abortSTM InternalServerError []
  73              $ Just
  74              $ A.toText ( "The status code is not good for a final status of a response: "
  75                           ⊕ printStatusCode sc )
  76
  77          when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
  78              $ abortSTM InternalServerError []
  79              $ Just
  80              $ A.toText ( "The status was "
  81                           ⊕ printStatusCode sc
  82                           ⊕ " but no Allow header." )
  83
  84          when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
  85              $ abortSTM InternalServerError []
  86              $ Just
  87              $ A.toText ( "The status code was "
  88                           ⊕ printStatusCode sc
  89                           ⊕ " but no Location header." )
  90
  91          when (reqM ≢ Nothing) relyOnRequest
  92
  93          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
  94          -- 能性が高い。
  95          do oldRes ← readItr itrResponse id itr
  96             newRes ← unsafeIOToSTM
  97                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
  98             writeItr itrResponse newRes itr
  99     where
 100       relyOnRequest ∷ STM ()
 101       relyOnRequest
 102           = do status ← readItr itrResponse resStatus itr
 103                req    ← readItr itrRequest  fromJust  itr
 104
 105                let reqVer      = reqVersion req
 106                    canHaveBody = if reqMethod req ≡ HEAD then
 107                                      False
 108                                  else
 109                                      not (isInformational status ∨
 110                                           status ≡ NoContent     ∨
 111                                           status ≡ ResetContent  ∨
 112                                           status ≡ NotModified   )
 113
 114                updateRes $ deleteHeader "Content-Length"
 115                updateRes $ deleteHeader "Transfer-Encoding"
 116
 117                cType ← readHeader "Content-Type"
 118                when (cType ≡ Nothing)
 119                         $ updateRes $ setHeader "Content-Type" defaultPageContentType
 120
 121                if canHaveBody then
 122                    when (reqVer ≡ HttpVersion 1 1)
 123                        $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
 124                             writeItr itrWillChunkBody True itr
 125                else
 126                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 127                    when (reqMethod req ≢ HEAD)
 128                        $ do updateRes $ deleteHeader "Content-Type"
 129                             updateRes $ deleteHeader "Etag"
 130                             updateRes $ deleteHeader "Last-Modified"
 131
 132                conn ← readHeader "Connection"
 133                case conn of
 134                  Nothing    → return ()
 135                  Just value → when (A.toCIAscii value ≡ "close")
 136                                   $ writeItr itrWillClose True itr
 137
 138                willClose ← readItr itrWillClose id itr
 139                when willClose
 140                    $ updateRes $ setHeader "Connection" "close"
 141
 142                when (reqMethod req ≡ HEAD ∨ not canHaveBody)
 143                    $ writeTVar (itrWillDiscardBody itr) True
 144
 145       readHeader ∷ CIAscii → STM (Maybe Ascii)
 146       {-# INLINE readHeader #-}
 147       readHeader k = readItr itrResponse (getHeader k) itr
 148
 149       updateRes ∷ (Response → Response) → STM ()
 150       {-# INLINE updateRes #-}
 151       updateRes f = updateItr itrResponse f itr
 152
 153 completeUnconditionalHeaders ∷ Config → Response → IO Response
 154 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
 155       where
 156         compServer res'
 157             = case getHeader "Server" res' of
 158                 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
 159                 Just _  → return res'
 160
 161         compDate res'
 162             = case getHeader "Date" res' of
 163                 Nothing → do date ← getCurrentDate
 164                              return $ setHeader "Date" date res'
 165                 Just _  → return res'
 166
 167 getCurrentDate ∷ IO Ascii
 168 getCurrentDate = HTTP.toAscii <$> getCurrentTime