{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Symantic.HTTP.Router where

import Control.Arrow (first)
import Control.Monad (Monad(..), unless, sequence)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor (Functor, (<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Prelude ((+))
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Text.Encoding as Text
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Web.HttpApiData as Web

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

{-
import Debug.Trace
debug msg x = trace (msg<>": "<>show x) x
-}

-- | Convenient alias.
liftIO :: MC.MonadExec IO m => IO a -> m a
liftIO = MC.exec

-- * Type 'RouterAPI'
-- | @RouterAPI f k@ is a recipe to produce an 'Wai.Application'
-- from handlers 'f' (one per number of alternative routes).
--
-- 'RouterAPI' is analogous to a scanf using a format customized for HTTP routing.
--
-- The multiple monad transformers are there to prioritize the errors
-- according to the type of check raising them,
-- instead of the order of the combinators within an actual API specification.
newtype RouterAPI f k = RouterAPI { unRouterAPI ::
	S.StateT RouterState
	 (RouterCheckT [RouterErrorBody]          -- 8th check, 400 error
	 (RouterCheckT [RouterErrorHeader]        -- 7th check, 400 error
	 (RouterCheckT [RouterErrorQuery]         -- 6th check, 400 error
	 (RouterCheckT [RouterErrorContentType]   -- 5th check, 415 error
	 (RouterCheckT [RouterErrorAccept]        -- 4th check, 406 error
	 (-- TODO: RouterCheckT [RouterErrorAuth] -- 3rd check, 401 error
	 (RouterCheckT [RouterErrorMethod]        -- 2nd check, 405 error
	 (RouterCheckT [RouterErrorPath]          -- 1st check, 404 error
	 IO)))))))) (f -> k) }
 deriving (Functor {-, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens-})
type Offset = Int

runRouterAPI ::
 S.StateT RouterState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 IO))))))) a ->
 RouterState -> IO (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, RouterState))))))))
runRouterAPI s st =
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	S.runStateT s st

-- ** Type 'RouterCheckT'
type RouterCheckT e = ExceptT (Fail e)

-- *** Type 'RouteResult'
type RouteResult e = Either (Fail e)

-- *** Type 'Fail'
data Fail e
 =   Fail RouterState e -- ^ Keep trying other paths. 404, 405 or 406.
 |   FailFatal !RouterState !e -- ^ Don't try other paths.
 deriving (Show)
failState :: Fail e -> RouterState
failState (Fail st _)      = st
failState (FailFatal st _) = st
instance Semigroup e => Semigroup (Fail e) where
	Fail _ x      <> Fail st y      = Fail      st (x<>y)
	FailFatal _ x <> Fail st y      = FailFatal st (x<>y)
	Fail _ x      <> FailFatal st y = FailFatal st (x<>y)
	FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)

-- ** Type 'RouterState'
data RouterState = RouterState
 { routerState_offset  :: Offset
 , routerState_request :: Wai.Request
 } -- deriving (Show)
instance Show RouterState where
	show _ = "RouterState"
instance Cat RouterAPI where
	(<.>) ::
	 forall a b c repr.
	 repr ~ RouterAPI =>
	 repr a b -> repr b c -> repr a c
	-- NOTE: if x fails, run y to see if it fails on a more prioritized check.
	-- And if so, fail with y instead of x.
	-- 
	-- This long spaghetti code may probably be avoided
	-- with a more sophisticated RouterAPI using a binary tree
	-- instead of nested Either, so that its Monad instance
	-- would do the right thing, but to my mind,
	-- with the very few priorities of checks currently needed,
	-- this is currently not worth the cognitive pain to design it.
	-- A copy/paste/modify will do for now.
	RouterAPI x <.> RouterAPI y = RouterAPI $
		S.StateT $ \st -> do
			xPath <- liftIO $ runRouterAPI x st
			case xPath of
			 Left xe -> MC.throw xe
			 Right xMethod ->
				case xMethod of
				 Left xe -> do
					yPath <- liftIO $ runRouterAPI y (failState xe)
					case yPath of
					 Left ye -> MC.throw ye
					 Right _yMethod -> MC.throw xe
				 Right xAccept ->
					case xAccept of
					 Left xe -> do
						yPath <- liftIO $ runRouterAPI y (failState xe)
						case yPath of
						 Left ye -> MC.throw ye
						 Right yMethod ->
							case yMethod of
							 Left ye -> MC.throw ye
							 Right _yAccept -> MC.throw xe
					 Right xContentType ->
						case xContentType of
						 Left xe -> do
							yPath <- liftIO $ runRouterAPI y (failState xe)
							case yPath of
							 Left ye -> MC.throw ye
							 Right yMethod ->
								case yMethod of
								 Left ye -> MC.throw ye
								 Right yAccept ->
									case yAccept of
									 Left ye -> MC.throw ye
									 Right _yQuery -> MC.throw xe
						 Right xQuery ->
							case xQuery of
							 Left xe -> do
								yPath <- liftIO $ runRouterAPI y (failState xe)
								case yPath of
								 Left ye -> MC.throw ye
								 Right yMethod ->
									case yMethod of
									 Left ye -> MC.throw ye
									 Right yAccept ->
										case yAccept of
										 Left ye -> MC.throw ye
										 Right yQuery ->
											case yQuery of
											 Left ye -> MC.throw ye
											 Right _yHeader -> MC.throw xe
							 Right xHeader ->
								case xHeader of
								 Left xe -> do
									yPath <- liftIO $ runRouterAPI y (failState xe)
									case yPath of
									 Left ye -> MC.throw ye
									 Right yMethod ->
										case yMethod of
										 Left ye -> MC.throw ye
										 Right yAccept ->
											case yAccept of
											 Left ye -> MC.throw ye
											 Right yQuery ->
												case yQuery of
												 Left ye -> MC.throw ye
												 Right yHeader ->
													case yHeader of
													 Left ye -> MC.throw ye
													 Right _yBody -> MC.throw xe
								 Right xBody ->
									case xBody of
									 Left xe -> do
										yPath <- liftIO $ runRouterAPI y (failState xe)
										case yPath of
										 Left ye -> MC.throw ye
										 Right yMethod ->
											case yMethod of
											 Left ye -> MC.throw ye
											 Right yAccept ->
												case yAccept of
												 Left ye -> MC.throw ye
												 Right yQuery ->
													case yQuery of
													 Left ye -> MC.throw ye
													 Right yHeader ->
														case yHeader of
														 Left ye -> MC.throw ye
														 Right _yBody -> MC.throw xe
									 Right (a2b, st') ->
										(first (. a2b)) <$> S.runStateT y st'
instance Alt RouterAPI where
	RouterAPI x <!> RouterAPI y = RouterAPI $
		S.StateT $ \st -> do
			xPath <- liftIO $ runRouterAPI x st
			yPath <- liftIO $ runRouterAPI y st
			let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
			case xPath of
			 Left xe | FailFatal{} <- xe -> MC.throw xe
			         | otherwise ->
				case yPath of
				 Left ye -> MC.throw (xe<>ye)
				 Right yMethod ->
					fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
						return $ Right yMethod
			 Right xMethod ->
				case xMethod of
				 Left xe | FailFatal{} <- xe -> MC.throw xe
				         | otherwise ->
					case yPath of
					 Left _ye -> MC.throw xe
					 Right yMethod ->
						case yMethod of
						 Left ye -> MC.throw (xe<>ye)
						 Right yAccept ->
							fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
								return $ Right $ yAccept
				 Right xAccept ->
					case xAccept of
					 Left xe | FailFatal{} <- xe -> MC.throw xe
					         | otherwise ->
						case yPath of
						 Left _ye -> MC.throw xe
						 Right yMethod ->
							case yMethod of
							 Left _ye -> MC.throw xe
							 Right yAccept ->
								case yAccept of
								 Left ye -> MC.throw (xe<>ye)
								 Right yContentType ->
									fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
										return $ Right yContentType
					 Right xContentType ->
						case xContentType of
						 Left xe | FailFatal{} <- xe -> MC.throw xe
						         | otherwise ->
							case yPath of
							 Left _ye -> MC.throw xe
							 Right yMethod ->
								case yMethod of
								 Left _ye -> MC.throw xe
								 Right yAccept ->
									case yAccept of
									 Left _ye -> MC.throw xe
									 Right yContentType ->
										case yContentType of
										 Left ye -> MC.throw (xe<>ye)
										 Right yQuery ->
											fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
												return $ Right yQuery
						 Right xQuery ->
							case xQuery of
							 Left xe | FailFatal{} <- xe -> MC.throw xe
							         | otherwise ->
								case yPath of
								 Left _ye -> MC.throw xe
								 Right yMethod ->
									case yMethod of
									 Left _ye -> MC.throw xe
									 Right yAccept ->
										case yAccept of
										 Left _ye -> MC.throw xe
										 Right yContentType ->
											case yContentType of
											 Left _ye -> MC.throw xe
											 Right yQuery ->
												case yQuery of
												 Left ye -> MC.throw (xe<>ye)
												 Right yHeader ->
													fy $ ExceptT $ ExceptT $ ExceptT $
														return $ Right yHeader
							 Right xHeader ->
								case xHeader of
								 Left xe | FailFatal{} <- xe -> MC.throw xe
								         | otherwise ->
									case yPath of
									 Left _ye -> MC.throw xe
									 Right yMethod ->
										case yMethod of
										 Left _ye -> MC.throw xe
										 Right yAccept ->
											case yAccept of
											 Left _ye -> MC.throw xe
											 Right yContentType ->
												case yContentType of
												 Left _ye -> MC.throw xe
												 Right yQuery ->
													case yQuery of
													 Left _ye -> MC.throw xe
													 Right yHeader ->
														case yHeader of
														 Left ye -> MC.throw (xe<>ye)
														 Right yBody ->
															fy $ ExceptT $ ExceptT $
																return $ Right yBody
								 Right xBody ->
									case xBody of
									 Left xe | FailFatal{} <- xe -> MC.throw xe
									         | otherwise ->
										case yPath of
										 Left _ye -> MC.throw xe
										 Right yMethod ->
											case yMethod of
											 Left _ye -> MC.throw xe
											 Right yAccept ->
												case yAccept of
												 Left _ye -> MC.throw xe
												 Right yContentType ->
													case yContentType of
													 Left _ye -> MC.throw xe
													 Right yQuery ->
														case yQuery of
														 Left _ye -> MC.throw xe
														 Right yHeader ->
															case yHeader of
															 Left _ye -> MC.throw xe
															 Right yBody ->
																case yBody of
																 Left ye -> MC.throw (xe<>ye)
																 Right yr ->
																	fy $ ExceptT $
																		return $ Right yr
									 Right xr ->
										return $ first (\a2k (a:!:_b) -> a2k a) xr

instance Pro RouterAPI where
	dimap a2b _b2a (RouterAPI r) = RouterAPI $ (\k b2k -> k (b2k . a2b)) <$> r

-- | @'routerAPI' rt api@ returns a 'Wai.Application'
-- ready to be given to @Warp.run 80@.
routerAPI ::
 RouterAPI handlers RouterResponse ->
 handlers ->
 Wai.Application
routerAPI (RouterAPI api) handlers rq re = do
	lrPath <- liftIO $ runRouterAPI api (RouterState 0 rq)
	case lrPath of
	 Left err -> respondError status404 err
	 Right lrMethod ->
		case lrMethod of
		 Left err -> respondError status405 err
		 Right lrAccept ->
			case lrAccept of
			 Left err -> respondError status406 err
			 Right lrContentType ->
				case lrContentType of
				 Left err -> respondError status415 err
				 Right lrQuery ->
					case lrQuery of
					 Left err -> respondError status400 err
					 Right lrHeader ->
						case lrHeader of
						 Left err -> respondError status400 err
						 Right lrBody ->
							case lrBody of
							 Left err -> respondError status400 err
							 Right (a2k, _st) ->
								let RouterResponse app = a2k handlers in app rq re
	where
	respondError :: Show err => HTTP.Status -> err -> IO Wai.ResponseReceived
	respondError st err =
		re $ Wai.responseLBS st
		 [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
		 (fromString $ show err)

-- ** Type 'RouterErrorPath'
data RouterErrorPath = RouterErrorPath Offset Text
 deriving (Eq, Show)
instance HTTP_Path RouterAPI where
	segment expSegment = RouterAPI $ do
		st@RouterState
		 { routerState_offset  = o
		 , routerState_request = req
		 } <- S.get
		case Wai.pathInfo req of
		 [] -> MC.throw $ Fail st [RouterErrorPath o "segment: empty"]
		 [""] -> MC.throw $ Fail st [RouterErrorPath o "trailing slash"]
		 curr:next
		  | curr /= expSegment ->
			MC.throw $ Fail st [RouterErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
		  | otherwise -> do
			S.put st
			 { routerState_offset  = o+1
			 , routerState_request = req{ Wai.pathInfo = next }
			 }
			return id
	capture' :: forall a k.
	            Web.FromHttpApiData a =>
	            Web.ToHttpApiData a =>
	            Name -> RouterAPI (a -> k) k
	capture' name = RouterAPI $ do
		st@RouterState
		 { routerState_offset  = o
		 , routerState_request = req
		 } <- S.get
		case Wai.pathInfo req of
		 [] -> MC.throw $ Fail st [RouterErrorPath o "empty"]
		 [""] -> MC.throw $ Fail st [RouterErrorPath o "trailing slash"]
		 curr:next ->
			case Web.parseUrlPiece curr of
			 Left err -> MC.throw $ Fail st [RouterErrorPath o $ "capture: "<>fromString name<>": "<>err]
			 Right a -> do
				S.put st
				 { routerState_offset  = o+1
				 , routerState_request = req{ Wai.pathInfo = next }
				 }
				return ($ a)
	captureAll = RouterAPI $ do
		req <- S.gets routerState_request
		return ($ Wai.pathInfo req)

-- ** Type 'RouterErrorMethod'
data RouterErrorMethod = RouterErrorMethod
 deriving (Eq, Show)
instance HTTP_Method RouterAPI where
	method exp = RouterAPI $ do
		st <- S.get
		let got = Wai.requestMethod $ routerState_request st
		if  got == exp
		 || got == HTTP.methodHead
		 && exp == HTTP.methodGet
		then return id
		else MC.throw $ Fail st [RouterErrorMethod]

-- | TODO: add its own error?
instance HTTP_Version RouterAPI where
	version exp = RouterAPI $ do
		st <- S.get
		let got = Wai.httpVersion $ routerState_request st
		if got == exp
		 then return id
		 else MC.throw $ Fail st [RouterErrorMethod] -- FIXME: RouterErrorVersion

-- ** Type 'RouterErrorAccept'
data RouterErrorAccept = RouterErrorAccept
 deriving (Eq, Show)
instance HTTP_Accept RouterAPI where
	accept exp = RouterAPI $ do
		st <- S.get
		let hs = Wai.requestHeaders $ routerState_request st
		case List.lookup HTTP.hAccept hs of
		 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
		 Just h ->
			case Media.parseAccept h of
			 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
			 Just got | mediaType exp`Media.matches`got -> return id
			          | otherwise -> MC.throw $ Fail st [RouterErrorAccept]

-- ** Type 'RouterErrorContentType'
data RouterErrorContentType = RouterErrorContentType
 deriving (Eq, Show)
instance HTTP_ContentType RouterAPI where
	contentType exp = RouterAPI $ do
		st <- S.get
		let hs = Wai.requestHeaders $ routerState_request st
		let got =
			-- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
			-- DOC: http://www.w3.org/2001/tag/2002/0129-mime
			fromMaybe "application/octet-stream" $
			List.lookup HTTP.hContentType hs
		case Media.mapContentMedia [(mediaType exp, ())] got of
		 Nothing -> MC.throw $ Fail st [RouterErrorContentType]
		 Just () -> return id -- TODO: mimeUnserialize

-- ** Type 'RouterErrorQuery'
newtype RouterErrorQuery = RouterErrorQuery Text
 deriving (Show)
instance HTTP_Query RouterAPI where
	queryParams' name = RouterAPI $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ return $
			let qs = Wai.queryString $ routerState_request st in
			let vals = catMaybes $ (<$> qs) $ \(n,v) ->
				if n == name
				 then Web.parseQueryParam . Text.decodeUtf8 <$> v
				 else Nothing in
			case sequence vals of
			 Left err -> Left  $ Fail st [RouterErrorQuery err]
			 Right vs -> Right $ Right $ Right ($ vs)

-- ** Type 'RouterErrorHeader'
data RouterErrorHeader = RouterErrorHeader
 deriving (Eq, Show)
instance HTTP_Header RouterAPI where
	header n = RouterAPI $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ return $
			let hs = Wai.requestHeaders $ routerState_request st in
			case List.lookup n hs of
			 Nothing -> Left $ Fail st [RouterErrorHeader]
			 Just v -> Right $ Right ($ v)

-- ** Type 'RouterErrorBody'
newtype RouterErrorBody = RouterErrorBody String
 deriving (Eq, Show)
-- *** Type 'RouterBodyArg'
newtype RouterBodyArg mt a = RouterBodyArg a

instance HTTP_Body RouterAPI where
	type BodyArg RouterAPI = RouterBodyArg
	body' ::
	 forall mt a k repr.
	 MimeUnserialize mt a =>
	 MimeSerialize mt a =>
	 repr ~ RouterAPI =>
	 repr (BodyArg repr mt a -> k) k
	body'= RouterAPI $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
			let hs = Wai.requestHeaders $ routerState_request st
			let expContentType = (Proxy::Proxy mt)
			let reqContentType =
				-- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
				-- DOC: http://www.w3.org/2001/tag/2002/0129-mime
				fromMaybe "application/octet-stream" $
				List.lookup HTTP.hContentType hs
			case Media.mapContentMedia
			 [ ( mediaType       expContentType
			   , mimeUnserialize expContentType )
			 ] reqContentType of
			 Nothing -> return $ Left $ Fail st [RouterErrorContentType]
			 Just unSerialize -> do
				bodyBS <- liftIO $ Wai.requestBody $ routerState_request st
				return $ Right $ Right $ Right $
					-- NOTE: delay unSerialize after all checks
					case unSerialize $ BSL.fromStrict bodyBS of
					 Left err -> Left $ Fail st [RouterErrorBody err]
					 Right a -> Right ($ RouterBodyArg a)

-- ** 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
 )
instance Show RouterResponse where
	show _ = "RouterResponse"

-- *** Type 'RouterResponseArg'
newtype RouterResponseArg mt a = RouterResponseArg
 (HTTP.Status ->
  HTTP.ResponseHeaders ->
  a -> Wai.Response)

instance HTTP_Response RouterAPI where
	type Response    RouterAPI = RouterResponse
	type ResponseArg RouterAPI = RouterResponseArg
	response' ::
	 forall mt a k repr.
	 MimeUnserialize mt a =>
	 MimeSerialize mt a =>
	 k ~ Response repr =>
	 repr ~ RouterAPI =>
	 HTTP.Method ->
	 repr (ResponseArg repr mt a -> k) k
	response' expMethod = RouterAPI $ do
		st <- S.get
		let reqMethod = Wai.requestMethod $ routerState_request st
		unless (reqMethod == expMethod
		 || reqMethod == HTTP.methodHead
		 && expMethod == HTTP.methodGet) $
			MC.throw $ Fail st [RouterErrorMethod]
		
		let reqHeaders = Wai.requestHeaders $ routerState_request st
		let expAccept = (Proxy::Proxy mt)
		reqAccept <- do
			case List.lookup HTTP.hAccept reqHeaders of
			 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
			 Just h ->
				case Media.parseAccept h of
				 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
				 Just got | mediaType expAccept`Media.matches`got ->
					return expAccept -- FIXME: return got, maybe with GADTs
				          | otherwise -> MC.throw $ Fail st [RouterErrorAccept]
		
		return ($ RouterResponseArg $ \s hs a ->
			Wai.responseLBS s
			 ((HTTP.hContentType, Media.renderHeader $ mediaType reqAccept):hs)
			 (if reqMethod == HTTP.methodHead
				then ""
				else mimeSerialize reqAccept a))