packages feed

hercules-ci-api-core (empty) → 0.1.1.0

raw patch · 7 files changed

+342/−0 lines, 7 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, cookie, exceptions, hashable, http-api-data, http-media, katip, lens, lifted-base, memory, monad-control, safe-exceptions, servant, servant-auth, servant-auth-swagger, servant-swagger, servant-swagger-ui-core, string-conv, swagger2, text, time, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/)++## [Unreleased]++## [0.1.1.0] - 2020-05-05++- Allow `Id` in JSON object keys++## [0.1.0.0] - 2020-01-30++- Initial release, split out of hercules-ci-api++[0.1.1.0]: https://github.com/hercules-ci/hercules-ci-agent/releases/tag/hercules-ci-api-core-0.1.1.0+[0.1.0.0]: https://github.com/hercules-ci/hercules-ci-agent/releases/tag/hercules-ci-api-core-0.1.0.0+[Unreleased]: https://github.com/hercules-ci/hercules-ci-agent/compare/stable...master
+ hercules-ci-api-core.cabal view
@@ -0,0 +1,58 @@+cabal-version: 1.12++name:           hercules-ci-api-core+version:        0.1.1.0+synopsis:       Types and convenience modules use across Hercules CI API packages+category:       API, CI, Testing, DevOps+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+maintainer:     info@hercules-ci.com+copyright:      2018-2020 Hercules CI+license:        Apache-2.0+build-type:     Simple+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/hercules-ci/hercules-ci++library+  exposed-modules:+      Hercules.API.Id+      Hercules.API.Name+      Hercules.API.Prelude+      Hercules.API.Servant+      Hercules.Error+  hs-source-dirs:+      src+  default-extensions: DeriveGeneric DeriveTraversable DisambiguateRecordFields FlexibleContexts InstanceSigs LambdaCase MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-incomplete-patterns+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , containers+    , cookie+    , exceptions+    , safe-exceptions+    , hashable+    , http-api-data+    , http-media+    , lens+    , katip+    , memory+    , lifted-base+    , monad-control+    , servant >=0.14.1+    , servant-auth+    , servant-auth-swagger+    , servant-swagger+    , servant-swagger-ui-core+    , string-conv+    , swagger2+    , text+    , time+    , uuid+  default-language: Haskell2010
+ src/Hercules/API/Id.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE PolyKinds #-}++module Hercules.API.Id+  ( Id (..),+    idText,+    uncheckedCast,+  )+where++import Data.Aeson+import Data.Aeson.Types (toJSONKeyText)+import Data.Hashable (Hashable (..))+import Data.Proxy+import Data.Swagger+  ( ToParamSchema (..),+    ToSchema (..),+  )+import Data.Text (Text)+import qualified Data.UUID as UUID+import Data.UUID (UUID)+import GHC.Generics (Generic)+import Web.HttpApiData+import Prelude++newtype Id (a :: k) = Id {idUUID :: UUID}+  deriving (Generic, Eq, Ord)++instance Hashable (Id a) where+  hashWithSalt s (Id uuid) =+    let (a, b, c, d) = UUID.toWords uuid+     in s+          `hashWithSalt` a+          `hashWithSalt` b+          `hashWithSalt` c+          `hashWithSalt` d++idText :: Id a -> Text+idText = UUID.toText . idUUID++uncheckedCast :: Id a -> Id b+uncheckedCast (Id s) = Id s++instance Show (Id a) where+  showsPrec n = showsPrec n . idText++instance ToJSON (Id a) where++  toEncoding = toEncoding . idText++  toJSON = toJSON . idText++instance FromJSON (Id a) where+  parseJSON = fmap Id . parseJSON++instance ToJSONKey (Id a) where+  toJSONKey = toJSONKeyText idText++instance FromJSONKey (Id a) where+  fromJSONKey = FromJSONKeyTextParser $ \text ->+    case UUID.fromText text of+      Just x -> pure $ Id x+      Nothing -> fail "Expected UUID"++instance ToHttpApiData (Id a) where+  toUrlPiece = idText++instance FromHttpApiData (Id a) where+  parseUrlPiece = fmap Id . parseUrlPiece++instance ToSchema (Id a) where+  declareNamedSchema = declareNamedSchema . invmap idText++instance ToParamSchema (Id a) where+  toParamSchema = toParamSchema . invmap idText++invmap :: (a -> b) -> proxy a -> Proxy b+invmap _ _ = Proxy
+ src/Hercules/API/Name.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE PolyKinds #-}++module Hercules.API.Name+  ( Name (..),+    uncheckedCast,+  )+where++import Data.Aeson+import Data.Hashable (Hashable (..))+import Data.Proxy+import Data.Swagger+  ( ToParamSchema (..),+    ToSchema (..),+  )+import Data.Text (Text)+import GHC.Generics (Generic)+import Web.HttpApiData+import Prelude++-- | A slug. Display names are simply 'Text'.+newtype Name (a :: k) = Name {nameText :: Text}+  deriving (Generic, Eq, Ord)++instance Hashable (Name a)++uncheckedCast :: Name a -> Name b+uncheckedCast (Name s) = Name s++instance Show (Name a) where+  showsPrec n = showsPrec n . nameText++instance ToJSON (Name a) where++  toEncoding = toEncoding . nameText++  toJSON = toJSON . nameText++instance FromJSON (Name a) where+  parseJSON = fmap Name . parseJSON++instance ToHttpApiData (Name a) where+  toUrlPiece = nameText++instance FromHttpApiData (Name a) where+  parseUrlPiece = fmap Name . parseUrlPiece++instance ToSchema (Name a) where+  declareNamedSchema = declareNamedSchema . invmap nameText++instance ToParamSchema (Name a) where+  toParamSchema = toParamSchema . invmap nameText++invmap :: (a -> b) -> proxy a -> Proxy b+invmap _ _ = Proxy
+ src/Hercules/API/Prelude.hs view
@@ -0,0 +1,44 @@+-- | Re-exports for the basic types that are used throughout the API+module Hercules.API.Prelude+  ( -- * Re-exports+    module Prelude,++    -- * Types+    Id,+    Name,+    Int64,+    Map,+    Set,+    Text,+    UTCTime,++    -- * Type classes+    Generic,+    ToJSON,+    FromJSON,+    ToSchema,+    schemaCompatibleOptions,+  )+where++import Data.Aeson+  ( FromJSON,+    ToJSON,+  )+import qualified Data.Aeson as Aeson+import Data.Int (Int64)+import Data.Map (Map)+import Data.Set (Set)+import Data.Swagger (ToSchema)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Hercules.API.Id (Id)+import Hercules.API.Name (Name)+import Prelude++schemaCompatibleOptions :: Aeson.Options+schemaCompatibleOptions =+  Aeson.defaultOptions+    { Aeson.sumEncoding = Aeson.ObjectWithSingleField+    }
+ src/Hercules/API/Servant.hs view
@@ -0,0 +1,26 @@+-- | Extras for working with servant+module Hercules.API.Servant where++import Control.Monad (void)+import Servant.API+import Servant.API.Generic+import Prelude++-- | Postcomposes 'Servant.API.Generic.fromServant' to an accessor,+-- preserving the mode parameter, because otherwise the mode parameter+-- can not be inferred.+--+-- Ideally, this functionality would be built into a new combinator.+useApi ::+  (GenericServant f mode, GenericServant g mode) =>+  (f mode -> ToServant g mode) ->+  f mode ->+  g mode+useApi = (Servant.API.Generic.fromServant .)++-- | 'Control.Monad.void' specialised to 'NoContent' to soothe the+-- compiler that rightfully warns about throwing away a do notation+-- result. By specialising, we make sure that we still get warnings+-- if the result type changes in the future. (We'll get an error)+noContent :: Functor m => m Servant.API.NoContent -> m ()+noContent = void
+ src/Hercules/Error.hs view
@@ -0,0 +1,63 @@+module Hercules.Error where++import qualified Control.Exception.Lifted+import qualified Control.Exception.Safe+import Control.Monad (when)+import Control.Monad.Catch+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Control (MonadBaseControl)+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++escalateAs :: (Exception exc, MonadThrow m) => (l -> exc) -> Either l a -> m a+escalateAs f = either (throwM . f) pure++safeLiftedCatch :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a+safeLiftedCatch m h =+  Control.Exception.Lifted.catch m $+    \e ->+      if Control.Exception.Safe.isSyncException (e :: SomeException)+        then h e+        else Control.Exception.Lifted.throw e++safeLiftedHandle ::+  MonadBaseControl IO m =>+  (SomeException -> m a) ->+  m a ->+  m a+safeLiftedHandle = flip safeLiftedCatch++exponential :: (Enum a, Floating a) => [a]+exponential = map exp [1, 2 ..]++cap :: Ord a => a -> [a] -> [a]+cap v = map (min v)++retry ::+  (KatipContext m, MonadBaseControl IO m) =>+  -- | Seconds+  [Double] ->+  m a ->+  m a+retry delaysSeconds io = loop delaysSeconds+  where+    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)+      loop delays++-- | ~5 minute exponential backoff+defaultRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a+defaultRetry = retry (take 10 $ cap 60 exponential)++-- | ~1 minute exponential backoff+quickRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a+quickRetry = retry (take 4 $ cap 60 exponential)