{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators   #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Logger (withStdoutLogger)
import qualified Network.Wai.Handler.CGI as CGI
import Network.Wai.Middleware.Timeout (timeout)
import Data.Aeson
import Data.Aeson.TH
import Data.Maybe (fromMaybe)
import Network.Wai
import Servant
import Text.TeXMath
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Text.XML.Light (ppElement)
import System.Environment (getProgName)
import Options.Applicative
import Safe (readMay)

-- This is the data to be supplied by the JSON payload
-- of requests.
data Params = Params
  { text           :: Text
  , from           :: Format
  , to             :: Format
  , display        :: Bool
  } deriving (Show)

data Format =
  TeX | MathML | Eqn | OMML | Typst
  deriving (Show, Ord, Eq)

instance FromJSON Format where
   parseJSON (String s) =
               case T.toLower s of
                 "tex" -> pure TeX
                 "mathml" -> pure MathML
                 "eqn" -> pure Eqn
                 "typst" -> pure Typst
                 "omml" -> pure OMML
                 _ -> fail $ "Unknown format " <> T.unpack s
   parseJSON _ = fail "Expecting string format"

instance ToJSON Format where
   toJSON x = String $ T.toLower $ T.pack $ show x

instance FromHttpApiData Format where
   parseQueryParam t =
               case T.toLower t of
                 "tex" -> pure TeX
                 "mathml" -> pure MathML
                 "eqn" -> pure Eqn
                 "typst" -> pure Typst
                 "omml" -> pure OMML
                 _ -> Left $ "Unknown format " <> t

-- Automatically derive code to convert to/from JSON.
$(deriveJSON defaultOptions ''Params)
data Opts = Opts
  { port      :: Int }

optsSpec :: Parser Opts
optsSpec = Opts
      <$> option (maybeReader readMay)
          ( long "port"
         <> short 'p'
         <> metavar "NUMBER"
         <> showDefault
         <> value 8080
         <> help "Port on which to run the server" )

main :: IO ()
main = do
  prg <- getProgName
  case prg of
    "texmath-server.cgi" -> CGI.run (timeout 2 app)
    _ -> do
      let options = info (optsSpec <**> helper)
            ( fullDesc
           <> progDesc "Run a server for texmath"
           <> header "texmath-server - an HTTP server for texmath" )
      opts <- execParser options
      putStrLn $ "Starting server on port " <> show (port opts)
      withStdoutLogger $ \logger -> do
        let settings = Warp.setPort (port opts) $ Warp.setLogger logger Warp.defaultSettings
        Warp.runSettings settings app

-- This is the API.  The root endpoint takes a request body
-- consisting of a JSON-encoded Params structure and responds to
-- Get requests with either plain text or JSON, depending on the
-- Accept header. Alternatively, the "/batch" endpoint may be
-- used, accepting a JSON-encoded array of Params and returning
-- an array of results.
type API =
  ReqBody '[JSON] Params :> Post '[PlainText, JSON] Text
  :<|>
  QueryParam "text" Text :> QueryParam "from" Format :> QueryParam "to" Format :> QueryFlag "display" :> Get '[PlainText] Text
  :<|>
  "batch" :> ReqBody '[JSON] [Params] :> Post '[JSON] [Text]

app :: Application
app = serve api server

api :: Proxy API
api = Proxy

server :: Server API
server = convert
    :<|> (\text' from' to' display' ->
             convert Params{ text = fromMaybe "" text',
                             from = fromMaybe TeX from',
                             to = fromMaybe MathML to',
                             display = display' })
    :<|> mapM convert
 where
  convert params
    = let dt = if display params
                  then DisplayBlock
                  else DisplayInline
          txt = text params
          reader = case from params of
                     OMML -> readOMML
                     TeX -> readTeX
                     MathML -> readMathML
                     Eqn -> \_ -> Left "eqn reader not implemented"
                     Typst -> \_ -> Left "typst reader not implemented"
          writer = case to params of
                     Eqn -> writeEqn dt
                     Typst -> writeTypst dt
                     OMML -> T.pack . ppElement . writeOMML dt
                     TeX -> writeTeX
                     MathML -> T.pack . ppElement . writeMathML dt
      in  handleErr $ writer <$> reader txt

  handleErr (Right t) = return t
  handleErr (Left err) = throwError $
    err500 { errBody = TLE.encodeUtf8 $ TL.fromStrict err }