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