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