Network/HTTP/Lucu/RequestReader.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , RecordWildCards
   4   , ScopedTypeVariables
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.RequestReader
   8     ( requestReader
   9     )
  10     where
  11 import Control.Applicative
  12 import Control.Concurrent.STM
  13 import Control.Exception
  14 import Control.Monad
  15 import qualified Data.Attoparsec.Lazy as LP
  16 import qualified Data.ByteString.Lazy as Lazy
  17 import Data.Maybe
  18 import qualified Data.Sequence as S
  19 import Data.Sequence.Unicode
  20 import Data.Text (Text)
  21 import Network.HTTP.Lucu.Config
  22 import Network.HTTP.Lucu.Chunk
  23 import Network.HTTP.Lucu.HandleLike
  24 import Network.HTTP.Lucu.Interaction
  25 import Network.HTTP.Lucu.Postprocess
  26 import Network.HTTP.Lucu.Preprocess
  27 import Network.HTTP.Lucu.Request
  28 import Network.HTTP.Lucu.Response
  29 import Network.HTTP.Lucu.Resource.Tree
  30 import Network.Socket
  31 import Network.URI
  32 import Prelude.Unicode
  33 import System.IO (hPutStrLn, stderr)
  34
  35 data Context h
  36     = Context {
  37         cConfig    ∷ !Config
  38       , cResTree   ∷ !ResTree
  39       , cFallbacks ∷ ![FallbackHandler]
  40       , cHandle    ∷ !h
  41       , cPort      ∷ !PortNumber
  42       , cAddr      ∷ !SockAddr
  43       , cQueue     ∷ !InteractionQueue
  44       }
  45
  46 requestReader ∷ HandleLike h
  47               ⇒ Config
  48               → ResTree
  49               → [FallbackHandler]
  50               → h
  51               → PortNumber
  52               → SockAddr
  53               → InteractionQueue
  54               → IO ()
  55 requestReader cnf tree fbs h port addr tQueue
  56     = do input ← hGetLBS h
  57          acceptRequest (Context cnf tree fbs h port addr tQueue) input
  58       `catches`
  59       [ Handler handleAsyncE
  60       , Handler handleBIOS
  61       , Handler handleOthers
  62       ]
  63     where
  64       handleAsyncE ∷ AsyncException → IO ()
  65       handleAsyncE ThreadKilled = return ()
  66       handleAsyncE e            = dump e
  67
  68       handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
  69       handleBIOS = dump
  70
  71       handleOthers ∷ SomeException → IO ()
  72       handleOthers = dump
  73
  74       dump ∷ Exception e ⇒ e → IO ()
  75       dump e
  76           = do hPutStrLn stderr "requestReader caught an exception:"
  77                hPutStrLn stderr (show $ toException e)
  78
  79 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
  80 acceptRequest ctx@(Context {..}) input
  81     -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
  82     -- それが限度以下になるまで待つ。
  83     = do atomically $
  84              do queue ← readTVar cQueue
  85                 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
  86                     retry
  87          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  88          -- Request 應答を設定し、それを出力してから切斷するやうに
  89          -- ResponseWriter に通知する。
  90          case LP.parse requestP input of
  91            LP.Done input' req → acceptParsableRequest ctx req input'
  92            LP.Fail _ _ _      → acceptNonparsableRequest ctx BadRequest
  93
  94 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
  95 acceptNonparsableRequest ctx@(Context {..}) sc
  96     = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
  97          atomically $
  98              do writeTVar (itrState itr) Done
  99                 postprocess itr
 100                 enqueue ctx itr
 101
 102 acceptParsableRequest ∷ HandleLike h
 103                       ⇒ Context h
 104                       → Request
 105                       → Lazy.ByteString
 106                       → IO ()
 107 acceptParsableRequest ctx@(Context {..}) req input
 108     = do cert ← hGetPeerCert cHandle
 109          itr  ← newInteraction cConfig cPort cAddr cert (Right req)
 110          join $ atomically
 111               $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
 112                    if isErr then
 113                        acceptSemanticallyInvalidRequest ctx itr input
 114                    else
 115                        return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
 116
 117 acceptSemanticallyInvalidRequest ∷ HandleLike h
 118                                  ⇒ Context h
 119                                  → Interaction
 120                                  → Lazy.ByteString
 121                                  → STM (IO ())
 122 acceptSemanticallyInvalidRequest ctx itr input
 123     = do writeTVar (itrState itr) Done
 124          postprocess itr
 125          enqueue ctx itr
 126          return $ acceptRequest ctx input
 127
 128 acceptSemanticallyValidRequest ∷ HandleLike h
 129                                ⇒ Context h
 130                                → Interaction
 131                                → URI
 132                                → Lazy.ByteString
 133                                → IO ()
 134 acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
 135     = do rsrcM ← findResource cResTree cFallbacks uri
 136          case rsrcM of
 137            Nothing
 138                → acceptRequestForNonexistentResource ctx itr input
 139            Just (rsrcPath, rsrcDef)
 140                → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
 141
 142 acceptRequestForNonexistentResource ∷ HandleLike h
 143                                     ⇒ Context h
 144                                     → Interaction
 145                                     → Lazy.ByteString
 146                                     → IO ()
 147 acceptRequestForNonexistentResource ctx itr input
 148     = do atomically $
 149              do setResponseStatus itr NotFound
 150                 writeTVar (itrState itr) Done
 151                 postprocess itr
 152                 enqueue ctx itr
 153          acceptRequest ctx input
 154
 155 acceptRequestForExistentResource ∷ HandleLike h
 156                                  ⇒ Context h
 157                                  → Interaction
 158                                  → Lazy.ByteString
 159                                  → [Text]
 160                                  → ResourceDef
 161                                  → IO ()
 162 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
 163     = do let itr = oldItr { itrResourcePath = Just rsrcPath }
 164          atomically $ enqueue ctx itr
 165          do _ ← runResource rsrcDef itr
 166             if reqMustHaveBody $ fromJust $ itrRequest itr then
 167                 observeRequest ctx itr input
 168             else
 169                 acceptRequest ctx input
 170
 171 observeRequest ∷ HandleLike h
 172                ⇒ Context h
 173                → Interaction
 174                → Lazy.ByteString
 175                → IO ()
 176 observeRequest ctx itr input
 177     = case fromJust $ itrReqBodyLength itr of
 178         Chunked
 179             → observeChunkedRequest ctx itr input 0
 180         Fixed len
 181             → observeNonChunkedRequest ctx itr input len
 182
 183 observeChunkedRequest ∷ HandleLike h
 184                       ⇒ Context h
 185                       → Interaction
 186                       → Lazy.ByteString
 187                       → Int
 188                       → IO ()
 189 observeChunkedRequest ctx itr input remaining
 190     = join $
 191       atomically $
 192       do isOver ← readTVar $ itrReqChunkIsOver itr
 193          if isOver then
 194              return $ acceptRequest ctx input
 195          else
 196              do wanted ← readTVar $ itrReqBodyWanted itr
 197                 case wanted of
 198                   0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
 199                          if wasteAll then
 200                              return $ wasteCurrentChunk ctx itr input remaining
 201                          else
 202                              retry
 203                   _ → return $ readCurrentChunk ctx itr input wanted remaining
 204
 205 wasteCurrentChunk ∷ HandleLike h
 206                   ⇒ Context h
 207                   → Interaction
 208                   → Lazy.ByteString
 209                   → Int
 210                   → IO ()
 211 wasteCurrentChunk ctx itr input len
 212     | len > 0
 213         = let input' = Lazy.drop (fromIntegral len) input
 214           in
 215             case LP.parse chunkFooterP input' of
 216               LP.Done input'' _
 217                   → observeChunkedRequest ctx itr input'' 0
 218               LP.Fail _ _ _
 219                   → chunkWasMalformed itr
 220     | otherwise
 221         = seekNextChunk ctx itr input
 222
 223 readCurrentChunk ∷ HandleLike h
 224                  ⇒ Context h
 225                  → Interaction
 226                  → Lazy.ByteString
 227                  → Int
 228                  → Int
 229                  → IO ()
 230 readCurrentChunk ctx itr input wanted remaining
 231     | remaining > 0
 232         = do let bytesToRead     = fromIntegral $ min wanted remaining
 233                  (chunk, input') = Lazy.splitAt bytesToRead input
 234                  actualReadBytes = fromIntegral $ Lazy.length chunk
 235                  newWanted       = wanted - actualReadBytes
 236                  newRemaining    = remaining - actualReadBytes
 237                  chunk'          = S.fromList $ Lazy.toChunks chunk
 238                  updateStates    = atomically $
 239                                    do writeTVar (itrReqBodyWanted itr) newWanted
 240                                       oldBody    ← readTVar $ itrReceivedBody    itr
 241                                       oldBodyLen ← readTVar $ itrReceivedBodyLen itr
 242                                       writeTVar (itrReceivedBody    itr) $ oldBody ⋈ chunk'
 243                                       writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
 244              if newRemaining ≡ 0 then
 245                  case LP.parse chunkFooterP input' of
 246                    LP.Done input'' _
 247                        → do updateStates
 248                             observeChunkedRequest ctx itr input'' 0
 249                    LP.Fail _ _ _
 250                        → chunkWasMalformed itr
 251              else
 252                  do updateStates
 253                     observeChunkedRequest ctx itr input' newRemaining
 254     | otherwise
 255         = seekNextChunk ctx itr input
 256
 257 seekNextChunk ∷ HandleLike h
 258               ⇒ Context h
 259               → Interaction
 260               → Lazy.ByteString
 261               → IO ()
 262 seekNextChunk ctx itr input
 263     = case LP.parse chunkHeaderP input of
 264         LP.Done input' len
 265             | len ≡ 0 -- Final chunk
 266                 → case LP.parse chunkTrailerP input' of
 267                      LP.Done input'' _
 268                          → do atomically $
 269                                   writeTVar (itrReqChunkIsOver itr) True
 270                               acceptRequest ctx input''
 271                      LP.Fail _ _ _
 272                          → chunkWasMalformed itr
 273             | otherwise -- Non-final chunk
 274                 → observeChunkedRequest ctx itr input' len
 275         LP.Fail _ _ _
 276                 → chunkWasMalformed itr
 277
 278 chunkWasMalformed ∷ Interaction → IO ()
 279 chunkWasMalformed itr
 280     = atomically $
 281       do setResponseStatus itr BadRequest
 282          writeTVar (itrWillClose itr) True
 283          writeTVar (itrState     itr) Done
 284          postprocess itr
 285
 286 observeNonChunkedRequest ∷ HandleLike h
 287                          ⇒ Context h
 288                          → Interaction
 289                          → Lazy.ByteString
 290                          → Int
 291                          → IO ()
 292 observeNonChunkedRequest ctx itr input remaining
 293     = join $
 294       atomically $
 295       do wanted ← readTVar $ itrReqBodyWanted itr
 296          case wanted of
 297            0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
 298                   if wasteAll then
 299                       return $ wasteNonChunkedRequestBody ctx itr input remaining
 300                   else
 301                       retry
 302            _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
 303
 304 wasteNonChunkedRequestBody ∷ HandleLike h
 305                            ⇒ Context h
 306                            → Interaction
 307                            → Lazy.ByteString
 308                            → Int
 309                            → IO ()
 310 wasteNonChunkedRequestBody ctx itr input remaining
 311     = do let input' = Lazy.drop (fromIntegral remaining) input
 312          atomically $ writeTVar (itrReqChunkIsOver itr) True
 313          acceptRequest ctx input'
 314
 315 readNonChunkedRequestBody ∷ HandleLike h
 316                           ⇒ Context h
 317                           → Interaction
 318                           → Lazy.ByteString
 319                           → Int
 320                           → Int
 321                           → IO ()
 322 readNonChunkedRequestBody ctx itr input wanted remaining
 323     = do let bytesToRead     = min wanted remaining
 324              (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 325              actualReadBytes = fromIntegral $ Lazy.length chunk
 326              newWanted       = wanted - actualReadBytes
 327              newRemaining    = remaining - actualReadBytes
 328              isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
 329              chunk'          = S.fromList $ Lazy.toChunks chunk
 330          atomically $
 331              do writeTVar (itrReqChunkIsOver  itr) isOver
 332                 writeTVar (itrReqBodyWanted   itr) newWanted
 333                 writeTVar (itrReceivedBody    itr) chunk'
 334                 writeTVar (itrReceivedBodyLen itr) actualReadBytes
 335          if isOver then
 336              acceptRequest ctx input'
 337          else
 338              observeNonChunkedRequest ctx itr input' newRemaining
 339
 340 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
 341 enqueue (Context {..}) itr
 342     = do queue ← readTVar cQueue
 343          writeTVar cQueue (itr ⊲ queue)