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