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 = list `seq` 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     = def `seq` itr `seq`
 171       fork
 172       $! catch ( runReaderT ( do req <- getRequest
 173                                  fromMaybe notAllowed $ rsrc req
 174                                  driftTo Done
 175                             ) itr
 176                )
 177              $ \ exc -> processException exc
 178     where
 179       fork :: IO () -> IO ThreadId
 180       fork = if (resUsesNativeThread def)
 181              then forkOS
 182              else forkIO
 183
 184       rsrc :: Request -> Maybe (Resource ())
 185       rsrc req
 186           = case reqMethod req of
 187               GET    -> resGet def
 188               HEAD   -> case resHead def of
 189                           Just r  -> Just r
 190                           Nothing -> resGet def
 191               POST   -> resPost def
 192               PUT    -> resPut def
 193               DELETE -> resDelete def
 194
 195       notAllowed :: Resource ()
 196       notAllowed = do setStatus MethodNotAllowed
 197                       setHeader "Allow" $ joinWith ", " allowedMethods
 198
 199       allowedMethods :: [String]
 200       allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
 201                                            , methods resHead   ["GET", "HEAD"]
 202                                            , methods resPost   ["POST"]
 203                                            , methods resPut    ["PUT"]
 204                                            , methods resDelete ["DELETE"]
 205                                            ]
 206
 207       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 208       methods f xs = case f def of
 209                        Just _  -> xs
 210                        Nothing -> []
 211
 212       processException :: Exception -> IO ()
 213       processException exc
 214           = do let abo = case exc of
 215                            ErrorCall    msg  -> Abortion InternalServerError [] $ Just msg
 216                            IOException  ioE  -> Abortion InternalServerError [] $ Just $ formatIOE ioE
 217                            DynException dynE -> case fromDynamic dynE of
 218                                                   Just (abo :: Abortion) -> abo
 219                                                   Nothing
 220                                                       -> Abortion InternalServerError []
 221                                                          $ Just $ show exc
 222                            _                 -> Abortion InternalServerError [] $ Just $ show exc
 223                    conf = itrConfig itr
 224                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 225                -- を應答に反映させる餘地がある。さうでなければ stderr
 226                -- にでも吐くしか無い。
 227                state <- atomically $ readItr itr itrState id
 228                reqM  <- atomically $ readItr itr itrRequest id
 229                res   <- atomically $ readItr itr itrResponse id
 230                if state <= DecidingHeader then
 231                    flip runReaderT itr
 232                       $ do setStatus $ aboStatus abo
 233                            -- FIXME: 同じ名前で複數の値があった時は、こ
 234                            -- れではまずいと思ふ。
 235                            mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
 236                            output $ abortPage conf reqM res abo
 237                  else
 238                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
 239                             $ hPutStrLn stderr $ show abo
 240
 241                flip runReaderT itr $ driftTo Done
 242
 243       formatIOE :: IOError -> String
 244       formatIOE ioE = if isUserError ioE then
 245                           ioeGetErrorString ioE
 246                       else
 247                           show ioE