{-# LANGUAGE
    ExistentialQuantification
  , FlexibleContexts
  , FlexibleInstances
  , GeneralizedNewtypeDeriving
  , OverlappingInstances
  , MultiParamTypeClasses
  , TemplateHaskell
  , UndecidableInstances
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Dispatcher.Internal
    ( HostMapper(..)
    , HostMap
    , ResourceMapper(..)
    , ResourceMap
    , ResourceTree
    , ResourceNode
    , greedy
    , nonGreedy

    , dispatch
    )
    where
import Control.Applicative hiding (empty)
import Control.Monad.Trans.Maybe
import Control.Monad.Unicode
import Data.Collections
import qualified Data.Collections.Newtype.TH as C
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, foldr, lookup, null)
import Prelude.Unicode

-- |Class of maps from 'Host' to 'ResourceMap' to provide name-based
-- virtual hosts.
--
-- Note that Lucu currently does not implement neither RFC 2817
-- connection upgrading (<http://tools.ietf.org/html/rfc2817>) nor RFC
-- 3546 server name indication
-- (<http://tools.ietf.org/html/rfc3546#section-3.1>) so you won't be
-- able to host more than one SSL virtual host on the same port
-- without using wildcard certificates
-- (<http://tools.ietf.org/html/rfc2818#section-3.1>).
--
-- Minimal complete definition: 'findResourceMap'
class HostMapper α where
    -- |Find a repository of resources for the given host name if any.
    findResourceMap ∷ Host → α → MaybeT IO ResourceMap
    -- |Wrap an instance of 'HostMapper' in a monoidal, homogeneous
    -- container.
    hostMap ∷ α → HostMap
    {-# INLINE hostMap #-}
    hostMap = HMap

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

-- |Class of maps from resource 'Path' to 'Resource'.
--
-- Minimal complete definition: 'findResource'
class ResourceMapper α where
    -- |Find a resource handler for the given resource path, along
    -- with the path where the said handler was found. The found path
    -- is usually the same as the queried path, but there are
    -- situations where the found path is just a prefix of the queried
    -- path. See 'greedy'.
    findResource ∷ Path → α → MaybeT IO (Path, Resource)
    -- |Wrap an instance of 'ResourceMapper' in a monoidal,
    -- homogeneous container.
    resourceMap  ∷ α → ResourceMap
    {-# INLINE resourceMap #-}
    resourceMap = RMap

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

-- |'ResourceTree' is an opaque structure which a map from resource
-- 'Path' to 'ResourceNode'.
--
-- @
--   'fromList' [ ([]        , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
--            , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
--            ]
-- @
--
-- Note that path segments 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.
newtype ResourceTree = Tree (M.Map Path ResourceNode)
    deriving Monoid

-- |A node of 'Resource' located somewhere in a 'ResourceTree'. Such
-- nodes are either 'greedy' or 'nonGreedy'.
data ResourceNode
    = Greedy    { nResource ∷ !Resource }
    | NonGreedy { nResource ∷ !Resource }

-- |Make a greedy resource node.
--
-- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is
-- no resource node at the path. If there are greedy resource nodes at
-- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a
-- fallback. Greedy resource nodes are searched in depth-first
-- order, just like CGI scripts.
greedy ∷ Resource → ResourceNode
{-# INLINE CONLIKE greedy #-}
greedy = Greedy

-- |Make a normal, non-greedy resource node.
nonGreedy ∷ Resource → ResourceNode
{-# INLINE CONLIKE nonGreedy #-}
nonGreedy = NonGreedy


-- 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 ∷ Path → MaybeT IO (Path, 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 ∷ Path → MaybeT IO (Path, Resource)
          {-# INLINE e #-}
          e = const (fail (⊥))
    {-# INLINE mappend #-}
    mappend = insert

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

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

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

-- Instances of ResourceTree --------------------------------------------------
instance Unfoldable ResourceTree (Path, ResourceNode) where
    {-# INLINEABLE insert #-}
    insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
    {-# INLINE empty #-}
    empty = Tree (∅)
    {-# INLINE singleton #-}
    singleton = Tree ∘ singleton

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

C.derive [d| instance Foldable ResourceTree (Path, ResourceNode)
           |]

instance Collection ResourceTree (Path, ResourceNode) where
    {-# INLINE filter #-}
    filter f (Tree m) = Tree $ filter f m

-- |'findResource' performs the longest prefix match on the tree,
-- finding the most specific one.
instance ResourceMapper ResourceTree where
    {-# INLINEABLE findResource #-}
    findResource p (Tree m)
        = case lookup p m of
            Just n  → return (p, nResource n)
            Nothing → findGreedyResource p m

findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
                   ⇒ Path
                   → α
                   → MaybeT m (Path, Resource)
findGreedyResource p m
    = case back p of
        Nothing      → fail (⊥)
        Just (p', _) → case lookup p' m of
                          Just (Greedy r)
                              → return (p', r)
                          _   → findGreedyResource p' m

-- dispatch -------------------------------------------------------------------
dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
dispatch uri
    = (findResource (uriPathSegments uri) =≪)
      ∘ findResourceMap (uriHost uri)