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