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     , input        -- Int -> Resource String
  10     , inputChunk   -- Int -> Resource String
  11     , inputBS      -- Int -> Resource ByteString
  12     , inputChunkBS -- Int -> Resource ByteString
  13     , defaultLimit -- Int
  14
  15     , setStatus -- StatusCode -> Resource ()
  16     , setHeader -- String -> String -> Resource ()
  17
  18     , redirect  -- StatusCode -> URI -> Resource ()
  19
  20     , output        -- String -> Resource ()
  21     , outputChunk   -- String -> Resource ()
  22     , outputBS      -- ByteString -> Resource ()
  23     , outputChunkBS -- ByteString -> Resource ()
  24     )
  25     where
  26
  27 import           Control.Concurrent
  28 import           Control.Concurrent.STM
  29 import           Control.Exception
  30 import           Control.Monad.Reader
  31 import qualified Data.ByteString.Lazy.Char8 as B
  32 import           Data.ByteString.Lazy.Char8 (ByteString)
  33 import           Data.Dynamic
  34 import           Data.List
  35 import qualified Data.Map as M
  36 import           Data.Map (Map)
  37 import           Data.Maybe
  38 import           GHC.Conc (unsafeIOToSTM)
  39 import           Network.HTTP.Lucu.Abortion
  40 import           Network.HTTP.Lucu.Config
  41 import           Network.HTTP.Lucu.DefaultPage
  42 import qualified Network.HTTP.Lucu.Headers as H
  43 import           Network.HTTP.Lucu.HttpVersion
  44 import           Network.HTTP.Lucu.Interaction
  45 import           Network.HTTP.Lucu.Postprocess
  46 import           Network.HTTP.Lucu.Request
  47 import           Network.HTTP.Lucu.Response
  48 import           Network.HTTP.Lucu.Utils
  49 import           Network.URI
  50 import           Prelude hiding (catch)
  51 import           System.IO
  52 import           System.IO.Error hiding (catch)
  53
  54
  55 type Resource a = ReaderT Interaction IO a
  56
  57
  58 {- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
  59    れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
  60    /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
  61    される。 -}
  62 data ResourceDef = ResourceDef {
  63       resUsesNativeThread :: Bool
  64     , resIsGreedy         :: Bool
  65     , resGet              :: Maybe (Resource ())
  66     , resHead             :: Maybe (Resource ())
  67     , resPost             :: Maybe (Resource ())
  68     , resPut              :: Maybe (Resource ())
  69     , resDelete           :: Maybe (Resource ())
  70     }
  71 type ResTree    = ResNode -- root だから Map ではない
  72 type ResSubtree = Map String ResNode
  73 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
  74
  75
  76 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
  77 mkResTree list = processRoot list
  78     where
  79       processRoot :: [ ([String], ResourceDef) ] -> ResTree
  80       processRoot list
  81           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
  82                 children = processNonRoot nonRoots
  83             in
  84               if null roots then
  85                   -- / にリソースが定義されない。/foo とかにはあるかも。
  86                   ResNode Nothing children
  87               else
  88                   -- / がある。
  89                   let (_, def) = last roots
  90                   in
  91                     ResNode (Just def) children
  92
  93       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
  94       processNonRoot list
  95           = let subtree    = M.fromList [(name, node name)
  96                                              | name <- childNames]
  97                 childNames = [name | (name:_, _) <- list]
  98                 node name  = let defs = [def | (path, def) <- list, path == [name]]
  99                              in
 100                                if null defs then
 101                                    -- この位置にリソースが定義されない。
 102                                    -- もっと下にはあるかも。
 103                                    ResNode Nothing children
 104                                else
 105                                    -- この位置にリソースがある。
 106                                    ResNode (Just $ last defs) children
 107                 children   = processNonRoot [(path, def)
 108                                                  | (_:path, def) <- list, not (null path)]
 109             in
 110               subtree
 111
 112
 113 findResource :: ResTree -> URI -> Maybe ResourceDef
 114 findResource (ResNode rootDefM subtree) uri
 115     = let pathStr = uriPath uri
 116           path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
 117       in
 118         if null path then
 119             rootDefM
 120         else
 121             walkTree subtree path
 122     where
 123       walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
 124
 125       walkTree subtree (name:[])
 126           = case M.lookup name subtree of
 127               Nothing               -> Nothing
 128               Just (ResNode defM _) -> defM
 129
 130       walkTree subtree (x:xs)
 131           = case M.lookup x subtree of
 132               Nothing                      -> Nothing
 133               Just (ResNode defM children) -> case defM of
 134                                                 Just (ResourceDef { resIsGreedy = True })
 135                                                     -> defM
 136                                                 _   -> walkTree children xs
 137
 138
 139 runResource :: ResourceDef -> Interaction -> IO ThreadId
 140 runResource def itr
 141     = fork
 142       $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
 143                                 driftTo Done
 144                            ) itr
 145               )
 146       $ \ exc -> processException (itrConfig itr) exc
 147     where
 148       fork :: IO () -> IO ThreadId
 149       fork = if (resUsesNativeThread def)
 150              then forkOS
 151              else forkIO
 152
 153       rsrc :: Maybe (Resource ())
 154       rsrc = case reqMethod $ fromJust $ itrRequest itr of
 155                GET    -> resGet def
 156                HEAD   -> case resHead def of
 157                            Just r  -> Just r
 158                            Nothing -> resGet def
 159                POST   -> resPost def
 160                PUT    -> resPut def
 161                DELETE -> resDelete def
 162
 163       notAllowed :: Resource ()
 164       notAllowed = do setStatus MethodNotAllowed
 165                       setHeader "Allow" $ joinWith ", " allowedMethods
 166
 167       allowedMethods :: [String]
 168       allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
 169                                            , methods resHead   ["GET", "HEAD"]
 170                                            , methods resPost   ["POST"]
 171                                            , methods resPut    ["PUT"]
 172                                            , methods resDelete ["DELETE"]
 173                                            ]
 174
 175       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 176       methods f xs = case f def of
 177                        Just _  -> xs
 178                        Nothing -> []
 179
 180       processException :: Config -> Exception -> IO ()
 181       processException conf exc
 182           = do let abo = case exc of
 183                            ErrorCall    msg  -> Abortion InternalServerError [] msg
 184                            IOException  ioE  -> Abortion InternalServerError [] $ formatIOE ioE
 185                            DynException dynE -> case fromDynamic dynE of
 186                                                   Just (abo :: Abortion) -> abo
 187                                                   Nothing
 188                                                       -> Abortion InternalServerError []
 189                                                          $ show exc
 190                            _                 -> Abortion InternalServerError [] $ show exc
 191                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 192                -- を應答に反映させる餘地がある。さうでなければ stderr
 193                -- にでも吐くしか無い。
 194                state <- atomically $ readItr itr itrState id
 195                if state <= DecidingHeader then
 196                    flip runReaderT itr
 197                       $ do setStatus $ aboStatus abo
 198                            -- FIXME: 同じ名前で複數の値があった時は、こ
 199                            -- れではまずいと思ふ。
 200                            mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
 201                            setHeader "Content-Type" "application/xhtml+xml"
 202                            output $ aboPage conf abo
 203                  else
 204                    hPutStrLn stderr $ show abo
 205
 206                flip runReaderT itr $ driftTo Done
 207
 208       formatIOE :: IOError -> String
 209       formatIOE ioE = if isUserError ioE then
 210                           ioeGetErrorString ioE
 211                       else
 212                           show ioE
 213
 214
 215 {- Resource モナド -}
 216
 217 input :: Int -> Resource String
 218 input limit = inputBS limit >>= return . B.unpack
 219
 220
 221 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
 222 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
 223 inputBS :: Int -> Resource ByteString
 224 inputBS limit
 225     = do driftTo GettingBody
 226          itr <- ask
 227          let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 228              actualLimit  = if limit <= 0 then
 229                                 defaultLimit
 230                             else
 231                                 limit
 232          when (actualLimit <= 0)
 233                   $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
 234          -- Reader にリクエスト
 235          liftIO $ atomically
 236                     $ do chunkLen <- readItr itr itrReqChunkLength id
 237                          writeItr itr itrWillReceiveBody True
 238                          if fmap (> actualLimit) chunkLen == Just True then
 239                              -- 受信前から多過ぎる事が分かってゐる
 240                              tooLarge actualLimit
 241                            else
 242                              writeItr itr itrReqBodyWanted $ Just actualLimit
 243          -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 244          chunk <- liftIO $ atomically
 245                   $ do chunk       <- readItr itr itrReceivedBody id
 246                        chunkIsOver <- readItr itr itrReqChunkIsOver id
 247                        if B.length chunk < fromIntegral actualLimit then
 248                            -- 要求された量に滿たなくて、まだ殘りがある
 249                            -- なら再試行。
 250                            unless chunkIsOver
 251                                       $ retry
 252                          else
 253                            -- 制限値一杯まで讀むやうに指示したのにまだ殘っ
 254                            -- てゐるなら、それは多過ぎる。
 255                            unless chunkIsOver
 256                                       $ tooLarge actualLimit
 257                        -- 成功。itr 内にチャンクを置いたままにするとメ
 258                        -- モリの無駄になるので除去。
 259                        writeItr itr itrReceivedBody B.empty
 260                        return chunk
 261          driftTo DecidingHeader
 262          return chunk
 263     where
 264       tooLarge :: Int -> STM ()
 265       tooLarge lim = abortSTM RequestEntityTooLarge []
 266                      ("Request body must be smaller than "
 267                       ++ show lim ++ " bytes.")
 268
 269
 270 inputChunk :: Int -> Resource String
 271 inputChunk limit = inputChunkBS limit >>= return . B.unpack
 272
 273
 274 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
 275 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
 276 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
 277 inputChunkBS :: Int -> Resource ByteString
 278 inputChunkBS limit
 279     = do driftTo GettingBody
 280          itr <- ask
 281          let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 282              actualLimit  = if limit < 0 then
 283                                 defaultLimit
 284                             else
 285                                 limit
 286          when (actualLimit <= 0)
 287                   $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
 288          -- Reader にリクエスト
 289          liftIO $ atomically
 290                     $ do writeItr itr itrReqBodyWanted $ Just actualLimit
 291                          writeItr itr itrWillReceiveBody True
 292          -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 293          chunk <- liftIO $ atomically
 294                   $ do chunk <- readItr itr itrReceivedBody id
 295                        -- 要求された量に滿たなくて、まだ殘りがあるなら
 296                        -- 再試行。
 297                        when (B.length chunk < fromIntegral actualLimit)
 298                                 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
 299                                      unless chunkIsOver
 300                                                 $ retry
 301                        -- 成功
 302                        writeItr itr itrReceivedBody B.empty
 303                        return chunk
 304          when (B.null chunk)
 305                   $ driftTo DecidingHeader
 306          return chunk
 307
 308
 309 defaultLimit :: Int
 310 defaultLimit = (-1)
 311
 312
 313 setStatus :: StatusCode -> Resource ()
 314 setStatus code
 315     = do driftTo DecidingHeader
 316          itr <- ask
 317          liftIO $ atomically $ updateItr itr itrResponse
 318                     $ \ resM -> case resM of
 319                                   Nothing  -> Just $ Response {
 320                                                 resVersion = HttpVersion 1 1
 321                                               , resStatus  = code
 322                                               , resHeaders = []
 323                                               }
 324                                   Just res -> Just $ res {
 325                                                 resStatus = code
 326                                               }
 327
 328
 329 setHeader :: String -> String -> Resource ()
 330 setHeader name value
 331     = do driftTo DecidingHeader
 332          itr <- ask
 333          liftIO $ atomically $ updateItr itr itrResponse
 334                     $ \ resM -> case resM of
 335                                   Nothing  -> Just $ Response {
 336                                                 resVersion = HttpVersion 1 1
 337                                               , resStatus  = Ok
 338                                               , resHeaders = [ (name, value) ]
 339                                               }
 340                                   Just res -> Just $ H.setHeader name value res
 341
 342
 343 redirect :: StatusCode -> URI -> Resource ()
 344 redirect code uri
 345     = do when (code == NotModified || not (isRedirection code))
 346                   $ abort InternalServerError []
 347                         $ "Attempted to redirect with status " ++ show code
 348          setStatus code
 349          setHeader "Location" (uriToString id uri $ "")
 350
 351
 352 output :: String -> Resource ()
 353 output = outputBS . B.pack
 354
 355
 356 outputBS :: ByteString -> Resource ()
 357 outputBS str = do outputChunkBS str
 358                   driftTo Done
 359
 360
 361 outputChunk :: String -> Resource ()
 362 outputChunk = outputChunkBS . B.pack
 363
 364
 365 outputChunkBS :: ByteString -> Resource ()
 366 outputChunkBS str = do driftTo DecidingBody
 367                        itr <- ask
 368                        liftIO $ atomically $
 369                               do updateItr itr itrBodyToSend (flip B.append str)
 370                                  unless (B.null str)
 371                                             $ writeItr itr itrBodyIsNull False
 372
 373
 374 {-
 375
 376   [GettingBody からそれ以降の状態に遷移する時]
 377
 378   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 379
 380
 381   [DecidingHeader からそれ以降の状態に遷移する時]
 382
 383   postprocess する。
 384
 385
 386   [Done に遷移する時]
 387
 388   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 389   る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK
 390   だった場合は、補完の代はりに 204 No Content に變へる。
 391
 392 -}
 393
 394 driftTo :: InteractionState -> Resource ()
 395 driftTo newState
 396     = do itr <- ask
 397          liftIO $ atomically $ do oldState <- readItr itr itrState id
 398                                   if newState < oldState then
 399                                       throwStateError oldState newState
 400                                     else
 401                                       do let a = [oldState .. newState]
 402                                              b = tail a
 403                                              c = zip a b
 404                                          mapM_ (uncurry $ drift itr) c
 405                                          writeItr itr itrState newState
 406     where
 407       throwStateError :: Monad m => InteractionState -> InteractionState -> m a
 408
 409       throwStateError Done DecidingBody
 410           = fail "It makes no sense to output something after finishing to output."
 411
 412       throwStateError old new
 413           = fail ("state error: " ++ show old ++ " ==> " ++ show new)
 414
 415
 416       drift :: Interaction -> InteractionState -> InteractionState -> STM ()
 417
 418       drift itr GettingBody _
 419           = writeItr itr itrReqBodyWasteAll True
 420
 421       drift itr DecidingHeader _
 422           = postprocess itr
 423
 424       drift itr _ Done
 425           = do bodyIsNull <- readItr itr itrBodyIsNull id
 426                when bodyIsNull
 427                         $ do status <- readStatus itr
 428                              if status == Ok then
 429                                  do updateItrF itr itrResponse
 430                                                    $ \ res -> res { resStatus = NoContent }
 431                                     updateItrF itr itrResponse
 432                                                    $ H.deleteHeader "Content-Type"
 433                                     updateItrF itr itrResponse
 434                                                    $ H.deleteHeader "ETag"
 435                                     updateItrF itr itrResponse
 436                                                    $ H.deleteHeader "Last-Modified"
 437                                else
 438                                  writeDefaultPage itr
 439
 440
 441       drift _ _ _
 442           = return ()
 443
 444
 445       readStatus :: Interaction -> STM StatusCode
 446       readStatus itr = readItr itr itrResponse (resStatus . fromJust)