Network/HTTP/Lucu/Resource/Tree.hs

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