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          case itrRequest of
  98            Just req → postprocessWithRequest sc req
  99            Nothing  → return ()
 100
 101          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
 102          -- 能性が高い。
 103          do oldRes ← readTVar itrResponse
 104             newRes ← unsafeIOToSTM
 105                      $ completeUnconditionalHeaders itrConfig oldRes
 106             writeTVar itrResponse newRes
 107     where
 108       postprocessWithRequest ∷ StatusCode → Request → STM ()
 109       postprocessWithRequest sc (Request {..})
 110           = do let canHaveBody = if reqMethod ≡ HEAD then
 111                                      False
 112                                  else
 113                                      (¬) (isInformational sc ∨
 114                                           sc ≡ NoContent     ∨
 115                                           sc ≡ ResetContent  ∨
 116                                           sc ≡ NotModified   )
 117
 118                updateRes $ deleteHeader "Content-Length"
 119                updateRes $ deleteHeader "Transfer-Encoding"
 120
 121                cType ← readHeader "Content-Type"
 122                when (cType ≡ Nothing)
 123                         $ updateRes $ setHeader "Content-Type" defaultPageContentType
 124
 125                if canHaveBody then
 126                    when (reqVersion ≡ HttpVersion 1 1)
 127                        $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
 128                             writeTVar itrWillChunkBody True
 129                else
 130                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
 131                    when (reqMethod ≢ HEAD)
 132                        $ do updateRes $ deleteHeader "Content-Type"
 133                             updateRes $ deleteHeader "Etag"
 134                             updateRes $ deleteHeader "Last-Modified"
 135
 136                conn ← readCIHeader "Connection"
 137                case conn of
 138                  Nothing    → return ()
 139                  Just value → when (value ≡ "close")
 140                                   $ writeTVar itrWillClose True
 141
 142                willClose ← readTVar itrWillClose
 143                when willClose
 144                    $ updateRes $ setHeader "Connection" "close"
 145
 146                when (reqMethod ≡ HEAD ∨ not canHaveBody)
 147                    $ writeTVar itrWillDiscardBody True
 148
 149       readHeader ∷ CIAscii → STM (Maybe Ascii)
 150       {-# INLINE readHeader #-}
 151       readHeader k = getHeader k <$> readTVar itrResponse
 152
 153       readCIHeader ∷ CIAscii → STM (Maybe CIAscii)
 154       {-# INLINE readCIHeader #-}
 155       readCIHeader k = getCIHeader k <$> readTVar itrResponse
 156
 157       updateRes ∷ (Response → Response) → STM ()
 158       {-# INLINE updateRes #-}
 159       updateRes f
 160           = do old ← readTVar itrResponse
 161                writeTVar itrResponse (f old)
 162
 163 completeUnconditionalHeaders ∷ Config → Response → IO Response
 164 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
 165       where
 166         compServer res'
 167             = case getHeader "Server" res' of
 168                 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
 169                 Just _  → return res'
 170
 171         compDate res'
 172             = case getHeader "Date" res' of
 173                 Nothing → do date ← getCurrentDate
 174                              return $ setHeader "Date" date res'
 175                 Just _  → return res'
 176
 177 getCurrentDate ∷ IO Ascii
 178 getCurrentDate = HTTP.toAscii <$> getCurrentTime