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