{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Server.Options where

import Data.ByteString.Lazy qualified as BL
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Web.Atomic.CSS
import Web.Hyperbole.Data.Encoded (Encoded, encodedToText)
import Web.Hyperbole.Types.Event
import Web.Hyperbole.Types.Response
import Web.Hyperbole.View


data ServerOptions = ServerOptions
  { ServerOptions -> ByteString -> ByteString
toDocument :: BL.ByteString -> BL.ByteString
  , ServerOptions -> ResponseError -> ServerError
serverError :: ResponseError -> ServerError
  }


defaultErrorMessage :: ResponseError -> Text
defaultErrorMessage :: ResponseError -> Text
defaultErrorMessage = \case
  -- mask server errors
  ErrCustom ServerError
e -> ServerError
e.message
  ResponseError
NotFound -> Text
"Not Found"
  ResponseError
ErrInternal -> Text
"Internal Server Error"
  ErrServer Text
m -> Text
m
  ResponseError
e -> [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
3 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ResponseError -> [Char]
forall a. Show a => a -> [Char]
show ResponseError
e


defaultErrorBody :: Text -> Body
defaultErrorBody :: Text -> Body
defaultErrorBody Text
msg = ByteString -> Body
Body (ByteString -> Body) -> ByteString -> Body
forall a b. (a -> b) -> a -> b
$
  View () () -> ByteString
renderLazyByteString (View () () -> ByteString) -> View () () -> ByteString
forall a b. (a -> b) -> a -> b
$ do
    View () () -> View () ()
forall c. View c () -> View c ()
el (View () () -> View () ())
-> (CSS (View () () -> View () ())
    -> CSS (View () () -> View () ()))
-> View () ()
-> View () ()
forall h. Styleable h => h -> (CSS h -> CSS h) -> h
~ HexColor
-> CSS (View () () -> View () ()) -> CSS (View () () -> View () ())
forall clr h. (ToColor clr, Styleable h) => clr -> CSS h -> CSS h
bg (Text -> HexColor
HexColor Text
"#F00") (CSS (View () () -> View () ()) -> CSS (View () () -> View () ()))
-> (CSS (View () () -> View () ())
    -> CSS (View () () -> View () ()))
-> CSS (View () () -> View () ())
-> CSS (View () () -> View () ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexColor
-> CSS (View () () -> View () ()) -> CSS (View () () -> View () ())
forall h clr. (Styleable h, ToColor clr) => clr -> CSS h -> CSS h
color (Text -> HexColor
HexColor Text
"#FFF") (View () () -> View () ()) -> View () () -> View () ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> View () ()
forall c. Text -> View c ()
text Text
msg


defaultError :: ResponseError -> ServerError
defaultError :: ResponseError -> ServerError
defaultError = \case
  ErrCustom ServerError
e -> ServerError
e
  ErrNotHandled Event TargetViewId Encoded Encoded
e -> Event TargetViewId Encoded Encoded -> ServerError
errNotHandled Event TargetViewId Encoded Encoded
e
  ResponseError
err ->
    let msg :: Text
msg = ResponseError -> Text
defaultErrorMessage ResponseError
err
     in Text -> Body -> ServerError
ServerError Text
msg (Text -> Body
defaultErrorBody Text
msg)
 where
  errNotHandled :: Event TargetViewId Encoded Encoded -> ServerError
  errNotHandled :: Event TargetViewId Encoded Encoded -> ServerError
errNotHandled Event TargetViewId Encoded Encoded
ev =
    Text -> Body -> ServerError
ServerError Text
"Action Not Handled" (Body -> ServerError) -> Body -> ServerError
forall a b. (a -> b) -> a -> b
$ ByteString -> Body
Body (ByteString -> Body) -> ByteString -> Body
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString (View () () -> ByteString) -> View () () -> ByteString
forall a b. (a -> b) -> a -> b
$ do
      View () () -> View () ()
forall c. View c () -> View c ()
el (View () () -> View () ()) -> View () () -> View () ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> View () ()
forall c. Text -> View c ()
text Text
"No Handler for Event viewId: "
        Text -> View () ()
forall c. Text -> View c ()
text (Text -> View () ()) -> Text -> View () ()
forall a b. (a -> b) -> a -> b
$ Encoded -> Text
encodedToText Event TargetViewId Encoded Encoded
ev.viewId.encoded
        Text -> View () ()
forall c. Text -> View c ()
text Text
" action: "
        Text -> View () ()
forall c. Text -> View c ()
text (Text -> View () ()) -> Text -> View () ()
forall a b. (a -> b) -> a -> b
$ Encoded -> Text
encodedToText Event TargetViewId Encoded Encoded
ev.action
      View () () -> View () ()
forall c. View c () -> View c ()
el (View () () -> View () ()) -> View () () -> View () ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> View () ()
forall c. Text -> View c ()
text Text
"Remember to add a `hyper` handler in your page function"
      Text -> View () ()
forall c. Text -> View c ()
pre (Text -> View () ()) -> Text -> View () ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Text] -> Text
T.intercalate
          Text
"\n"
          [ Text
"page :: (Hyperbole :> es) => Page es Response"
          , Text
"page = do"
          , Text
"  handle contentsHandler"
          , Text
"  load $ do"
          , Text
"    pure $ hyper Contents contentsView"
          , Text
"</pre>"
          ]