Network/HTTP/Lucu/Preprocess.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.Preprocess
   8     ( preprocess
   9     )
  10     where
  11 import Control.Applicative
  12 import Control.Concurrent.STM
  13 import Control.Monad
  14 import Data.Ascii (Ascii)
  15 import qualified Data.Ascii as A
  16 import Data.ByteString (ByteString)
  17 import qualified Data.ByteString.Char8 as C8
  18 import Data.Char
  19 import Data.Maybe
  20 import Data.Text (Text)
  21 import qualified Data.Text as T
  22 import Network.HTTP.Lucu.Config
  23 import Network.HTTP.Lucu.Headers
  24 import Network.HTTP.Lucu.HttpVersion
  25 import Network.HTTP.Lucu.Interaction
  26 import Network.HTTP.Lucu.Request
  27 import Network.HTTP.Lucu.Response
  28 import Network.URI
  29 import Prelude.Unicode
  30
  31 {-
  32   TODO: Tanslate this memo into English. It doesn't make sense to
  33   non-Japanese speakers.
  34
  35   * URI にホスト名が存在しない時、
  36     [1] HTTP/1.0 ならば Config を使って補完
  37     [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
  38
  39   * Expect: に問題があった場合は 417 Expectation Failed に設定。
  40     100-continue 以外のものは全部 417 に。
  41
  42   * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
  43     体的には、identity でも chunked でもなければ 501 Not Implemented に
  44     する。
  45
  46   * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
  47     Not Implemented にする。
  48
  49   * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
  50     Version Not Supported を返す。
  51
  52   * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
  53     411 Length Required にする。
  54
  55   * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
  56     Request にする。
  57
  58   * willDiscardBody その他の變數を設定する。
  59 -}
  60
  61 preprocess ∷ Interaction → STM ()
  62 preprocess itr@(Interaction {..})
  63     = do req ← fromJust <$> readTVar itrRequest
  64
  65          let reqVer = reqVersion req
  66
  67          if reqVer ≢ HttpVersion 1 0 ∧
  68             reqVer ≢ HttpVersion 1 1 then
  69
  70              do setStatus itr HttpVersionNotSupported
  71                 writeTVar itrWillClose True
  72
  73          else
  74              -- HTTP/1.0 では Keep-Alive できない
  75              do when (reqVer ≡ HttpVersion 1 0)
  76                      $ writeTVar itrWillClose True
  77
  78                 -- ホスト部の補完
  79                 completeAuthority itr req
  80
  81                 case reqMethod req of
  82                   GET    → return ()
  83                   HEAD   → writeTVar itrWillDiscardBody True
  84                   POST   → writeTVar itrRequestHasBody  True
  85                   PUT    → writeTVar itrRequestHasBody  True
  86                   DELETE → return ()
  87                   _      → setStatus itr NotImplemented
  88
  89                 preprocessHeader itr req
  90
  91 setStatus ∷ Interaction → StatusCode → STM ()
  92 setStatus (Interaction {..}) sc
  93     = do res ← readTVar itrResponse
  94          let res' = res {
  95                       resStatus = sc
  96                     }
  97          writeTVar itrResponse res'
  98
  99 completeAuthority ∷ Interaction → Request → STM ()
 100 completeAuthority itr@(Interaction {..}) req
 101     = when (isNothing $ uriAuthority $ reqURI req)
 102           $ if reqVersion req == HttpVersion 1 0 then
 103                 -- HTTP/1.0 なので Config から補完
 104                 do let host    = cnfServerHost itrConfig
 105                        portStr = case itrLocalPort of
 106                                    80 → ""
 107                                    n  → ':' : show n
 108                    updateAuthority host $ A.unsafeFromString portStr
 109             else
 110                 case getHeader "Host" req of
 111                   Just str → let (host, portStr) = parseHost str
 112                              in
 113                                updateAuthority host portStr
 114                   Nothing  → setStatus itr BadRequest
 115
 116 parseHost ∷ Ascii → (Text, Ascii)
 117 parseHost = C8.break (≡ ':')
 118
 119 updateAuthority ∷ Text → Ascii → STM ()
 120 updateAuthority host portStr
 121     = do Just req ← readTVar itrRequest
 122          let uri  = reqURI req
 123              uri' = uri {
 124                       uriAuthority = Just URIAuth {
 125                                        uriUserInfo = ""
 126                                      , uriRegName  = T.unpack host
 127                                      , uriPort     = A.toString portStr
 128                                      }
 129                     }
 130              req' = req { reqURI = uri' }
 131          writeTVar itrRequest $ Just req'
 132
 133 preprocessHeader ∷ Interaction → Request → STM ()
 134 preprocessHeader (Interaction {..}) req
 135     = do case getCIHeader "Expect" req of
 136            Nothing    → return ()
 137            Just value → if value ≡ "100-continue" then
 138                              writeTVar itrExpectedContinue True
 139                          else
 140                              setStatus ExpectationFailed
 141
 142          case getCIHeader "Transfer-Encoding" req of
 143            Nothing    → return ()
 144            Just value → unless (value ≡ "identity")
 145                             $ if value ≡ "chunked" then
 146                                   writeTVar itrRequestIsChunked True
 147                               else
 148                                   setStatus NotImplemented
 149
 150          case getHeader "Content-Length" req of
 151            Nothing    → return ()
 152            Just value → if C8.all isDigit value then
 153                             do let Just (len, _) = C8.readInt value
 154                                writeTVar itrReqChunkLength    $ Just len
 155                                writeTVar itrReqChunkRemaining $ Just len
 156                         else
 157                             setStatus BadRequest
 158
 159          case getCIHeader "Connection" req of
 160            Nothing    → return ()
 161            Just value → when (value ≡ "close")
 162                             $ writeTVar itrWillClose True