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 hiding (block)
  14 import Control.Monad
  15 import qualified Data.Attoparsec.Lazy as LP
  16 import qualified Data.ByteString as Strict
  17 import qualified Data.ByteString.Lazy as Lazy
  18 import Data.Maybe
  19 import Data.Monoid.Unicode
  20 import qualified Data.Sequence as S
  21 import Data.Sequence.Unicode hiding ((∅))
  22 import Network.HTTP.Lucu.Config
  23 import Network.HTTP.Lucu.Chunk
  24 import Network.HTTP.Lucu.HandleLike
  25 import Network.HTTP.Lucu.Interaction
  26 import Network.HTTP.Lucu.Postprocess
  27 import Network.HTTP.Lucu.Preprocess
  28 import Network.HTTP.Lucu.Request
  29 import Network.HTTP.Lucu.Response
  30 import Network.HTTP.Lucu.Resource.Internal
  31 import Network.HTTP.Lucu.Resource.Tree
  32 import Network.Socket
  33 import Network.URI
  34 import Prelude.Unicode
  35 import System.IO (hPutStrLn, stderr)
  36
  37 data Context h
  38     = Context {
  39         cConfig    ∷ !Config
  40       , cResTree   ∷ !ResTree
  41       , cFallbacks ∷ ![FallbackHandler]
  42       , cHandle    ∷ !h
  43       , cPort      ∷ !PortNumber
  44       , cAddr      ∷ !SockAddr
  45       , cQueue     ∷ !InteractionQueue
  46       }
  47
  48 data ChunkReceivingState
  49     = Initial
  50     | InChunk !Int -- ^Number of remaining octets in the current
  51                    -- chunk. It's always positive.
  52
  53 requestReader ∷ HandleLike h
  54               ⇒ Config
  55               → ResTree
  56               → [FallbackHandler]
  57               → h
  58               → PortNumber
  59               → SockAddr
  60               → InteractionQueue
  61               → IO ()
  62 requestReader cnf tree fbs h port addr tQueue
  63     = do input ← hGetLBS h
  64          acceptRequest (Context cnf tree fbs h port addr tQueue) input
  65       `catches`
  66       [ Handler handleAsyncE
  67       , Handler handleBIOS
  68       , Handler handleOthers
  69       ]
  70     where
  71       handleAsyncE ∷ AsyncException → IO ()
  72       handleAsyncE ThreadKilled = return ()
  73       handleAsyncE e            = dump e
  74
  75       handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
  76       handleBIOS = dump
  77
  78       handleOthers ∷ SomeException → IO ()
  79       handleOthers = dump
  80
  81       dump ∷ Exception e ⇒ e → IO ()
  82       dump e
  83           = do hPutStrLn stderr "requestReader caught an exception:"
  84                hPutStrLn stderr (show $ toException e)
  85
  86 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
  87 acceptRequest ctx@(Context {..}) input
  88     -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
  89     -- それが限度以下になるまで待つ。
  90     = do atomically $
  91              do queue ← readTVar cQueue
  92                 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
  93                     retry
  94          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  95          -- Request 應答を設定し、それを出力してから切斷するやうに
  96          -- ResponseWriter に通知する。
  97          case LP.parse requestP input of
  98            LP.Done input' req → acceptParsableRequest ctx req input'
  99            LP.Fail _ _ _      → acceptNonparsableRequest ctx BadRequest
 100
 101 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
 102 acceptNonparsableRequest ctx@(Context {..}) sc
 103     = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
 104          atomically $
 105              do writeTVar (itrState itr) Done
 106                 postprocess itr
 107                 enqueue ctx itr
 108
 109 acceptParsableRequest ∷ HandleLike h
 110                       ⇒ Context h
 111                       → Request
 112                       → Lazy.ByteString
 113                       → IO ()
 114 acceptParsableRequest ctx@(Context {..}) req input
 115     = do cert ← hGetPeerCert cHandle
 116          itr  ← newInteraction cConfig cPort cAddr cert (Right req)
 117          join $ atomically
 118               $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
 119                    if isErr then
 120                        acceptSemanticallyInvalidRequest ctx itr input
 121                    else
 122                        return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
 123
 124 acceptSemanticallyInvalidRequest ∷ HandleLike h
 125                                  ⇒ Context h
 126                                  → Interaction
 127                                  → Lazy.ByteString
 128                                  → STM (IO ())
 129 acceptSemanticallyInvalidRequest ctx itr input
 130     = do writeTVar (itrState itr) Done
 131          postprocess itr
 132          enqueue ctx itr
 133          return $ acceptRequest ctx input
 134
 135 acceptSemanticallyValidRequest ∷ HandleLike h
 136                                ⇒ Context h
 137                                → Interaction
 138                                → URI
 139                                → Lazy.ByteString
 140                                → IO ()
 141 acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
 142     = do rsrcM ← findResource cResTree cFallbacks uri
 143          case rsrcM of
 144            Nothing
 145                → acceptRequestForNonexistentResource ctx itr input
 146            Just (rsrcPath, rsrcDef)
 147                → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
 148
 149 acceptRequestForNonexistentResource ∷ HandleLike h
 150                                     ⇒ Context h
 151                                     → Interaction
 152                                     → Lazy.ByteString
 153                                     → IO ()
 154 acceptRequestForNonexistentResource ctx itr input
 155     = do atomically $
 156              do setResponseStatus itr NotFound
 157                 writeTVar (itrState itr) Done
 158                 postprocess itr
 159                 enqueue ctx itr
 160          acceptRequest ctx input
 161
 162 acceptRequestForExistentResource ∷ HandleLike h
 163                                  ⇒ Context h
 164                                  → Interaction
 165                                  → Lazy.ByteString
 166                                  → [Strict.ByteString]
 167                                  → ResourceDef
 168                                  → IO ()
 169 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
 170     = do let itr = oldItr { itrResourcePath = Just rsrcPath }
 171          atomically $ enqueue ctx itr
 172          do _ ← spawnResource rsrcDef itr
 173             if reqMustHaveBody $ fromJust $ itrRequest itr then
 174                 waitForReceiveBodyReq ctx itr input
 175             else
 176                 acceptRequest ctx input
 177
 178 waitForReceiveBodyReq ∷ HandleLike h
 179                       ⇒ Context h
 180                       → Interaction
 181                       → Lazy.ByteString
 182                       → IO ()
 183 waitForReceiveBodyReq ctx itr input
 184     = case fromJust $ itrReqBodyLength itr of
 185         Chunked
 186             → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
 187         Fixed len
 188             → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
 189
 190 -- Toooooo long name for a function...
 191 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
 192                                             ⇒ Context h
 193                                             → Interaction
 194                                             → Lazy.ByteString
 195                                             → IO ()
 196 waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
 197     = join $
 198       atomically $
 199       do req ← takeTMVar itrReceiveBodyReq
 200          case req of
 201            ReceiveBody wanted
 202                → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
 203                     return $ readCurrentChunk ctx itr input Initial wanted
 204            WasteAll
 205                → do putTMVar itrSendContinue False
 206                     return $ wasteAllChunks ctx itr input Initial
 207
 208 waitForReceiveChunkedBodyReq ∷ HandleLike h
 209                              ⇒ Context h
 210                              → Interaction
 211                              → Lazy.ByteString
 212                              → ChunkReceivingState
 213                              → IO ()
 214 waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
 215     = do req ← atomically $ takeTMVar itrReceiveBodyReq
 216          case req of
 217            ReceiveBody wanted
 218                → readCurrentChunk ctx itr input st wanted
 219            WasteAll
 220                → wasteAllChunks ctx itr input st
 221
 222 wasteAllChunks ∷ HandleLike h
 223                ⇒ Context h
 224                → Interaction
 225                → Lazy.ByteString
 226                → ChunkReceivingState
 227                → IO ()
 228 wasteAllChunks ctx itr = go
 229     where
 230       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 231       go input Initial
 232           = case LP.parse chunkHeaderP input of
 233               LP.Done input' chunkLen
 234                   | chunkLen ≡ 0 → gotFinalChunk input'
 235                   | otherwise    → gotChunk input' chunkLen
 236               LP.Fail _ _ _
 237                   → chunkWasMalformed itr
 238       go input (InChunk chunkLen)
 239           = gotChunk input chunkLen
 240
 241       gotChunk ∷ Lazy.ByteString → Int → IO ()
 242       gotChunk input chunkLen
 243           = let input' = Lazy.drop (fromIntegral chunkLen) input
 244             in
 245               case LP.parse chunkFooterP input' of
 246                 LP.Done input'' _
 247                     → go input'' Initial
 248                 LP.Fail _ _ _
 249                     → chunkWasMalformed itr
 250
 251       gotFinalChunk ∷ Lazy.ByteString → IO ()
 252       gotFinalChunk input
 253           = case LP.parse chunkFooterP input of
 254               LP.Done input' _
 255                   → case LP.parse chunkTrailerP input' of
 256                        LP.Done input'' _
 257                            → acceptRequest ctx input''
 258                        LP.Fail _ _ _
 259                            → chunkWasMalformed itr
 260               LP.Fail _ _ _
 261                   → chunkWasMalformed itr
 262
 263 readCurrentChunk ∷ HandleLike h
 264                  ⇒ Context h
 265                  → Interaction
 266                  → Lazy.ByteString
 267                  → ChunkReceivingState
 268                  → Int
 269                  → IO ()
 270 readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
 271     = go input0 st0
 272     where
 273       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
 274       go input Initial
 275           = case LP.parse chunkHeaderP input of
 276               LP.Done input' chunkLen
 277                   | chunkLen ≡ 0
 278                       → gotFinalChunk input'
 279                   | otherwise
 280                       → gotChunk input' chunkLen
 281               LP.Fail _ _ _
 282                   → chunkWasMalformed itr
 283       go input (InChunk chunkLen)
 284           = gotChunk input chunkLen
 285
 286       gotChunk ∷ Lazy.ByteString → Int → IO ()
 287       gotChunk input chunkLen
 288           = do let bytesToRead     = min wanted chunkLen
 289                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 290                    block'          = Strict.concat $ Lazy.toChunks block
 291                    actualReadBytes = Strict.length block'
 292                    chunkLen'       = chunkLen - actualReadBytes
 293                atomically $ putTMVar itrReceivedBody block'
 294                if chunkLen' ≡ 0 then
 295                    case LP.parse chunkFooterP input' of
 296                      LP.Done input'' _
 297                          → waitForReceiveChunkedBodyReq ctx itr input'' Initial
 298                      LP.Fail _ _ _
 299                          → chunkWasMalformed itr
 300                else
 301                    waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
 302
 303       gotFinalChunk ∷ Lazy.ByteString → IO ()
 304       gotFinalChunk input
 305           = do atomically $ putTMVar itrReceivedBody (∅)
 306                case LP.parse chunkFooterP input of
 307                  LP.Done input' _
 308                      → case LP.parse chunkTrailerP input' of
 309                           LP.Done input'' _
 310                               → acceptRequest ctx input''
 311                           LP.Fail _ _ _
 312                               → chunkWasMalformed itr
 313                  LP.Fail _ _ _
 314                      → chunkWasMalformed itr
 315
 316 chunkWasMalformed ∷ Interaction → IO ()
 317 chunkWasMalformed itr
 318     -- FIXME: This is a totally wrong way to abort!
 319     = atomically $
 320       do setResponseStatus itr BadRequest
 321          writeTVar (itrWillClose itr) True
 322          writeTVar (itrState     itr) Done
 323          postprocess itr
 324
 325 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
 326                                                ⇒ Context h
 327                                                → Interaction
 328                                                → Lazy.ByteString
 329                                                → Int
 330                                                → IO ()
 331 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
 332     = join $
 333       atomically $
 334       do req ← takeTMVar itrReceiveBodyReq
 335          case req of
 336            ReceiveBody wanted
 337                → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
 338                     return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
 339            WasteAll
 340                → do putTMVar itrSendContinue False
 341                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 342
 343 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
 344                                 ⇒ Context h
 345                                 → Interaction
 346                                 → Lazy.ByteString
 347                                 → Int
 348                                 → IO ()
 349 waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
 350     = do req ← atomically $ takeTMVar itrReceiveBodyReq
 351          case req of
 352            ReceiveBody wanted
 353                → readNonChunkedRequestBody ctx itr input bodyLen wanted
 354            WasteAll
 355                → wasteNonChunkedRequestBody ctx input bodyLen
 356
 357 wasteNonChunkedRequestBody ∷ HandleLike h
 358                            ⇒ Context h
 359                            → Lazy.ByteString
 360                            → Int
 361                            → IO ()
 362 wasteNonChunkedRequestBody ctx input bodyLen
 363     = do let input' = Lazy.drop (fromIntegral bodyLen) input
 364          acceptRequest ctx input'
 365
 366 readNonChunkedRequestBody ∷ HandleLike h
 367                           ⇒ Context h
 368                           → Interaction
 369                           → Lazy.ByteString
 370                           → Int
 371                           → Int
 372                           → IO ()
 373 readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
 374     | bodyLen ≡ 0 = gotEndOfRequest
 375     | otherwise   = gotBody
 376     where
 377       gotBody ∷ IO ()
 378       gotBody
 379           = do let bytesToRead     = min wanted bodyLen
 380                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 381                    block'          = Strict.concat $ Lazy.toChunks block
 382                    actualReadBytes = Strict.length block'
 383                    bodyLen'        = bodyLen - actualReadBytes
 384                atomically $ putTMVar itrReceivedBody block'
 385                waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
 386
 387       gotEndOfRequest ∷ IO ()
 388       gotEndOfRequest
 389           = do atomically $ putTMVar itrReceivedBody (∅)
 390                acceptRequest ctx input
 391
 392 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
 393 enqueue (Context {..}) itr
 394     = do queue ← readTVar cQueue
 395          writeTVar cQueue (itr ⊲ queue)