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

module Literate.Web.Semantics.Server where

-- import Data.Text.Lazy qualified as TextL
-- import Data.Text.Lazy.Encoding qualified as TextL
-- import Network.Wai qualified as Wai
-- import Prelude (undefined)
-- import Data.Text.Encoding qualified as Text
import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..))
import Control.Monad.Classes qualified as MC
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.Error qualified as Text
import Symantic.Syntaxes (Iso (..))
import System.IO (IO)
import Text.Show (Show (..))
import Prelude (min)

--
import Literate.Web.Syntaxes

-- import Literate.Web.Types.MIME
import Literate.Web.Types.URL

-- * The 'Server' interpreter

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

-- ** 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 :: (Monad m) => Server err m a -> Request -> m (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, Ord, Show)
deriving instance Ord Text.UnicodeException

instance (Monad m) => IsoFunctor (Server err m) where
  (<%>) Iso{..} = (a2b <$>)
instance (Monad m) => ProductFunctor (Server err m) where
  (<.>) = liftA2 (,)
  (<.) = (<*)
  (.>) = (*>)
instance (Monad m, Ord err) => SumFunctor (Server err m) 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 xErr ->
          -- TODO: better error merging
          MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT y env) st)) >>= \case
            Right (b, st') -> return (Right b, st')
            Left yErr -> MT.throwE (min xErr yErr)

-- instance Endable (Server err m) where
--   end = Server do
--     MT.lift (MT.gets serverStatePathSegments) >>= \case
--       [] -> return ()
--       lo -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathLeftover lo
instance (Monad m) => Repeatable (Server err m) 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 (Monad m) => Optionable (Server err m) 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 (Monad m) => PathSegmentable (Server err m) 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 m) where
  contentType = Server do
    Request{..} <- MT.ask
    return requestBody
instance ContentTypeable PlainText Text.Text (Server err m) 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 (Monad m) => Capturable PathSegment (Server err m) 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 m) 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 (MC.MonadExec IO m) => Fileable (Server err m) where
  type FileableConstraint (Server err m) = Parsable err
  static = Server do
    return ()
  dynamic = Server do
    Request{..} <- MT.ask
    content <-
      MT.lift $
        MT.lift $
          MT.lift $
            MC.exec @IO $
              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