{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE TypeOperators     #-}
{-# LANGUAGE FlexibleContexts  #-}
module Snap.Routes
  ( Routes
  , showRoutes
  , expandRoutes
  , addRoute
  , get
  , get_
  , Snap.Routes.head
  , head_
  , post
  , post_
  , put
  , put_
  , delete
  , delete_
  , trace
  , trace_
  , options
  , options_
  , connect
  , connect_
  )
where

import Control.Applicative hiding (Const)
import Control.Monad
import Control.Monad.State.Strict hiding (get, put)
import Data.ByteString (ByteString)
import Data.Either
import Data.List hiding (head, delete)
import Data.Predicate
import Data.Predicate.Env (Env)
import Snap.Core
import Snap.Predicates
import qualified Data.List as L
import qualified Data.Predicate.Env as E
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as C

data Pack m where
    Pack :: (Show p, Predicate p Request, FVal p ~ Error)
         => p
         -> (TVal p -> m ())
         -> Pack m

data Route m = Route
  { _method  :: !Method
  , _path    :: !ByteString
  , _pred    :: !(Pack m)
  }

-- | The Routes monad is used to add routing declarations via 'addRoute' or
-- one of 'get', 'post', etc.
-- Routing declarations can then be turned into the ordinary snap format,
-- i.e. @MonadSnap m => [(ByteString, m a)]@ or into strings.
newtype Routes m a = Routes
  { _unroutes :: State [Route m] a }

instance Monad (Routes m) where
    return  = Routes . return
    m >>= f = Routes $ _unroutes m >>= _unroutes . f

-- | Add a route for some 'Method' and path (potentially with variable
-- captures), and constrained the some 'Predicate'.
addRoute :: (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)
         => Method
         -> ByteString        -- ^ path
         -> (TVal p -> m ())  -- ^ handler
         -> p                 -- ^ 'Predicate'
         -> Routes m ()
addRoute m r x p = Routes $ modify ((Route m r (Pack p x)):)

-- | Specialisation of 'addRoute' for a specific HTTP 'Method'.
get, head, post, put, delete, trace, options, connect ::
    (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)
    => ByteString        -- ^ path
    -> (TVal p -> m ())  -- ^ handler
    -> p                 -- ^ 'Predicate'
    -> Routes m ()
get     = addRoute GET
head    = addRoute HEAD
post    = addRoute POST
put     = addRoute PUT
delete  = addRoute DELETE
trace   = addRoute TRACE
options = addRoute OPTIONS
connect = addRoute CONNECT

-- | Specialisation of 'addRoute' for a specific HTTP 'Method' taking
-- no 'Predicate' into consideration.
get_, head_, post_, put_, delete_, trace_, options_, connect_ ::
    (MonadSnap m)
    => ByteString    -- ^ path
    -> (() -> m ())  -- ^ handler
    -> Routes m ()
get_     p h = addRoute GET     p h (Const ())
head_    p h = addRoute HEAD    p h (Const ())
post_    p h = addRoute POST    p h (Const ())
put_     p h = addRoute PUT     p h (Const ())
delete_  p h = addRoute DELETE  p h (Const ())
trace_   p h = addRoute TRACE   p h (Const ())
options_ p h = addRoute OPTIONS p h (Const ())
connect_ p h = addRoute CONNECT p h (Const ())

-- | Turn route definitions into a list of 'String's.
showRoutes :: Routes m () -> [String]
showRoutes (Routes routes) =
    flip map (concat . normalise $ execState routes []) $ \x ->
        case _pred x of
            Pack p _ -> shows (_method x)
                      . (' ':)
                      . shows (_path x)
                      . (' ':)
                      . shows p $ ""

-- | Turn route definitions into \"snapable\" format, i.e.
-- Routes are grouped per path and selection evaluates routes
-- against the given Snap 'Request'.
expandRoutes :: MonadSnap m => Routes m () -> [(ByteString, m ())]
expandRoutes (Routes routes) =
    map (\g -> (_path (L.head g), select g)) (normalise $ execState routes [])

-- | Group routes by path.
normalise :: [Route m] -> [[Route m]]
normalise rr =
    let rg    = grouped . sorted $ rr
        paths = map (namelessPath . L.head) rg
        ambig = paths \\ nub paths
    in if null ambig then rg else error (ambiguityMessage ambig)
  where
    sorted :: [Route m] -> [Route m]
    sorted = sortBy (\a b -> _path a `compare` _path b)

    grouped :: [Route m] -> [[Route m]]
    grouped = groupBy (\a b -> _path a == _path b)

    namelessPath :: Route m -> ByteString
    namelessPath =
        let colon = 0x3A
            slash = 0x2F
            fun s = if s /= "" && S.head s == colon then "<>" else s
        in S.intercalate "/" . map fun . S.split slash . _path

    ambiguityMessage a =
        "Paths differing only in variable names are not supported.\n"  ++
        "Problematic paths (with variable positions denoted by <>):\n" ++
        (show a)

data Handler m = Handler
  { _delta   :: !Delta
  , _handler :: !(m ())
  }

-- The handler selection proceeds as follows:
-- (1) Consider only handlers with matching methods, or else return 405.
-- (2) Evaluate 'Route' predicates.
-- (3) Pick the first one which is 'Good', or else respond with status
--     and message of the first one.
select :: MonadSnap m => [Route m] -> m ()
select g = do
    ms <- filterM byMethod g
    if null ms
        then do
            respond (Error 405 Nothing)
            modifyResponse (setHeader "Allow" validMethods)
        else evalAll ms
  where
    byMethod :: MonadSnap m => Route m -> m Bool
    byMethod x = (_method x ==) <$> getsRequest rqMethod

    validMethods :: ByteString
    validMethods = S.intercalate "," $ nub (C.pack . show . _method <$> g)

    evalAll :: MonadSnap m => [Route m] -> m ()
    evalAll rs = do
        req <- getRequest
        let (n, y) = partitionEithers . snd $ foldl' (evalSingle req) (E.empty, []) rs
        if null y
            then respond (L.head n)
            else closest y

    evalSingle :: MonadSnap m => Request -> (Env, [Either Error (Handler m)]) -> Route m -> (Env, [Either Error (Handler m)])
    evalSingle rq (e, rs) r =
        case _pred r of
            Pack p h ->
                case runState (apply p rq) e of
                    (F   m, e') -> (e', Left m : rs)
                    (T d v, e') -> (e', Right (Handler d (h v)) : rs)

    closest :: MonadSnap m => [Handler m] -> m ()
    closest = foldl' (<|>) pass
            . map _handler
            . sortBy (\a b -> _delta a `compare` _delta b)

respond :: MonadSnap m => Error -> m ()
respond e = do
    putResponse . clearContentLength
                . setResponseCode (fromIntegral . _status $ e)
                $ emptyResponse
    maybe (return ()) writeBS (_message e)