Network/HTTP/Lucu/Resource.hs

   1 module Network.HTTP.Lucu.Resource
   2     ( ResourceDef(..)
   3     , Resource
   4     , ResTree
   5     , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
   6     , findResource -- ResTree -> URI -> Maybe ResourceDef
   7     , runResource  -- ResourceDef -> Interaction -> IO ThreadId
   8     )
   9     where
  10
  11 import           Control.Concurrent
  12 import           Control.Monad.Reader
  13 import qualified Data.ByteString.Lazy.Char8 as B
  14 import           Data.ByteString.Lazy.Char8 (ByteString)
  15 import           Data.List
  16 import qualified Data.Map as M
  17 import           Data.Map (Map)
  18 import           Network.HTTP.Lucu.Interaction
  19 import           Network.HTTP.Lucu.Utils
  20 import           Network.URI
  21
  22
  23 type Resource a = ReaderT Interaction IO a
  24
  25
  26 {- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
  27    れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
  28    /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
  29    される。 -}
  30 data ResourceDef = ResourceDef {
  31       resUsesNativeThread :: Bool
  32     , resIsGreedy         :: Bool
  33     , resResource         :: Resource ()
  34     }
  35 type ResTree    = ResNode -- root だから Map ではない
  36 type ResSubtree = Map String ResNode
  37 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
  38
  39
  40 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
  41 mkResTree list = processRoot list
  42     where
  43       processRoot :: [ ([String], ResourceDef) ] -> ResTree
  44       processRoot list
  45           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
  46                 children = processNonRoot nonRoots
  47             in
  48               if null roots then
  49                   -- / にリソースが定義されない。/foo とかにはあるかも。
  50                   ResNode Nothing children
  51               else
  52                   -- / がある。
  53                   let (_, def) = last roots
  54                   in
  55                     ResNode (Just def) children
  56
  57       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
  58       processNonRoot list
  59           = let subtree    = M.fromList [(name, node name)
  60                                              | name <- childNames]
  61                 childNames = [name | (name:_, _) <- list]
  62                 node name  = let defs = [def | (path, def) <- list, path == [name]]
  63                              in
  64                                if null defs then
  65                                    -- この位置にリソースが定義されない。
  66                                    -- もっと下にはあるかも。
  67                                    ResNode Nothing children
  68                                else
  69                                    -- この位置にリソースがある。
  70                                    ResNode (Just $ last defs) children
  71                 children   = processNonRoot [(path, def)
  72                                                  | (_:path, def) <- list, not (null path)]
  73             in
  74               subtree
  75
  76
  77 findResource :: ResTree -> URI -> Maybe ResourceDef
  78 findResource (ResNode rootDefM subtree) uri
  79     = let pathStr = uriPath uri
  80           path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
  81       in
  82         if null path then
  83             rootDefM
  84         else
  85             walkTree subtree path
  86     where
  87       walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
  88
  89       walkTree subtree (name:[])
  90           = case M.lookup name subtree of
  91               Nothing               -> Nothing
  92               Just (ResNode defM _) -> defM
  93
  94       walkTree subtree (x:xs)
  95           = case M.lookup x subtree of
  96               Nothing                      -> Nothing
  97               Just (ResNode defM children) -> case defM of
  98                                                 Just (ResourceDef { resIsGreedy = True })
  99                                                     -> defM
 100                                                 _   -> walkTree children xs
 101
 102
 103 runResource :: ResourceDef -> Interaction -> IO ThreadId
 104 runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
 105     where
 106       fork = if (resUsesNativeThread def)
 107              then forkOS
 108              else forkIO
 109       rsrc = resResource def