{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Server.Handlers.RenderHandlers
    ( RenderAPI
    , renderServer
    , PDF
    , PDFByteString (..)
    , Zip
    , ZipByteString (..)
    ) where

import Control.Exception (Exception (displayException), SomeException, try)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson (encode)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
import Data.OpenApi
    ( NamedSchema (..)
    , ToSchema
    , binarySchema
    , declareNamedSchema
    )
import Data.Text (Text)
import Language.Ltml.ToLaTeX.PDFGenerator (generatePDFFromSection)
import Network.HTTP.Media.MediaType ((//))
import Servant
import Servant.Auth.Server
import Server.Auth (AuthMethod)
import qualified Server.Auth as Auth
import Server.HandlerUtil
import Prelude hiding (head, lines, unlines)

-- | Return type for rendered documents
newtype DocByteString = DocByteString ByteString

instance ToSchema DocByteString where
    declareNamedSchema :: Proxy DocByteString -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy DocByteString
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Document BinaryString") Schema
binarySchema

-- | PDF ByteString wrapper
newtype PDFByteString = PDFByteString ByteString

instance ToSchema PDFByteString where
    declareNamedSchema :: Proxy PDFByteString -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy PDFByteString
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"PDF BinaryString") Schema
binarySchema

--

-- | Zip ByteString wrapper
newtype ZipByteString = ZipByteString ByteString

instance ToSchema ZipByteString where
    declareNamedSchema :: Proxy ZipByteString -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy ZipByteString
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Zip BinaryString") Schema
binarySchema

-- | API type for all render formats
type RenderAPI =
    "render"
        :> ( "plain" :> RenderRoute Plain
                :<|> "pdf"
                    :> Auth AuthMethod Auth.Token
                    :> ReqBody '[JSON] Text
                    :> Post '[PDF] PDFByteString
           )

renderServer :: Server RenderAPI
renderServer :: Server RenderAPI
renderServer =
    (Text -> ByteString)
-> AuthResult Token -> Text -> Handler DocByteString
forall a.
(a -> ByteString) -> AuthResult Token -> a -> Handler DocByteString
renderHandler Text -> ByteString
renderPlain (AuthResult Token -> Text -> Handler DocByteString)
-> (AuthResult Token -> Text -> Handler PDFByteString)
-> (AuthResult Token -> Text -> Handler DocByteString)
   :<|> (AuthResult Token -> Text -> Handler PDFByteString)
forall a b. a -> b -> a :<|> b
:<|> AuthResult Token -> Text -> Handler PDFByteString
renderPDFHandler

-- | Format type for HTML
data HTML

-- | Format type for plain text
data Plain

-- | Format type for PDF
data PDF

-- | Format type for Zip
data Zip

instance Accept Zip where
    contentType :: Proxy Zip -> MediaType
contentType Proxy Zip
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"zip"

instance Accept PDF where
    contentType :: Proxy PDF -> MediaType
contentType Proxy PDF
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"pdf"

-- | MIME type for HTML
instance Accept HTML where
    contentType :: Proxy HTML -> MediaType
contentType Proxy HTML
_ = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"html"

-- | MIME type for plain text
instance Accept Plain where
    contentType :: Proxy Plain -> MediaType
contentType Proxy Plain
_ = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"plain"

instance MimeRender Zip ZipByteString where
    mimeRender :: Proxy Zip -> ZipByteString -> ByteString
mimeRender Proxy Zip
_ (ZipByteString ByteString
bs) = ByteString
bs

instance MimeRender PDF PDFByteString where
    mimeRender :: Proxy PDF -> PDFByteString -> ByteString
mimeRender Proxy PDF
_ (PDFByteString ByteString
bs) = ByteString
bs

instance MimeRender Plain DocByteString where
    mimeRender :: Proxy Plain -> DocByteString -> ByteString
mimeRender Proxy Plain
_ (DocByteString ByteString
bs) = ByteString
bs

instance MimeRender HTML DocByteString where
    mimeRender :: Proxy HTML -> DocByteString -> ByteString
mimeRender Proxy HTML
_ (DocByteString ByteString
bs) = ByteString
bs

renderPlain :: Text -> ByteString
renderPlain :: Text -> ByteString
renderPlain = Text -> ByteString
forall a. ToJSON a => a -> ByteString
encode

-- | Generic API type for single render format
type RenderRoute format =
    Auth AuthMethod Auth.Token
        :> ReqBody '[JSON] Text
        :> Post '[format] DocByteString

-- | Generic renderHandler which takes a render function
renderHandler
    :: (a -> ByteString) -> AuthResult Auth.Token -> a -> Handler DocByteString
renderHandler :: forall a.
(a -> ByteString) -> AuthResult Token -> a -> Handler DocByteString
renderHandler a -> ByteString
renderFunc (Authenticated Token
_) a
input = do
    DocByteString -> Handler DocByteString
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (DocByteString -> Handler DocByteString)
-> DocByteString -> Handler DocByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> DocByteString
DocByteString (ByteString -> DocByteString) -> ByteString -> DocByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
renderFunc a
input
renderHandler a -> ByteString
_ AuthResult Token
_ a
_ = ServerError -> Handler DocByteString
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn

renderPDFHandler
    :: AuthResult Auth.Token -> Text -> Handler PDFByteString
renderPDFHandler :: AuthResult Token -> Text -> Handler PDFByteString
renderPDFHandler (Authenticated Token
_) Text
input = do
    Either SomeException (Either [Char] ByteString)
result <- IO (Either SomeException (Either [Char] ByteString))
-> Handler (Either SomeException (Either [Char] ByteString))
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException (Either [Char] ByteString))
 -> Handler (Either SomeException (Either [Char] ByteString)))
-> IO (Either SomeException (Either [Char] ByteString))
-> Handler (Either SomeException (Either [Char] ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Either [Char] ByteString)
-> IO (Either SomeException (Either [Char] ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Either [Char] ByteString)
 -> IO (Either SomeException (Either [Char] ByteString)))
-> IO (Either [Char] ByteString)
-> IO (Either SomeException (Either [Char] ByteString))
forall a b. (a -> b) -> a -> b
$ Text -> IO (Either [Char] ByteString)
generatePDFFromSection Text
input
    case Either SomeException (Either [Char] ByteString)
result of
        Left (SomeException
e :: SomeException) -> do
            IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char]
"*** Handler exception: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e)
            ServerError -> Handler PDFByteString
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err500 {errBody = BS.pack "Internal Server Error"}
        Right Either [Char] ByteString
eAction -> case Either [Char] ByteString
eAction of
            Left [Char]
err -> ServerError -> Handler PDFByteString
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400 {errBody = BS.pack err}
            Right ByteString
pdf -> PDFByteString -> Handler PDFByteString
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (PDFByteString -> Handler PDFByteString)
-> PDFByteString -> Handler PDFByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> PDFByteString
PDFByteString ByteString
pdf
renderPDFHandler AuthResult Token
_ Text
_ = ServerError -> Handler PDFByteString
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn