mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(third_party/haskell): update pa packages

Browse source 
Change-Id: I8abcb479b0f5c0bd6ed1abc3c9618c2362ff835a
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9740
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2023-10-15 20:16:52 +02:00 • committed by clbot
parent 9aafbe8d95
commit 0a98f8ec3b
6 changed files with 28 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

8
users/Profpatsch/my-prelude/src/Tool.hs
View file

@ -31,12 +31,12 @@ readTools env toolParser =
Exit.die [fmt|Please set {env.toolsEnvVar} to a directory with all tools we need (see `Tools` in the code).|]
Just toolsDir ->
(Posix.fileExist toolsDir & ifTrueOrErr () [fmt|{env.toolsEnvVar} directory does not exist: {toolsDir}|])
& thenValidate
& thenValidateM
( \() ->
(Posix.getFileStatus toolsDir <&> Posix.isDirectory)
& ifTrueOrErr () [fmt|{env.toolsEnvVar} does not point to a directory: {toolsDir}|]
)
& thenValidate
& thenValidateM
(\() -> toolParser.unToolParser toolsDir)
<&> first (errorTree [fmt|Could not find all tools in {env.toolsEnvVar}|])
>>= \case
@ -61,14 +61,14 @@ readTool exeName = ToolParserT $ \toolDir -> do
let exec = True
Posix.fileExist toolPath
& ifTrueOrErr () [fmt|Tool does not exist: {toolPath}|]
& thenValidate
& thenValidateM
( \() ->
Posix.fileAccess toolPath read' write exec
& ifTrueOrErr (Tool {..}) [fmt|Tool is not readable/executable: {toolPath}|]
)
-- | helper
ifTrueOrErr :: Functor f => a -> Text -> f Bool -> f (Validation (NonEmpty Error) a)
ifTrueOrErr :: (Functor f) => a -> Text -> f Bool -> f (Validation (NonEmpty Error) a)
ifTrueOrErr true err io =
io <&> \case
True -> Success true

7
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -19,7 +19,6 @@ import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Pool (Pool)
import Data.Pool qualified as Pool
import Data.Scientific (Scientific)
import Data.Text qualified as Text
import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
import Database.PostgreSQL.Simple qualified as Postgres
@ -364,7 +363,7 @@ getAndUpdateTransmissionTorrentsStatus knownTorrents = do
)
$ do
torrentHash <- Json.keyLabel @"torrentHash" "hashString" Json.asText
percentDone <- Json.keyLabel @"percentDone" "percentDone" (Field.jsonParser $ Field.jsonNumber >>> scientificPercentage)
percentDone <- Json.keyLabel @"percentDone" "percentDone" (Field.toJsonParser $ Field.jsonNumber >>> scientificPercentage)
pure (torrentHash, percentDone)
)
<&> Map.fromList
@ -621,7 +620,7 @@ doTransmissionRequest span dat (req, parser) = do
tag <-
Json.keyMay
"tag"
(Field.jsonParser (Field.jsonNumber >>> Field.boundedScientificIntegral "tag too long"))
(Field.toJsonParser (Field.jsonNumber >>> Field.boundedScientificIntegral "tag too long"))
pure TransmissionResponse {..}
)
& first (Json.parseErrorTree "Cannot parse transmission RPC response")
@ -747,7 +746,7 @@ redactedSearchAndInsert extraArguments = do
Json.throwCustomError [fmt|Status was not "success", but {status}|]
Json.key "response" $ do
pages <-
Json.keyMay "pages" (Field.jsonParser (Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural))
Json.keyMay "pages" (Field.toJsonParser (Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural))
-- in case the field is missing, let’s assume there is only one page
<&> fromMaybe 1
Json.key "results" $ do