Network/HTTP/Lucu/Resource/Tree.hs

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