{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Literate.Web.Semantics.Server where

import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..))
import Control.Monad.Trans.Class qualified as MT
import Control.Monad.Trans.Except qualified as MT
import Control.Monad.Trans.Reader qualified as MT
import Control.Monad.Trans.State qualified as MT
import Data.Bifunctor (first)
import Data.Bool
import Data.ByteString.Lazy qualified as BSL
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Foldable (null)
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.List qualified as List
import Data.Maybe (Maybe (..))
import Data.Ord (Ord)
import Data.Semigroup (Semigroup (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error qualified as Text

-- import Data.Text.Lazy qualified as TextL
-- import Data.Text.Lazy.Encoding qualified as TextL
import Symantic.Syntaxes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
import System.IO (IO)
import Text.Show (Show (..))

-- import Network.Wai qualified as Wai

-- import Prelude (undefined)

import Literate.Web.Syntaxes
import Literate.Web.Types.MIME
import Literate.Web.Types.URL

-- * The 'Server' interpreter

-- | A very very basic parser.
newtype Server model err a = Server
  { unServer ::
      MT.ReaderT
        (ServerEnv model)
        ( MT.StateT
            ServerState
            (MT.ExceptT (ServerError err) IO)
        )
        a
  }
  deriving (Functor, Applicative, Monad)

data ServerEnv model = ServerEnv
  { serverEnvRequest :: Request
  , serverEnvModel :: model
  }

-- ** Type 'Request'
data Request = Request
  { requestPathSegments :: [PathSegment]
  , requestBody :: BSL.ByteString
  }

{-
data Servers err a = Servers
  { serversPath :: [PathSegment] -> a
  , serversMethod :: [PathSegment] -> Bool
  --, serversBasicAuth ::
  , serversAccept :: Bool
  , serversContentType :: Bool
  , serversQuery :: Bool
  , serversHeader :: Bool
  , serversBody :: BSL.ByteString -> a
  }
-}

data ServerState = ServerState
  { serverStatePathSegments :: [PathSegment]
  }

decode :: Server err a -> Request -> IO (Either (ServerError err) a)
decode (Server dec) req =
  MT.runExceptT (MT.runStateT (MT.runReaderT dec req) st) >>= \case
    Left err -> return $ Left err
    Right (a, ServerState{..})
      | null serverStatePathSegments -> return $ Right a
      | otherwise -> return $ Left $ ServerErrorPathLeftover serverStatePathSegments
  where
    st =
      ServerState
        { serverStatePathSegments = requestPathSegments req
        }

data ServerError err
  = -- 1st checks, 404 error
    ServerErrorPathMismatch
      { expectedPathSegments :: Set PathSegment
      , gotPathSegment :: PathSegment
      }
  | ServerErrorPathMissing
  | ServerErrorPathLeftover [PathSegment]
  | -- 2nd check, 405 error
    ServerErrorMethod
  | -- 3rd check, 401 or 403 error
    ServerErrorBasicAuth
  | -- 4th check, 406 error
    ServerErrorAccept
  | -- 5th check, 415 error
    ServerErrorContentType
  | -- 6th check, 400 error
    ServerErrorQuery
  | -- 7th check, 400 error
    ServerErrorHeader
  | -- 8th check, 400 error
    ServerErrorUnicode Text.UnicodeException
  | -- 9th check, custom
    ServerErrorParser err
  deriving (Eq, Show)
deriving instance Ord Text.UnicodeException

instance IsoFunctor (Server err) where
  (<%>) Iso{..} = (a2b <$>)
instance ProductFunctor (Server err) where
  (<.>) = liftA2 (,)
  (<.) = (<*)
  (.>) = (*>)
instance SumFunctor (Server err) where
  Server x <+> Server y = Server $
    MT.ReaderT $ \env -> MT.StateT $ \st -> do
      MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
        Right (a, st') -> return (Left a, st')
        Left _err ->
          -- TODO: better error merging
          MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT y env) st)) >>= \case
            Right (b, st') -> return (Right b, st')
            Left err -> MT.throwE err

-- instance Endable (Server err) where
--   end = Server do
--     MT.lift (MT.gets serverStatePathSegments) >>= \case
--       [] -> return ()
--       lo -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathLeftover lo
instance Repeatable (Server err) where
  many0 (Server x) = Server (MT.ReaderT (MT.StateT . go))
    where
      go env st = do
        MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
          Left _err -> return ([], st) -- always backtrack
          Right (a, st') -> first (a :) <$> go env st'
  many1 x = (:) <$> x <*> many0 x
instance Optionable (Server err) where
  optional (Server x) = Server $
    MT.ReaderT $ \env -> MT.StateT $ \st -> do
      MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
        Left{} -> return (Nothing, st)
        Right (a, st') -> return (Just a, st')
instance PathSegmentable (Server err) where
  pathSegment expectedPathSegment = Server $ do
    ps <- MT.lift (MT.gets serverStatePathSegments)
    case ps of
      [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
      gotPathSegment : nextPathSegments
        | expectedPathSegment /= gotPathSegment ->
            MT.lift $ MT.lift $ MT.throwE ServerErrorPathMismatch{expectedPathSegments = Set.singleton expectedPathSegment, ..}
        | otherwise ->
            MT.local (\req -> req{requestPathSegments = requestPathSegments req <> [gotPathSegment]}) $
              MT.lift $
                MT.modify' $
                  \st -> st{serverStatePathSegments = nextPathSegments}

-- choosePathSegment expectedPathSegments = Server $ do
--   ps <- MT.lift (MT.gets serverStatePathSegments)
--   case ps of
--     [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
--     gotPathSegment : nextPathSegments
--       | gotPathSegment `Set.notMember` expectedPathSegments ->
--         MT.lift $ MT.lift $ MT.throwE ServerErrorPathMismatch{expectedPathSegments, ..}
--       | otherwise -> do
--         MT.local (\req -> req{requestPathSegments = requestPathSegments req <> [gotPathSegment]}) $
--           MT.lift $ MT.modify' $ \st -> st{serverStatePathSegments = nextPathSegments}
--         return gotPathSegment
{-
instance ContentTypeable PlainText BSL.ByteString (Server err) where
  contentType = Server do
    Request{..} <- MT.ask
    return requestBody
instance ContentTypeable PlainText Text.Text (Server err) where
  contentType = Server do
    Request{..} <- MT.ask
    case Text.decodeUtf8' (BSL.toStrict requestBody) of
      Right a -> return a
      Left err -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorUnicode err
-}

-- choosePathSegments = undefined
-- choosePathSegments expectedPathSegments = Server $ do
--   ps <- MT.lift MT.get
--   case ps of
--     [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
--     gotPathSegment : nextPathSegments
--       | gotPathSegment `Set.member` expectedPathSegments ->
--         MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathMismatch{expectedPathSegments, ..}
--       | otherwise -> do
--         MT.local (<> [gotPathSegment]) $
--           MT.lift $ MT.put nextPathSegments
--         return gotPathSegment
instance Capturable PathSegment (Server err) where
  capturePathSegment _name = Server $ do
    ps <- MT.lift (MT.gets serverStatePathSegments)
    case ps of
      [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
      gotPathSegment : nextPathSegments ->
        MT.local (\req -> req{requestPathSegments = requestPathSegments req <> [gotPathSegment]}) do
          MT.lift $ MT.modify' $ \st -> st{serverStatePathSegments = nextPathSegments}
          return gotPathSegment

-- choosePathSegment expectedPathSegments = Server $ do
--  ps <- MT.lift MT.get
--  case ps of
--    [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
--    gotPathSegment : nextPathSegments
--      | gotPathSegment `Set.member` expectedPathSegments ->
--        MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathMismatch{..}
--      | otherwise -> do
--        MT.local (<> [gotPathSegment]) $
--          MT.lift $ MT.put nextPathSegments
--        return gotPathSegment
{-
instance Selectable (Server err) where
  select ra a2bs = do
    a <- ra
    case Map.lookup a a2bs of
      Nothing ->
        Server $ MT.lift $ MT.lift $ MT.throwE
          ServerErrorPathMissing -- FIXME
    where
    go a [] = Server $
      MT.lift $ MT.lift $ MT.throwE
        ServerErrorPathMissing -- FIXME
    go a ((ca, x):xs) = Server $
      MT.ReaderT $ \env -> MT.StateT $ \st -> do
        MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT (unServer x) env) st)) >>= \case
          Right r -> return r
          Left _err ->
            MT.runStateT (MT.runReaderT (unServer (choose ra xs)) env) st
-}
instance Fileable (Server err) where
  type FileableConstraint (Server err) = Parsable err
  static = Server do
    return ()
  dynamic = Server do
    Request{..} <- MT.ask
    content <-
      MT.lift $
        MT.lift $
          MT.lift $
            BSL.readFile $
              List.intercalate "/" $
                Text.unpack . encodePathSegment <$> requestPathSegments
    case parse content of
      Right a -> return a
      Left err -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorParser err

-- * Class 'Parsable'
class Parsable err a where
  parse :: BSL.ByteString -> Either err a