refactor(users/Profpatsch/whatcd-resolver): response struct as GADT
I got stuck with unsolvable type inference problems using HasField and a struct here, since this is all returning an enum anyway, why not just use a GADT. It seems to work just fine and is more ergonomic (still not very, but this is Haskell). Change-Id: I1b5d0f98528ff85c0e3044bc730b660972142cd6 Reviewed-on: https://cl.tvl.fyi/c/depot/+/13005 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch
parent
de8ffb723c
commit
5d31e25588
1 changed files with 49 additions and 55 deletions
|
|
@ -124,11 +124,11 @@ htmlUi = do
|
||||||
& assertMNewSpan spanName (first AppExceptionTree)
|
& assertMNewSpan spanName (first AppExceptionTree)
|
||||||
|
|
||||||
let handlers :: Handlers (AppT IO)
|
let handlers :: Handlers (AppT IO)
|
||||||
handlers respond =
|
handlers =
|
||||||
Map.fromList
|
Map.fromList
|
||||||
[ ("", respond.html (mainHtml uniqueRunId)),
|
[ ("", Html (mainHtml uniqueRunId)),
|
||||||
( "snips/redacted/search",
|
( "snips/redacted/search",
|
||||||
respond.html $
|
Html $
|
||||||
\span -> do
|
\span -> do
|
||||||
dat <-
|
dat <-
|
||||||
mp
|
mp
|
||||||
|
|
@ -159,12 +159,12 @@ htmlUi = do
|
||||||
|]
|
|]
|
||||||
),
|
),
|
||||||
( "snips/redacted/torrentDataJson",
|
( "snips/redacted/torrentDataJson",
|
||||||
respond.html $ \span -> do
|
Html $ \span -> do
|
||||||
dat <- torrentIdMp span
|
dat <- torrentIdMp span
|
||||||
Html.mkVal <$> (runTransaction $ getTorrentById dat)
|
Html.mkVal <$> (runTransaction $ getTorrentById dat)
|
||||||
),
|
),
|
||||||
( "snips/redacted/getTorrentFile",
|
( "snips/redacted/getTorrentFile",
|
||||||
respond.htmlOrReferer $ \span -> do
|
HtmlOrReferer $ \span -> do
|
||||||
dat <- torrentIdMp span
|
dat <- torrentIdMp span
|
||||||
runTransaction $ do
|
runTransaction $ do
|
||||||
inserted <- redactedGetTorrentFileAndInsert dat
|
inserted <- redactedGetTorrentFileAndInsert dat
|
||||||
|
|
@ -184,7 +184,7 @@ htmlUi = do
|
||||||
),
|
),
|
||||||
-- TODO: this is bad duplication??
|
-- TODO: this is bad duplication??
|
||||||
( "snips/redacted/startTorrentFile",
|
( "snips/redacted/startTorrentFile",
|
||||||
respond.html $ \span -> do
|
Html $ \span -> do
|
||||||
dat <- torrentIdMp span
|
dat <- torrentIdMp span
|
||||||
runTransaction $ do
|
runTransaction $ do
|
||||||
file <-
|
file <-
|
||||||
|
|
@ -207,7 +207,7 @@ htmlUi = do
|
||||||
"Starting"
|
"Starting"
|
||||||
),
|
),
|
||||||
( "snips/transmission/getTorrentState",
|
( "snips/transmission/getTorrentState",
|
||||||
respond.html $ \span -> do
|
Html $ \span -> do
|
||||||
dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8
|
dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8
|
||||||
status <-
|
status <-
|
||||||
doTransmissionRequest'
|
doTransmissionRequest'
|
||||||
|
|
@ -227,8 +227,7 @@ htmlUi = do
|
||||||
),
|
),
|
||||||
( "snips/jsonld/render",
|
( "snips/jsonld/render",
|
||||||
do
|
do
|
||||||
let HandlerResponses {htmlWithQueryArgs} = respond
|
HtmlWithQueryArgs
|
||||||
htmlWithQueryArgs
|
|
||||||
( label @"target"
|
( label @"target"
|
||||||
<$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI)
|
<$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI)
|
||||||
& Parse.andParse uriToHttpClientRequest
|
& Parse.andParse uriToHttpClientRequest
|
||||||
|
|
@ -241,9 +240,7 @@ htmlUi = do
|
||||||
),
|
),
|
||||||
( "artist",
|
( "artist",
|
||||||
do
|
do
|
||||||
let HandlerResponses {htmlWithQueryArgs} = respond
|
HtmlWithQueryArgs
|
||||||
|
|
||||||
htmlWithQueryArgs
|
|
||||||
( label @"artistRedactedId"
|
( label @"artistRedactedId"
|
||||||
<$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural))
|
<$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural))
|
||||||
)
|
)
|
||||||
|
|
@ -251,7 +248,7 @@ htmlUi = do
|
||||||
artistPage qry
|
artistPage qry
|
||||||
),
|
),
|
||||||
( "artist/refresh",
|
( "artist/refresh",
|
||||||
respond.htmlOrRedirect $
|
HtmlOrRedirect $
|
||||||
\span -> do
|
\span -> do
|
||||||
dat <-
|
dat <-
|
||||||
mp
|
mp
|
||||||
|
|
@ -263,7 +260,7 @@ htmlUi = do
|
||||||
pure $ E22 (label @"redirectTo" [fmt|/artist?redacted_id={dat.artistId}|])
|
pure $ E22 (label @"redirectTo" [fmt|/artist?redacted_id={dat.artistId}|])
|
||||||
),
|
),
|
||||||
( "autorefresh",
|
( "autorefresh",
|
||||||
respond.plain $ do
|
Plain $ do
|
||||||
qry <-
|
qry <-
|
||||||
parseQueryArgsNewSpan
|
parseQueryArgsNewSpan
|
||||||
"Autorefresh Query Parse"
|
"Autorefresh Query Parse"
|
||||||
|
|
@ -284,7 +281,7 @@ htmlUi = do
|
||||||
]
|
]
|
||||||
runInIO $
|
runInIO $
|
||||||
runHandlers
|
runHandlers
|
||||||
(\respond -> respond.html $ (mainHtml uniqueRunId))
|
(Html $ mainHtml uniqueRunId)
|
||||||
handlers
|
handlers
|
||||||
req
|
req
|
||||||
respondOrig
|
respondOrig
|
||||||
|
|
@ -425,26 +422,25 @@ artistPage dat = runTransaction $ do
|
||||||
</form>
|
</form>
|
||||||
|]
|
|]
|
||||||
|
|
||||||
type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived)
|
type Handlers m = Map Text (HandlerResponse m)
|
||||||
|
|
||||||
data HandlerResponses m = HandlerResponses
|
data HandlerResponse m where
|
||||||
{ -- | render html
|
-- | render html
|
||||||
html :: (Otel.Span -> m Html) -> m ResponseReceived,
|
Html :: (Otel.Span -> m Html) -> HandlerResponse m
|
||||||
-- | either render html or redirect to another page
|
-- | either render html or redirect to another page
|
||||||
htmlOrRedirect :: (Otel.Span -> m (E2 "respond" Html "redirectTo" ByteString)) -> m ResponseReceived,
|
HtmlOrRedirect :: (Otel.Span -> m (E2 "respond" Html "redirectTo" ByteString)) -> HandlerResponse m
|
||||||
-- | render html after parsing some query arguments
|
-- | render html after parsing some query arguments
|
||||||
htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived),
|
HtmlWithQueryArgs :: Parse Query a -> (a -> Otel.Span -> m Html) -> HandlerResponse m
|
||||||
-- | render html or reload the page via the Referer header if no htmx
|
-- | render html or reload the page via the Referer header if no htmx
|
||||||
htmlOrReferer :: (Otel.Span -> m Html) -> m ResponseReceived,
|
HtmlOrReferer :: (Otel.Span -> m Html) -> HandlerResponse m
|
||||||
-- | render a plain wai response
|
-- | render a plain wai response
|
||||||
plain :: (m Wai.Response -> m ResponseReceived)
|
Plain :: m Wai.Response -> HandlerResponse m
|
||||||
}
|
|
||||||
|
|
||||||
runHandlers ::
|
runHandlers ::
|
||||||
forall m.
|
forall m.
|
||||||
(MonadOtel m) =>
|
(MonadOtel m) =>
|
||||||
(HandlerResponses m -> m ResponseReceived) ->
|
(HandlerResponse m) ->
|
||||||
(HandlerResponses m -> Map Text (m ResponseReceived)) ->
|
(Map Text (HandlerResponse m)) ->
|
||||||
Wai.Request ->
|
Wai.Request ->
|
||||||
(Wai.Response -> IO ResponseReceived) ->
|
(Wai.Response -> IO ResponseReceived) ->
|
||||||
m ResponseReceived
|
m ResponseReceived
|
||||||
|
|
@ -477,37 +473,35 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
|
||||||
r.redirectTo
|
r.redirectTo
|
||||||
(\status header -> Wai.responseLBS status [header] "")
|
(\status header -> Wai.responseLBS status [header] "")
|
||||||
req
|
req
|
||||||
let handlerResponses =
|
let htmlWithQueryArgs parser act =
|
||||||
( HandlerResponses
|
case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of
|
||||||
{ plain = (\m -> liftIO $ runInIO m >>= respond),
|
Right a -> html (act a)
|
||||||
html,
|
Left err ->
|
||||||
htmlOrRedirect,
|
html
|
||||||
htmlWithQueryArgs = \parser act ->
|
( \span -> do
|
||||||
case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of
|
recordException
|
||||||
Right a -> html (act a)
|
span
|
||||||
Left err ->
|
( T2
|
||||||
html
|
(label @"type_" "Query Parse Exception")
|
||||||
( \span -> do
|
(label @"message" (prettyErrorTree err))
|
||||||
recordException
|
)
|
||||||
span
|
|
||||||
( T2
|
|
||||||
(label @"type_" "Query Parse Exception")
|
|
||||||
(label @"message" (prettyErrorTree err))
|
|
||||||
)
|
|
||||||
|
|
||||||
pure
|
pure
|
||||||
[hsx|
|
[hsx|
|
||||||
<h1>Error:</h1>
|
<h1>Error:</h1>
|
||||||
<pre>{err & prettyErrorTree}</pre>
|
<pre>{err & prettyErrorTree}</pre>
|
||||||
|]
|
|]
|
||||||
),
|
)
|
||||||
htmlOrReferer
|
|
||||||
}
|
|
||||||
)
|
|
||||||
let handler =
|
let handler =
|
||||||
(handlers handlerResponses)
|
handlers
|
||||||
& Map.lookup path
|
& Map.lookup path
|
||||||
& fromMaybe (defaultHandler handlerResponses)
|
& fromMaybe defaultHandler
|
||||||
|
& \case
|
||||||
|
Html act -> html act
|
||||||
|
HtmlOrRedirect act -> htmlOrRedirect act
|
||||||
|
HtmlWithQueryArgs parser act -> htmlWithQueryArgs parser act
|
||||||
|
HtmlOrReferer act -> htmlOrReferer act
|
||||||
|
Plain act -> liftIO $ runInIO act >>= respond
|
||||||
runInIO handler
|
runInIO handler
|
||||||
|
|
||||||
singleQueryArgument :: Text -> FieldParser ByteString to -> Parse Http.Query to
|
singleQueryArgument :: Text -> FieldParser ByteString to -> Parse Http.Query to
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue