Network/HTTP/Lucu/Resource/Tree.hs

   1 module Network.HTTP.Lucu.Resource.Tree
   2     ( ResourceDef(..)
   3     , Resource
   4     , ResTree
   5     , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
   6
   7     , findResource -- ResTree -> URI -> Maybe ResourceDef
   8     , runResource  -- ResourceDef -> Interaction -> IO ThreadId
   9     )
  10     where
  11
  12 import           Control.Concurrent
  13 import           Control.Concurrent.STM
  14 import           Control.Exception
  15 import           Control.Monad.Reader
  16 import           Data.Dynamic
  17 import           Data.List
  18 import qualified Data.Map as M
  19 import           Data.Map (Map)
  20 import           Data.Maybe
  21 import           Network.HTTP.Lucu.Abortion
  22 import           Network.HTTP.Lucu.Config
  23 import           Network.HTTP.Lucu.Request
  24 import           Network.HTTP.Lucu.Resource
  25 import           Network.HTTP.Lucu.Response
  26 import           Network.HTTP.Lucu.Interaction
  27 import           Network.HTTP.Lucu.Utils
  28 import           Network.URI
  29 import           System.IO
  30 import           System.IO.Error hiding (catch)
  31 import           Prelude hiding (catch)
  32
  33
  34 {- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
  35    れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
  36    /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
  37    される。 -}
  38 data ResourceDef = ResourceDef {
  39       resUsesNativeThread :: Bool
  40     , resIsGreedy         :: Bool
  41     , resGet              :: Maybe (Resource ())
  42     , resHead             :: Maybe (Resource ())
  43     , resPost             :: Maybe (Resource ())
  44     , resPut              :: Maybe (Resource ())
  45     , resDelete           :: Maybe (Resource ())
  46     }
  47 type ResTree    = ResNode -- root だから Map ではない
  48 type ResSubtree = Map String ResNode
  49 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
  50
  51
  52 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
  53 mkResTree list = processRoot list
  54     where
  55       processRoot :: [ ([String], ResourceDef) ] -> ResTree
  56       processRoot list
  57           = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
  58                 children = processNonRoot nonRoots
  59             in
  60               if null roots then
  61                   -- / にリソースが定義されない。/foo とかにはあるかも。
  62                   ResNode Nothing children
  63               else
  64                   -- / がある。
  65                   let (_, def) = last roots
  66                   in
  67                     ResNode (Just def) children
  68
  69       processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
  70       processNonRoot list
  71           = let subtree    = M.fromList [(name, node name)
  72                                              | name <- childNames]
  73                 childNames = [name | (name:_, _) <- list]
  74                 node name  = let defs = [def | (path, def) <- list, path == [name]]
  75                              in
  76                                if null defs then
  77                                    -- この位置にリソースが定義されない。
  78                                    -- もっと下にはあるかも。
  79                                    ResNode Nothing children
  80                                else
  81                                    -- この位置にリソースがある。
  82                                    ResNode (Just $ last defs) children
  83                 children   = processNonRoot [(path, def)
  84                                                  | (_:path, def) <- list, not (null path)]
  85             in
  86               subtree
  87
  88
  89 findResource :: ResTree -> URI -> Maybe ResourceDef
  90 findResource (ResNode rootDefM subtree) uri
  91     = let pathStr = uriPath uri
  92           path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
  93       in
  94         if null path then
  95             rootDefM
  96         else
  97             walkTree subtree path
  98     where
  99       walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
 100
 101       walkTree subtree (name:[])
 102           = case M.lookup name subtree of
 103               Nothing               -> Nothing
 104               Just (ResNode defM _) -> defM
 105
 106       walkTree subtree (x:xs)
 107           = case M.lookup x subtree of
 108               Nothing                      -> Nothing
 109               Just (ResNode defM children) -> case defM of
 110                                                 Just (ResourceDef { resIsGreedy = True })
 111                                                     -> defM
 112                                                 _   -> walkTree children xs
 113
 114
 115 runResource :: ResourceDef -> Interaction -> IO ThreadId
 116 runResource def itr
 117     = fork
 118       $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
 119                                 driftTo Done
 120                            ) itr
 121               )
 122       $ \ exc -> processException exc
 123     where
 124       fork :: IO () -> IO ThreadId
 125       fork = if (resUsesNativeThread def)
 126              then forkOS
 127              else forkIO
 128
 129       rsrc :: Maybe (Resource ())
 130       rsrc = case reqMethod $ fromJust $ itrRequest itr of
 131                GET    -> resGet def
 132                HEAD   -> case resHead def of
 133                            Just r  -> Just r
 134                            Nothing -> resGet def
 135                POST   -> resPost def
 136                PUT    -> resPut def
 137                DELETE -> resDelete def
 138
 139       notAllowed :: Resource ()
 140       notAllowed = do setStatus MethodNotAllowed
 141                       setHeader "Allow" $ joinWith ", " allowedMethods
 142
 143       allowedMethods :: [String]
 144       allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
 145                                            , methods resHead   ["GET", "HEAD"]
 146                                            , methods resPost   ["POST"]
 147                                            , methods resPut    ["PUT"]
 148                                            , methods resDelete ["DELETE"]
 149                                            ]
 150
 151       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 152       methods f xs = case f def of
 153                        Just _  -> xs
 154                        Nothing -> []
 155
 156       processException :: Exception -> IO ()
 157       processException exc
 158           = do let abo = case exc of
 159                            ErrorCall    msg  -> Abortion InternalServerError [] $ Just msg
 160                            IOException  ioE  -> Abortion InternalServerError [] $ Just $ formatIOE ioE
 161                            DynException dynE -> case fromDynamic dynE of
 162                                                   Just (abo :: Abortion) -> abo
 163                                                   Nothing
 164                                                       -> Abortion InternalServerError []
 165                                                          $ Just $ show exc
 166                            _                 -> Abortion InternalServerError [] $ Just $ show exc
 167                    conf = itrConfig itr
 168                    reqM = itrRequest itr
 169                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 170                -- を應答に反映させる餘地がある。さうでなければ stderr
 171                -- にでも吐くしか無い。
 172                state <- atomically $ readItr itr itrState id
 173                resM  <- atomically $ readItr itr itrResponse id
 174                if state <= DecidingHeader then
 175                    flip runReaderT itr
 176                       $ do setStatus $ aboStatus abo
 177                            -- FIXME: 同じ名前で複數の値があった時は、こ
 178                            -- れではまずいと思ふ。
 179                            mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
 180                            setHeader "Content-Type" "application/xhtml+xml"
 181                            output $ abortPage conf reqM resM abo
 182                  else
 183                    hPutStrLn stderr $ show abo
 184
 185                flip runReaderT itr $ driftTo Done
 186
 187       formatIOE :: IOError -> String
 188       formatIOE ioE = if isUserError ioE then
 189                           ioeGetErrorString ioE
 190                       else
 191                           show ioE