module Network.HTTP.Lucu.Resource.Tree
    ( ResourceDef(..)
    , Resource
    , ResTree
    , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree

    , findResource -- ResTree -> URI -> Maybe ResourceDef
    , runResource  -- ResourceDef -> Interaction -> IO ThreadId
    )
    where

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad.Reader
import           Data.Dynamic
import           Data.List
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.Maybe
import           Network.HTTP.Lucu.Abortion
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Request
import           Network.HTTP.Lucu.Resource
import           Network.HTTP.Lucu.Response
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Utils
import           Network.URI
import           System.IO
import           System.IO.Error hiding (catch)
import           Prelude hiding (catch)


{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
   れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
   /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
   される。 -}
data ResourceDef = ResourceDef {
      resUsesNativeThread :: Bool
    , resIsGreedy         :: Bool
    , resGet              :: Maybe (Resource ())
    , resHead             :: Maybe (Resource ())
    , resPost             :: Maybe (Resource ())
    , resPut              :: Maybe (Resource ())
    , resDelete           :: Maybe (Resource ())
    }
type ResTree    = ResNode -- root だから Map ではない
type ResSubtree = Map String ResNode
data ResNode    = ResNode (Maybe ResourceDef) ResSubtree


mkResTree :: [ ([String], ResourceDef) ] -> ResTree
mkResTree list = processRoot list
    where
      processRoot :: [ ([String], ResourceDef) ] -> ResTree
      processRoot list
          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
                children = processNonRoot nonRoots
            in
              if null roots then
                  -- / にリソースが定義されない。/foo とかにはあるかも。
                  ResNode Nothing children
              else
                  -- / がある。
                  let (_, def) = last roots
                  in 
                    ResNode (Just def) children

      processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
      processNonRoot list
          = let subtree    = M.fromList [(name, node name)
                                             | name <- childNames]
                childNames = [name | (name:_, _) <- list]
                node name  = let defs = [def | (path, def) <- list, path == [name]]
                             in
                               if null defs then
                                   -- この位置にリソースが定義されない。
                                   -- もっと下にはあるかも。
                                   ResNode Nothing children
                               else
                                   -- この位置にリソースがある。
                                   ResNode (Just $ last defs) children
                children   = processNonRoot [(path, def)
                                                 | (_:path, def) <- list, not (null path)]
            in
              subtree


findResource :: ResTree -> URI -> Maybe ResourceDef
findResource (ResNode rootDefM subtree) uri
    = let pathStr = uriPath uri
          path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
      in
        if null path then
            rootDefM
        else
            walkTree subtree path
    where
      walkTree :: ResSubtree -> [String] -> Maybe ResourceDef

      walkTree subtree (name:[])
          = case M.lookup name subtree of
              Nothing               -> Nothing
              Just (ResNode defM _) -> defM

      walkTree subtree (x:xs)
          = case M.lookup x subtree of
              Nothing                      -> Nothing
              Just (ResNode defM children) -> case defM of
                                                Just (ResourceDef { resIsGreedy = True })
                                                    -> defM
                                                _   -> walkTree children xs


runResource :: ResourceDef -> Interaction -> IO ThreadId
runResource def itr
    = fork
      $ catch ( runReaderT ( do fromMaybe notAllowed rsrc 
                                driftTo Done
                           ) itr
              )
      $ \ exc -> processException (itrConfig itr) exc
    where
      fork :: IO () -> IO ThreadId
      fork = if (resUsesNativeThread def)
             then forkOS
             else forkIO
      
      rsrc :: Maybe (Resource ())
      rsrc = case reqMethod $ fromJust $ itrRequest itr of
               GET    -> resGet def
               HEAD   -> case resHead def of
                           Just r  -> Just r
                           Nothing -> resGet def
               POST   -> resPost def
               PUT    -> resPut def
               DELETE -> resDelete def

      notAllowed :: Resource ()
      notAllowed = do setStatus MethodNotAllowed
                      setHeader "Allow" $ joinWith ", " allowedMethods

      allowedMethods :: [String]
      allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
                                           , methods resHead   ["GET", "HEAD"]
                                           , methods resPost   ["POST"]
                                           , methods resPut    ["PUT"]
                                           , methods resDelete ["DELETE"]
                                           ]

      methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
      methods f xs = case f def of
                       Just _  -> xs
                       Nothing -> []

      processException :: Config -> Exception -> IO ()
      processException conf exc
          = do let abo = case exc of
                           ErrorCall    msg  -> Abortion InternalServerError [] msg
                           IOException  ioE  -> Abortion InternalServerError [] $ formatIOE ioE
                           DynException dynE -> case fromDynamic dynE of
                                                  Just (abo :: Abortion) -> abo
                                                  Nothing
                                                      -> Abortion InternalServerError []
                                                         $ show exc
                           _                 -> Abortion InternalServerError [] $ show exc
               -- まだ DecidingHeader 以前の状態だったら、この途中終了
               -- を應答に反映させる餘地がある。さうでなければ stderr
               -- にでも吐くしか無い。
               state <- atomically $ readItr itr itrState id
               if state <= DecidingHeader then
                   flip runReaderT itr
                      $ do setStatus $ aboStatus abo
                           -- FIXME: 同じ名前で複數の値があった時は、こ
                           -- れではまずいと思ふ。
                           mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
                           setHeader "Content-Type" "application/xhtml+xml"
                           output $ aboPage conf abo
                 else
                   hPutStrLn stderr $ show abo

               flip runReaderT itr $ driftTo Done

      formatIOE :: IOError -> String
      formatIOE ioE = if isUserError ioE then
                          ioeGetErrorString ioE
                      else
                          show ioE