Network/HTTP/Lucu/Postprocess.hs

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