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