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