Network/HTTP/Lucu/Resource/Tree.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , UnicodeSyntax
   6   #-}
   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 --
 148 -- Note that the request path in an incoming HTTP request is always
 149 -- treated as an URI-encoded UTF-8 string.
 150 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
 151 mkResTree = processRoot ∘ map (first canonicalisePath)
 152     where
 153       canonicalisePath ∷ [Text] → [Text]
 154       canonicalisePath = filter (≢ "")
 155
 156       processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
 157       processRoot list
 158           = let (roots, nonRoots) = partition (\(path, _) → null path) list
 159                 children = processNonRoot nonRoots
 160             in
 161               if null roots then
 162                   -- The root has no resources. Maybe there's one at
 163                   -- somewhere like "/foo".
 164                   ResTree (ResNode Nothing children)
 165               else
 166                   -- There is a root resource.
 167                   let (_, def) = last roots
 168                   in
 169                     ResTree (ResNode (Just def) children)
 170
 171       processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
 172       processNonRoot list
 173           = let subtree    = M.fromList [(name, node name)
 174                                              | name ← childNames]
 175                 childNames = [name | (name:_, _) ← list]
 176                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
 177                              in
 178                                if null defs then
 179                                    -- No resources are defined
 180                                    -- here. Maybe there's one at
 181                                    -- somewhere below this node.
 182                                    ResNode Nothing children
 183                                else
 184                                    -- There is a resource here.
 185                                    ResNode (Just $ last defs) children
 186                 children   = processNonRoot [(path, def)
 187                                                  | (_:path, def) ← list]
 188             in
 189               subtree
 190
 191 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
 192 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 193     = do let path          = splitPathInfo uri
 194              hasGreedyRoot = maybe False resIsGreedy rootDefM
 195              foundInTree    = if hasGreedyRoot ∨ 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           = do ResNode defM _ ← M.lookup name tree
 212                def            ← defM
 213                return (soFar ⧺ [name], def)
 214
 215       walkTree tree (x:xs) soFar
 216           = do ResNode defM sub ← M.lookup x tree
 217                case defM of
 218                  Just (ResourceDef { resIsGreedy = True })
 219                      → do def ← defM
 220                           return (soFar ⧺ [x], def)
 221                  _   → walkTree sub xs (soFar ⧺ [x])
 222
 223       fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
 224       fallback _    []     = return Nothing
 225       fallback path (x:xs) = do m ← x path
 226                                 case m of
 227                                   Just def → return $ Just ([], def)
 228                                   Nothing  → fallback path xs
 229
 230
 231 runResource ∷ ResourceDef → Interaction → IO ThreadId
 232 runResource (ResourceDef {..}) itr@(Interaction {..})
 233     = fork $ run `catch` processException
 234     where
 235       fork ∷ IO () → IO ThreadId
 236       fork | resUsesNativeThread = forkOS
 237            | otherwise           = forkIO
 238
 239       run ∷ IO ()
 240       run = flip runRes itr $
 241             do req ← getRequest
 242                fromMaybe notAllowed $ rsrc req
 243                driftTo Done
 244
 245       rsrc ∷ Request → Maybe (Resource ())
 246       rsrc req
 247           = case reqMethod req of
 248               GET    → resGet
 249               HEAD   → case resHead of
 250                           Just r  → Just r
 251                           Nothing → resGet
 252               POST   → resPost
 253               PUT    → resPut
 254               DELETE → resDelete
 255               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 256
 257       notAllowed ∷ Resource ()
 258       notAllowed
 259           = setStatus MethodNotAllowed
 260             *>
 261             (setHeader "Allow" $ A.fromAsciiBuilder
 262                                $ joinWith ", "
 263                                $ map A.toAsciiBuilder allowedMethods)
 264
 265       allowedMethods ∷ [Ascii]
 266       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 267                                     , methods resHead   ["GET", "HEAD"]
 268                                     , methods resPost   ["POST"]
 269                                     , methods resPut    ["PUT"]
 270                                     , methods resDelete ["DELETE"]
 271                                     ]
 272
 273       methods ∷ Maybe a → [Ascii] → [Ascii]
 274       methods m xs
 275           | isJust m  = xs
 276           | otherwise = []
 277
 278       toAbortion ∷ SomeException → Abortion
 279       toAbortion e
 280           = case fromException e of
 281               Just abortion → abortion
 282               Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
 283
 284       processException ∷ SomeException → IO ()
 285       processException exc
 286           = do let abo = toAbortion exc
 287                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 288                -- を應答に反映させる餘地がある。さうでなければ stderr
 289                -- にでも吐くしか無い。
 290                state ← atomically $ readTVar itrState
 291                res   ← atomically $ readTVar itrResponse
 292                if state ≤ DecidingHeader then
 293                    flip runRes itr $
 294                        do setStatus $ aboStatus abo
 295                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
 296                           output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
 297                else
 298                    do when (cnfDumpTooLateAbortionToStderr itrConfig)
 299                           $ hPutStrLn stderr $ show abo
 300                       atomically $ writeTVar itrWillClose True
 301                runRes (driftTo Done) itr