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 wantedM ← readTVar $ itrReqBodyWanted itr
 189                 case wantedM of
 190                   Nothing
 191                       → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
 192                            if wasteAll then
 193                                return $ wasteCurrentChunk ctx itr input remaining
 194                            else
 195                                retry
 196                   Just wanted
 197                       → return $ readCurrentChunk ctx itr input wanted remaining
 198
 199 wasteCurrentChunk ∷ HandleLike h
 200                   ⇒ Context h
 201                   → Interaction
 202                   → Lazy.ByteString
 203                   → Int
 204                   → IO ()
 205 wasteCurrentChunk ctx itr input len
 206     | len > 0
 207         = let input' = Lazy.drop (fromIntegral len) input
 208           in
 209             case LP.parse chunkFooterP input' of
 210               LP.Done input'' _
 211                   → observeChunkedRequest ctx itr input'' 0
 212               LP.Fail _ _ _
 213                   → chunkWasMalformed itr
 214     | otherwise
 215         = seekNextChunk ctx itr input
 216
 217 readCurrentChunk ∷ HandleLike h
 218                  ⇒ Context h
 219                  → Interaction
 220                  → Lazy.ByteString
 221                  → Int
 222                  → Int
 223                  → IO ()
 224 readCurrentChunk ctx itr input wanted remaining
 225     | remaining > 0
 226         = do let bytesToRead     = fromIntegral $ min wanted remaining
 227                  (chunk, input') = Lazy.splitAt bytesToRead input
 228                  actualReadBytes = fromIntegral $ Lazy.length chunk
 229                  newWanted       = case wanted - actualReadBytes of
 230                                      0 → Nothing
 231                                      n → Just n
 232                  newRemaining    = remaining - actualReadBytes
 233                  chunk'          = S.fromList $ Lazy.toChunks chunk
 234                  updateStates    = atomically $
 235                                    do writeTVar (itrReqBodyWanted itr) newWanted
 236                                       oldBody    ← readTVar $ itrReceivedBody    itr
 237                                       oldBodyLen ← readTVar $ itrReceivedBodyLen itr
 238                                       writeTVar (itrReceivedBody    itr) $ oldBody ⋈ chunk'
 239                                       writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
 240              if newRemaining ≡ 0 then
 241                  case LP.parse chunkFooterP input' of
 242                    LP.Done input'' _
 243                        → do updateStates
 244                             observeChunkedRequest ctx itr input'' 0
 245                    LP.Fail _ _ _
 246                        → chunkWasMalformed itr
 247              else
 248                  do updateStates
 249                     observeChunkedRequest ctx itr input' newRemaining
 250     | otherwise
 251         = seekNextChunk ctx itr input
 252
 253 seekNextChunk ∷ HandleLike h
 254               ⇒ Context h
 255               → Interaction
 256               → Lazy.ByteString
 257               → IO ()
 258 seekNextChunk ctx itr input
 259     = case LP.parse chunkHeaderP input of
 260         LP.Done input' len
 261             | len ≡ 0 -- Final chunk
 262                 → case LP.parse chunkTrailerP input' of
 263                      LP.Done input'' _
 264                          → do atomically $
 265                                   writeTVar (itrReqChunkIsOver itr) True
 266                               acceptRequest ctx input''
 267                      LP.Fail _ _ _
 268                          → chunkWasMalformed itr
 269             | otherwise -- Non-final chunk
 270                 → observeChunkedRequest ctx itr input' len
 271         LP.Fail _ _ _
 272                 → chunkWasMalformed itr
 273
 274 chunkWasMalformed ∷ Interaction → IO ()
 275 chunkWasMalformed itr
 276     = atomically $
 277       do setResponseStatus itr BadRequest
 278          writeTVar (itrWillClose itr) True
 279          writeTVar (itrState     itr) Done
 280          writeDefaultPage itr
 281          postprocess itr
 282
 283 observeNonChunkedRequest ∷ HandleLike h
 284                          ⇒ Context h
 285                          → Interaction
 286                          → Lazy.ByteString
 287                          → Int
 288                          → IO ()
 289 observeNonChunkedRequest ctx itr input remaining
 290     = join $
 291       atomically $
 292       do wantedM ← readTVar $ itrReqBodyWanted itr
 293          case wantedM of
 294            Nothing
 295                → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
 296                     if wasteAll then
 297                         return $ wasteNonChunkedRequestBody ctx itr input remaining
 298                     else
 299                         retry
 300            Just wanted
 301                → return $ readNonChunkedRequestBody ctx itr input wanted remaining
 302
 303 wasteNonChunkedRequestBody ∷ HandleLike h
 304                            ⇒ Context h
 305                            → Interaction
 306                            → Lazy.ByteString
 307                            → Int
 308                            → IO ()
 309 wasteNonChunkedRequestBody ctx itr input remaining
 310     = do let input' = Lazy.drop (fromIntegral remaining) input
 311          atomically $ writeTVar (itrReqChunkIsOver itr) True
 312          acceptRequest ctx input'
 313
 314 readNonChunkedRequestBody ∷ HandleLike h
 315                           ⇒ Context h
 316                           → Interaction
 317                           → Lazy.ByteString
 318                           → Int
 319                           → Int
 320                           → IO ()
 321 readNonChunkedRequestBody ctx itr input wanted remaining
 322     = do let bytesToRead     = min wanted remaining
 323              (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
 324              actualReadBytes = fromIntegral $ Lazy.length chunk
 325              newRemaining    = remaining - actualReadBytes
 326              isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
 327              chunk'          = S.fromList $ Lazy.toChunks chunk
 328          atomically $
 329              do writeTVar (itrReqChunkIsOver  itr) isOver
 330                 writeTVar (itrReqBodyWanted   itr) Nothing
 331                 writeTVar (itrReceivedBody    itr) chunk'
 332                 writeTVar (itrReceivedBodyLen itr) actualReadBytes
 333          if isOver then
 334              acceptRequest ctx input'
 335          else
 336              observeNonChunkedRequest ctx itr input' newRemaining
 337
 338 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
 339 enqueue (Context {..}) itr
 340     = do queue ← readTVar cQueue
 341          writeTVar cQueue (itr ⊲ queue)