{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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(..), MonadPlus(..), void)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (toList)
import Data.Function (($), (.), id)
import Data.Functor (Functor)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
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 Language.Symantic.HTTP.Media
import Language.Symantic.HTTP.API

-- * Type 'Router'
newtype Router a = Router { unRouter :: R.ReaderT Wai.Request (P.Parsec RouteError RouteTokens) a }
 deriving (Functor, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens)

runRouter :: Router a -> Wai.Request -> RoutingResult a
runRouter (Router rt) rq =
	let p = R.runReaderT rt rq in
	P.runParser (p <* P.eof) "<Request>" $
		RouteToken_Segment <$> Wai.pathInfo rq

runRouterApp :: Router Application -> Wai.Application
runRouterApp rt rq re =
	case runRouter rt rq of
	 Right app -> runApplication app rq re
	 Left err -> re $ Wai.responseLBS
		 (HTTP.mkStatus 404 "Not Found")
		 [(HTTP.hContentType, Media.renderHeader $ mediaType plainText)]
		 (fromString $ P.errorBundlePretty err)

{-
runRouterIO :: Show a => Router (IO a) -> Wai.Request -> IO ()
runRouterIO rt rq =
	case runRouter rt rq of
	 Left err -> putStrLn $ P.parseErrorPretty err
	 Right a -> print =<< a
-}

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

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

-- * Type 'Application'
newtype Application = Application
 (Wai.Request ->
 (RoutingResult Wai.Response -> IO Wai.ResponseReceived) ->
 IO Wai.ResponseReceived)

runApplication :: Application -> Wai.Application
runApplication (Application app) rq re = app rq routingRespond
	where
	routingRespond :: RoutingResult Wai.Response -> IO Wai.ResponseReceived
	routingRespond = \case
	 Right res -> re res
	 Left err -> re $ Wai.responseLBS
		 (HTTP.mkStatus 404 "Not Found")
		 [(HTTP.hContentType, Media.renderHeader $ mediaType plainText)]
		 (fromString $ P.errorBundlePretty err)

-- * 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 Altern Router where
	tina    = empty
	x <+> y = P.try x <|> y
	try     = P.try
instance HTTP_Path Router where
	segment = void . P.single . RouteToken_Segment
	capture _n = unRouteToken_Segment <$> P.anySingle
	captureAll = P.many $ unRouteToken_Segment <$> P.anySingle
instance HTTP_Method Router where
	method exp = do
		got <- Router $ R.asks Wai.requestMethod
		inp <- P.getInput
		P.setInput [RouteToken_Method got]
		ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Method exp)) $ \_tok ->
			if got == exp
			 then Just got
			 else Nothing
		P.setInput inp
		return ret
instance HTTP_Header Router where
	header exp = do
		got <- Router $ 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 ret
instance HTTP_Accept Router where
	accept exp = do
		h <- header HTTP.hAccept
		case Media.parseAccept h of
		 Just got | mediaType exp`Media.matches`got -> return $ toMediaType exp
		 _ -> P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ RouteError_Accept_unsupported (mediaType exp) h
instance HTTP_Query Router where
	query exp = do
		got <- Router $ 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 ret
	queryFlag n = do
		vs <- query n
		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 = do
		got <- Router $ R.asks Wai.httpVersion
		inp <- P.getInput
		P.setInput [RouteToken_Version got]
		ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Version exp)) $ \_tok ->
			if got == exp
			 then Just got
			 else Nothing
		P.setInput inp
		return ret
-- ** Type 'RouterEndpoint'
newtype RouterEndpoint a
 =      RouterEndpoint (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
instance HTTP_Endpoint Router where
	type Endpoint Router = RouterEndpoint
	endpoint expMethod expAccept = do
		meth <- if expMethod == HTTP.methodGet
			then method HTTP.methodHead <+> method HTTP.methodGet
			else method expMethod
		hAccept <- header HTTP.hAccept
		let mt = mediaType expAccept
		case Media.parseAccept hAccept of
		 Just gotAccept | mediaType expAccept`Media.matches`gotAccept ->
			return $ RouterEndpoint $ \st hs a ->
				Wai.responseLBS st
				 ((HTTP.hContentType, Media.renderHeader mt):hs)
				 (if meth == HTTP.methodHead then "" else toMediaType expAccept a)
		 _ -> P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ RouteError_Accept_unsupported mt hAccept
instance HTTP_API Router