{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
{-# OPTIONS_HADDOCK prune #-}

-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
    ( ResourceDef(..)
    , emptyResource

    , ResTree
    , FallbackHandler

    , mkResTree

    , findResource
    , runResource
    )
    where
import           Control.Arrow
import Control.Applicative
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as LT
import           Data.List
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.Maybe
import Data.Monoid.Unicode
import           Network.HTTP.Lucu.Abortion
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Headers (fromHeaders)
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 hiding (path)
import           System.IO
import           Prelude hiding (catch)
import Prelude.Unicode


-- |'FallbackHandler' is an extra resource handler for resources which
-- can't be statically located anywhere in the resource tree. The Lucu
-- httpd first searches for a resource in the tree, and then calls
-- fallback handlers to ask them for a resource. If all of the
-- handlers returned 'Nothing', the httpd responds with 404 Not Found.
type FallbackHandler = [Text] → IO (Maybe ResourceDef)


-- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
-- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
-- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
-- 無視される。

-- | 'ResourceDef' is basically a set of 'Resource' monads for each
-- HTTP methods.
data ResourceDef = ResourceDef {
    -- |Whether to run a 'Resource' on a native thread (spawned by
    -- 'forkOS') or to run it on a user thread (spanwed by
    -- 'forkIO'). Generally you don't need to set this field to
    -- 'True'.
      resUsesNativeThread ∷ !Bool
    -- | Whether to be greedy or not.
    -- 
    -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
    -- greedy resource at \/aaa\/bbb, it is always chosen even if
    -- there is another resource at \/aaa\/bbb\/ccc. If the resource
    -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
    -- resources are like CGI scripts.
    , resIsGreedy         ∷ !Bool
    -- | A 'Resource' to be run when a GET request comes for the
    -- resource path. If 'resGet' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for GET requests.
    -- 
    -- It also runs for HEAD request if the 'resHead' is Nothing. In
    -- this case 'output' and such like don't actually write a
    -- response body.
    , resGet              ∷ !(Maybe (Resource ()))
    -- | A 'Resource' to be run when a HEAD request comes for the
    -- resource path. If 'resHead' is Nothing, the system runs
    -- 'resGet' instead. If 'resGet' is also Nothing, the system
    -- responds \"405 Method Not Allowed\" for HEAD requests.
    , resHead             ∷ !(Maybe (Resource ()))
    -- | A 'Resource' to be run when a POST request comes for the
    -- resource path. If 'resPost' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for POST requests.
    , resPost             ∷ !(Maybe (Resource ()))
    -- | A 'Resource' to be run when a PUT request comes for the
    -- resource path. If 'resPut' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for PUT requests.
    , resPut              ∷ !(Maybe (Resource ()))
    -- | A 'Resource' to be run when a DELETE request comes for the
    -- resource path. If 'resDelete' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for DELETE requests.
    , resDelete           ∷ !(Maybe (Resource ()))
    }

-- |'emptyResource' is a resource definition with no actual
-- handlers. You can construct a 'ResourceDef' by selectively
-- overriding 'emptyResource'. It is defined as follows:
--
-- @
--   emptyResource = ResourceDef {
--                     resUsesNativeThread = False
--                   , resIsGreedy         = False
--                   , resGet              = Nothing
--                   , resHead             = Nothing
--                   , resPost             = Nothing
--                   , resPut              = Nothing
--                   , resDelete           = Nothing
--                   }
-- @
emptyResource ∷ ResourceDef
emptyResource = ResourceDef {
                  resUsesNativeThread = False
                , resIsGreedy         = False
                , resGet              = Nothing
                , resHead             = Nothing
                , resPost             = Nothing
                , resPut              = Nothing
                , resDelete           = Nothing
                }

-- |'ResTree' is an opaque structure which is a map from resource path
-- to 'ResourceDef'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
type ResSubtree = Map Text ResNode
data ResNode    = ResNode (Maybe ResourceDef) ResSubtree

-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
--
-- @
--   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
--             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
--             ]
-- @
mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
mkResTree = processRoot ∘ map (first canonicalisePath)
    where
      canonicalisePath ∷ [Text] → [Text]
      canonicalisePath = filter (≢ "")

      processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
      processRoot list
          = let (roots, nonRoots) = partition (\(path, _) → null path) list
                children = processNonRoot nonRoots
            in
              if null roots then
                  -- The root has no resources. Maybe there's one at
                  -- somewhere like "/foo".
                  ResTree (ResNode Nothing children)
              else
                  -- There is a root resource.
                  let (_, def) = last roots
                  in 
                    ResTree (ResNode (Just def) children)

      processNonRoot ∷ [ ([Text], 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
                                   -- No resources are defined
                                   -- here. Maybe there's one at
                                   -- somewhere below this node.
                                   ResNode Nothing children
                               else
                                   -- There is a resource here.
                                   ResNode (Just $ last defs) children
                children   = processNonRoot [(path, def)
                                                 | (_:path, def) ← list]
            in
              subtree

findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
    = do let path          = splitPathInfo uri
             hasGreedyRoot = maybe False resIsGreedy rootDefM
             foundInTree    = if hasGreedyRoot ∨ null path then
                                  do def ← rootDefM
                                     return ([], def)
                              else
                                  walkTree subtree path []
         if isJust foundInTree then
             return foundInTree
         else
             fallback path fbs
    where
      walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)

      walkTree _ [] _
          = error "Internal error: should not reach here."

      walkTree tree (name:[]) soFar
          = do ResNode defM _ ← M.lookup name tree
               def            ← defM
               return (soFar ⧺ [name], def)

      walkTree tree (x:xs) soFar
          = do ResNode defM sub ← M.lookup x tree
               case defM of
                 Just (ResourceDef { resIsGreedy = True })
                     → do def ← defM
                          return (soFar ⧺ [x], def)
                 _   → walkTree sub xs (soFar ⧺ [x])

      fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
      fallback _    []     = return Nothing
      fallback path (x:xs) = do m ← x path
                                case m of
                                  Just def → return $ Just ([], def)
                                  Nothing  → fallback path xs


runResource ∷ ResourceDef → Interaction → IO ThreadId
runResource (ResourceDef {..}) itr@(Interaction {..})
    = fork $ run `catch` processException
    where
      fork ∷ IO () → IO ThreadId
      fork | resUsesNativeThread = forkOS
           | otherwise           = forkIO

      run ∷ IO ()
      run = flip runRes itr $
            do req ← getRequest
               fromMaybe notAllowed $ rsrc req
               driftTo Done
      
      rsrc ∷ Request → Maybe (Resource ())
      rsrc req
          = case reqMethod req of
              GET    → resGet
              HEAD   → case resHead of
                          Just r  → Just r
                          Nothing → resGet
              POST   → resPost
              PUT    → resPut
              DELETE → resDelete
              _      → error $ "Unknown request method: " ⧺ show (reqMethod req)

      notAllowed ∷ Resource ()
      notAllowed
          = setStatus MethodNotAllowed
            *>
            (setHeader "Allow" $ A.fromAsciiBuilder
                               $ joinWith ", "
                               $ map A.toAsciiBuilder allowedMethods)

      allowedMethods ∷ [Ascii]
      allowedMethods = nub $ concat [ methods resGet    ["GET"]
                                    , methods resHead   ["GET", "HEAD"]
                                    , methods resPost   ["POST"]
                                    , methods resPut    ["PUT"]
                                    , methods resDelete ["DELETE"]
                                    ]

      methods ∷ Maybe a → [Ascii] → [Ascii]
      methods m xs
          | isJust m  = xs
          | otherwise = []

      toAbortion ∷ SomeException → Abortion
      toAbortion e
          = case fromException e of
              Just abortion → abortion
              Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)

      processException ∷ SomeException → IO ()
      processException exc
          = do let abo = toAbortion exc
               -- まだ DecidingHeader 以前の状態だったら、この途中終了
               -- を應答に反映させる餘地がある。さうでなければ stderr
               -- にでも吐くしか無い。
               state ← atomically $ readTVar itrState
               res   ← atomically $ readTVar itrResponse
               if state ≤ DecidingHeader then
                   flip runRes itr $
                       do setStatus $ aboStatus abo
                          mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
                          output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
               else
                   when (cnfDumpTooLateAbortionToStderr itrConfig)
                       $ hPutStrLn stderr $ show abo
               runRes (driftTo Done) itr