{-# LANGUAGE
    DoAndIfThenElse
  , ExistentialQuantification
  , FlexibleInstances
  , GeneralizedNewtypeDeriving
  , OverlappingInstances
  , MultiParamTypeClasses
  , RecordWildCards
  , ScopedTypeVariables
  , TemplateHaskell
  , UndecidableInstances
  , UnicodeSyntax
  #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Network.HTTP.Lucu.Dispatcher.Internal
    ( SchemeMapper(..)
    , SchemeMap
    , HostMapper(..)
    , HostMap
    , ResourceMapper(..)
    , ResourceMap
    , ResourceTree
    , ResourceNode

    , dispatch
    )
    where
import Control.Applicative hiding (empty)
import Control.Monad.Trans.Maybe
import Control.Monad.Unicode
import Data.Collections
import qualified Data.Map as M
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
import Prelude hiding (filter, lookup, null)
import Prelude.Unicode

-- |FIXME: docs
--
-- Minimal complete definition: 'findHostMap'
class SchemeMapper α where
    findHostMap ∷ Scheme → α → MaybeT IO HostMap
    schemeMap   ∷ α → SchemeMap
    {-# INLINE schemeMap #-}
    schemeMap   = SMap

-- |Container type for the 'SchemeMapper' type class.
data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α

-- |FIXME: docs
--
-- Minimal complete definition: 'findResourceMap'
class HostMapper α where
    findResourceMap ∷ Host → α → MaybeT IO ResourceMap
    hostMap ∷ α → HostMap
    {-# INLINE hostMap #-}
    hostMap = HMap

-- |Container type for the 'HostMapper' type class.
data HostMap = ∀α. HostMapper α ⇒ HMap α

-- |FIXME: docs
--
-- Minimal complete definition: 'findResource'
class ResourceMapper α where
    findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
    resourceMap  ∷ α → ResourceMap
    {-# INLINE resourceMap #-}
    resourceMap = RMap

-- |Container type for the 'ResourceMapper' type class.
data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α

-- |FIXME: doc
newtype ResourceTree = Root ResourceNode
    deriving (Monoid, Show)

-- |FIXME: docs
data ResourceNode
    = Greedy    !Resource
    | NonGreedy !Resource !SubTree
    | Branch              !SubTree

type SubTree
    = M.Map PathSegment ResourceNode

-- Instances of SchemeMapper --------------------------------------------------
instance SchemeMapper SchemeMap where
    {-# INLINE findHostMap #-}
    findHostMap s (SMap α) = findHostMap s α
    {-# INLINE schemeMap #-}
    schemeMap = id

-- |'HostMap's are also 'SchemeMapper's too, which matches to any
-- schemes.
instance SchemeMapper HostMap where
    {-# INLINE findHostMap #-}
    findHostMap = const return

-- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
-- schemes and hosts.
instance SchemeMapper ResourceMap where
    {-# INLINE findHostMap #-}
    findHostMap _ r = return $ hostMap f
        where
          f ∷ Host → Maybe ResourceMap
          {-# INLINE f #-}
          f = const $ Just r

-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
    {-# INLINE insert #-}
    insert a (SMap b) = schemeMap c
        where
          c ∷ Scheme → MaybeT IO HostMap
          {-# INLINEABLE c #-}
          c s = findHostMap s a <|> findHostMap s b
    {-# INLINE empty #-}
    empty = (∅)
    {-# INLINE singleton #-}
    singleton = schemeMap

-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
instance Monoid SchemeMap where
    {-# INLINE mempty #-}
    mempty = schemeMap e
        where
          e ∷ Scheme → MaybeT IO HostMap
          {-# INLINE e #-}
          e = const (fail (⊥))
    {-# INLINE mappend #-}
    mappend = insert

-- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's.
instance Map α Scheme HostMap ⇒ SchemeMapper α where
    {-# INLINE findHostMap #-}
    findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup

-- |An IO-based scheme mapper.
instance SchemeMapper (Scheme → MaybeT IO HostMap) where
    {-# INLINE findHostMap #-}
    findHostMap = flip id

-- |A pure scheme mapper.
instance SchemeMapper (Scheme → Maybe HostMap) where
    {-# INLINE findHostMap #-}
    findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id


-- Instances of HostMapper ----------------------------------------------------
instance HostMapper HostMap where
    {-# INLINE findResourceMap #-}
    findResourceMap h (HMap α) = findResourceMap h α
    {-# INLINE hostMap #-}
    hostMap = id

-- |'ResourceMap's are also 'HostMapper's too, which matches to any
-- hosts.
instance HostMapper ResourceMap where
    {-# INLINE findResourceMap #-}
    findResourceMap = const return

-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
instance HostMapper α ⇒ Unfoldable HostMap α where
    {-# INLINE insert #-}
    insert a (HMap b) = hostMap c
        where
          c ∷ Host → MaybeT IO ResourceMap
          {-# INLINEABLE c #-}
          c h = findResourceMap h a <|> findResourceMap h b
    {-# INLINE empty #-}
    empty = (∅)
    {-# INLINE singleton #-}
    singleton = hostMap

-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
instance Monoid HostMap where
    {-# INLINE mempty #-}
    mempty = hostMap e
        where
          e ∷ Host → MaybeT IO ResourceMap
          {-# INLINE e #-}
          e = const (fail (⊥))
    {-# INLINE mappend #-}
    mappend = insert

-- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
instance Map α Host ResourceMap ⇒ HostMapper α where
    {-# INLINE findResourceMap #-}
    findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup

-- |An IO-based host mapper.
instance HostMapper (Host → MaybeT IO ResourceMap) where
    {-# INLINE findResourceMap #-}
    findResourceMap = flip id

-- |A pure host mapper.
instance HostMapper (Host → Maybe ResourceMap) where
    {-# INLINE findResourceMap #-}
    findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id

-- Instances of ResourceMapper ------------------------------------------------
instance ResourceMapper ResourceMap where
    {-# INLINE findResource #-}
    findResource s (RMap α) = findResource s α
    {-# INLINE resourceMap #-}
    resourceMap = id

-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
    {-# INLINE insert #-}
    insert a (RMap b) = resourceMap c
        where
          c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
          {-# INLINEABLE c #-}
          c s = findResource s a <|> findResource s b
    {-# INLINE empty #-}
    empty = (∅)
    {-# INLINE singleton #-}
    singleton = resourceMap

-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
instance Monoid ResourceMap where
    {-# INLINE mempty #-}
    mempty = resourceMap e
        where
          e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
          {-# INLINE e #-}
          e = const (fail (⊥))
    {-# INLINE mappend #-}
    mappend = insert

-- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
-- are also 'ResourceMapper's.
instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
    {-# INLINE findResource #-}
    findResource = (maybe (fail (⊥)) return ∘) ∘ lookup

-- |An IO-based resource mapper.
instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
    {-# INLINE findResource #-}
    findResource = flip id

-- |A pure resource mapper.
instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
    {-# INLINE findResource #-}
    findResource = (maybe (fail (⊥)) return ∘) ∘ flip id

-- Instances of ResourceTree --------------------------------------------------
instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
    {-# INLINEABLE insert #-}
    insert (p, a) (Root b) = Root $ insertNodeAt (canonPath p) a b
    {-# INLINE empty #-}
    empty = Root $ Branch (∅)

canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
{-# INLINEABLE canonPath #-}
canonPath = filter ((¬) ∘ null)

insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode
{-# INLINEABLE insertNodeAt #-}
insertNodeAt p a b
    = case front p of
        Nothing         → a ⊕ b
        Just (x, xs)
            | null xs   → Branch (singleton (x, a)) ⊕ b
            | otherwise → insertNodeAt xs a (∅) ⊕ b

instance Foldable ResourceTree (PathSegments, ResourceNode) where
    foldMap f (Root n) = go (∅) n
        where
          go p (Greedy    r  ) = f (p, Greedy r)
          go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m
          go p (Branch      m) = go' p m

          go' p = foldMap $ \(s, n') → go (p `snoc` s) n'

    null (Root (Greedy    _  )) = False
    null (Root (NonGreedy _ _)) = False
    null (Root (Branch      m)) = null m


-- Instances of ResourceNode --------------------------------------------------
instance Show ResourceNode where
    show (Greedy    _  ) = "Greedy _"
    show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m
    show (Branch      m) = "Branch " ⊕ show m

instance Monoid ResourceNode where
    {-# INLINE mempty #-}
    mempty = Branch (∅)
    {-# INLINEABLE mappend #-}
    mappend (Greedy    r  ) _               = Greedy    r
    mappend (NonGreedy r m) (Greedy    _  ) = NonGreedy r      m
    mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n)
    mappend (NonGreedy r m) (Branch      n) = NonGreedy r (m ⊕ n)
    mappend (Branch      _) (Greedy    r  ) = Greedy    r
    mappend (Branch      m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
    mappend (Branch      m) (Branch      n) = Branch      (m ⊕ n)

-- dispatch -------------------------------------------------------------------
dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
dispatch uri
    = (findResource (uriPathSegments uri) =≪)
      ∘ (findResourceMap (uriHost uri) =≪)
      ∘ findHostMap (uriCIScheme uri)

{-
-- |'ResTree' is an opaque structure which is a map from resource path
-- to 'Resource'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
type ResSubtree = Map ByteString ResNode
data ResNode    = ResNode (Maybe Resource) 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
--             ]
-- @
--
-- Note that path components are always represented as octet streams
-- in this system. Lucu automatically decodes percent-encoded URIs but
-- has no involvement in character encodings such as UTF-8, since RFC
-- 2616 (HTTP/1.1) says nothing about character encodings to be used
-- in \"http\" and \"https\" URI schemas.
mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
mkResTree = processRoot ∘ map (first canonicalisePath)
    where
      canonicalisePath ∷ [ByteString] → [ByteString]
      canonicalisePath = filter ((¬) ∘ BS.null)

      processRoot ∷ [ ([ByteString], Resource) ] → 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 ∷ [ ([ByteString], Resource) ] → 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
-}