hercules-ci-api-core 0.1.1.0 → 0.1.2.0
raw patch · 6 files changed
+35/−20 lines, 6 filesdep +deepseqdep ~katip
Dependencies added: deepseq
Dependency ranges changed: katip
Files
- CHANGELOG.md +4/−1
- hercules-ci-api-core.cabal +4/−3
- src/Hercules/API/Id.hs +18/−10
- src/Hercules/API/Name.hs +3/−2
- src/Hercules/API/Prelude.hs +2/−0
- src/Hercules/Error.hs +4/−4
CHANGELOG.md view
@@ -4,7 +4,10 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) -## [Unreleased]+## [0.1.2.0] - 2020-03-07++- Use `uuid` type in swagger+- Add `NFData` instances ## [0.1.1.0] - 2020-05-05
hercules-ci-api-core.cabal view
@@ -1,9 +1,9 @@ cabal-version: 1.12 name: hercules-ci-api-core-version: 0.1.1.0+version: 0.1.2.0 synopsis: Types and convenience modules use across Hercules CI API packages-category: API, CI, Testing, DevOps+category: API, CI, Testing, DevOps, Nix homepage: https://github.com/hercules-ci/hercules-ci-agent#readme bug-reports: https://github.com/hercules-ci/hercules-ci-agent/issues author: Hercules CI contributors@@ -35,13 +35,14 @@ , bytestring , containers , cookie+ , deepseq , exceptions , safe-exceptions , hashable , http-api-data , http-media , lens- , katip+ , katip >= 0.7.0.0 , memory , lifted-base , monad-control
src/Hercules/API/Id.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} module Hercules.API.Id@@ -7,23 +8,31 @@ ) where +import Control.DeepSeq (NFData)+import Control.Lens ((?~)) import Data.Aeson import Data.Aeson.Types (toJSONKeyText)+import Data.Function ((&)) import Data.Hashable (Hashable (..))-import Data.Proxy import Data.Swagger- ( ToParamSchema (..),+ ( NamedSchema (NamedSchema),+ ParamSchema,+ SwaggerType (SwaggerString),+ ToParamSchema (..), ToSchema (..),+ format,+ paramSchemaToSchema,+ type_, ) import Data.Text (Text)-import qualified Data.UUID as UUID import Data.UUID (UUID)+import qualified Data.UUID as UUID import GHC.Generics (Generic) import Web.HttpApiData import Prelude newtype Id (a :: k) = Id {idUUID :: UUID}- deriving (Generic, Eq, Ord)+ deriving (Generic, Eq, Ord, NFData) instance Hashable (Id a) where hashWithSalt s (Id uuid) =@@ -44,7 +53,6 @@ showsPrec n = showsPrec n . idText instance ToJSON (Id a) where- toEncoding = toEncoding . idText toJSON = toJSON . idText@@ -68,10 +76,10 @@ parseUrlPiece = fmap Id . parseUrlPiece instance ToSchema (Id a) where- declareNamedSchema = declareNamedSchema . invmap idText+ declareNamedSchema = pure . NamedSchema Nothing . paramSchemaToSchema instance ToParamSchema (Id a) where- toParamSchema = toParamSchema . invmap idText--invmap :: (a -> b) -> proxy a -> Proxy b-invmap _ _ = Proxy+ toParamSchema _ =+ (mempty :: ParamSchema t)+ & type_ ?~ SwaggerString+ & format ?~ "uuid"
src/Hercules/API/Name.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} module Hercules.API.Name@@ -6,6 +7,7 @@ ) where +import Control.DeepSeq (NFData) import Data.Aeson import Data.Hashable (Hashable (..)) import Data.Proxy@@ -20,7 +22,7 @@ -- | A slug. Display names are simply 'Text'. newtype Name (a :: k) = Name {nameText :: Text}- deriving (Generic, Eq, Ord)+ deriving (Generic, Eq, Ord, NFData) instance Hashable (Name a) @@ -31,7 +33,6 @@ showsPrec n = showsPrec n . nameText instance ToJSON (Name a) where- toEncoding = toEncoding . nameText toJSON = toJSON . nameText
src/Hercules/API/Prelude.hs view
@@ -14,6 +14,7 @@ -- * Type classes Generic,+ NFData (..), ToJSON, FromJSON, ToSchema,@@ -21,6 +22,7 @@ ) where +import Control.DeepSeq (NFData (..)) import Data.Aeson ( FromJSON, ToJSON,
src/Hercules/Error.hs view
@@ -9,7 +9,6 @@ import GHC.Conc (threadDelay) import Hercules.API.Prelude import Katip-import Katip.Monadic (logLocM) escalate :: (Exception exc, MonadThrow m) => Either exc a -> m a escalate = escalateAs id@@ -49,9 +48,10 @@ loop [] = io loop (delay : delays) = safeLiftedCatch io $ \e -> do logLocM WarningS $ "Retrying on exception: " <> logStr (show e)- when (delay >= 0.000001) $ liftIO $- threadDelay- (floor $ delay * 1000 * 1000)+ when (delay >= 0.000001) $+ liftIO $+ threadDelay+ (floor $ delay * 1000 * 1000) loop delays -- | ~5 minute exponential backoff