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