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