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.Concurrent
  19 import           Control.Concurrent.STM
  20 import           Control.Exception
  21 import           Control.Monad
  22 import qualified Data.ByteString.Char8 as C8
  23 import           Data.List
  24 import qualified Data.Map as M
  25 import           Data.Map (Map)
  26 import           Data.Maybe
  27 import           Network.HTTP.Lucu.Abortion
  28 import           Network.HTTP.Lucu.Config
  29 import           Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders)
  30 import           Network.HTTP.Lucu.Request
  31 import           Network.HTTP.Lucu.Resource
  32 import           Network.HTTP.Lucu.Response
  33 import           Network.HTTP.Lucu.Interaction
  34 import           Network.HTTP.Lucu.Utils
  35 import           Network.URI hiding (path)
  36 import           System.IO
  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 -- |'emptyResource' is a resource definition with no actual
 104 -- handlers. You can construct a 'ResourceDef' by selectively
 105 -- overriding 'emptyResource'. It is defined as follows:
 106 --
 107 -- @
 108 --   emptyResource = ResourceDef {
 109 --                     resUsesNativeThread = False
 110 --                   , resIsGreedy         = False
 111 --                   , resGet              = Nothing
 112 --                   , resHead             = Nothing
 113 --                   , resPost             = Nothing
 114 --                   , resPut              = Nothing
 115 --                   , resDelete           = Nothing
 116 --                   }
 117 -- @
 118 emptyResource :: ResourceDef
 119 emptyResource = ResourceDef {
 120                   resUsesNativeThread = False
 121                 , resIsGreedy         = False
 122                 , resGet              = Nothing
 123                 , resHead             = Nothing
 124                 , resPost             = Nothing
 125                 , resPut              = Nothing
 126                 , resDelete           = Nothing
 127                 }
 128
 129 -- |'ResTree' is an opaque structure which is a map from resource path
 130 -- to 'ResourceDef'.
 131 newtype ResTree = ResTree ResNode -- root だから Map ではない
 132 type ResSubtree = Map String ResNode
 133 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
 134
 135 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
 136 --
 137 -- @
 138 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
 139 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
 140 --             ]
 141 -- @
 142 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
 143 mkResTree = processRoot . mapFirst canonicalisePath
 144     where
 145       mapFirst :: (a -> a') -> [(a, b)] -> [(a', b)]
 146       mapFirst f = map (\ (a, b) -> (f a, b))
 147
 148       canonicalisePath :: [String] -> [String]
 149       canonicalisePath = filter (\ x -> x /= "")
 150
 151       processRoot :: [ ([String], ResourceDef) ] -> ResTree
 152       processRoot list
 153           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
 154                 children = processNonRoot nonRoots
 155             in
 156               if null roots then
 157                   -- The root has no resources. Maybe there's one at
 158                   -- somewhere like "/foo".
 159                   ResTree (ResNode Nothing children)
 160               else
 161                   -- There is a root resource.
 162                   let (_, def) = last roots
 163                   in
 164                     ResTree (ResNode (Just def) children)
 165
 166       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
 167       processNonRoot list
 168           = let subtree    = M.fromList [(name, node name)
 169                                              | name <- childNames]
 170                 childNames = [name | (name:_, _) <- list]
 171                 node name  = let defs = [def | (path, def) <- list, path == [name]]
 172                              in
 173                                if null defs then
 174                                    -- No resources are defined
 175                                    -- here. Maybe there's one at
 176                                    -- somewhere below this node.
 177                                    ResNode Nothing children
 178                                else
 179                                    -- There is a resource here.
 180                                    ResNode (Just $ last defs) children
 181                 children   = processNonRoot [(path, def)
 182                                                  | (_:path, def) <- list]
 183             in
 184               subtree
 185
 186
 187 findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
 188 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 189     = do let pathStr        = uriPath uri
 190              path           = [unEscapeString x | x <- splitBy (== '/') pathStr, x /= ""]
 191              haveGreedyRoot = case rootDefM of
 192                                 Just def -> resIsGreedy def
 193                                 Nothing  -> False
 194              foundInTree    = if haveGreedyRoot || null path then
 195                                   do def <- rootDefM
 196                                      return ([], def)
 197                               else
 198                                   walkTree subtree path []
 199          if isJust foundInTree then
 200              return foundInTree
 201            else
 202              fallback path fbs
 203     where
 204       walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
 205
 206       walkTree _ [] _
 207           = error "Internal error: should not reach here."
 208
 209       walkTree tree (name:[]) soFar
 210           = case M.lookup name tree of
 211               Nothing               -> Nothing
 212               Just (ResNode defM _) -> do def <- defM
 213                                           return (soFar ++ [name], def)
 214
 215       walkTree tree (x:xs) soFar
 216           = case M.lookup x tree of
 217               Nothing                      -> Nothing
 218               Just (ResNode defM children) -> case defM of
 219                                                 Just (ResourceDef { resIsGreedy = True })
 220                                                     -> do def <- defM
 221                                                           return (soFar ++ [x], def)
 222                                                 _   -> walkTree children xs (soFar ++ [x])
 223
 224       fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
 225       fallback _    []     = return Nothing
 226       fallback path (x:xs) = do m <- x path
 227                                 case m of
 228                                   Just def -> return $! Just ([], def)
 229                                   Nothing  -> fallback path xs
 230
 231
 232 runResource :: ResourceDef -> Interaction -> IO ThreadId
 233 runResource def itr
 234     = def `seq` itr `seq`
 235       fork
 236       $! catch ( runRes ( do req <- getRequest
 237                              fromMaybe notAllowed $ rsrc req
 238                              driftTo Done
 239                         ) itr
 240                )
 241                processException
 242     where
 243       fork :: IO () -> IO ThreadId
 244       fork = if resUsesNativeThread def
 245              then forkOS
 246              else forkIO
 247
 248       rsrc :: Request -> Maybe (Resource ())
 249       rsrc req
 250           = case reqMethod req of
 251               GET    -> resGet def
 252               HEAD   -> case resHead def of
 253                           Just r  -> Just r
 254                           Nothing -> resGet def
 255               POST   -> resPost def
 256               PUT    -> resPut def
 257               DELETE -> resDelete def
 258               _      -> undefined
 259
 260       notAllowed :: Resource ()
 261       notAllowed = do setStatus MethodNotAllowed
 262                       setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
 263
 264       allowedMethods :: [String]
 265       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 266                                     , methods resHead   ["GET", "HEAD"]
 267                                     , methods resPost   ["POST"]
 268                                     , methods resPut    ["PUT"]
 269                                     , methods resDelete ["DELETE"]
 270                                     ]
 271
 272       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 273       methods f xs = case f def of
 274                        Just _  -> xs
 275                        Nothing -> []
 276
 277       toAbortion :: SomeException -> Abortion
 278       toAbortion e = case fromException e of
 279                        Just abortion -> abortion
 280                        Nothing       -> Abortion InternalServerError emptyHeaders (Just (show e))
 281
 282       processException :: SomeException -> IO ()
 283       processException exc
 284           = do let abo = toAbortion exc
 285                    conf = itrConfig itr
 286                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 287                -- を應答に反映させる餘地がある。さうでなければ stderr
 288                -- にでも吐くしか無い。
 289                state <- atomically $ readItr itr itrState id
 290                reqM  <- atomically $ readItr itr itrRequest id
 291                res   <- atomically $ readItr itr itrResponse id
 292                if state <= DecidingHeader then
 293                    flip runRes itr
 294                       $ do setStatus $ aboStatus abo
 295                            mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
 296                            output $ abortPage conf reqM res abo
 297                  else
 298                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
 299                             $ hPutStrLn stderr $ show abo
 300
 301                flip runRes itr $ driftTo Done