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