Network/HTTP/Lucu/Resource/Tree.hs

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