Network/HTTP/Lucu/Resource/Tree.hs

   1 {-# OPTIONS_HADDOCK prune #-}
   2
   3 -- | Repository of the resources in httpd.
   4 module Network.HTTP.Lucu.Resource.Tree
   5     ( ResourceDef(..)
   6     , ResTree
   7     , FallbackHandler
   8
   9     , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
  10
  11     , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
  12     , runResource  -- ResourceDef -> Interaction -> IO ThreadId
  13     )
  14     where
  15
  16 import           Control.Concurrent
  17 import           Control.Concurrent.STM
  18 import           Control.Exception
  19 import           Control.Monad
  20 import qualified Data.ByteString.Char8 as C8
  21 import           Data.List
  22 import qualified Data.Map as M
  23 import           Data.Map (Map)
  24 import           Data.Maybe
  25 import           Network.HTTP.Lucu.Abortion
  26 import           Network.HTTP.Lucu.Config
  27 import           Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders)
  28 import           Network.HTTP.Lucu.Request
  29 import           Network.HTTP.Lucu.Resource
  30 import           Network.HTTP.Lucu.Response
  31 import           Network.HTTP.Lucu.Interaction
  32 import           Network.HTTP.Lucu.Utils
  33 import           Network.URI hiding (path)
  34 import           System.IO
  35 import           System.IO.Error hiding (catch)
  36 import           Prelude hiding (catch)
  37
  38
  39 -- |'FallbackHandler' is an extra resource handler for resources which
  40 -- can't be statically located somewhere in the resource tree. The
  41 -- Lucu httpd first search for a resource in the tree, and then call
  42 -- fallback handlers to ask them for a resource. If all of the
  43 -- handlers returned 'Prelude.Nothing', the httpd responds with 404
  44 -- Not Found.
  45 type FallbackHandler = [String] -> IO (Maybe ResourceDef)
  46
  47
  48 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
  49 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
  50 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
  51 -- 無視される。
  52
  53 -- | 'ResourceDef' is basically a set of
  54 -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
  55 data ResourceDef = ResourceDef {
  56     -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
  57     -- native thread (spawned by 'Control.Concurrent.forkOS') or to
  58     -- run it on a user thread (spanwed by
  59     -- 'Control.Concurrent.forkIO'). Generally you don't need to set
  60     -- this field to 'Prelude.True'.
  61       resUsesNativeThread :: !Bool
  62     -- | Whether to be greedy or not.
  63     --
  64     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
  65     -- greedy resource at \/aaa\/bbb, it is always chosen even if
  66     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
  67     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
  68     -- resources are like CGI scripts.
  69     , resIsGreedy         :: !Bool
  70     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
  71     -- request comes for the resource path. If 'resGet' is Nothing,
  72     -- the system responds \"405 Method Not Allowed\" for GET
  73     -- requests.
  74     --
  75     -- It also runs for HEAD request if the 'resHead' is Nothing. In
  76     -- this case 'Network.HTTP.Lucu.Resource.output' and such like
  77     -- don't actually write a response body.
  78     , resGet              :: !(Maybe (Resource ()))
  79     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
  80     -- request comes for the resource path. If 'resHead' is Nothing,
  81     -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
  82     -- the system responds \"405 Method Not Allowed\" for HEAD
  83     -- requests.
  84     , resHead             :: !(Maybe (Resource ()))
  85     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
  86     -- request comes for the resource path. If 'resPost' is Nothing,
  87     -- the system responds \"405 Method Not Allowed\" for POST
  88     -- requests.
  89     , resPost             :: !(Maybe (Resource ()))
  90     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
  91     -- request comes for the resource path. If 'resPut' is Nothing,
  92     -- the system responds \"405 Method Not Allowed\" for PUT
  93     -- requests.
  94     , resPut              :: !(Maybe (Resource ()))
  95     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
  96     -- DELETE request comes for the resource path. If 'resDelete' is
  97     -- Nothing, the system responds \"405 Method Not Allowed\" for
  98     -- DELETE requests.
  99     , resDelete           :: !(Maybe (Resource ()))
 100     }
 101
 102 -- |'ResTree' is an opaque structure which is a map from resource path
 103 -- to 'ResourceDef'.
 104 newtype ResTree = ResTree ResNode -- root だから Map ではない
 105 type ResSubtree = Map String ResNode
 106 data ResNode    = ResNode !(Maybe ResourceDef) !ResSubtree
 107
 108 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
 109 --
 110 -- @
 111 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
 112 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
 113 --             ]
 114 -- @
 115 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
 116 mkResTree xs = xs `seq` processRoot xs
 117     where
 118       processRoot :: [ ([String], ResourceDef) ] -> ResTree
 119       processRoot list
 120           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
 121                 children = processNonRoot nonRoots
 122             in
 123               if null roots then
 124                   -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
 125                   ResTree (ResNode Nothing children)
 126               else
 127                   -- "/" がある。
 128                   let (_, def) = last roots
 129                   in
 130                     ResTree (ResNode (Just def) children)
 131
 132       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
 133       processNonRoot list
 134           = let subtree    = M.fromList [(name, node name)
 135                                              | name <- childNames]
 136                 childNames = [name | (name:_, _) <- list]
 137                 node name  = let defs = [def | (path, def) <- list, path == [name]]
 138                              in
 139                                if null defs then
 140                                    -- この位置にリソースが定義されない。
 141                                    -- もっと下にはあるかも。
 142                                    ResNode Nothing children
 143                                else
 144                                    -- この位置にリソースがある。
 145                                    ResNode (Just $ last defs) children
 146                 children   = processNonRoot [(path, def)
 147                                                  | (_:path, def) <- list, not (null path)]
 148             in
 149               subtree
 150
 151
 152 findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
 153 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 154     = do let pathStr     = uriPath uri
 155              path        = [x | x <- splitBy (== '/') pathStr, x /= ""]
 156              foundInTree = if null path then
 157                                do def <- rootDefM
 158                                   return (path, def)
 159                            else
 160                                walkTree subtree path []
 161          if isJust foundInTree then
 162              return foundInTree
 163            else
 164              fallback path fbs
 165     where
 166       walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
 167
 168       walkTree _ [] _
 169           = error "Internal error: should not reach here."
 170
 171       walkTree tree (name:[]) soFar
 172           = case M.lookup name tree of
 173               Nothing               -> Nothing
 174               Just (ResNode defM _) -> do def <- defM
 175                                           return (soFar ++ [name], def)
 176
 177       walkTree tree (x:xs) soFar
 178           = case M.lookup x tree of
 179               Nothing                      -> Nothing
 180               Just (ResNode defM children) -> case defM of
 181                                                 Just (ResourceDef { resIsGreedy = True })
 182                                                     -> do def <- defM
 183                                                           return (soFar ++ [x], def)
 184                                                 _   -> walkTree children xs (soFar ++ [x])
 185
 186       fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
 187       fallback _    []     = return Nothing
 188       fallback path (x:xs) = do m <- x path
 189                                 case m of
 190                                   Just def -> return $! Just ([], def)
 191                                   Nothing  -> fallback path xs
 192
 193
 194 runResource :: ResourceDef -> Interaction -> IO ThreadId
 195 runResource def itr
 196     = def `seq` itr `seq`
 197       fork
 198       $! catch ( runRes ( do req <- getRequest
 199                              fromMaybe notAllowed $ rsrc req
 200                              driftTo Done
 201                         ) itr
 202                )
 203              $ \ exc -> processException exc
 204     where
 205       fork :: IO () -> IO ThreadId
 206       fork = if (resUsesNativeThread def)
 207              then forkOS
 208              else forkIO
 209
 210       rsrc :: Request -> Maybe (Resource ())
 211       rsrc req
 212           = case reqMethod req of
 213               GET    -> resGet def
 214               HEAD   -> case resHead def of
 215                           Just r  -> Just r
 216                           Nothing -> resGet def
 217               POST   -> resPost def
 218               PUT    -> resPut def
 219               DELETE -> resDelete def
 220               _      -> undefined
 221
 222       notAllowed :: Resource ()
 223       notAllowed = do setStatus MethodNotAllowed
 224                       setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
 225
 226       allowedMethods :: [String]
 227       allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
 228                                            , methods resHead   ["GET", "HEAD"]
 229                                            , methods resPost   ["POST"]
 230                                            , methods resPut    ["PUT"]
 231                                            , methods resDelete ["DELETE"]
 232                                            ]
 233
 234       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 235       methods f xs = case f def of
 236                        Just _  -> xs
 237                        Nothing -> []
 238
 239       toAbortion :: SomeException -> Abortion
 240       toAbortion e = case fromException e of
 241                        Just abortion -> abortion
 242                        Nothing       -> Abortion InternalServerError emptyHeaders (Just (show e))
 243
 244       processException :: SomeException -> IO ()
 245       processException exc
 246           = do let abo = toAbortion exc
 247                    conf = itrConfig itr
 248                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 249                -- を應答に反映させる餘地がある。さうでなければ stderr
 250                -- にでも吐くしか無い。
 251                state <- atomically $ readItr itr itrState id
 252                reqM  <- atomically $ readItr itr itrRequest id
 253                res   <- atomically $ readItr itr itrResponse id
 254                if state <= DecidingHeader then
 255                    flip runRes itr
 256                       $ do setStatus $ aboStatus abo
 257                            mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo
 258                            output $ abortPage conf reqM res abo
 259                  else
 260                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
 261                             $ hPutStrLn stderr $ show abo
 262
 263                flip runRes itr $ driftTo Done
 264
 265       formatIOE :: IOError -> String
 266       formatIOE ioE = if isUserError ioE then
 267                           ioeGetErrorString ioE
 268                       else
 269                           show ioE