feat(users/Profpatsch/whatcd-resolver): overloaded matching whoo yea
whoooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo Change-Id: Ie4fdf9f3ceee4a83e6132e9cb8ef6952a0430b29 Reviewed-on: https://cl.tvl.fyi/c/depot/+/13218 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch
parent
745978def7
commit
3da25ef2cf
1 changed files with 82 additions and 44 deletions
|
|
@ -1,5 +1,7 @@
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
module WhatcdResolver where
|
module WhatcdResolver where
|
||||||
|
|
||||||
|
|
@ -30,6 +32,9 @@ import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
|
||||||
import Database.Postgres.Temp qualified as TmpPg
|
import Database.Postgres.Temp qualified as TmpPg
|
||||||
import FieldParser (FieldParser)
|
import FieldParser (FieldParser)
|
||||||
import FieldParser qualified as Field
|
import FieldParser qualified as Field
|
||||||
|
import GHC.OverloadedLabels (IsLabel (fromLabel))
|
||||||
|
import GHC.Records (HasField (..))
|
||||||
|
import GHC.TypeLits (Symbol)
|
||||||
import Html qualified
|
import Html qualified
|
||||||
import Http
|
import Http
|
||||||
import IHP.HSX.QQ (hsx)
|
import IHP.HSX.QQ (hsx)
|
||||||
|
|
@ -1332,49 +1337,82 @@ prefetchResourceIntegrity dat = inSpan' [fmt|prefetching resource {dat.integrity
|
||||||
let !bodyStrict = resp & Http.responseBody
|
let !bodyStrict = resp & Http.responseBody
|
||||||
let !bodyLength = bodyStrict & ByteString.length
|
let !bodyLength = bodyStrict & ByteString.length
|
||||||
if
|
if
|
||||||
| statusCode == 200 ->
|
| statusCode == 200 -> do
|
||||||
case dat.isTag of
|
let tagMatch prx1 val1 prx2 val2 =
|
||||||
E21 l -> do
|
dat.isTag
|
||||||
let _ = l.link
|
& caseE2
|
||||||
pure
|
( t2
|
||||||
( -- hsx does not understand the `as` attr
|
prx1
|
||||||
( Html.link
|
(\() -> val1)
|
||||||
! HtmlA.rel "preload"
|
prx2
|
||||||
! HtmlA.href (Html.textValue dat.localPath)
|
(\() -> val2)
|
||||||
! Html.customAttribute "as" "style"
|
)
|
||||||
)
|
pure
|
||||||
<> [hsx|
|
( -- hsx does not understand the `as` attr
|
||||||
<link rel="stylesheet" href={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous">
|
( Html.link
|
||||||
|],
|
! HtmlA.rel "preload"
|
||||||
Plain $
|
! HtmlA.href (Html.textValue dat.localPath)
|
||||||
pure $
|
! Html.customAttribute
|
||||||
Wai.responseLBS
|
"as"
|
||||||
Http.ok200
|
( tagMatch
|
||||||
[ ("Content-Type", mContentType & fromMaybe "text/css; charset=UTF-8"),
|
#link
|
||||||
("Content-Length", buildBytes intDecimalB bodyLength)
|
"style"
|
||||||
]
|
#script
|
||||||
(toLazyBytes $ bodyStrict)
|
"script"
|
||||||
)
|
)
|
||||||
E22 l -> do
|
)
|
||||||
let _ = l.script
|
<> ( tagMatch
|
||||||
pure
|
#link
|
||||||
( ( -- hsx does not understand the `as` attr
|
[hsx|<link rel="stylesheet" href={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous">|]
|
||||||
Html.link
|
#script
|
||||||
! HtmlA.rel "preload"
|
[hsx|<script src={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous"></script>|]
|
||||||
! HtmlA.href (Html.textValue dat.localPath)
|
),
|
||||||
! Html.customAttribute "as" "script"
|
Plain $
|
||||||
)
|
pure $
|
||||||
<> [hsx|
|
Wai.responseLBS
|
||||||
<script src={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous"></script>
|
Http.ok200
|
||||||
|],
|
[ ( "Content-Type",
|
||||||
Plain $
|
mContentType
|
||||||
pure $
|
& fromMaybe
|
||||||
Wai.responseLBS
|
( tagMatch
|
||||||
Http.ok200
|
#script
|
||||||
[ ("Content-Type", mContentType & fromMaybe "text/javascript; charset=UTF-8"),
|
"text/javascript; charset=UTF-8"
|
||||||
("Content-Length", buildBytes intDecimalB bodyLength)
|
#link
|
||||||
]
|
"text/css; charset=UTF-8"
|
||||||
(toLazyBytes $ bodyStrict)
|
)
|
||||||
)
|
),
|
||||||
|
("Content-Length", buildBytes intDecimalB bodyLength)
|
||||||
|
]
|
||||||
|
(toLazyBytes $ bodyStrict)
|
||||||
|
)
|
||||||
| code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
|
| code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
|
||||||
)
|
)
|
||||||
|
|
||||||
|
-- case-match on an e2 with a t2 that provides the relevant functions
|
||||||
|
caseE2 ::
|
||||||
|
forall l1 t1 l2 t2 matcher r.
|
||||||
|
( HasField l1 matcher (t1 -> r),
|
||||||
|
HasField l2 matcher (t2 -> r)
|
||||||
|
) =>
|
||||||
|
matcher ->
|
||||||
|
E2 l1 t1 l2 t2 ->
|
||||||
|
r
|
||||||
|
{-# INLINE caseE2 #-}
|
||||||
|
caseE2 m e2 = do
|
||||||
|
let f1 = getField @l1 m
|
||||||
|
let f2 = getField @l2 m
|
||||||
|
case e2 of
|
||||||
|
E21 a -> f1 $ getField @l1 a
|
||||||
|
E22 b -> f2 $ getField @l2 b
|
||||||
|
|
||||||
|
t2 :: forall l1 t1 l2 t2. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> T2 l1 t1 l2 t2
|
||||||
|
{-# INLINE t2 #-}
|
||||||
|
t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b)
|
||||||
|
|
||||||
|
data LabelPrx (l :: Symbol) = LabelPrx
|
||||||
|
|
||||||
|
instance (l ~ l') => IsLabel l (LabelPrx l') where
|
||||||
|
fromLabel = LabelPrx
|
||||||
|
|
||||||
|
instance (t ~ t') => IsLabel l (t -> (Label l t')) where
|
||||||
|
fromLabel = label @l
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue