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.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 using @forkOS@) or to run it on a user
  46     -- thread (spanwed using @forkIO@). Generally you don't
  47       resUsesNativeThread :: !Bool
  48     -- | Whether to be greedy or not.
  49     --
  50     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
  51     -- greedy resource at \/aaa\/bbb, it is always chosen even if
  52     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
  53     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
  54     -- resource is like a CGI script.
  55     , resIsGreedy         :: !Bool
  56     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
  57     -- request comes for the resource path. If 'resGet' is Nothing,
  58     -- the system responds \"405 Method Not Allowed\" for GET
  59     -- requests.
  60     --
  61     -- It also runs for HEAD request if the 'resHead' is Nothing. In
  62     -- this case 'Network.HTTP.Lucu.Resource.output' and such like
  63     -- don't actually write a response body.
  64     , resGet              :: !(Maybe (Resource ()))
  65     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
  66     -- request comes for the resource path. If 'resHead' is Nothing,
  67     -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
  68     -- the system responds \"405 Method Not Allowed\" for HEAD
  69     -- requests.
  70     , resHead             :: !(Maybe (Resource ()))
  71     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
  72     -- request comes for the resource path. If 'resPost' is Nothing,
  73     -- the system responds \"405 Method Not Allowed\" for POST
  74     -- requests.
  75     , resPost             :: !(Maybe (Resource ()))
  76     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
  77     -- request comes for the resource path. If 'resPut' is Nothing,
  78     -- the system responds \"405 Method Not Allowed\" for PUT
  79     -- requests.
  80     , resPut              :: !(Maybe (Resource ()))
  81     -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
  82     -- DELETE request comes for the resource path. If 'resDelete' is
  83     -- Nothing, the system responds \"405 Method Not Allowed\" for
  84     -- DELETE requests.
  85     , resDelete           :: !(Maybe (Resource ()))
  86     }
  87
  88 -- | 'ResTree' is an opaque structure which is a map from resource
  89 -- path to 'ResourceDef'.
  90 type ResTree    = ResNode -- root だから Map ではない
  91 type ResSubtree = Map String ResNode
  92 data ResNode    = ResNode !(Maybe ResourceDef) !ResSubtree
  93
  94 -- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
  95 --
  96 -- @
  97 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
  98 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
  99 --             ]
 100 -- @
 101 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
 102 mkResTree list = list `seq` processRoot list
 103     where
 104       processRoot :: [ ([String], ResourceDef) ] -> ResTree
 105       processRoot list
 106           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
 107                 children = processNonRoot nonRoots
 108             in
 109               if null roots then
 110                   -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
 111                   ResNode Nothing children
 112               else
 113                   -- "/" がある。
 114                   let (_, def) = last roots
 115                   in
 116                     ResNode (Just def) children
 117
 118       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
 119       processNonRoot list
 120           = let subtree    = M.fromList [(name, node name)
 121                                              | name <- childNames]
 122                 childNames = [name | (name:_, _) <- list]
 123                 node name  = let defs = [def | (path, def) <- list, path == [name]]
 124                              in
 125                                if null defs then
 126                                    -- この位置にリソースが定義されない。
 127                                    -- もっと下にはあるかも。
 128                                    ResNode Nothing children
 129                                else
 130                                    -- この位置にリソースがある。
 131                                    ResNode (Just $ last defs) children
 132                 children   = processNonRoot [(path, def)
 133                                                  | (_:path, def) <- list, not (null path)]
 134             in
 135               subtree
 136
 137
 138 findResource :: ResTree -> URI -> Maybe ([String], ResourceDef)
 139 findResource (ResNode rootDefM subtree) uri
 140     = let pathStr = uriPath uri
 141           path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
 142       in
 143         if null path then
 144             do def <- rootDefM
 145                return (path, def)
 146         else
 147             walkTree subtree path []
 148     where
 149       walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
 150
 151       walkTree subtree (name:[]) soFar
 152           = case M.lookup name subtree of
 153               Nothing               -> Nothing
 154               Just (ResNode defM _) -> do def <- defM
 155                                           return (soFar ++ [name], def)
 156
 157       walkTree subtree (x:xs) soFar
 158           = case M.lookup x subtree of
 159               Nothing                      -> Nothing
 160               Just (ResNode defM children) -> case defM of
 161                                                 Just (ResourceDef { resIsGreedy = True })
 162                                                     -> do def <- defM
 163                                                           return (soFar ++ [x], def)
 164                                                 _   -> walkTree children xs (soFar ++ [x])
 165
 166
 167 runResource :: ResourceDef -> Interaction -> IO ThreadId
 168 runResource def itr
 169     = def `seq` itr `seq`
 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