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     ( ResTree
  11     , FallbackHandler
  12
  13     , mkResTree
  14     , findResource
  15     )
  16     where
  17 import Control.Arrow
  18 import Control.Applicative
  19 import Data.Ascii (Ascii)
  20 import qualified Data.Ascii as A
  21 import Control.Concurrent
  22 import Control.Concurrent.STM
  23 import Control.Exception
  24 import Control.Monad
  25 import Data.Text (Text)
  26 import qualified Data.Text as T
  27 import Data.List
  28 import qualified Data.Map as M
  29 import Data.Map (Map)
  30 import Data.Maybe
  31 import Data.Monoid.Unicode
  32 import Network.HTTP.Lucu.Abortion
  33 import Network.HTTP.Lucu.Config
  34 import Network.HTTP.Lucu.DefaultPage
  35 import Network.HTTP.Lucu.Headers (fromHeaders)
  36 import Network.HTTP.Lucu.Request
  37 import Network.HTTP.Lucu.Resource
  38 import Network.HTTP.Lucu.Response
  39 import Network.HTTP.Lucu.Interaction
  40 import Network.HTTP.Lucu.Utils
  41 import Network.URI hiding (path)
  42 import System.IO
  43 import Prelude hiding (catch)
  44 import Prelude.Unicode
  45
  46 -- |'FallbackHandler' is an extra resource handler for resources which
  47 -- can't be statically located anywhere in the resource tree. The Lucu
  48 -- httpd first searches for a resource in the tree, and then calls
  49 -- fallback handlers to ask them for a resource. If all of the
  50 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
  51 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
  52
  53 -- |'ResTree' is an opaque structure which is a map from resource path
  54 -- to 'ResourceDef'.
  55 newtype ResTree = ResTree ResNode -- root だから Map ではない
  56 type ResSubtree = Map Text ResNode
  57 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
  58
  59 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
  60 --
  61 -- @
  62 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
  63 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
  64 --             ]
  65 -- @
  66 --
  67 -- Note that the request path in an incoming HTTP request is always
  68 -- treated as an URI-encoded UTF-8 string.
  69 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
  70 mkResTree = processRoot ∘ map (first canonicalisePath)
  71     where
  72       canonicalisePath ∷ [Text] → [Text]
  73       canonicalisePath = filter (≢ "")
  74
  75       processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
  76       processRoot list
  77           = let (roots, nonRoots) = partition (\(path, _) → null path) list
  78                 children = processNonRoot nonRoots
  79             in
  80               if null roots then
  81                   -- The root has no resources. Maybe there's one at
  82                   -- somewhere like "/foo".
  83                   ResTree (ResNode Nothing children)
  84               else
  85                   -- There is a root resource.
  86                   let (_, def) = last roots
  87                   in
  88                     ResTree (ResNode (Just def) children)
  89
  90       processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
  91       processNonRoot list
  92           = let subtree    = M.fromList [(name, node name)
  93                                              | name ← childNames]
  94                 childNames = [name | (name:_, _) ← list]
  95                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
  96                              in
  97                                if null defs then
  98                                    -- No resources are defined
  99                                    -- here. Maybe there's one at
 100                                    -- somewhere below this node.
 101                                    ResNode Nothing children
 102                                else
 103                                    -- There is a resource here.
 104                                    ResNode (Just $ last defs) children
 105                 children   = processNonRoot [(path, def)
 106                                                  | (_:path, def) ← list]
 107             in
 108               subtree
 109
 110 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
 111 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 112     = do let path          = splitPathInfo uri
 113              hasGreedyRoot = maybe False resIsGreedy rootDefM
 114              foundInTree    = if hasGreedyRoot ∨ null path then
 115                                   do def ← rootDefM
 116                                      return ([], def)
 117                               else
 118                                   walkTree subtree path []
 119          if isJust foundInTree then
 120              return foundInTree
 121          else
 122              fallback path fbs
 123     where
 124       walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
 125
 126       walkTree _ [] _
 127           = error "Internal error: should not reach here."
 128
 129       walkTree tree (name:[]) soFar
 130           = do ResNode defM _ ← M.lookup name tree
 131                def            ← defM
 132                return (soFar ⧺ [name], def)
 133
 134       walkTree tree (x:xs) soFar
 135           = do ResNode defM sub ← M.lookup x tree
 136                case defM of
 137                  Just (ResourceDef { resIsGreedy = True })
 138                      → do def ← defM
 139                           return (soFar ⧺ [x], def)
 140                  _   → walkTree sub xs (soFar ⧺ [x])
 141
 142       fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
 143       fallback _    []     = return Nothing
 144       fallback path (x:xs) = do m ← x path
 145                                 case m of
 146                                   Just def → return $ Just ([], def)
 147                                   Nothing  → fallback path xs