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