Network/HTTP/Lucu/RequestReader.hs

   1 module Network.HTTP.Lucu.RequestReader
   2     ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
   3     )
   4     where
   5
   6 import           Control.Concurrent.STM
   7 import           Control.Exception
   8 import           Control.Monad
   9 import qualified Data.ByteString.Lazy.Char8 as B
  10 import           Data.ByteString.Lazy.Char8 (ByteString)
  11 import           Data.Map as M
  12 import           Data.Map (Map)
  13 import           Data.Maybe
  14 import qualified Data.Sequence as S
  15 import           Data.Sequence (Seq, (<|), ViewR(..))
  16 import           Network
  17 import           Network.HTTP.Lucu.Config
  18 import           Network.HTTP.Lucu.DefaultPage
  19 import           Network.HTTP.Lucu.HttpVersion
  20 import           Network.HTTP.Lucu.Interaction
  21 import           Network.HTTP.Lucu.Parser
  22 import           Network.HTTP.Lucu.Postprocess
  23 import           Network.HTTP.Lucu.Preprocess
  24 import           Network.HTTP.Lucu.Request
  25 import           Network.HTTP.Lucu.Response
  26 import           Network.HTTP.Lucu.Resource
  27 import           Prelude hiding (catch)
  28 import           System.IO
  29
  30 import GHC.Conc (unsafeIOToSTM)
  31
  32 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
  33 requestReader cnf tree h host tQueue
  34     = do catch (do input <- B.hGetContents h
  35                    acceptRequest input) $ \ exc ->
  36              case exc of
  37                IOException _               -> return ()
  38                AsyncException ThreadKilled -> return ()
  39                BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
  40                _                           -> print exc
  41     where
  42       acceptRequest :: ByteString -> IO ()
  43       acceptRequest input
  44           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
  45           -- 時は、それが限度以下になるまで待つ。
  46           = do atomically $ do queue    <- readTVar tQueue
  47                                when (S.length queue >= cnfMaxPipelineDepth cnf)
  48                                     retry
  49
  50                -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  51                -- Request 應答を設定し、それを出力してから切斷するやう
  52                -- に ResponseWriter に通知する。
  53                case parse requestP input of
  54                  (Success req , input') -> acceptParsableRequest req input'
  55                  (IllegalInput, _     ) -> acceptNonparsableRequest BadRequest
  56                  (ReachedEOF  , _     ) -> acceptNonparsableRequest BadRequest
  57
  58       acceptNonparsableRequest :: StatusCode -> IO ()
  59       acceptNonparsableRequest status
  60           = do itr <- newInteraction cnf host Nothing
  61                let res = Response {
  62                            resVersion = HttpVersion 1 1
  63                          , resStatus  = status
  64                          , resHeaders = []
  65
  66                          }
  67                atomically $ do writeItr itr itrResponse $ Just res
  68                                writeItr itr itrWillClose True
  69                                writeItr itr itrState     Done
  70                                writeDefaultPage itr
  71                                postprocess itr
  72                                enqueue itr
  73
  74       acceptParsableRequest :: Request -> ByteString -> IO ()
  75       acceptParsableRequest req input
  76           = do itr <- newInteraction cnf host (Just req)
  77                action
  78                    <- atomically $
  79                       do preprocess itr
  80                          isErr <- readItrF itr itrResponse (isError . resStatus)
  81                          if isErr == Just True then
  82                              acceptSemanticallyInvalidRequest itr input
  83                            else
  84                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
  85                                Nothing -- Resource が無かった
  86                                    -> acceptRequestForNonexistentResource itr input
  87
  88                                Just rsrcDef -- あった
  89                                    -> acceptRequestForExistentResource itr input rsrcDef
  90                action
  91
  92       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  93       acceptSemanticallyInvalidRequest itr input
  94           = do writeItr itr itrState Done
  95                writeDefaultPage itr
  96                postprocess itr
  97                enqueue itr
  98                return $ acceptRequest input
  99
 100       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
 101       acceptRequestForNonexistentResource itr input
 102           = do let res = Response {
 103                            resVersion = HttpVersion 1 1
 104                          , resStatus  = NotFound
 105                          , resHeaders = []
 106                          }
 107                writeItr itr itrResponse $ Just res
 108                writeItr itr itrState Done
 109                writeDefaultPage itr
 110                postprocess itr
 111                enqueue itr
 112                return $ acceptRequest input
 113
 114       acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
 115       acceptRequestForExistentResource itr input rsrcDef
 116           = do requestHasBody <- readItr itr itrRequestHasBody id
 117                writeItr itr itrState (if requestHasBody
 118                                       then ExaminingHeader
 119                                       else DecidingHeader)
 120                enqueue itr
 121                return $ do runResource rsrcDef itr
 122                            if requestHasBody then
 123                                observeRequest itr input
 124                              else
 125                                acceptRequest input
 126
 127       observeRequest :: Interaction -> ByteString -> IO ()
 128       observeRequest itr input
 129           = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 130                if isChunked then
 131                    observeChunkedRequest itr input
 132                  else
 133                    observeNonChunkedRequest itr input
 134
 135       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 136       observeChunkedRequest itr input
 137           = fail "FIXME: not implemented"
 138
 139       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 140       observeNonChunkedRequest itr input
 141           = do action
 142                    <- atomically $
 143                       do wantedM <- readItr itr itrReqBodyWanted id
 144                          if wantedM == Nothing then
 145                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 146                                 if wasteAll then
 147                                     -- 破棄要求が來た
 148                                     do remainingM <- readItr itr itrReqChunkRemaining id
 149
 150                                        let (_, input') = if remainingM == Nothing then
 151                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 152                                                          else
 153                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 154
 155                                        writeItr itr itrReqChunkRemaining $ Just 0
 156                                        writeItr itr itrReqChunkIsOver True
 157                                        writeItr itr itrReqBodyWanted Nothing
 158                                        writeItr itr itrReceivedBody B.empty
 159
 160                                        return $ acceptRequest input'
 161                                   else
 162                                     -- 要求がまだ来ない
 163                                     retry
 164                            else
 165                                -- 受信要求が來た
 166                                do remainingM <- readItr itr itrReqChunkRemaining id
 167
 168                                   let wanted = fromJust wantedM
 169                                       expectedChunkLen = fromIntegral $ maybe wanted (min wanted) remainingM
 170                                       (chunk, input')  = B.splitAt expectedChunkLen input
 171                                       newRemaining     = fmap
 172                                                          (\ x -> x - (fromIntegral $ B.length chunk))
 173                                                          remainingM
 174                                       isOver           = B.length chunk < expectedChunkLen
 175
 176                                   writeItr itr itrReqChunkRemaining newRemaining
 177                                   writeItr itr itrReqChunkIsOver isOver
 178                                   writeItr itr itrReqBodyWanted Nothing
 179                                   writeItr itr itrReceivedBody chunk
 180
 181                                   if isOver then
 182                                       return $ acceptRequest input'
 183                                     else
 184                                       return $ observeNonChunkedRequest itr input'
 185                action
 186
 187       enqueue :: Interaction -> STM ()
 188       enqueue itr = do queue <- readTVar tQueue
 189                        writeTVar tQueue (itr <| queue)