{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.HTTP.Router where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), (>=>))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (toList)
import Data.Function (($), (.), id, const)
import Data.Functor (Functor, (<$>), (<$))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Tuple (fst, snd)
import Prelude (Num(..), max, undefined)
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Reader as R
import qualified Data.ByteString as BS
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Text.Megaparsec as P
import qualified Web.HttpApiData as Web

import Language.Symantic.HTTP.Media
import Language.Symantic.HTTP.Mime
import Language.Symantic.HTTP.API

-- import Debug.Trace

-- * Type 'Router'
-- | @Router f k@ is a recipe to produce an 'Wai.Application'
-- from handlers 'f' (one per number of alternative routes).
--
-- 'Router' is analogous to a scanf using a format customized for HTTP routing.
newtype Router f k = Router { unRouter ::
 f -> R.ReaderT Wai.Request
               (P.Parsec RouteError RouteTokens)
               k }
 deriving (Functor {-, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens-})
instance Applicative (Router f) where
	pure a = Router $ const $ return a
	Router ma2b <*> Router mb = Router $ \f -> ma2b f <*> mb f
instance Monad (Router f) where
	return = pure
	Router ma >>= a2mb = Router $ \f ->
		ma f >>= ($ f) . unRouter . a2mb

-- | Useful to constrain 'repr' to be 'Router'.
router :: Router f k -> Router f k
router = id

-- | Special case where the handler 'f' is 'id'.
-- Useful within a 'Router' to get the return value of another 'Router'.
inRouter ::
 Router (a -> a) k ->
 R.ReaderT Wai.Request (P.Parsec RouteError RouteTokens) k
inRouter = (`unRouter` id)

-- | @'runRouter' rt api@ returns a 'Wai.Application'
-- ready to be given to @Warp.run 80@.
runRouter :: Router api RouterResponse -> api -> Wai.Application
runRouter (Router rt) api rq re =
	let p = R.runReaderT (rt api) rq in
	let r = RouteToken_Segment <$> Wai.pathInfo rq in
	case P.runParser (p <* P.eof) "<Request>" r of
	 Right (RouterResponse app) -> app rq re
	 Left err ->
		-- trace (show rq) $
		re $ Wai.responseLBS status404
		 [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
		 (fromString $ P.errorBundlePretty err)

-- ** Type 'RouteError'
data RouteError
 =   RouteError_Accept_unsupported {-expected-}MediaType {-got-}HeaderValue
 |   RouteError_Query_param_not_a_boolean QueryName [Maybe BS.ByteString]
 |   RouteError_HttpApiData Text.Text
 deriving (Eq, Ord, Show)
instance P.ShowErrorComponent RouteError where
	showErrorComponent = show

-- ** Type 'RoutingResult'
type RoutingResult = Either RoutingError
type RoutingError = P.ParseErrorBundle RouteTokens RouteError

-- ** Type 'RouterResponse'
newtype RouterResponse = RouterResponse
 ( -- the request made to the router
   Wai.Request ->
   -- the continuation for the router to respond
   (Wai.Response -> IO Wai.ResponseReceived) ->
   IO Wai.ResponseReceived
 )

-- * Type 'RouteTokens'
type RouteTokens = [RouteToken]
instance P.Stream RouteTokens where
	type Token  RouteTokens = RouteToken
	type Tokens RouteTokens = RouteTokens
	take1_ = List.uncons
	takeN_ n s | n <= 0 = Just ([], s)
	           | List.null s = Nothing
	           | otherwise = Just (List.splitAt n s)
	takeWhile_ = List.span
	tokenToChunk _ps = pure
	tokensToChunk _ps = id
	chunkToTokens _ps = id
	chunkLength _ps = List.length
	chunkEmpty _ps = List.null
	showTokens _s toks = List.intercalate ", " $ toList $ show <$> toks
	reachOffset o pos@P.PosState{..} =
		( spos
		, List.head $ (show <$> inp)<>["End"]
		, pos
		 { P.pstateInput     = inp
		 , P.pstateOffset    = max o pstateOffset
		 , P.pstateSourcePos = spos
		 })
		where
		d    = o - pstateOffset
		inp  = List.drop d pstateInput
		line | d == 0    = P.sourceLine pstateSourcePos
		     | otherwise = P.sourceLine pstateSourcePos <> P.mkPos d
		spos = pstateSourcePos{P.sourceLine = line}
instance P.Stream Path where
	type Token  Path = Segment
	type Tokens Path = [Segment]
	take1_ = List.uncons
	takeN_ n s | n <= 0 = Just ([], s)
	           | List.null s = Nothing
	           | otherwise = Just (List.splitAt n s)
	takeWhile_ = List.span
	tokenToChunk _ps = pure
	tokensToChunk _ps = id
	chunkToTokens _ps = id
	chunkLength _ps = List.length
	chunkEmpty _ps = List.null
	showTokens _s toks = List.intercalate ", " $ toList $ Text.unpack <$> toks
	reachOffset o pos@P.PosState{..} =
		( spos
		, List.head $ (show <$> inp)<>["End"]
		, pos
		 { P.pstateInput     = inp
		 , P.pstateOffset    = max o pstateOffset
		 , P.pstateSourcePos = spos
		 }
		)
		where
		d    = o - pstateOffset
		inp  = List.drop d pstateInput
		spos = pstateSourcePos{P.sourceLine = P.sourceLine pstateSourcePos <> P.mkPos d}

-- ** Type 'RouteToken'
data RouteToken
 =   RouteToken_Segment     Segment
 |   RouteToken_Header      HTTP.HeaderName
 |   RouteToken_Headers     HTTP.RequestHeaders
 |   RouteToken_Query       QueryName
 |   RouteToken_QueryString HTTP.Query
 |   RouteToken_Method      HTTP.Method
 |   RouteToken_Version     HTTP.HttpVersion
 deriving (Eq, Ord, Show)

unRouteToken_Segment :: RouteToken -> Segment
unRouteToken_Segment (RouteToken_Segment x) = x
unRouteToken_Segment _ = undefined

instance Appli Router where
	Router x <.> Router y = Router $ x >=> y
instance Altern Router where
	Router x <!> Router y = Router $ \(b:!:c) ->
		P.try (x b) <|> y c
	{-
	type AlternMerge Router = Either
	Router x <!> Router y = Router $ \(b:!:c) ->
		P.try (Left <$> x b)
		<|> (Right <$> y c)
	-}
	try (Router r) = Router (P.try <$> r)
instance HTTP_Path Router where
	segment s  = Router $ \f -> f <$ P.single (RouteToken_Segment s)
	capture' _n = Router $ \f -> do
		ret <- unRouteToken_Segment <$> P.anySingle
		case Web.parseUrlPiece ret of
		 Right ok -> return (f ok)
		 Left err -> P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ RouteError_HttpApiData err
	captureAll = Router $ \f -> f <$> P.many (unRouteToken_Segment <$> P.anySingle)
instance HTTP_Method Router where
	method exp = Router $ \f -> do
		got <- R.asks Wai.requestMethod
		inp <- P.getInput
		P.setInput [RouteToken_Method got]
		(`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Method exp)) $ \_tok ->
			if got == exp
			 then Just ()
			 else Nothing
		P.setInput inp
		return f
instance HTTP_Header Router where
	header exp = Router $ \f -> do
		got <- R.asks Wai.requestHeaders
		inp <- P.getInput
		P.setInput [RouteToken_Headers got]
		ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Header exp)) $ \_tok ->
			List.lookup exp got
		P.setInput inp
		return (f ret)
instance HTTP_Accept Router where
	accept exp = Router $ \f -> do
		hdr <- inRouter $ header HTTP.hAccept
		case Media.parseAccept hdr of
		 Just got | mediaType exp`Media.matches`got -> return f
		 _ -> P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ RouteError_Accept_unsupported (mediaType exp) hdr
instance HTTP_Query Router where
	query exp = Router $ \f -> do
		got <- R.asks Wai.queryString
		inp <- P.getInput
		P.setInput [RouteToken_QueryString got]
		ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Query exp)) $ \_tok ->
			case List.filter ((== exp) . fst) got of
			 [] -> Nothing
			 hs -> Just $ snd <$> hs
		P.setInput inp
		return (f ret)
	queryFlag n = Router $ \f -> do
		vs <- inRouter $ query n
		f <$> case vs of
		 [] -> return True
		 [Nothing] -> return True
		 [Just "0"] -> return False
		 [Just "false"] -> return False
		 [Just "1"] -> return True
		 [Just "true"] -> return True
		 _ -> P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ RouteError_Query_param_not_a_boolean n vs
instance HTTP_Version Router where
	version exp = Router $ \f -> do
		got <- R.asks Wai.httpVersion
		inp <- P.getInput
		P.setInput [RouteToken_Version got]
		(`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Version exp)) $ \_tok ->
			if got == exp
			 then Just ()
			 else Nothing
		P.setInput inp
		return f
-- ** Type 'RouterEndpointArg'
newtype RouterEndpointArg mt a = RouterEndpointArg
 (HTTP.Status ->
  HTTP.ResponseHeaders ->
  a -> Wai.Response)
instance HTTP_Endpoint Router where
	type Endpoint Router = RouterResponse
	type EndpointArg Router = RouterEndpointArg
	endpoint' ::
	 forall repr k mt a.
	 MimeSerialize mt a =>
	 MimeUnserialize mt a =>
	 k ~ Endpoint repr =>
	 repr ~ Router =>
	 HTTP.Method ->
	 repr (EndpointArg repr mt a -> k) k
	endpoint' expMethod = Router $ \f -> do
		meth <-
			if expMethod == HTTP.methodGet
			then
				-- (unEither <$>) $
				(`unRouter` (HTTP.methodHead:!:HTTP.methodGet)) $
				method HTTP.methodHead <!> method HTTP.methodGet
			else (`unRouter` expMethod) $ method expMethod
		hAccept <- (`unRouter` (id:!:id)) $ header HTTP.hAccept <!> pure "*/*"
		let mt = mediaType (Proxy::Proxy mt)
		case Media.parseAccept hAccept of
		 Just gotAccept | mt`Media.matches`gotAccept ->
			return $ f $ RouterEndpointArg $ \st hs a ->
				Wai.responseLBS st
				 ((HTTP.hContentType, Media.renderHeader mt):hs)
				 (if meth == HTTP.methodHead then "" else mimeSerialize (Proxy::Proxy mt) a)
		 _ -> P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ RouteError_Accept_unsupported mt hAccept
instance HTTP_API Router

{-
unEither :: Either a a -> a
unEither (Left a) = a
unEither (Right a) = a
-}