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