{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Symantic.HTTP.Server 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 as BS
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.Mime

-- * Type 'Server'
-- | @Server f k@ is a recipe to produce an 'Wai.Application'
-- from handlers 'f' (one per number of alternative routes).
--
-- 'Server' 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 Server f k = Server { unServer ::
	S.StateT ServerState
	 (ServerCheckT [ServerErrorBody]          -- 8th check, 400 error
	 (ServerCheckT [ServerErrorHeader]        -- 7th check, 400 error
	 (ServerCheckT [ServerErrorQuery]         -- 6th check, 400 error
	 (ServerCheckT [ServerErrorContentType]   -- 5th check, 415 error
	 (ServerCheckT [ServerErrorAccept]        -- 4th check, 406 error
	 (-- TODO: ServerCheckT [ServerErrorAuth] -- 3rd check, 401 error
	 (ServerCheckT [ServerErrorMethod]        -- 2nd check, 405 error
	 (ServerCheckT [ServerErrorPath]          -- 1st check, 404 error
	 IO))))))))
	 (f -> k)
 } deriving (Functor)

-- | @'server' api handlers@ returns a 'Wai.Application'
-- ready to be given to @Warp.run 80@.
server ::
 Server handlers ServerResponse ->
 handlers ->
 Wai.Application
server (Server api) handlers rq re = do
	lrPath <- runServerChecks api $ ServerState 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 ServerResponse app = a2k handlers in
								app rq re
	where
	respondError :: Show err => HTTP.Status -> err -> IO Wai.ResponseReceived
	respondError st err =
		-- Trace.trace (show err) $
		re $ Wai.responseLBS st
		 [(HTTP.hContentType, Media.renderHeader $ mimeType mimePlainText)]
		 (fromString $ show err) -- TODO: see what to return in the body


-- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
runServerChecks ::
 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 IO))))))) a ->
 ServerState -> IO (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState))))))))
runServerChecks s st =
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	S.runStateT s st

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

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

-- *** Type 'Fail'
data Fail e
 =   Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
 |   FailFatal !ServerState !e -- ^ Don't try other paths.
 deriving (Show)
failState :: Fail e -> ServerState
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 'ServerState'
data ServerState = ServerState
 { serverState_offset  :: Offset -- TODO: remove
 , serverState_request :: Wai.Request
 } -- deriving (Show)
type Offset = Int

instance Show ServerState where
	show _ = "ServerState"
instance Cat Server where
	(<.>) ::
	 forall a b c repr.
	 repr ~ Server =>
	 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 'Server' using a binary tree
	-- instead of nested 'Either's, 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 not worth the cognitive pain to design it.
	-- A copy/paste/adapt will do for now.
	Server x <.> Server y = Server $
		S.StateT $ \st -> do
			xPath <- liftIO $ runServerChecks x st
			case xPath of
			 Left xe -> MC.throw xe
			 Right xMethod ->
				case xMethod of
				 Left xe -> do
					yPath <- liftIO $ runServerChecks 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 $ runServerChecks 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 $ runServerChecks 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 $ runServerChecks 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 $ runServerChecks 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 $ runServerChecks 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 Server where
	Server x <!> Server y = Server $
		S.StateT $ \st -> do
			xPath <- liftIO $ runServerChecks x st
			yPath <- liftIO $ runServerChecks 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 Server where
	dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r

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

-- ** Type 'ServerErrorMethod'
data ServerErrorMethod = ServerErrorMethod
 deriving (Eq, Show)

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

-- ** Type 'ServerErrorAccept'
data ServerErrorAccept =
 ServerErrorAccept
  MediaType
  (Maybe (Either BS.ByteString MediaType))
 deriving (Eq, Show)

-- ** Type 'ServerErrorContentType'
data ServerErrorContentType = ServerErrorContentType
 deriving (Eq, Show)
instance HTTP_ContentType Server where
	contentType exp = Server $ do
		st <- S.get
		let hs = Wai.requestHeaders $ serverState_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 [(mimeType exp, ())] got of
		 Nothing -> MC.throw $ Fail st [ServerErrorContentType]
		 Just () -> return id -- TODO: mimeUnserialize

-- ** Type 'ServerErrorQuery'
newtype ServerErrorQuery = ServerErrorQuery Text
 deriving (Show)
instance HTTP_Query Server where
	queryParams' name = Server $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ return $
			let qs = Wai.queryString $ serverState_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 [ServerErrorQuery err]
			 Right vs -> Right $ Right $ Right ($ vs)

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

-- ** Type 'ServerErrorBody'
newtype ServerErrorBody = ServerErrorBody String
 deriving (Eq, Show)

-- *** Type 'ServerBodyArg'
newtype ServerBodyArg mt a = ServerBodyArg a

instance HTTP_Body Server where
	type BodyArg Server = ServerBodyArg
	body' ::
	 forall mt a k repr.
	 MimeUnserialize a mt =>
	 MimeSerialize a mt =>
	 repr ~ Server =>
	 repr (BodyArg repr mt a -> k) k
	body'= Server $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
			let hs = Wai.requestHeaders $ serverState_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
			 [ ( mimeType       expContentType
			   , mimeUnserialize expContentType )
			 ] reqContentType of
			 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
			 Just unSerialize -> do
				bodyBS <- liftIO $ Wai.requestBody $ serverState_request st
				return $ Right $ Right $ Right $
					-- NOTE: delay unSerialize after all checks
					case unSerialize $ BSL.fromStrict bodyBS of
					 Left err -> Left $ Fail st [ServerErrorBody err]
					 Right a -> Right ($ ServerBodyArg a)

-- ** Type 'ServerResponse'
newtype ServerResponse = ServerResponse
 ( -- the request made to the server
   Wai.Request ->
   -- the continuation for the server to respond
   (Wai.Response -> IO Wai.ResponseReceived) ->
   IO Wai.ResponseReceived
 )
instance Show ServerResponse where
	show _ = "ServerResponse"

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

instance HTTP_Response Server where
	type Response    Server = ServerResponse
	type ResponseArg Server = ServerResponseArg
	response ::
	 forall a mt k repr.
	 MimeUnserialize a mt =>
	 MimeSerialize a mt =>
	 k ~ Response repr =>
	 repr ~ Server =>
	 HTTP.Method ->
	 repr (ResponseArg repr mt a -> k) k
	response expMethod = Server $ do
		st@ServerState
		 { serverState_offset  = o
		 , serverState_request = req
		 } <- S.get
		
		-- Check the path has been fully consumed
		unless (List.null $ Wai.pathInfo req) $
			MC.throw $ Fail st [ServerErrorPath o "path is longer"]
		
		-- Check the method
		let reqMethod = Wai.requestMethod $ serverState_request st
		unless (reqMethod == expMethod
		 || reqMethod == HTTP.methodHead
		 && expMethod == HTTP.methodGet) $
			MC.throw $ Fail st [ServerErrorMethod]
		
		-- Check the Accept header
		let reqHeaders = Wai.requestHeaders $ serverState_request st
		let expAccept = (Proxy::Proxy mt)
		reqAccept <- do
			case List.lookup HTTP.hAccept reqHeaders of
			 Nothing -> return expAccept
			 Just h ->
				case Media.parseAccept h of
				 Nothing -> MC.throw $ Fail st
					 [ServerErrorAccept (mimeType expAccept) (Just (Left h))]
				 Just gotAccept
				  | mimeType expAccept`Media.matches`gotAccept -> return expAccept
					-- FIXME: return gotAccept, maybe with GADTs
				  | otherwise -> MC.throw $ Fail st
					 [ServerErrorAccept (mimeType expAccept) (Just (Right gotAccept))]
		
		-- Respond
		return ($ ServerResponseArg $ \s hs a ->
			Wai.responseLBS s
			 ((HTTP.hContentType, Media.renderHeader $ mimeType reqAccept):hs)
			 (if reqMethod == HTTP.methodHead
				then ""
				else mimeSerialize reqAccept a))

-- * Utils
liftIO :: MC.MonadExec IO m => IO a -> m a
liftIO = MC.exec
{-# INLINE liftIO #-}