Network/HTTP/Lucu/Postprocess.hs

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