{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}

module Web.Hyperbole.Server.Wai where

import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.List qualified as L
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.String.Interpolate (i)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static (throwError_)
import Effectful.Exception (throwIO)
import Effectful.State.Static.Local (get, modify)
import Effectful.Writer.Static.Local (tell)
import Network.HTTP.Types (Header, HeaderName, status200, status400, status401, status404, status500)
import Network.Wai qualified as Wai
import Network.Wai.Internal (ResponseReceived (..))
import Web.Atomic (att, (@))
import Web.Cookie qualified
import Web.Hyperbole.Data.Cookie (Cookie, Cookies)
import Web.Hyperbole.Data.Cookie qualified as Cookie
import Web.Hyperbole.Data.Encoded (Encoded, decode)
import Web.Hyperbole.Data.URI (path, uriToText)
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Server.Message
import Web.Hyperbole.Server.Options
import Web.Hyperbole.Types.Client
import Web.Hyperbole.Types.Event (Event (..), TargetViewId (..))
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response
import Web.Hyperbole.View (View, renderLazyByteString, runViewContext, script', type_)


handleRequestWai
  :: (IOE :> es)
  => ServerOptions
  -> Wai.Request
  -> (Wai.Response -> IO ResponseReceived)
  -> Eff (Hyperbole : es) Response
  -> Eff es Wai.ResponseReceived
handleRequestWai :: forall (es :: [Effect]).
(IOE :> es) =>
ServerOptions
-> Request
-> (Response -> IO ResponseReceived)
-> Eff (Hyperbole : es) Response
-> Eff es ResponseReceived
handleRequestWai ServerOptions
options Request
req Response -> IO ResponseReceived
respond Eff (Hyperbole : es) Response
actions = do
  -- NOTE: Remember, this is called for both updates AND for page loads
  ByteString
body <- IO ByteString -> Eff es ByteString
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Eff es ByteString)
-> IO ByteString -> Eff es ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.consumeRequestBodyLazy Request
req
  Request
rq <- (MessageError -> Eff es Request)
-> (Request -> Eff es Request)
-> Either MessageError Request
-> Eff es Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MessageError -> Eff es Request
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO Request -> Eff es Request
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MessageError Request -> Eff es Request)
-> Either MessageError Request -> Eff es Request
forall a b. (a -> b) -> a -> b
$ do
    Request -> ByteString -> Either MessageError Request
fromWaiRequest Request
req ByteString
body
  (Response
res, Client
client, [Remote]
rmts) <- Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall (es :: [Effect]).
Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
runHyperboleWai Request
rq Eff (Hyperbole : es) Response
actions
  IO ResponseReceived -> Eff es ResponseReceived
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> Eff es ResponseReceived)
-> IO ResponseReceived -> Eff es ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerOptions
-> Request
-> Client
-> Response
-> [Remote]
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
sendResponse ServerOptions
options Request
rq Client
client Response
res [Remote]
rmts Response -> IO ResponseReceived
respond


-- | Run the 'Hyperbole' effect to get a response
runHyperboleWai
  :: Request
  -> Eff (Hyperbole : es) Response
  -> Eff es (Response, Client, [Remote])
runHyperboleWai :: forall (es :: [Effect]).
Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
runHyperboleWai Request
req = (Eff
   (Error Response : State Client : Writer [Remote] : es) Response
 -> Eff es (Response, Client, [Remote]))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv
      localEs (Error Response : State Client : Writer [Remote] : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Error Response : State Client : Writer [Remote] : es) a)
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall (e :: Effect) (handlerEs :: [Effect]) a (es :: [Effect]) b.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret (Request
-> Eff
     (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
forall (es :: [Effect]).
Request
-> Eff
     (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
runHyperboleLocal Request
req) ((forall {a} {localEs :: [Effect]}.
  (HasCallStack, Hyperbole :> localEs) =>
  LocalEnv
    localEs (Error Response : State Client : Writer [Remote] : es)
  -> Hyperbole (Eff localEs) a
  -> Eff (Error Response : State Client : Writer [Remote] : es) a)
 -> Eff (Hyperbole : es) Response
 -> Eff es (Response, Client, [Remote]))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv
      localEs (Error Response : State Client : Writer [Remote] : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Error Response : State Client : Writer [Remote] : es) a)
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall a b. (a -> b) -> a -> b
$ \LocalEnv
  localEs (Error Response : State Client : Writer [Remote] : es)
_ -> \case
  Hyperbole (Eff localEs) a
GetRequest -> do
    a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall a.
a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Request
req
  RespondNow Response
r -> do
    Response
-> Eff (Error Response : State Client : Writer [Remote] : es) a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ Response
r
  PushUpdate ViewUpdate
_ -> do
    -- ignore! you can't push updates using WAI
    a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall a.
a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Hyperbole (Eff localEs) a
GetClient -> do
    forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
Eff es s
get @Client
  ModClient Client -> Client
f -> do
    forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify @Client Client -> Client
f
  TriggerAction TargetViewId
vid Encoded
act -> do
    [Remote]
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall w (es :: [Effect]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell [TargetViewId -> Encoded -> Remote
RemoteAction TargetViewId
vid Encoded
act]
  TriggerEvent Text
name Value
dat -> do
    [Remote]
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall w (es :: [Effect]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell [Text -> Value -> Remote
RemoteEvent Text
name Value
dat]


sendResponse :: ServerOptions -> Request -> Client -> Response -> [Remote] -> (Wai.Response -> IO ResponseReceived) -> IO Wai.ResponseReceived
sendResponse :: ServerOptions
-> Request
-> Client
-> Response
-> [Remote]
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
sendResponse ServerOptions
options Request
req Client
client Response
res [Remote]
remotes Response -> IO ResponseReceived
respond = do
  let metas :: Metadata
metas = Request -> Metadata
requestMetadata Request
req Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Path -> Client -> [Remote] -> Metadata
responseMetadata Request
req.path Client
client [Remote]
remotes
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Metadata -> Response -> Response
response Metadata
metas Response
res
 where
  response :: Metadata -> Response -> Wai.Response
  response :: Metadata -> Response -> Response
response Metadata
metas = \case
    (Err ResponseError
err) ->
      Status -> [Header] -> ServerError -> Response
forall {r}.
(HasField "message" r Text, HasField "body" r Body) =>
Status -> [Header] -> r -> Response
respondError (ResponseError -> Status
errStatus ResponseError
err) [] (ServerError -> Response) -> ServerError -> Response
forall a b. (a -> b) -> a -> b
$ ServerOptions
options.serverError ResponseError
err
    (Response (ViewUpdate TargetViewId
_ Body
vw)) -> do
      Status -> [Header] -> ByteString -> Response
respondHtml Status
status200 (Client -> [Header]
clientHeaders Client
client) (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Metadata -> Body -> ByteString
renderViewResponse Metadata
metas Body
vw
    (Redirect URI
u) -> do
      let url :: Text
url = URI -> Text
uriToText URI
u
      let hs :: [Header]
hs = (HeaderName
"Location", Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
url) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: Client -> [Header]
clientHeaders Client
client
      Status -> [Header] -> ByteString -> Response
respondHtml Status
status200 [Header]
hs (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Metadata -> Body -> ByteString
renderViewResponse Metadata
metas (Body -> ByteString) -> Body -> ByteString
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
        ByteString -> View () ()
forall c. ByteString -> View c ()
script'
          [i|window.location = '#{uriToText u}'|]

  errStatus :: ResponseError -> Status
errStatus = \case
    ResponseError
NotFound -> Status
status404
    ErrParse String
_ -> Status
status400
    ErrQuery String
_ -> Status
status400
    ErrSession Text
_ String
_ -> Status
status400
    ErrAuth Text
_ -> Status
status401
    ResponseError
_ -> Status
status500

  -- convert to document if full page request
  addDocument :: BL.ByteString -> BL.ByteString
  addDocument :: ByteString -> ByteString
addDocument ByteString
body =
    case Request
req.event of
      Maybe (Event TargetViewId Encoded Encoded)
Nothing -> ServerOptions
options.toDocument ByteString
body
      Maybe (Event TargetViewId Encoded Encoded)
_ -> ByteString
body

  renderViewResponse :: Metadata -> Body -> BL.ByteString
  renderViewResponse :: Metadata -> Body -> ByteString
renderViewResponse Metadata
metas (Body ByteString
body) =
    ByteString -> ByteString
addDocument (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString (Metadata -> ViewState Metadata -> View Metadata () -> View () ()
forall ctx c. ctx -> ViewState ctx -> View ctx () -> View c ()
runViewContext Metadata
metas () (View Metadata () -> View () ()) -> View Metadata () -> View () ()
forall a b. (a -> b) -> a -> b
$ Metadata -> View Metadata ()
scriptMeta Metadata
metas) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
body

  respondError :: Status -> [Header] -> r -> Response
respondError Status
s [Header]
hs r
serr = Status -> [Header] -> ByteString -> Response
respondHtml Status
s [Header]
hs (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Metadata -> Body -> ByteString
renderViewResponse (Text -> Metadata
metaError r
serr.message) r
serr.body
  respondHtml :: Status -> [Header] -> ByteString -> Response
respondHtml Status
s [Header]
hs = Status -> [Header] -> ByteString -> Response
Wai.responseLBS Status
s (ContentType -> Header
contentType ContentType
ContentHtml Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
hs)
  -- respondText s hs = Wai.responseLBS s (contentType ContentText : hs)

  -- via HTTP, we want to manually set some headers rather than just rely on the client
  clientHeaders :: Client -> [Header]
  clientHeaders :: Client -> [Header]
clientHeaders = Client -> [Header]
forall {r}. HasField "session" r Cookies => r -> [Header]
setCookies
   where
    setCookies :: r -> [Header]
setCookies r
clnt =
      (Cookie -> Header) -> [Cookie] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> Header
setCookie ([Cookie] -> [Header]) -> [Cookie] -> [Header]
forall a b. (a -> b) -> a -> b
$ Cookies -> [Cookie]
Cookie.toList r
clnt.session

    setCookie :: Cookie -> (HeaderName, BS.ByteString)
    setCookie :: Cookie -> Header
setCookie Cookie
cookie =
      (HeaderName
"Set-Cookie", Path -> Cookie -> ByteString
Cookie.render Request
req.path Cookie
cookie)


scriptMeta :: Metadata -> View Metadata ()
scriptMeta :: Metadata -> View Metadata ()
scriptMeta Metadata
m =
  ByteString -> View Metadata ()
forall c. ByteString -> View c ()
script' (ByteString -> View Metadata ())
-> (Attributes (ByteString -> View Metadata ())
    -> Attributes (ByteString -> View Metadata ()))
-> ByteString
-> View Metadata ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Attributes (ByteString -> View Metadata ())
-> Attributes (ByteString -> View Metadata ())
forall h. Attributable h => Text -> Attributes h -> Attributes h
type_ Text
"application/hyp.metadata" (Attributes (ByteString -> View Metadata ())
 -> Attributes (ByteString -> View Metadata ()))
-> (Attributes (ByteString -> View Metadata ())
    -> Attributes (ByteString -> View Metadata ()))
-> Attributes (ByteString -> View Metadata ())
-> Attributes (ByteString -> View Metadata ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Text
-> Attributes (ByteString -> View Metadata ())
-> Attributes (ByteString -> View Metadata ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"id" Text
"hyp.metadata" (ByteString -> View Metadata ()) -> ByteString -> View Metadata ()
forall a b. (a -> b) -> a -> b
$
    Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
      Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Metadata -> Text
renderMetadata Metadata
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"


messageFromBody :: BL.ByteString -> Either MessageError Message
messageFromBody :: ByteString -> Either MessageError Message
messageFromBody ByteString
inp = do
  (String -> MessageError)
-> Either String Message -> Either MessageError Message
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
e -> String -> Text -> MessageError
InvalidMessage String
e (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
inp)) (Either String Message -> Either MessageError Message)
-> Either String Message -> Either MessageError Message
forall a b. (a -> b) -> a -> b
$ Text -> Either String Message
parseActionMessage (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
inp)


fromWaiRequest :: Wai.Request -> BL.ByteString -> Either MessageError Request
fromWaiRequest :: Request -> ByteString -> Either MessageError Request
fromWaiRequest Request
wr ByteString
body = do
  let pth :: Path
pth = Text -> Path
path (Text -> Path) -> Text -> Path
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.rawPathInfo Request
wr
      query :: Query
query = Request -> Query
Wai.queryString Request
wr
      headers :: [Header]
headers = Request -> [Header]
Wai.requestHeaders Request
wr
      cookie :: ByteString
cookie = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Cookie" [Header]
headers
      host :: Host
host = ByteString -> Host
Host (ByteString -> Host) -> ByteString -> Host
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Host" [Header]
headers
      requestId :: RequestId
requestId = Text -> RequestId
RequestId (Text -> RequestId) -> Text -> RequestId
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-RequestId" [Header]
headers
      method :: ByteString
method = Request -> ByteString
Wai.requestMethod Request
wr
      event :: Maybe (Event TargetViewId Encoded Encoded)
event = [Header] -> Maybe (Event TargetViewId Encoded Encoded)
lookupEvent [Header]
headers
  Cookies
cookies <- ByteString -> Either MessageError Cookies
fromCookieHeader ByteString
cookie

  Request -> Either MessageError Request
forall a. a -> Either MessageError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Either MessageError Request)
-> Request -> Either MessageError Request
forall a b. (a -> b) -> a -> b
$
    Request
      { $sel:body:Request :: ByteString
body = ByteString
body
      , $sel:path:Request :: Path
path = Path
pth
      , Maybe (Event TargetViewId Encoded Encoded)
event :: Maybe (Event TargetViewId Encoded Encoded)
$sel:event:Request :: Maybe (Event TargetViewId Encoded Encoded)
event
      , Query
query :: Query
$sel:query:Request :: Query
query
      , ByteString
method :: ByteString
$sel:method:Request :: ByteString
method
      , Cookies
cookies :: Cookies
$sel:cookies:Request :: Cookies
cookies
      , Host
host :: Host
$sel:host:Request :: Host
host
      , RequestId
requestId :: RequestId
$sel:requestId:Request :: RequestId
requestId
      }
 where
  lookupEvent :: [Header] -> Maybe (Event TargetViewId Encoded Encoded)
  lookupEvent :: [Header] -> Maybe (Event TargetViewId Encoded Encoded)
lookupEvent [Header]
headers = do
    Text
viewIdText <- ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-ViewId" [Header]
headers
    Text
actText <- ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-Action" [Header]
headers
    Text
stText <- ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup HeaderName
"Hyp-State" [Header]
headers
    Encoded
act <- Text -> Maybe Encoded
forall a. FromEncoded a => Text -> Maybe a
decode Text
actText
    TargetViewId
viewId <- Encoded -> TargetViewId
TargetViewId (Encoded -> TargetViewId) -> Maybe Encoded -> Maybe TargetViewId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Encoded
forall a. FromEncoded a => Text -> Maybe a
decode Text
viewIdText
    Encoded
st <- Text -> Maybe Encoded
forall a. FromEncoded a => Text -> Maybe a
decode Text
stText
    Event TargetViewId Encoded Encoded
-> Maybe (Event TargetViewId Encoded Encoded)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event TargetViewId Encoded Encoded
 -> Maybe (Event TargetViewId Encoded Encoded))
-> Event TargetViewId Encoded Encoded
-> Maybe (Event TargetViewId Encoded Encoded)
forall a b. (a -> b) -> a -> b
$ TargetViewId
-> Encoded -> Encoded -> Event TargetViewId Encoded Encoded
forall id act st. id -> act -> st -> Event id act st
Event TargetViewId
viewId Encoded
act Encoded
st


-- Client only returns ONE Cookie header, with everything concatenated
fromCookieHeader :: BS.ByteString -> Either MessageError Cookies
fromCookieHeader :: ByteString -> Either MessageError Cookies
fromCookieHeader ByteString
h =
  case [(ByteString, ByteString)] -> Either String Cookies
Cookie.parse (ByteString -> [(ByteString, ByteString)]
Web.Cookie.parseCookies ByteString
h) of
    Left String
err -> MessageError -> Either MessageError Cookies
forall a b. a -> Either a b
Left (MessageError -> Either MessageError Cookies)
-> MessageError -> Either MessageError Cookies
forall a b. (a -> b) -> a -> b
$ ByteString -> String -> MessageError
InvalidCookie ByteString
h String
err
    Right Cookies
a -> Cookies -> Either MessageError Cookies
forall a. a -> Either MessageError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cookies
a


contentType :: ContentType -> (HeaderName, BS.ByteString)
contentType :: ContentType -> Header
contentType ContentType
ContentHtml = (HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")
contentType ContentType
ContentText = (HeaderName
"Content-Type", ByteString
"text/plain; charset=utf-8")