Network/HTTP/Lucu/Resource/Tree.hs

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