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