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           Network.HTTP.Lucu.Config
  21 import           Network.HTTP.Lucu.Chunk
  22 import           Network.HTTP.Lucu.DefaultPage
  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 req input'
  80            LP.Fail _ _ _      → acceptNonparsableRequest ctx BadRequest
  81
  82 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
  83 acceptNonparsableRequest (Context {..}) status
  84     = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing
  85          atomically $
  86              do setResponseStatus itr status
  87                 writeTVar (itrWillClose itr) True
  88                 writeTVar (itrState     itr) Done
  89                 writeDefaultPage itr
  90                 postprocess itr
  91                 enqueue itr
  92
  93 acceptParsableRequest ∷ HandleLike h
  94                       ⇒ Context h
  95                       → Request
  96                       → Lazy.ByteString
  97                       → IO ()
  98 acceptParsableRequest (Context {..}) req input
  99     = do cert ← hGetPeerCert cHandle
 100          itr  ← newInteraction cConfig cPort cAddr cert (Right req)
 101          join $ atomically
 102               $ do preprocess itr
 103                    isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
 104                    if isErr then
 105                        acceptSemanticallyInvalidRequest itr input
 106                    else
 107                        acceptSemanticallyValidRequest itr (reqURI req) input
 108
 109 acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ())
 110 acceptSemanticallyInvalidRequest itr input
 111     = do writeTVar (itr itrState) Done
 112          writeDefaultPage itr
 113          postprocess itr
 114          enqueue itr
 115          return $ acceptRequest input
 116
 117 acceptSemanticallyValidRequest ∷ HandleLike h
 118                                ⇒ Context h
 119                                → Interaction
 120                                → URI
 121                                → Lazy.ByteString
 122                                → IO ()
 123 acceptSemanticallyValidRequest (Context {..}) itr uri input
 124     = do rsrcM ← findResource cResTree cFallbacks uri
 125          case rsrcM of
 126            Nothing
 127                → acceptRequestForNonexistentResource itr input
 128            Just (rsrcPath, rsrcDef)
 129                → acceptRequestForExistentResource itr input rsrcPath rsrcDef
 130
 131 acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ())
 132 acceptRequestForNonexistentResource itr input
 133     = do setResponseStatus itr NotFound
 134          writeTVar (itrState itr) Done
 135          writeDefaultPage itr
 136          postprocess itr
 137          enqueue itr
 138          return $ acceptRequest input
 139
 140 acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ())
 141 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
 142     = do let itr = oldItr { itrResourcePath = Just rsrcPath }
 143          enqueue itr
 144          return $ do _ ← runResource rsrcDef itr
 145                      if reqHasBody $ fromJust $ itrRequest itr then
 146                          observeRequest itr input
 147                      else
 148                          acceptRequest input
 149
 150 observeRequest ∷ Interaction → Lazy.ByteString → IO ()
 151 observeRequest itr input
 152     | itrReqBodyLength itr ≡ Just Chunked
 153         = observeChunkedRequest itr input
 154     | otherwise
 155         = observeNonChunkedRequest itr input
 156
 157 observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
 158 observeChunkedRequest itr input
 159     = join $
 160       atomically $
 161       do isOver ← readTVar $ itrReqChunkIsOver itr
 162          if isOver then
 163              return $ acceptRequest input
 164          else
 165              do wantedM ← readTVar $ itrReqBodyWanted itr
 166                 if isNothing wantedM then
 167                     do wasteAll ← readTVar $ itrReqBodyWasteAll itr
 168                        if wasteAll then
 169                            wasteCurrentChunk input
 170                        else
 171                            retry
 172                 else
 173                     readCurrentChunk (fromJust wantedM)
 174
 175 wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO ()
 176 wasteCurrentChunk itr input len
 177     | len > 0
 178         = let input' = Lazy.drop (fromIntegral len) input
 179           in
 180             case LP.parse chunkFooterP input' of
 181               LP.Done input'' _
 182                   → observeChunkedRequest itr input''
 183               LP.Fail _ _ _
 184                   → chunkWasMalformed itr
 185     | otherwise
 186         = seekNextChunk itr input
 187
 188 readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO ()
 189 readCurrentChunk itr input wanted remaining
 190     | remaining > 0
 191         = do let bytesToRead     = fromIntegral $ min wanted remaining
 192                  (chunk, input') = Lazy.splitAt bytesToRead input
 193                  actualReadBytes = fromIntegral $ Lazy.length chunk
 194                  newWanted       = case wanted - actualReadBytes of
 195                                      0 → Nothing
 196                                      n → Just n
 197                  newRemaining    = Just $ remaining - actualReadBytes
 198                  updateStates    = do writeTVar (itrReqBodyWanted itr) newWanted
 199                                       oldBody    ← readTVar $ itrReceivedBody    itr
 200                                       oldBodyLen ← readTVar $ itrReceivedBodyLen itr
 201                                       writeTVar (itrReceivedBody    itr) $ oldBody ⊳ chunk
 202                                       writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
 203              if newRemaining ≡ Just 0 then
 204                  case LP.parse chunkFooterP input' of
 205                    LP.Done input'' _
 206                        → do updateStates
 207                             observeChunkedRequest itr input''
 208                    LP.Fail _ _ _
 209                        → chunkWasMalformed itr
 210              else
 211                  do updateStates
 212                     observeChunkedRequest itr input'
 213     | otherwise
 214         = seekNextChunk itr input
 215
 216 seekNextChunk ∷ Interaction → Lazy.ByteString → IO ()
 217 seekNextChunk itr input
 218     = case LP.parse chunkHeaderP input of
 219         LP.Done input' len
 220             | len ≡ 0 -- Final chunk
 221                 → case LP.parse chunkTrailerP input' of
 222                      LP.Done input'' _
 223                          → do writeTVar (itrReqChunkIsOver itr) True
 224                               acceptRequest input''
 225                      LP.Fail _ _ _
 226                          → chunkWasMalformed itr
 227             | otherwise -- Non-final chunk
 228                 →  do observeChunkedRequest itr input'
 229         LP.Fail _ _ _
 230                 → chunkWasMalformed itr
 231
 232 chunkWasMalformed ∷ Interaction → IO ()
 233 chunkWasMalformed itr
 234     = atomically $
 235           do setResponseStatus BadRequest
 236              writeTVar (itrWillClose itr) True
 237              writeTVar (itrState     itr) Done
 238              writeDefaultPage itr
 239              postprocess itr
 240
 241 observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
 242 observeNonChunkedRequest itr input
 243     = join $
 244       atomically $
 245       do wantedM ← readTVar $ itrReqBodyWanted itr
 246          if isNothing wantedM then
 247              do wasteAll ← readTVar itr itrReqBodyWasteAll id
 248                 if wasteAll then
 249                     wasteNonChunkedRequestBody itr input
 250                 else
 251                     retry
 252          else
 253              readNonChunkedRequestBody itr input
 254
 255 wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO ()
 256 wasteNonChunkedRequestBody itr input remaining
 257     = do let input' = case remaining of
 258                         Just len → Lazy.drop len input
 259                         Nothing  → (∅)
 260          writeTVar (itrReqChunkIsOver itr) True
 261          acceptRequest input'
 262
 263 readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO ()
 264 readNonChunkedRequestBody itr input wanted remaining
 265     = do let bytesToRead     = fromIntegral $ maybe wanted (min wanted) remaining
 266              (chunk, input') = Lazy.splitAt bytesToRead input
 267              actualReadBytes = fromIntegral $ Lazy.length chunk
 268              newRemaining    = (- actualReadBytes) <$> remaining
 269              isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
 270          writeTVar (itrReqChunkIsOver  itr) isOver
 271          writeTVar (itrReqBodyWanted   itr) Nothing
 272          writeTVar (itrReceivedBody    itr) chunk
 273          writeTVar (itrReceivedBodyLen itr) actualReadBytes
 274          if isOver then
 275              acceptRequest input'
 276          else
 277              observeNonChunkedRequest itr input'
 278
 279 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
 280 enqueue (Context {..}) itr
 281     = do queue ← readTVar cQueue
 282          writeTVar cQueue (itr ⊲ queue)