{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module WikiMusic.SSR.Servant.Utilities where

import Data.ByteString.Base16.Lazy qualified as B16
import Data.Map qualified as Map
import Data.Text qualified as T
import NeatInterpolation
import Principium
import Servant
import Servant.Multipart
import Text.Blaze.Html.Renderer.Utf8
import WikiMusic.SSR.Backend.Rest ()
import WikiMusic.SSR.Free.View
import WikiMusic.SSR.View.Html ()

fromForm :: MultipartData tag -> Text -> Text -> Text
fromForm :: forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipart Text
fallback Text
name =
  Text -> (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
fallback NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head
    (Maybe (NonEmpty Text) -> Text)
-> ([Input] -> Maybe (NonEmpty Text)) -> [Input] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty
    ([Text] -> Maybe (NonEmpty Text))
-> ([Input] -> [Text]) -> [Input] -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Text) -> [Input] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Input -> Text
iValue
    ([Input] -> [Text]) -> ([Input] -> [Input]) -> [Input] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Bool) -> [Input] -> [Input]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Input
i -> Input -> Text
iName Input
i Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name)
    ([Input] -> Text) -> [Input] -> Text
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> [Input]
forall tag. MultipartData tag -> [Input]
inputs MultipartData tag
multipart

maybeFromForm :: MultipartData tag -> Text -> Maybe Text
maybeFromForm :: forall tag. MultipartData tag -> Text -> Maybe Text
maybeFromForm MultipartData tag
multipart Text
name = case Maybe Text
rawVal of
  (Just Text
"") -> Maybe Text
forall a. Maybe a
Nothing
  (Just Text
x) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
  Maybe Text
Nothing -> Maybe Text
forall a. Maybe a
Nothing
  where
    rawVal :: Maybe Text
rawVal =
      (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head
        (Maybe (NonEmpty Text) -> Maybe Text)
-> ([Input] -> Maybe (NonEmpty Text)) -> [Input] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty
        ([Text] -> Maybe (NonEmpty Text))
-> ([Input] -> [Text]) -> [Input] -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Text) -> [Input] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Input -> Text
iValue
        ([Input] -> [Text]) -> ([Input] -> [Input]) -> [Input] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Bool) -> [Input] -> [Input]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Input
i -> Input -> Text
iName Input
i Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name)
        ([Input] -> Maybe Text) -> [Input] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> [Input]
forall tag. MultipartData tag -> [Input]
inputs MultipartData tag
multipart

setCookieRoute :: (MonadError ServerError m) => CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute :: forall (m :: * -> *) a.
MonadError ServerError m =>
CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute CookieConfig
cookieConfig Text
newLocation Map Text Text
cookieMap =
  ServerError -> m a
forall a. ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError -> m a) -> ServerError -> m a
forall a b. (a -> b) -> a -> b
$ ServerError
      { $sel:errHTTPCode:ServerError :: Int
errHTTPCode = Int
302,
        $sel:errReasonPhrase:ServerError :: String
errReasonPhrase = String
"Found",
        $sel:errBody:ServerError :: ByteString
errBody = ByteString
"",
        $sel:errHeaders:ServerError :: [Header]
errHeaders =
          (HeaderName
"Location", Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
newLocation) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
cookieHeaders
      }
  where
    mkCookieHeaders :: (Text, Text) -> Header
mkCookieHeaders (Text
cookieName, Text
cookieValue) =
      ( HeaderName
"Set-Cookie",
        String -> ByteString
forall a. IsString a => String -> a
fromString
          (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
          (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieConfig -> Text -> Text
mkCookieData CookieConfig
cookieConfig
          (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [trimming|$cookieName=$cookieValue|]
      )
    cookieHeaders :: [Header]
cookieHeaders = ((Text, Text) -> Header) -> [(Text, Text)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Header
mkCookieHeaders (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Text Text
cookieMap)

mkCookieData :: CookieConfig -> Text -> Text
mkCookieData :: CookieConfig -> Text -> Text
mkCookieData CookieConfig
cookieConfig Text
dyn =
  [trimming|
    $dyn; HttpOnly; $sameSite; Domain=$domain; Path=/; Max-Age=$maxAge $secureSuffix
  |]
  where
    maxAge :: Text
maxAge = Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Int
#maxAge
    domain :: Text
domain = CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Text
#domain
    sameSite :: Text
sameSite = CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Text
#sameSite
    secureSuffix :: Text
secureSuffix = if CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Bool
#secure then Text
"; Secure" else Text
""

mkCookieMap :: Maybe Text -> Map Text Text
mkCookieMap :: Maybe Text -> Map Text Text
mkCookieMap Maybe Text
cookie = do
  let diffCookies :: [Text]
diffCookies = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"; ") Maybe Text
cookie
      cookieParser :: [b] -> Maybe (b, b)
cookieParser [b
a, b
b] = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
a, b
b)
      cookieParser [b]
_ = Maybe (b, b)
forall a. Maybe a
Nothing
      cookieMap :: Map Text Text
cookieMap = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> Maybe (Text, Text)
forall {b}. [b] -> Maybe (b, b)
cookieParser ([Text] -> Maybe (Text, Text))
-> (Text -> [Text]) -> Text -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"=") [Text]
diffCookies
  Map Text Text
cookieMap

decodeToken :: Text -> Text
decodeToken :: Text -> Text
decodeToken = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

encodeToken :: Text -> Text
encodeToken :: Text -> Text
encodeToken = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

vvFromCookies :: Maybe Text -> ViewVars
vvFromCookies :: Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie = ViewVars {SortOrder
AuthToken
UiMode
Language
SongAsciiSize
Palette
language :: Language
uiMode :: UiMode
authToken :: AuthToken
songAsciiSize :: SongAsciiSize
artistSorting :: SortOrder
songSorting :: SortOrder
genreSorting :: SortOrder
palette :: Palette
$sel:language:ViewVars :: Language
$sel:uiMode:ViewVars :: UiMode
$sel:authToken:ViewVars :: AuthToken
$sel:songSorting:ViewVars :: SortOrder
$sel:artistSorting:ViewVars :: SortOrder
$sel:genreSorting:ViewVars :: SortOrder
$sel:songAsciiSize:ViewVars :: SongAsciiSize
$sel:palette:ViewVars :: Palette
..}
  where
    cookieMap :: Map Text Text
cookieMap = Maybe Text -> Map Text Text
mkCookieMap Maybe Text
cookie
    language :: Language
language = Language {$sel:value:Language :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"en" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
localeCookieName)}
    uiMode :: UiMode
uiMode = UiMode {$sel:value:UiMode :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"light" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
uiModeCookieName)}
    authToken :: AuthToken
authToken = AuthToken {$sel:value:AuthToken :: Text
value = Text -> Text
decodeToken (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
authCookieName)}
    songAsciiSize :: SongAsciiSize
songAsciiSize = SongAsciiSize {$sel:value:SongAsciiSize :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"sm" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
songAsciiSizeCookieName)}
    artistSorting :: SortOrder
artistSorting =
      SortOrder
        { $sel:value:SortOrder :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"created-at-desc" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
artistSortingCookieName)
        }
    songSorting :: SortOrder
songSorting =
      SortOrder
        { $sel:value:SortOrder :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"created-at-desc" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
songSortingCookieName)
        }
    genreSorting :: SortOrder
genreSorting =
      SortOrder
        { $sel:value:SortOrder :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"created-at-desc" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
genreSortingCookieName)
        }
    palette :: Palette
palette = Palette {$sel:value:Palette :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"purple" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
paletteCookieName)}

errorRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Text -> m Html
errorRoute :: forall (m :: * -> *).
(MonadIO m, MonadError ServerError m) =>
Env
-> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Text -> m Html
errorRoute Env
env Maybe Text
cookie Maybe Text
_ Maybe Int
maybeCode Maybe Text
maybeMessage = do
  Html
h <- IO Html -> m Html
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Html -> m Html) -> IO Html -> m Html
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @View (Env -> ViewVars -> Maybe Int -> Maybe Text -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> ViewVars -> Maybe Int -> Maybe Text -> Free f Html
errorPage Env
env ViewVars
vv Maybe Int
maybeCode Maybe Text
maybeMessage)
  ServerError -> m Html
forall a. ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError -> m Html) -> ServerError -> m Html
forall a b. (a -> b) -> a -> b
$ ServerError
      { $sel:errHTTPCode:ServerError :: Int
errHTTPCode = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
500 Maybe Int
maybeCode,
        $sel:errReasonPhrase:ServerError :: String
errReasonPhrase = String
"Error!",
        $sel:errBody:ServerError :: ByteString
errBody = Html -> ByteString
renderHtml Html
h,
        $sel:errHeaders:ServerError :: [Header]
errHeaders = []
      }
  where
    vv :: ViewVars
vv = Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie

data ServerResponse = ServerResponse
  { ServerResponse -> Int
code :: Int,
    ServerResponse -> Maybe Text
cause :: Maybe Text,
    ServerResponse -> Maybe Text
body :: Maybe Text,
    ServerResponse -> [(Text, Text)]
headers :: [(Text, Text)]
  }
  deriving (ServerResponse -> ServerResponse -> Bool
(ServerResponse -> ServerResponse -> Bool)
-> (ServerResponse -> ServerResponse -> Bool) -> Eq ServerResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerResponse -> ServerResponse -> Bool
== :: ServerResponse -> ServerResponse -> Bool
$c/= :: ServerResponse -> ServerResponse -> Bool
/= :: ServerResponse -> ServerResponse -> Bool
Eq, Int -> ServerResponse -> ShowS
[ServerResponse] -> ShowS
ServerResponse -> String
(Int -> ServerResponse -> ShowS)
-> (ServerResponse -> String)
-> ([ServerResponse] -> ShowS)
-> Show ServerResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerResponse -> ShowS
showsPrec :: Int -> ServerResponse -> ShowS
$cshow :: ServerResponse -> String
show :: ServerResponse -> String
$cshowList :: [ServerResponse] -> ShowS
showList :: [ServerResponse] -> ShowS
Show)

makeFieldLabelsNoPrefix ''ServerResponse

serverResponse :: ServerResponse
serverResponse :: ServerResponse
serverResponse =
  ServerResponse
    { $sel:code:ServerResponse :: Int
code = Int
200,
      $sel:cause:ServerResponse :: Maybe Text
cause = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"OK",
      $sel:body:ServerResponse :: Maybe Text
body = Maybe Text
forall a. Maybe a
Nothing,
      $sel:headers:ServerResponse :: [(Text, Text)]
headers = []
    }

withLocation :: (IsString a, IsString b) => Text -> (a, b)
withLocation :: forall a b. (IsString a, IsString b) => Text -> (a, b)
withLocation Text
location = (a
"Location", String -> b
forall a. IsString a => String -> a
fromString (String -> b) -> (Text -> String) -> Text -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> b) -> Text -> b
forall a b. (a -> b) -> a -> b
$ Text
location)

respondWithHttp :: (MonadIO m, MonadError ServerError m) => ServerResponse -> m a
respondWithHttp :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
ServerResponse -> m a
respondWithHttp ServerResponse
sr =
  ServerError -> m a
forall a. ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError -> m a) -> ServerError -> m a
forall a b. (a -> b) -> a -> b
$ ServerError
      { $sel:errHTTPCode:ServerError :: Int
errHTTPCode = ServerResponse
sr ServerResponse -> Optic' A_Lens NoIx ServerResponse Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ServerResponse Int
#code,
        $sel:errReasonPhrase:ServerError :: String
errReasonPhrase = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ServerResponse
sr ServerResponse
-> Optic' A_Lens NoIx ServerResponse (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ServerResponse (Maybe Text)
#cause,
        $sel:errBody:ServerError :: ByteString
errBody = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ServerResponse
sr ServerResponse
-> Optic' A_Lens NoIx ServerResponse (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ServerResponse (Maybe Text)
#body,
        $sel:errHeaders:ServerError :: [Header]
errHeaders =
          ((Text, Text) -> Header) -> [(Text, Text)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map
            ( (Text -> HeaderName)
-> (Text -> ByteString) -> (Text, Text) -> Header
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
                (String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> (Text -> String) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpackText)
                (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpackText)
            )
            (ServerResponse
sr ServerResponse
-> Optic' A_Lens NoIx ServerResponse [(Text, Text)]
-> [(Text, Text)]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ServerResponse [(Text, Text)]
#headers)
      }

httpFound :: ServerResponse
httpFound :: ServerResponse
httpFound = ServerResponse
serverResponse {code = 302}

callErrorPage :: (MonadIO m, MonadError ServerError m) => Text -> m a
callErrorPage :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Text -> m a
callErrorPage Text
e = ServerResponse -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
ServerResponse -> m a
respondWithHttp ServerResponse
httpFound {cause = Just "Error occured!", headers = [withLocation newLocation]}
  where
    newLocation :: Text
newLocation =
      Text
"/error?code="
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ( String -> Text
T.pack
               (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall b a. (Show a, IsString b) => a -> b
show
               (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
500
           )
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&message="
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ( ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
               (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode
               (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a. IsString a => String -> a
fromString
               (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
               (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
e
           )

respondWithViewOrErr :: (MonadIO m, MonadError ServerError m) => Either Text t -> (t -> IO a) -> m a
respondWithViewOrErr :: forall (m :: * -> *) t a.
(MonadIO m, MonadError ServerError m) =>
Either Text t -> (t -> IO a) -> m a
respondWithViewOrErr Either Text t
x t -> IO a
eff = case Either Text t
x of
  Left Text
e -> Text -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Text -> m a
callErrorPage Text
e
  Right t
r -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ t -> IO a
eff t
r

respondWithViewOrErr' :: (MonadIO m, MonadError ServerError m) => Either Text (Maybe t) -> (t -> IO a) -> m a
respondWithViewOrErr' :: forall (m :: * -> *) t a.
(MonadIO m, MonadError ServerError m) =>
Either Text (Maybe t) -> (t -> IO a) -> m a
respondWithViewOrErr' Either Text (Maybe t)
x t -> IO a
eff = case Either Text (Maybe t)
x of
  Left Text
e -> Text -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Text -> m a
callErrorPage Text
e
  Right Maybe t
r -> case Maybe t
r of
    Maybe t
Nothing -> Text -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Text -> m a
callErrorPage Text
"Error!"
    Just t
item -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ t -> IO a
eff t
item