Network/HTTP/Lucu/Resource.hs

   1 module Network.HTTP.Lucu.Resource
   2     ( ResourceDef(..)
   3     , Resource
   4     , ResTree
   5     , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
   6     , findResource -- ResTree -> URI -> Maybe ResourceDef
   7     , runResource  -- ResourceDef -> Interaction -> IO ThreadId
   8
   9     , getMethod -- Resource Method
  10     , getHeader -- String -> Resource (Maybe String)
  11
  12     , foundEntity    -- Bool -> String -> ClockTime -> Resource ()
  13     , foundETag      -- Bool -> String -> Resource ()
  14     , foundTimeStamp -- ClockTime -> Resource ()
  15     , foundNoEntity  -- Maybe String -> Resource ()
  16
  17     , input        -- Int -> Resource String
  18     , inputChunk   -- Int -> Resource String
  19     , inputBS      -- Int -> Resource ByteString
  20     , inputChunkBS -- Int -> Resource ByteString
  21     , defaultLimit -- Int
  22
  23     , setStatus -- StatusCode -> Resource ()
  24     , setHeader -- String -> String -> Resource ()
  25     , redirect  -- StatusCode -> URI -> Resource ()
  26     , setETag   -- Bool -> String -> Resource ()
  27     , setLastModified -- ClockTime -> Resource ()
  28
  29     , output        -- String -> Resource ()
  30     , outputChunk   -- String -> Resource ()
  31     , outputBS      -- ByteString -> Resource ()
  32     , outputChunkBS -- ByteString -> Resource ()
  33     )
  34     where
  35
  36 import           Control.Concurrent
  37 import           Control.Concurrent.STM
  38 import           Control.Exception
  39 import           Control.Monad.Reader
  40 import qualified Data.ByteString.Lazy.Char8 as B
  41 import           Data.ByteString.Lazy.Char8 (ByteString)
  42 import           Data.Dynamic
  43 import           Data.List
  44 import qualified Data.Map as M
  45 import           Data.Map (Map)
  46 import           Data.Maybe
  47 import           GHC.Conc (unsafeIOToSTM)
  48 import           Network.HTTP.Lucu.Abortion
  49 import           Network.HTTP.Lucu.Config
  50 import           Network.HTTP.Lucu.DefaultPage
  51 import           Network.HTTP.Lucu.ETag
  52 import qualified Network.HTTP.Lucu.Headers as H
  53 import           Network.HTTP.Lucu.HttpVersion
  54 import           Network.HTTP.Lucu.Interaction
  55 import           Network.HTTP.Lucu.Parser
  56 import           Network.HTTP.Lucu.Postprocess
  57 import           Network.HTTP.Lucu.RFC1123DateTime
  58 import           Network.HTTP.Lucu.Request
  59 import           Network.HTTP.Lucu.Response
  60 import           Network.HTTP.Lucu.Utils
  61 import           Network.URI
  62 import           Prelude hiding (catch)
  63 import           System.IO
  64 import           System.IO.Error hiding (catch)
  65 import           System.Time
  66
  67
  68 type Resource a = ReaderT Interaction IO a
  69
  70
  71 {- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
  72    れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
  73    /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
  74    される。 -}
  75 data ResourceDef = ResourceDef {
  76       resUsesNativeThread :: Bool
  77     , resIsGreedy         :: Bool
  78     , resGet              :: Maybe (Resource ())
  79     , resHead             :: Maybe (Resource ())
  80     , resPost             :: Maybe (Resource ())
  81     , resPut              :: Maybe (Resource ())
  82     , resDelete           :: Maybe (Resource ())
  83     }
  84 type ResTree    = ResNode -- root だから Map ではない
  85 type ResSubtree = Map String ResNode
  86 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
  87
  88
  89 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
  90 mkResTree list = processRoot list
  91     where
  92       processRoot :: [ ([String], ResourceDef) ] -> ResTree
  93       processRoot list
  94           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
  95                 children = processNonRoot nonRoots
  96             in
  97               if null roots then
  98                   -- / にリソースが定義されない。/foo とかにはあるかも。
  99                   ResNode Nothing children
 100               else
 101                   -- / がある。
 102                   let (_, def) = last roots
 103                   in
 104                     ResNode (Just def) children
 105
 106       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
 107       processNonRoot list
 108           = let subtree    = M.fromList [(name, node name)
 109                                              | name <- childNames]
 110                 childNames = [name | (name:_, _) <- list]
 111                 node name  = let defs = [def | (path, def) <- list, path == [name]]
 112                              in
 113                                if null defs then
 114                                    -- この位置にリソースが定義されない。
 115                                    -- もっと下にはあるかも。
 116                                    ResNode Nothing children
 117                                else
 118                                    -- この位置にリソースがある。
 119                                    ResNode (Just $ last defs) children
 120                 children   = processNonRoot [(path, def)
 121                                                  | (_:path, def) <- list, not (null path)]
 122             in
 123               subtree
 124
 125
 126 findResource :: ResTree -> URI -> Maybe ResourceDef
 127 findResource (ResNode rootDefM subtree) uri
 128     = let pathStr = uriPath uri
 129           path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
 130       in
 131         if null path then
 132             rootDefM
 133         else
 134             walkTree subtree path
 135     where
 136       walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
 137
 138       walkTree subtree (name:[])
 139           = case M.lookup name subtree of
 140               Nothing               -> Nothing
 141               Just (ResNode defM _) -> defM
 142
 143       walkTree subtree (x:xs)
 144           = case M.lookup x subtree of
 145               Nothing                      -> Nothing
 146               Just (ResNode defM children) -> case defM of
 147                                                 Just (ResourceDef { resIsGreedy = True })
 148                                                     -> defM
 149                                                 _   -> walkTree children xs
 150
 151
 152 runResource :: ResourceDef -> Interaction -> IO ThreadId
 153 runResource def itr
 154     = fork
 155       $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
 156                                 driftTo Done
 157                            ) itr
 158               )
 159       $ \ exc -> processException (itrConfig itr) exc
 160     where
 161       fork :: IO () -> IO ThreadId
 162       fork = if (resUsesNativeThread def)
 163              then forkOS
 164              else forkIO
 165
 166       rsrc :: Maybe (Resource ())
 167       rsrc = case reqMethod $ fromJust $ itrRequest itr of
 168                GET    -> resGet def
 169                HEAD   -> case resHead def of
 170                            Just r  -> Just r
 171                            Nothing -> resGet def
 172                POST   -> resPost def
 173                PUT    -> resPut def
 174                DELETE -> resDelete def
 175
 176       notAllowed :: Resource ()
 177       notAllowed = do setStatus MethodNotAllowed
 178                       setHeader "Allow" $ joinWith ", " allowedMethods
 179
 180       allowedMethods :: [String]
 181       allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
 182                                            , methods resHead   ["GET", "HEAD"]
 183                                            , methods resPost   ["POST"]
 184                                            , methods resPut    ["PUT"]
 185                                            , methods resDelete ["DELETE"]
 186                                            ]
 187
 188       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 189       methods f xs = case f def of
 190                        Just _  -> xs
 191                        Nothing -> []
 192
 193       processException :: Config -> Exception -> IO ()
 194       processException conf exc
 195           = do let abo = case exc of
 196                            ErrorCall    msg  -> Abortion InternalServerError [] msg
 197                            IOException  ioE  -> Abortion InternalServerError [] $ formatIOE ioE
 198                            DynException dynE -> case fromDynamic dynE of
 199                                                   Just (abo :: Abortion) -> abo
 200                                                   Nothing
 201                                                       -> Abortion InternalServerError []
 202                                                          $ show exc
 203                            _                 -> Abortion InternalServerError [] $ show exc
 204                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 205                -- を應答に反映させる餘地がある。さうでなければ stderr
 206                -- にでも吐くしか無い。
 207                state <- atomically $ readItr itr itrState id
 208                if state <= DecidingHeader then
 209                    flip runReaderT itr
 210                       $ do setStatus $ aboStatus abo
 211                            -- FIXME: 同じ名前で複數の値があった時は、こ
 212                            -- れではまずいと思ふ。
 213                            mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
 214                            setHeader "Content-Type" "application/xhtml+xml"
 215                            output $ aboPage conf abo
 216                  else
 217                    hPutStrLn stderr $ show abo
 218
 219                flip runReaderT itr $ driftTo Done
 220
 221       formatIOE :: IOError -> String
 222       formatIOE ioE = if isUserError ioE then
 223                           ioeGetErrorString ioE
 224                       else
 225                           show ioE
 226
 227
 228 getMethod :: Resource Method
 229 getMethod = do itr <- ask
 230                return $ reqMethod $ fromJust $ itrRequest itr
 231
 232
 233 getHeader :: String -> Resource (Maybe String)
 234 getHeader name = do itr <- ask
 235                     return $ H.getHeader name $ fromJust $ itrRequest itr
 236
 237
 238 {- ExaminingRequest 時に使用するアクション群 -}
 239
 240 foundEntity :: Bool -> String -> ClockTime -> Resource ()
 241 foundEntity isWeak token timeStamp
 242     = do driftTo ExaminingRequest
 243
 244          method <- getMethod
 245          when (method == GET || method == HEAD)
 246                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 247          foundETag isWeak token
 248
 249          driftTo GettingBody
 250
 251
 252 foundETag :: Bool -> String -> Resource ()
 253 foundETag isWeak token
 254     = do driftTo ExaminingRequest
 255
 256          let tag = mkETag isWeak token
 257
 258          method <- getMethod
 259          when (method == GET || method == HEAD)
 260                   $ setHeader' "ETag" $ show tag
 261
 262          -- If-Match があればそれを見る。
 263          ifMatch <- getHeader "If-Match"
 264          case ifMatch of
 265            Nothing   -> return ()
 266            Just "*"  -> return ()
 267            Just list -> case parseStr eTagListP list of
 268                           (Success tags, _)
 269                               -- tags の中に一致するものが無ければ
 270                               -- PreconditionFailed で終了。
 271                               -> when (not $ any (== tag) tags)
 272                                  $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list)
 273                           _   -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch)
 274
 275          let statusForNoneMatch = if method == GET || method == HEAD then
 276                                       NotModified
 277                                   else
 278                                       PreconditionFailed
 279
 280          -- If-None-Match があればそれを見る。
 281          ifNoneMatch <- getHeader "If-None-Match"
 282          case ifNoneMatch of
 283            Nothing   -> return ()
 284            Just "*"  -> abort statusForNoneMatch [] ("The entity tag matches: *")
 285            Just list -> case parseStr eTagListP list of
 286                           (Success tags, _)
 287                               -> when (any (== tag) tags)
 288                                  $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list)
 289                           _   -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list)
 290
 291          driftTo GettingBody
 292
 293
 294 foundTimeStamp :: ClockTime -> Resource ()
 295 foundTimeStamp timeStamp
 296     = do driftTo ExaminingRequest
 297
 298          method <- getMethod
 299          when (method == GET || method == HEAD)
 300                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 301
 302          let statusForIfModSince = if method == GET || method == HEAD then
 303                                        NotModified
 304                                    else
 305                                        PreconditionFailed
 306
 307          -- If-Modified-Since があればそれを見る。
 308          ifModSince <- getHeader "If-Modified-Since"
 309          case ifModSince of
 310            Just str -> case parseHTTPDateTime str of
 311                          Just lastTime
 312                              -> when (timeStamp <= lastTime)
 313                                 $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str)
 314                          Nothing
 315                              -> return () -- 不正な時刻は無視
 316            Nothing  -> return ()
 317
 318          -- If-Unmodified-Since があればそれを見る。
 319          ifUnmodSince <- getHeader "If-Unmodified-Since"
 320          case ifUnmodSince of
 321            Just str -> case parseHTTPDateTime str of
 322                          Just lastTime
 323                              -> when (timeStamp > lastTime)
 324                                 $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str)
 325                          Nothing
 326                              -> return () -- 不正な時刻は無視
 327            Nothing  -> return ()
 328
 329          driftTo GettingBody
 330
 331
 332 foundNoEntity :: Maybe String -> Resource ()
 333 foundNoEntity msgM
 334     = do driftTo ExaminingRequest
 335
 336          let msg = fromMaybe "The requested entity was not found in this server." msgM
 337
 338          method <- getMethod
 339          when (method /= PUT)
 340               $ abort NotFound [] msg
 341
 342          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 343          -- If-Match: 條件も滿たさない。
 344          ifMatch <- getHeader "If-Match"
 345          when (ifMatch /= Nothing)
 346                   $ abort PreconditionFailed [] msg
 347
 348          driftTo GettingBody
 349
 350
 351 {- GettingBody 時に使用するアクション群 -}
 352
 353 input :: Int -> Resource String
 354 input limit = inputBS limit >>= return . B.unpack
 355
 356
 357 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
 358 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
 359 inputBS :: Int -> Resource ByteString
 360 inputBS limit
 361     = do driftTo GettingBody
 362          itr     <- ask
 363          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 364          chunk   <- if hasBody then
 365                         askForInput itr
 366                     else
 367                         do driftTo DecidingHeader
 368                            return B.empty
 369          return chunk
 370     where
 371       askForInput :: Interaction -> Resource ByteString
 372       askForInput itr
 373           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 374                    actualLimit  = if limit <= 0 then
 375                                       defaultLimit
 376                                   else
 377                                       limit
 378                when (actualLimit <= 0)
 379                         $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
 380                -- Reader にリクエスト
 381                liftIO $ atomically
 382                           $ do chunkLen <- readItr itr itrReqChunkLength id
 383                                writeItr itr itrWillReceiveBody True
 384                                if fmap (> actualLimit) chunkLen == Just True then
 385                                    -- 受信前から多過ぎる事が分かってゐる
 386                                    tooLarge actualLimit
 387                                  else
 388                                    writeItr itr itrReqBodyWanted $ Just actualLimit
 389                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 390                chunk <- liftIO $ atomically
 391                         $ do chunk       <- readItr itr itrReceivedBody id
 392                              chunkIsOver <- readItr itr itrReqChunkIsOver id
 393                              if B.length chunk < fromIntegral actualLimit then
 394                                  -- 要求された量に滿たなくて、まだ殘り
 395                                  -- があるなら再試行。
 396                                  unless chunkIsOver
 397                                             $ retry
 398                                else
 399                                  -- 制限値一杯まで讀むやうに指示したの
 400                                  -- にまだ殘ってゐるなら、それは多過ぎ
 401                                  -- る。
 402                                  unless chunkIsOver
 403                                             $ tooLarge actualLimit
 404                              -- 成功。itr 内にチャンクを置いたままにす
 405                              -- るとメモリの無駄になるので除去。
 406                              writeItr itr itrReceivedBody B.empty
 407                              return chunk
 408                driftTo DecidingHeader
 409                return chunk
 410
 411       tooLarge :: Int -> STM ()
 412       tooLarge lim = abortSTM RequestEntityTooLarge []
 413                      ("Request body must be smaller than "
 414                       ++ show lim ++ " bytes.")
 415
 416
 417 inputChunk :: Int -> Resource String
 418 inputChunk limit = inputChunkBS limit >>= return . B.unpack
 419
 420
 421 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
 422 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
 423 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
 424 inputChunkBS :: Int -> Resource ByteString
 425 inputChunkBS limit
 426     = do driftTo GettingBody
 427          itr <- ask
 428          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 429          chunk   <- if hasBody then
 430                         askForInput itr
 431                     else
 432                         do driftTo DecidingHeader
 433                            return B.empty
 434          return chunk
 435     where
 436       askForInput :: Interaction -> Resource ByteString
 437       askForInput itr
 438           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 439                    actualLimit  = if limit < 0 then
 440                                       defaultLimit
 441                                   else
 442                                       limit
 443                when (actualLimit <= 0)
 444                         $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
 445                -- Reader にリクエスト
 446                liftIO $ atomically
 447                           $ do writeItr itr itrReqBodyWanted $ Just actualLimit
 448                                writeItr itr itrWillReceiveBody True
 449                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 450                chunk <- liftIO $ atomically
 451                         $ do chunk <- readItr itr itrReceivedBody id
 452                              -- 要求された量に滿たなくて、まだ殘りがあ
 453                              -- るなら再試行。
 454                              when (B.length chunk < fromIntegral actualLimit)
 455                                       $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
 456                                            unless chunkIsOver
 457                                                       $ retry
 458                              -- 成功
 459                              writeItr itr itrReceivedBody B.empty
 460                              return chunk
 461                when (B.null chunk)
 462                         $ driftTo DecidingHeader
 463                return chunk
 464
 465
 466 defaultLimit :: Int
 467 defaultLimit = (-1)
 468
 469
 470
 471 {- DecidingHeader 時に使用するアクション群 -}
 472
 473 setStatus :: StatusCode -> Resource ()
 474 setStatus code
 475     = do driftTo DecidingHeader
 476          itr <- ask
 477          liftIO $ atomically $ updateItr itr itrResponse
 478                     $ \ resM -> case resM of
 479                                   Nothing  -> Just $ Response {
 480                                                 resVersion = HttpVersion 1 1
 481                                               , resStatus  = code
 482                                               , resHeaders = []
 483                                               }
 484                                   Just res -> Just $ res {
 485                                                 resStatus = code
 486                                               }
 487
 488
 489 setHeader :: String -> String -> Resource ()
 490 setHeader name value
 491     = driftTo DecidingHeader >> setHeader' name value
 492
 493
 494 setHeader' :: String -> String -> Resource()
 495 setHeader' name value
 496     = do itr <- ask
 497          liftIO $ atomically $ updateItr itr itrResponse
 498                     $ \ resM -> case resM of
 499                                   Nothing  -> Just $ Response {
 500                                                 resVersion = HttpVersion 1 1
 501                                               , resStatus  = Ok
 502                                               , resHeaders = [ (name, value) ]
 503                                               }
 504                                   Just res -> Just $ H.setHeader name value res
 505
 506
 507 redirect :: StatusCode -> URI -> Resource ()
 508 redirect code uri
 509     = do when (code == NotModified || not (isRedirection code))
 510                   $ abort InternalServerError []
 511                         $ "Attempted to redirect with status " ++ show code
 512          setStatus code
 513          setHeader "Location" (uriToString id uri $ "")
 514
 515
 516 setETag :: Bool -> String -> Resource ()
 517 setETag isWeak token
 518     = setHeader "ETag" $ show $ mkETag isWeak token
 519
 520
 521 setLastModified :: ClockTime -> Resource ()
 522 setLastModified lastmod
 523     = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
 524
 525
 526 {- DecidingBody 時に使用するアクション群 -}
 527
 528 output :: String -> Resource ()
 529 output = outputBS . B.pack
 530
 531
 532 outputBS :: ByteString -> Resource ()
 533 outputBS str = do outputChunkBS str
 534                   driftTo Done
 535
 536
 537 outputChunk :: String -> Resource ()
 538 outputChunk = outputChunkBS . B.pack
 539
 540
 541 outputChunkBS :: ByteString -> Resource ()
 542 outputChunkBS str = do driftTo DecidingBody
 543                        itr <- ask
 544                        liftIO $ atomically $
 545                               do updateItr itr itrBodyToSend (flip B.append str)
 546                                  unless (B.null str)
 547                                             $ writeItr itr itrBodyIsNull False
 548
 549
 550 {-
 551
 552   [GettingBody からそれ以降の状態に遷移する時]
 553
 554   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 555
 556
 557   [DecidingHeader からそれ以降の状態に遷移する時]
 558
 559   postprocess する。
 560
 561
 562   [Done に遷移する時]
 563
 564   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 565   る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK
 566   だった場合は、補完の代はりに 204 No Content に變へる。
 567
 568 -}
 569
 570 driftTo :: InteractionState -> Resource ()
 571 driftTo newState
 572     = do itr <- ask
 573          liftIO $ atomically $ do oldState <- readItr itr itrState id
 574                                   if newState < oldState then
 575                                       throwStateError oldState newState
 576                                     else
 577                                       do let a = [oldState .. newState]
 578                                              b = tail a
 579                                              c = zip a b
 580                                          mapM_ (uncurry $ drift itr) c
 581                                          writeItr itr itrState newState
 582     where
 583       throwStateError :: Monad m => InteractionState -> InteractionState -> m a
 584
 585       throwStateError Done DecidingBody
 586           = fail "It makes no sense to output something after finishing to output."
 587
 588       throwStateError old new
 589           = fail ("state error: " ++ show old ++ " ==> " ++ show new)
 590
 591
 592       drift :: Interaction -> InteractionState -> InteractionState -> STM ()
 593
 594       drift itr GettingBody _
 595           = writeItr itr itrReqBodyWasteAll True
 596
 597       drift itr DecidingHeader _
 598           = postprocess itr
 599
 600       drift itr _ Done
 601           = do bodyIsNull <- readItr itr itrBodyIsNull id
 602                when bodyIsNull
 603                         $ do status <- readStatus itr
 604                              if status == Ok then
 605                                  do updateItrF itr itrResponse
 606                                                    $ \ res -> res { resStatus = NoContent }
 607                                     updateItrF itr itrResponse
 608                                                    $ H.deleteHeader "Content-Type"
 609                                     updateItrF itr itrResponse
 610                                                    $ H.deleteHeader "ETag"
 611                                     updateItrF itr itrResponse
 612                                                    $ H.deleteHeader "Last-Modified"
 613                                else
 614                                  writeDefaultPage itr
 615
 616
 617       drift _ _ _
 618           = return ()
 619
 620
 621       readStatus :: Interaction -> STM StatusCode
 622       readStatus itr = readItr itr itrResponse (resStatus . fromJust)