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