Network/HTTP/Lucu/Resource/Tree.hs

   1 module Network.HTTP.Lucu.Resource.Tree
   2     ( ResourceDef(..)
   3     , ResTree
   4     , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
   5
   6     , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
   7     , runResource  -- ResourceDef -> Interaction -> IO ThreadId
   8     )
   9     where
  10
  11 import           Control.Concurrent
  12 import           Control.Concurrent.STM
  13 import           Control.Exception
  14 import           Control.Monad.Reader
  15 import           Data.Dynamic
  16 import           Data.List
  17 import qualified Data.Map as M
  18 import           Data.Map (Map)
  19 import           Data.Maybe
  20 import           Network.HTTP.Lucu.Abortion
  21 import           Network.HTTP.Lucu.Config
  22 import           Network.HTTP.Lucu.MIMEType
  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 ([String], 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             do def <- rootDefM
  96                return (path, def)
  97         else
  98             walkTree subtree path []
  99     where
 100       walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
 101
 102       walkTree subtree (name:[]) soFar
 103           = case M.lookup name subtree of
 104               Nothing               -> Nothing
 105               Just (ResNode defM _) -> do def <- defM
 106                                           return (soFar ++ [name], def)
 107
 108       walkTree subtree (x:xs) soFar
 109           = case M.lookup x subtree of
 110               Nothing                      -> Nothing
 111               Just (ResNode defM children) -> case defM of
 112                                                 Just (ResourceDef { resIsGreedy = True })
 113                                                     -> do def <- defM
 114                                                           return (soFar ++ [x], def)
 115                                                 _   -> walkTree children xs (soFar ++ [x])
 116
 117
 118 runResource :: ResourceDef -> Interaction -> IO ThreadId
 119 runResource def itr
 120     = fork
 121       $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
 122                                 driftTo Done
 123                            ) itr
 124               )
 125       $ \ exc -> processException exc
 126     where
 127       fork :: IO () -> IO ThreadId
 128       fork = if (resUsesNativeThread def)
 129              then forkOS
 130              else forkIO
 131
 132       rsrc :: Maybe (Resource ())
 133       rsrc = case reqMethod $ fromJust $ itrRequest itr of
 134                GET    -> resGet def
 135                HEAD   -> case resHead def of
 136                            Just r  -> Just r
 137                            Nothing -> resGet def
 138                POST   -> resPost def
 139                PUT    -> resPut def
 140                DELETE -> resDelete def
 141
 142       notAllowed :: Resource ()
 143       notAllowed = do setStatus MethodNotAllowed
 144                       setHeader "Allow" $ joinWith ", " allowedMethods
 145
 146       allowedMethods :: [String]
 147       allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
 148                                            , methods resHead   ["GET", "HEAD"]
 149                                            , methods resPost   ["POST"]
 150                                            , methods resPut    ["PUT"]
 151                                            , methods resDelete ["DELETE"]
 152                                            ]
 153
 154       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
 155       methods f xs = case f def of
 156                        Just _  -> xs
 157                        Nothing -> []
 158
 159       processException :: Exception -> IO ()
 160       processException exc
 161           = do let abo = case exc of
 162                            ErrorCall    msg  -> Abortion InternalServerError [] $ Just msg
 163                            IOException  ioE  -> Abortion InternalServerError [] $ Just $ formatIOE ioE
 164                            DynException dynE -> case fromDynamic dynE of
 165                                                   Just (abo :: Abortion) -> abo
 166                                                   Nothing
 167                                                       -> Abortion InternalServerError []
 168                                                          $ Just $ show exc
 169                            _                 -> Abortion InternalServerError [] $ Just $ show exc
 170                    conf = itrConfig itr
 171                    reqM = itrRequest itr
 172                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 173                -- を應答に反映させる餘地がある。さうでなければ stderr
 174                -- にでも吐くしか無い。
 175                state <- atomically $ readItr itr itrState id
 176                resM  <- atomically $ readItr itr itrResponse id
 177                if state <= DecidingHeader then
 178                    flip runReaderT itr
 179                       $ do setStatus $ aboStatus abo
 180                            -- FIXME: 同じ名前で複數の値があった時は、こ
 181                            -- れではまずいと思ふ。
 182                            mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
 183                            setContentType ("application" +/+ "xhtml+xml")
 184                            output $ abortPage conf reqM resM abo
 185                  else
 186                    hPutStrLn stderr $ show abo
 187
 188                flip runReaderT itr $ driftTo Done
 189
 190       formatIOE :: IOError -> String
 191       formatIOE ioE = if isUserError ioE then
 192                           ioeGetErrorString ioE
 193                       else
 194                           show ioE