packages feed

approveapi (empty) → 0.1.0.0

raw patch · 18 files changed

+2685/−0 lines, 18 filesdep +QuickCheckdep +aesondep +approveapisetup-changed

Dependencies added: QuickCheck, aeson, approveapi, base, base64-bytestring, bytestring, case-insensitive, containers, deepseq, exceptions, hspec, http-api-data, http-client, http-client-tls, http-media, http-types, iso8601-time, katip, microlens, mtl, network, random, safe-exceptions, semigroups, text, time, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2019 KryptCo, Inc.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ README.md view
@@ -0,0 +1,49 @@+# approveapi-haskell++Haskell API bindings for the [ApproveAPI HTTP API](https://approveapi.com).++*ApproveAPI is a simple API to request a user's real-time approval on anything via email, sms + mobile push.*++## Getting Started++To get started, we create a config:++```haskell+import qualified ApproveApi as A+...+config <- (`A.addAuthMethod` A.AuthBasicApiKey "sk_test_yourapikeyhere" "")+          <$> A.newConfig +```++Now we can make API calls. For example, let's send an approval prompt to confirm a financial transaction.++```haskell+import qualified Network.HTTP.Client.TLS as NH+...+let body = "Your AcmeBank credit card was just charged $3249.99 at APPLE STORE,\+\ San Francisco. Authorize this transaction?"+let prompt = (A.mkCreatePromptRequest "alice@approveapi.com" body) {+                A.createPromptRequestLongPoll = Just True,+		            A.createPromptRequestApproveText = Just "Authorize",+		            A.createPromptRequestRejectText = Just "Reject"+              }+let createPromptRequest = A.createPrompt prompt++mgr <- NH.newTlsManager+createPromptResponse <- A.dispatchMime mgr config createPromptRequest++flip mapM_ createPromptResponse (\r ->+  case A.promptAnswer r of +    Nothing -> putStrLn $ "No response yet"+    Just answer -> case A.promptAnswerResult answer of+      True -> putStrLn $ "Request approved"+      False -> putStrLn $ "Request rejected"+  )+```++## Documentation++Full documentation is available here: [approveapi.com/docs](https://www.approveapi.com/docs/?haskell).+++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ approveapi.cabal view
@@ -0,0 +1,93 @@+name:           approveapi+version:        0.1.0.0+synopsis:       ApproveAPI Haskell Client+description:    .+                Haskell client for the ApproveAPI HTTP API+                ApproveAPI is a simple API to request a user's real-time approval on anything via email, sms + mobile push.+                category:       Web+homepage:       https://approveapi.com+author:         Kevin King+maintainer:     dev@approveapi.com+copyright:      2019 - ApproveAPI+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+category:       API, Client++extra-source-files:+    README.md+    openapi.yaml++library+  hs-source-dirs:+      lib+  ghc-options: -Wall -funbox-strict-fields+  build-depends:+      aeson >=1.0 && <2.0+    , base >=4.7 && <5.0+    , base64-bytestring >1.0 && <2.0+    , bytestring >=0.10.0 && <0.11+    , containers >=0.5.0.0 && <0.6+    , deepseq >= 1.4 && <1.6+    , http-api-data >= 0.3.4 && <0.4+    , http-client >=0.5 && <0.6+    , http-media >= 0.4 && < 0.8+    , http-types >=0.8 && <0.13+    , iso8601-time >=0.1.3 && <0.2.0+    , microlens >= 0.4.3 && <0.5+    , network >=2.6.2 && <2.8+    , random >=1.1+    , safe-exceptions <0.2+    , text >=0.11 && <1.3+    , time >=1.5 && <1.10+    , transformers         >= 0.4.0.0 && < 0.6+    , unordered-containers >= 0.2.9 && < 0.3+    , random               >= 1.1 && < 1.2+    , case-insensitive     >= 1.2.0 && < 1.3+    , exceptions           >= 0.10.0 && < 0.11+    , mtl                  >= 2.2.2 && < 2.3+    , http-client-tls      >= 0.3.5 && < 0.4+    , katip                >= 0.4 && < 0.9+    , vector >=0.10.9 && <0.13+  other-modules:+      Paths_approveapi+  exposed-modules:+      ApproveApi+      ApproveApi.API+      ApproveApi.API.Approve+      ApproveApi.Client+      ApproveApi.Core+      ApproveApi.Logging+      ApproveApi.MimeTypes+      ApproveApi.Model+      ApproveApi.ModelLens+  default-language: Haskell2010++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Test.hs+  hs-source-dirs:+      tests+  ghc-options: -Wall -fno-warn-orphans+  build-depends:+      approveapi+    , QuickCheck+    , aeson+    , base >=4.7 && <5.0+    , bytestring >=0.10.0 && <0.11+    , containers+    , hspec >=1.8+    , iso8601-time+    , mtl >=2.2.1+    , semigroups+    , text+    , time+    , transformers+    , unordered-containers+    , vector+  other-modules:+      ApproxEq+      Instances+      PropMime+  default-language: Haskell2010
+ lib/ApproveApi.hs view
@@ -0,0 +1,32 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi+-}++module ApproveApi+  (  module ApproveApi.API+  , module ApproveApi.Client+  , module ApproveApi.Core+  , module ApproveApi.Logging+  , module ApproveApi.MimeTypes+  , module ApproveApi.Model+  , module ApproveApi.ModelLens+  ) where++import ApproveApi.API+import ApproveApi.Client+import ApproveApi.Core+import ApproveApi.Logging+import ApproveApi.MimeTypes+import ApproveApi.Model+import ApproveApi.ModelLens
+ lib/ApproveApi/API.hs view
@@ -0,0 +1,20 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.API+-}++module ApproveApi.API+  ( module ApproveApi.API.Approve+  ) where++import ApproveApi.API.Approve
+ lib/ApproveApi/API/Approve.hs view
@@ -0,0 +1,136 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.API.Approve+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports #-}++module ApproveApi.API.Approve where++import ApproveApi.Core+import ApproveApi.MimeTypes+import ApproveApi.Model as M++import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Data as P (Typeable, TypeRep, typeOf, typeRep)+import qualified Data.Foldable as P+import qualified Data.Map as Map+import qualified Data.Maybe as P+import qualified Data.Proxy as P (Proxy(..))+import qualified Data.Set as Set+import qualified Data.String as P+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Time as TI+import qualified Network.HTTP.Client.MultipartFormData as NH+import qualified Network.HTTP.Media as ME+import qualified Network.HTTP.Types as NH+import qualified Web.FormUrlEncoded as WH+import qualified Web.HttpApiData as WH++import Data.Text (Text)+import GHC.Base ((<|>))++import Prelude ((==),(/=),($), (.),(<$>),(<*>),(>>=),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor)+import qualified Prelude as P++-- * Operations+++-- ** Approve++-- *** createPrompt++-- | @POST \/prompt@+-- +-- Sending a prompt+-- +-- Creates a prompt and pushes it to the user (sends via email, sms, or other supported protocols).+-- +-- AuthMethod: 'AuthBasicApiKey'+-- +createPrompt +  :: (Consumes CreatePrompt MimeJSON, MimeRender MimeJSON CreatePromptRequest)+  => CreatePromptRequest -- ^ "createPromptRequest"+  -> ApproveApiRequest CreatePrompt MimeJSON Prompt MimeJSON+createPrompt createPromptRequest =+  _mkRequest "POST" ["/prompt"]+    `_hasAuthType` (P.Proxy :: P.Proxy AuthBasicApiKey)+    `setBodyParam` createPromptRequest++data CreatePrompt +instance HasBodyParam CreatePrompt CreatePromptRequest ++-- | @application/json@+instance Consumes CreatePrompt MimeJSON++-- | @application/json@+instance Produces CreatePrompt MimeJSON+++-- *** getPrompt++-- | @GET \/prompt\/{id}@+-- +-- Retrieve a prompt+-- +-- Retrieve the prompt object with the given ID.+-- +-- AuthMethod: 'AuthBasicApiKey'+-- +getPrompt +  :: Id -- ^ "id" -  The identifier for a pending or completed prompt. This is returned when you create a prompt.+  -> ApproveApiRequest GetPrompt MimeNoContent Prompt MimeJSON+getPrompt (Id id) =+  _mkRequest "GET" ["/prompt/",toPath id]+    `_hasAuthType` (P.Proxy :: P.Proxy AuthBasicApiKey)++data GetPrompt  ++-- | /Optional Param/ "long_poll" - If true, the request waits (long-polls) until the user responds to the prompt or more than 10 minutes pass. Defaults to false.+instance HasOptionalParam GetPrompt LongPoll where+  applyOptionalParam req (LongPoll xs) =+    req `setQuery` toQuery ("long_poll", Just xs)++-- | @application/json@+instance Produces GetPrompt MimeJSON+++-- *** getPromptStatus++-- | @GET \/prompt\/{id}\/status@+-- +-- Check prompt status+-- +-- Returns whether a prompt has been completed by the user. This request does not require authentication, and so can be used client-side without sharing API credentials.+-- +getPromptStatus +  :: Id -- ^ "id" -  The prompt identifier.+  -> ApproveApiRequest GetPromptStatus MimeNoContent PromptStatus MimeJSON+getPromptStatus (Id id) =+  _mkRequest "GET" ["/prompt/",toPath id,"/status"]++data GetPromptStatus  ++-- | @application/json@+instance Produces GetPromptStatus MimeJSON+
+ lib/ApproveApi/Client.hs view
@@ -0,0 +1,218 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.Client+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}++module ApproveApi.Client where++import ApproveApi.Core+import ApproveApi.Logging+import ApproveApi.MimeTypes++import qualified Control.Exception.Safe as E+import qualified Control.Monad.IO.Class as P+import qualified Control.Monad as P+import qualified Data.Aeson.Types as A+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BCL+import qualified Data.Proxy as P (Proxy(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Client as NH+import qualified Network.HTTP.Client.MultipartFormData as NH+import qualified Network.HTTP.Types as NH+import qualified Web.FormUrlEncoded as WH+import qualified Web.HttpApiData as WH++import Data.Function ((&))+import Data.Monoid ((<>))+import Data.Text (Text)+import GHC.Exts (IsString(..))++-- * Dispatch++-- ** Lbs++-- | send a request returning the raw http response+dispatchLbs+  :: (Produces req accept, MimeType contentType)+  => NH.Manager -- ^ http-client Connection manager+  -> ApproveApiConfig -- ^ config+  -> ApproveApiRequest req contentType res accept -- ^ request+  -> IO (NH.Response BCL.ByteString) -- ^ response+dispatchLbs manager config request  = do+  initReq <- _toInitRequest config request+  dispatchInitUnsafe manager config initReq++-- ** Mime++-- | pair of decoded http body and http response+data MimeResult res =+  MimeResult { mimeResult :: Either MimeError res -- ^ decoded http body+             , mimeResultResponse :: NH.Response BCL.ByteString -- ^ http response +             }+  deriving (Show, Functor, Foldable, Traversable)++-- | pair of unrender/parser error and http response+data MimeError =+  MimeError {+    mimeError :: String -- ^ unrender/parser error+  , mimeErrorResponse :: NH.Response BCL.ByteString -- ^ http response +  } deriving (Eq, Show)++-- | send a request returning the 'MimeResult'+dispatchMime+  :: forall req contentType res accept. (Produces req accept, MimeUnrender accept res, MimeType contentType)+  => NH.Manager -- ^ http-client Connection manager+  -> ApproveApiConfig -- ^ config+  -> ApproveApiRequest req contentType res accept -- ^ request+  -> IO (MimeResult res) -- ^ response+dispatchMime manager config request = do+  httpResponse <- dispatchLbs manager config request+  let statusCode = NH.statusCode . NH.responseStatus $ httpResponse+  parsedResult <-+    runConfigLogWithExceptions "Client" config $+    do if (statusCode >= 400 && statusCode < 600)+         then do+           let s = "error statusCode: " ++ show statusCode+           _log "Client" levelError (T.pack s)+           pure (Left (MimeError s httpResponse))+         else case mimeUnrender (P.Proxy :: P.Proxy accept) (NH.responseBody httpResponse) of+           Left s -> do+             _log "Client" levelError (T.pack s)+             pure (Left (MimeError s httpResponse))+           Right r -> pure (Right r)+  return (MimeResult parsedResult httpResponse)++-- | like 'dispatchMime', but only returns the decoded http body+dispatchMime'+  :: (Produces req accept, MimeUnrender accept res, MimeType contentType)+  => NH.Manager -- ^ http-client Connection manager+  -> ApproveApiConfig -- ^ config+  -> ApproveApiRequest req contentType res accept -- ^ request+  -> IO (Either MimeError res) -- ^ response+dispatchMime' manager config request  = do+    MimeResult parsedResult _ <- dispatchMime manager config request+    return parsedResult++-- ** Unsafe++-- | like 'dispatchReqLbs', but does not validate the operation is a 'Producer' of the "accept" 'MimeType'.  (Useful if the server's response is undocumented)+dispatchLbsUnsafe+  :: (MimeType accept, MimeType contentType)+  => NH.Manager -- ^ http-client Connection manager+  -> ApproveApiConfig -- ^ config+  -> ApproveApiRequest req contentType res accept -- ^ request+  -> IO (NH.Response BCL.ByteString) -- ^ response+dispatchLbsUnsafe manager config request  = do+  initReq <- _toInitRequest config request+  dispatchInitUnsafe manager config initReq++-- | dispatch an InitRequest+dispatchInitUnsafe+  :: NH.Manager -- ^ http-client Connection manager+  -> ApproveApiConfig -- ^ config+  -> InitRequest req contentType res accept -- ^ init request+  -> IO (NH.Response BCL.ByteString) -- ^ response+dispatchInitUnsafe manager config (InitRequest req) = do+  runConfigLogWithExceptions src config $+    do _log src levelInfo requestLogMsg+       _log src levelDebug requestDbgLogMsg+       res <- P.liftIO $ NH.httpLbs req manager+       _log src levelInfo (responseLogMsg res)+       _log src levelDebug ((T.pack . show) res)+       return res+  where+    src = "Client"+    endpoint =+      T.pack $+      BC.unpack $+      NH.method req <> " " <> NH.host req <> NH.path req <> NH.queryString req+    requestLogMsg = "REQ:" <> endpoint+    requestDbgLogMsg =+      "Headers=" <> (T.pack . show) (NH.requestHeaders req) <> " Body=" <>+      (case NH.requestBody req of+         NH.RequestBodyLBS xs -> T.decodeUtf8 (BL.toStrict xs)+         _ -> "<RequestBody>")+    responseStatusCode = (T.pack . show) . NH.statusCode . NH.responseStatus+    responseLogMsg res =+      "RES:statusCode=" <> responseStatusCode res <> " (" <> endpoint <> ")"++-- * InitRequest++-- | wraps an http-client 'Request' with request/response type parameters+newtype InitRequest req contentType res accept = InitRequest+  { unInitRequest :: NH.Request+  } deriving (Show)++-- |  Build an http-client 'Request' record from the supplied config and request+_toInitRequest+  :: (MimeType accept, MimeType contentType)+  => ApproveApiConfig -- ^ config+  -> ApproveApiRequest req contentType res accept -- ^ request+  -> IO (InitRequest req contentType res accept) -- ^ initialized request+_toInitRequest config req0  = +  runConfigLogWithExceptions "Client" config $ do+    parsedReq <- P.liftIO $ NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (rUrlPath req0))+    req1 <- P.liftIO $ _applyAuthMethods req0 config+    P.when+        (configValidateAuthMethods config && (not . null . rAuthTypes) req1)+        (E.throw $ AuthMethodException $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1)+    let req2 = req1 & _setContentTypeHeader & _setAcceptHeader+        reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders (rParams req2)+        reqQuery = NH.renderQuery True (paramsQuery (rParams req2))+        pReq = parsedReq { NH.method = (rMethod req2)+                        , NH.requestHeaders = reqHeaders+                        , NH.queryString = reqQuery+                        }+    outReq <- case paramsBody (rParams req2) of+        ParamBodyNone -> pure (pReq { NH.requestBody = mempty })+        ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs })+        ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl })+        ParamBodyFormUrlEncoded form -> pure (pReq { NH.requestBody = NH.RequestBodyLBS (WH.urlEncodeForm form) })+        ParamBodyMultipartFormData parts -> NH.formDataBody parts pReq++    pure (InitRequest outReq)++-- | modify the underlying Request+modifyInitRequest :: InitRequest req contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept+modifyInitRequest (InitRequest req) f = InitRequest (f req)++-- | modify the underlying Request (monadic)+modifyInitRequestM :: Monad m => InitRequest req contentType res accept -> (NH.Request -> m NH.Request) -> m (InitRequest req contentType res accept)+modifyInitRequestM (InitRequest req) f = fmap InitRequest (f req)++-- ** Logging ++-- | Run a block using the configured logger instance+runConfigLog+  :: P.MonadIO m+  => ApproveApiConfig -> LogExec m+runConfigLog config = configLogExecWithContext config (configLogContext config)++-- | Run a block using the configured logger instance (logs exceptions)+runConfigLogWithExceptions+  :: (E.MonadCatch m, P.MonadIO m)+  => T.Text -> ApproveApiConfig -> LogExec m+runConfigLogWithExceptions src config = runConfigLog config . logExceptions src
+ lib/ApproveApi/Core.hs view
@@ -0,0 +1,545 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.Core+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}++module ApproveApi.Core where++import ApproveApi.MimeTypes+import ApproveApi.Logging++import qualified Control.Arrow as P (left)+import qualified Control.DeepSeq as NF+import qualified Control.Exception.Safe as E+import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64.Lazy as BL64+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BCL+import qualified Data.CaseInsensitive as CI+import qualified Data.Data as P (Data, Typeable, TypeRep, typeRep)+import qualified Data.Foldable as P+import qualified Data.Ix as P+import qualified Data.Maybe as P+import qualified Data.Proxy as P (Proxy(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Time as TI+import qualified Data.Time.ISO8601 as TI+import qualified GHC.Base as P (Alternative)+import qualified Lens.Micro as L+import qualified Network.HTTP.Client.MultipartFormData as NH+import qualified Network.HTTP.Types as NH+import qualified Prelude as P+import qualified Web.FormUrlEncoded as WH+import qualified Web.HttpApiData as WH+import qualified Text.Printf as T++import Control.Applicative ((<|>))+import Control.Applicative (Alternative)+import Data.Function ((&))+import Data.Foldable(foldlM)+import Data.Monoid ((<>))+import Data.Text (Text)+import Prelude (($), (.), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor)++-- * ApproveApiConfig++-- | +data ApproveApiConfig = ApproveApiConfig+  { configHost  :: BCL.ByteString -- ^ host supplied in the Request+  , configUserAgent :: Text -- ^ user-agent supplied in the Request+  , configLogExecWithContext :: LogExecWithContext -- ^ Run a block using a Logger instance+  , configLogContext :: LogContext -- ^ Configures the logger+  , configAuthMethods :: [AnyAuthMethod] -- ^ List of configured auth methods+  , configValidateAuthMethods :: Bool -- ^ throw exceptions if auth methods are not configured+  }++-- | display the config+instance P.Show ApproveApiConfig where+  show c =+    T.printf+      "{ configHost = %v, configUserAgent = %v, ..}"+      (show (configHost c))+      (show (configUserAgent c))++-- | constructs a default ApproveApiConfig+--+-- configHost:+--+-- @https://approve.sh@+--+-- configUserAgent:+--+-- @"approveapi/0.1.0.0"@+--+newConfig :: IO ApproveApiConfig+newConfig = do+    logCxt <- initLogContext+    return $ ApproveApiConfig+        { configHost = "https://approve.sh"+        , configUserAgent = "approveapi/0.1.0.0"+        , configLogExecWithContext = runDefaultLogExecWithContext+        , configLogContext = logCxt+        , configAuthMethods = []+        , configValidateAuthMethods = True+        }  ++-- | updates config use AuthMethod on matching requests+addAuthMethod :: AuthMethod auth => ApproveApiConfig -> auth -> ApproveApiConfig+addAuthMethod config@ApproveApiConfig {configAuthMethods = as} a =+  config { configAuthMethods = AnyAuthMethod a : as}++-- | updates the config to use stdout logging+withStdoutLogging :: ApproveApiConfig -> IO ApproveApiConfig+withStdoutLogging p = do+    logCxt <- stdoutLoggingContext (configLogContext p)+    return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt }++-- | updates the config to use stderr logging+withStderrLogging :: ApproveApiConfig -> IO ApproveApiConfig+withStderrLogging p = do+    logCxt <- stderrLoggingContext (configLogContext p)+    return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt }++-- | updates the config to disable logging+withNoLogging :: ApproveApiConfig -> ApproveApiConfig+withNoLogging p = p { configLogExecWithContext =  runNullLogExec}+ +-- * ApproveApiRequest++-- | Represents a request.+--+--   Type Variables:+--+--   * req - request operation+--   * contentType - 'MimeType' associated with request body+--   * res - response model+--   * accept - 'MimeType' associated with response body+data ApproveApiRequest req contentType res accept = ApproveApiRequest+  { rMethod  :: NH.Method   -- ^ Method of ApproveApiRequest+  , rUrlPath :: [BCL.ByteString] -- ^ Endpoint of ApproveApiRequest+  , rParams   :: Params -- ^ params of ApproveApiRequest+  , rAuthTypes :: [P.TypeRep] -- ^ types of auth methods+  }+  deriving (P.Show)++-- | 'rMethod' Lens+rMethodL :: Lens_' (ApproveApiRequest req contentType res accept) NH.Method+rMethodL f ApproveApiRequest{..} = (\rMethod -> ApproveApiRequest { rMethod, ..} ) <$> f rMethod+{-# INLINE rMethodL #-}++-- | 'rUrlPath' Lens+rUrlPathL :: Lens_' (ApproveApiRequest req contentType res accept) [BCL.ByteString]+rUrlPathL f ApproveApiRequest{..} = (\rUrlPath -> ApproveApiRequest { rUrlPath, ..} ) <$> f rUrlPath+{-# INLINE rUrlPathL #-}++-- | 'rParams' Lens+rParamsL :: Lens_' (ApproveApiRequest req contentType res accept) Params+rParamsL f ApproveApiRequest{..} = (\rParams -> ApproveApiRequest { rParams, ..} ) <$> f rParams+{-# INLINE rParamsL #-}++-- | 'rParams' Lens+rAuthTypesL :: Lens_' (ApproveApiRequest req contentType res accept) [P.TypeRep]+rAuthTypesL f ApproveApiRequest{..} = (\rAuthTypes -> ApproveApiRequest { rAuthTypes, ..} ) <$> f rAuthTypes+{-# INLINE rAuthTypesL #-}++-- * HasBodyParam++-- | Designates the body parameter of a request+class HasBodyParam req param where+  setBodyParam :: forall contentType res accept. (Consumes req contentType, MimeRender contentType param) => ApproveApiRequest req contentType res accept -> param -> ApproveApiRequest req contentType res accept+  setBodyParam req xs =+    req `_setBodyLBS` mimeRender (P.Proxy :: P.Proxy contentType) xs & _setContentTypeHeader++-- * HasOptionalParam++-- | Designates the optional parameters of a request+class HasOptionalParam req param where+  {-# MINIMAL applyOptionalParam | (-&-) #-}++  -- | Apply an optional parameter to a request+  applyOptionalParam :: ApproveApiRequest req contentType res accept -> param -> ApproveApiRequest req contentType res accept+  applyOptionalParam = (-&-)+  {-# INLINE applyOptionalParam #-}++  -- | infix operator \/ alias for 'addOptionalParam'+  (-&-) :: ApproveApiRequest req contentType res accept -> param -> ApproveApiRequest req contentType res accept+  (-&-) = applyOptionalParam+  {-# INLINE (-&-) #-}++infixl 2 -&-++-- | Request Params+data Params = Params+  { paramsQuery :: NH.Query+  , paramsHeaders :: NH.RequestHeaders+  , paramsBody :: ParamBody+  }+  deriving (P.Show)++-- | 'paramsQuery' Lens+paramsQueryL :: Lens_' Params NH.Query+paramsQueryL f Params{..} = (\paramsQuery -> Params { paramsQuery, ..} ) <$> f paramsQuery+{-# INLINE paramsQueryL #-}++-- | 'paramsHeaders' Lens+paramsHeadersL :: Lens_' Params NH.RequestHeaders+paramsHeadersL f Params{..} = (\paramsHeaders -> Params { paramsHeaders, ..} ) <$> f paramsHeaders+{-# INLINE paramsHeadersL #-}++-- | 'paramsBody' Lens+paramsBodyL :: Lens_' Params ParamBody+paramsBodyL f Params{..} = (\paramsBody -> Params { paramsBody, ..} ) <$> f paramsBody+{-# INLINE paramsBodyL #-}++-- | Request Body+data ParamBody+  = ParamBodyNone+  | ParamBodyB B.ByteString+  | ParamBodyBL BL.ByteString+  | ParamBodyFormUrlEncoded WH.Form+  | ParamBodyMultipartFormData [NH.Part]+  deriving (P.Show)++-- ** ApproveApiRequest Utils++_mkRequest :: NH.Method -- ^ Method +          -> [BCL.ByteString] -- ^ Endpoint+          -> ApproveApiRequest req contentType res accept -- ^ req: Request Type, res: Response Type+_mkRequest m u = ApproveApiRequest m u _mkParams []++_mkParams :: Params+_mkParams = Params [] [] ParamBodyNone++setHeader :: ApproveApiRequest req contentType res accept -> [NH.Header] -> ApproveApiRequest req contentType res accept+setHeader req header =+  req `removeHeader` P.fmap P.fst header &+  L.over (rParamsL . paramsHeadersL) (header P.++)++removeHeader :: ApproveApiRequest req contentType res accept -> [NH.HeaderName] -> ApproveApiRequest req contentType res accept+removeHeader req header =+  req &+  L.over+    (rParamsL . paramsHeadersL)+    (P.filter (\h -> cifst h `P.notElem` P.fmap CI.mk header))+  where+    cifst = CI.mk . P.fst+++_setContentTypeHeader :: forall req contentType res accept. MimeType contentType => ApproveApiRequest req contentType res accept -> ApproveApiRequest req contentType res accept+_setContentTypeHeader req =+    case mimeType (P.Proxy :: P.Proxy contentType) of +        Just m -> req `setHeader` [("content-type", BC.pack $ P.show m)]+        Nothing -> req `removeHeader` ["content-type"]++_setAcceptHeader :: forall req contentType res accept. MimeType accept => ApproveApiRequest req contentType res accept -> ApproveApiRequest req contentType res accept+_setAcceptHeader req =+    case mimeType (P.Proxy :: P.Proxy accept) of +        Just m -> req `setHeader` [("accept", BC.pack $ P.show m)]+        Nothing -> req `removeHeader` ["accept"]++setQuery :: ApproveApiRequest req contentType res accept -> [NH.QueryItem] -> ApproveApiRequest req contentType res accept+setQuery req query = +  req &+  L.over+    (rParamsL . paramsQueryL)+    ((query P.++) . P.filter (\q -> cifst q `P.notElem` P.fmap cifst query))+  where+    cifst = CI.mk . P.fst++addForm :: ApproveApiRequest req contentType res accept -> WH.Form -> ApproveApiRequest req contentType res accept+addForm req newform = +    let form = case paramsBody (rParams req) of+            ParamBodyFormUrlEncoded _form -> _form+            _ -> mempty+    in req & L.set (rParamsL . paramsBodyL) (ParamBodyFormUrlEncoded (newform <> form))++_addMultiFormPart :: ApproveApiRequest req contentType res accept -> NH.Part -> ApproveApiRequest req contentType res accept+_addMultiFormPart req newpart = +    let parts = case paramsBody (rParams req) of+            ParamBodyMultipartFormData _parts -> _parts+            _ -> []+    in req & L.set (rParamsL . paramsBodyL) (ParamBodyMultipartFormData (newpart : parts))++_setBodyBS :: ApproveApiRequest req contentType res accept -> B.ByteString -> ApproveApiRequest req contentType res accept+_setBodyBS req body = +    req & L.set (rParamsL . paramsBodyL) (ParamBodyB body)++_setBodyLBS :: ApproveApiRequest req contentType res accept -> BL.ByteString -> ApproveApiRequest req contentType res accept+_setBodyLBS req body = +    req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body)++_hasAuthType :: AuthMethod authMethod => ApproveApiRequest req contentType res accept -> P.Proxy authMethod -> ApproveApiRequest req contentType res accept+_hasAuthType req proxy =+  req & L.over rAuthTypesL (P.typeRep proxy :)++-- ** Params Utils++toPath+  :: WH.ToHttpApiData a+  => a -> BCL.ByteString+toPath = BB.toLazyByteString . WH.toEncodedUrlPiece++toHeader :: WH.ToHttpApiData a => (NH.HeaderName, a) -> [NH.Header]+toHeader x = [fmap WH.toHeader x]++toForm :: WH.ToHttpApiData v => (BC.ByteString, v) -> WH.Form+toForm (k,v) = WH.toForm [(BC.unpack k,v)]++toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem]+toQuery x = [(fmap . fmap) toQueryParam x]+  where toQueryParam = T.encodeUtf8 . WH.toQueryParam++-- *** OpenAPI `CollectionFormat` Utils++-- | Determines the format of the array if type array is used.+data CollectionFormat+  = CommaSeparated -- ^ CSV format for multiple parameters.+  | SpaceSeparated -- ^ Also called "SSV"+  | TabSeparated -- ^ Also called "TSV"+  | PipeSeparated -- ^ `value1|value2|value2`+  | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. This is valid only for parameters in "query" ('NH.Query') or "formData" ('WH.Form')++toHeaderColl :: WH.ToHttpApiData a => CollectionFormat -> (NH.HeaderName, [a]) -> [NH.Header]+toHeaderColl c xs = _toColl c toHeader xs++toFormColl :: WH.ToHttpApiData v => CollectionFormat -> (BC.ByteString, [v]) -> WH.Form+toFormColl c xs = WH.toForm $ fmap unpack $ _toColl c toHeader $ pack xs+  where+    pack (k,v) = (CI.mk k, v)+    unpack (k,v) = (BC.unpack (CI.original k), BC.unpack v)++toQueryColl :: WH.ToHttpApiData a => CollectionFormat -> (BC.ByteString, Maybe [a]) -> NH.Query+toQueryColl c xs = _toCollA c toQuery xs++_toColl :: P.Traversable f => CollectionFormat -> (f a -> [(b, BC.ByteString)]) -> f [a] -> [(b, BC.ByteString)]+_toColl c encode xs = fmap (fmap P.fromJust) (_toCollA' c fencode BC.singleton (fmap Just xs))+  where fencode = fmap (fmap Just) . encode . fmap P.fromJust+        {-# INLINE fencode #-}++_toCollA :: (P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t BC.ByteString)]) -> f (t [a]) -> [(b, t BC.ByteString)]+_toCollA c encode xs = _toCollA' c encode BC.singleton xs++_toCollA' :: (P.Monoid c, P.Traversable f, P.Traversable t, P.Alternative t) => CollectionFormat -> (f (t a) -> [(b, t c)]) -> (Char -> c) -> f (t [a]) -> [(b, t c)]+_toCollA' c encode one xs = case c of+  CommaSeparated -> go (one ',')+  SpaceSeparated -> go (one ' ')+  TabSeparated -> go (one '\t')+  PipeSeparated -> go (one '|')+  MultiParamArray -> expandList+  where+    go sep =+      [P.foldl1 (\(sk, sv) (_, v) -> (sk, (combine sep <$> sv <*> v) <|> sv <|> v)) expandList]+    combine sep x y = x <> sep <> y+    expandList = (P.concatMap encode . (P.traverse . P.traverse) P.toList) xs+    {-# INLINE go #-}+    {-# INLINE expandList #-}+    {-# INLINE combine #-}+  +-- * AuthMethods++-- | Provides a method to apply auth methods to requests+class P.Typeable a =>+      AuthMethod a  where+  applyAuthMethod+    :: ApproveApiConfig+    -> a+    -> ApproveApiRequest req contentType res accept+    -> IO (ApproveApiRequest req contentType res accept)++-- | An existential wrapper for any AuthMethod+data AnyAuthMethod = forall a. AuthMethod a => AnyAuthMethod a deriving (P.Typeable)++instance AuthMethod AnyAuthMethod where applyAuthMethod config (AnyAuthMethod a) req = applyAuthMethod config a req++-- | indicates exceptions related to AuthMethods+data AuthMethodException = AuthMethodException String deriving (P.Show, P.Typeable)++instance E.Exception AuthMethodException++-- | apply all matching AuthMethods in config to request+_applyAuthMethods+  :: ApproveApiRequest req contentType res accept+  -> ApproveApiConfig+  -> IO (ApproveApiRequest req contentType res accept)+_applyAuthMethods req config@(ApproveApiConfig {configAuthMethods = as}) =+  foldlM go req as+  where+    go r (AnyAuthMethod a) = applyAuthMethod config a r+  +-- * Utils++-- | Removes Null fields.  (OpenAPI-Specification 2.0 does not allow Null in JSON)+_omitNulls :: [(Text, A.Value)] -> A.Value+_omitNulls = A.object . P.filter notNull+  where+    notNull (_, A.Null) = False+    notNull _ = True++-- | Encodes fields using WH.toQueryParam+_toFormItem :: (WH.ToHttpApiData a, Functor f) => t -> f a -> f (t, [Text])+_toFormItem name x = (name,) . (:[]) . WH.toQueryParam <$> x++-- | Collapse (Just "") to Nothing+_emptyToNothing :: Maybe String -> Maybe String+_emptyToNothing (Just "") = Nothing+_emptyToNothing x = x+{-# INLINE _emptyToNothing #-}++-- | Collapse (Just mempty) to Nothing+_memptyToNothing :: (P.Monoid a, P.Eq a) => Maybe a -> Maybe a+_memptyToNothing (Just x) | x P.== P.mempty = Nothing+_memptyToNothing x = x+{-# INLINE _memptyToNothing #-}++-- * DateTime Formatting++newtype DateTime = DateTime { unDateTime :: TI.UTCTime }+  deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData,TI.ParseTime,TI.FormatTime)+instance A.FromJSON DateTime where+  parseJSON = A.withText "DateTime" (_readDateTime . T.unpack)+instance A.ToJSON DateTime where+  toJSON (DateTime t) = A.toJSON (_showDateTime t)+instance WH.FromHttpApiData DateTime where+  parseUrlPiece = P.left T.pack . _readDateTime . T.unpack+instance WH.ToHttpApiData DateTime where+  toUrlPiece (DateTime t) = T.pack (_showDateTime t)+instance P.Show DateTime where+  show (DateTime t) = _showDateTime t+instance MimeRender MimeMultipartFormData DateTime where+  mimeRender _ = mimeRenderDefaultMultipartFormData++-- | @_parseISO8601@+_readDateTime :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t+_readDateTime =+  _parseISO8601+{-# INLINE _readDateTime #-}++-- | @TI.formatISO8601Millis@+_showDateTime :: (t ~ TI.UTCTime, TI.FormatTime t) => t -> String+_showDateTime =+  TI.formatISO8601Millis+{-# INLINE _showDateTime #-}++-- | parse an ISO8601 date-time string+_parseISO8601 :: (TI.ParseTime t, Monad m, Alternative m) => String -> m t+_parseISO8601 t =+  P.asum $+  P.flip (TI.parseTimeM True TI.defaultTimeLocale) t <$>+  ["%FT%T%QZ", "%FT%T%Q%z", "%FT%T%Q%Z"]+{-# INLINE _parseISO8601 #-}++-- * Date Formatting++newtype Date = Date { unDate :: TI.Day }+  deriving (P.Enum,P.Eq,P.Data,P.Ord,P.Ix,NF.NFData,TI.ParseTime,TI.FormatTime)+instance A.FromJSON Date where+  parseJSON = A.withText "Date" (_readDate . T.unpack)+instance A.ToJSON Date where+  toJSON (Date t) = A.toJSON (_showDate t)+instance WH.FromHttpApiData Date where+  parseUrlPiece = P.left T.pack . _readDate . T.unpack+instance WH.ToHttpApiData Date where+  toUrlPiece (Date t) = T.pack (_showDate t)+instance P.Show Date where+  show (Date t) = _showDate t+instance MimeRender MimeMultipartFormData Date where+  mimeRender _ = mimeRenderDefaultMultipartFormData++-- | @TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d"@+_readDate :: (TI.ParseTime t, Monad m) => String -> m t+_readDate =+  TI.parseTimeM True TI.defaultTimeLocale "%Y-%m-%d"+{-# INLINE _readDate #-}++-- | @TI.formatTime TI.defaultTimeLocale "%Y-%m-%d"@+_showDate :: TI.FormatTime t => t -> String+_showDate =+  TI.formatTime TI.defaultTimeLocale "%Y-%m-%d"+{-# INLINE _showDate #-}++-- * Byte/Binary Formatting++  +-- | base64 encoded characters+newtype ByteArray = ByteArray { unByteArray :: BL.ByteString }+  deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData)++instance A.FromJSON ByteArray where+  parseJSON = A.withText "ByteArray" _readByteArray+instance A.ToJSON ByteArray where+  toJSON = A.toJSON . _showByteArray+instance WH.FromHttpApiData ByteArray where+  parseUrlPiece = P.left T.pack . _readByteArray+instance WH.ToHttpApiData ByteArray where+  toUrlPiece = _showByteArray+instance P.Show ByteArray where+  show = T.unpack . _showByteArray+instance MimeRender MimeMultipartFormData ByteArray where+  mimeRender _ = mimeRenderDefaultMultipartFormData++-- | read base64 encoded characters+_readByteArray :: Monad m => Text -> m ByteArray+_readByteArray = P.either P.fail (pure . ByteArray) . BL64.decode . BL.fromStrict . T.encodeUtf8+{-# INLINE _readByteArray #-}++-- | show base64 encoded characters+_showByteArray :: ByteArray -> Text+_showByteArray = T.decodeUtf8 . BL.toStrict . BL64.encode . unByteArray+{-# INLINE _showByteArray #-}++-- | any sequence of octets+newtype Binary = Binary { unBinary :: BL.ByteString }+  deriving (P.Eq,P.Data,P.Ord,P.Typeable,NF.NFData)++instance A.FromJSON Binary where+  parseJSON = A.withText "Binary" _readBinaryBase64+instance A.ToJSON Binary where+  toJSON = A.toJSON . _showBinaryBase64+instance WH.FromHttpApiData Binary where+  parseUrlPiece = P.left T.pack . _readBinaryBase64+instance WH.ToHttpApiData Binary where+  toUrlPiece = _showBinaryBase64+instance P.Show Binary where+  show = T.unpack . _showBinaryBase64+instance MimeRender MimeMultipartFormData Binary where+  mimeRender _ = unBinary++_readBinaryBase64 :: Monad m => Text -> m Binary+_readBinaryBase64 = P.either P.fail (pure . Binary) . BL64.decode . BL.fromStrict . T.encodeUtf8+{-# INLINE _readBinaryBase64 #-}++_showBinaryBase64 :: Binary -> Text+_showBinaryBase64 = T.decodeUtf8 . BL.toStrict . BL64.encode . unBinary+{-# INLINE _showBinaryBase64 #-}++-- * Lens Type Aliases++type Lens_' s a = Lens_ s s a a+type Lens_ s t a b = forall (f :: * -> *). Functor f => (a -> f b) -> s -> f t
+ lib/ApproveApi/Logging.hs view
@@ -0,0 +1,119 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.Logging+Katip Logging functions+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ApproveApi.Logging where++import qualified Control.Exception.Safe as E+import qualified Control.Monad.IO.Class as P+import qualified Control.Monad.Trans.Reader as P+import qualified Data.Text as T+import qualified Lens.Micro as L+import qualified System.IO as IO++import Data.Text (Text)+import GHC.Exts (IsString(..))++import qualified Katip as LG++-- * Type Aliases (for compatibility)++-- | Runs a Katip logging block with the Log environment+type LogExecWithContext = forall m. P.MonadIO m =>+                                    LogContext -> LogExec m++-- | A Katip logging block+type LogExec m = forall a. LG.KatipT m a -> m a++-- | A Katip Log environment+type LogContext = LG.LogEnv++-- | A Katip Log severity+type LogLevel = LG.Severity++-- * default logger++-- | the default log environment+initLogContext :: IO LogContext+initLogContext = LG.initLogEnv "ApproveApi" "dev"++-- | Runs a Katip logging block with the Log environment+runDefaultLogExecWithContext :: LogExecWithContext+runDefaultLogExecWithContext = LG.runKatipT++-- * stdout logger++-- | Runs a Katip logging block with the Log environment+stdoutLoggingExec :: LogExecWithContext+stdoutLoggingExec = runDefaultLogExecWithContext++-- | A Katip Log environment which targets stdout+stdoutLoggingContext :: LogContext -> IO LogContext+stdoutLoggingContext cxt = do+    handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stdout LG.InfoS LG.V2+    LG.registerScribe "stdout" handleScribe LG.defaultScribeSettings cxt++-- * stderr logger++-- | Runs a Katip logging block with the Log environment+stderrLoggingExec :: LogExecWithContext+stderrLoggingExec = runDefaultLogExecWithContext++-- | A Katip Log environment which targets stderr+stderrLoggingContext :: LogContext -> IO LogContext+stderrLoggingContext cxt = do+    handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stderr LG.InfoS LG.V2+    LG.registerScribe "stderr" handleScribe LG.defaultScribeSettings cxt++-- * Null logger++-- | Disables Katip logging+runNullLogExec :: LogExecWithContext+runNullLogExec le (LG.KatipT f) = P.runReaderT f (L.set LG.logEnvScribes mempty le)++-- * Log Msg++-- | Log a katip message+_log :: (Applicative m, LG.Katip m) => Text -> LogLevel -> Text -> m ()+_log src level msg = do+  LG.logMsg (fromString $ T.unpack src) level (LG.logStr msg)++-- * Log Exceptions++-- | re-throws exceptions after logging them+logExceptions+  :: (LG.Katip m, E.MonadCatch m, Applicative m)+  => Text -> m a -> m a+logExceptions src =+  E.handle+    (\(e :: E.SomeException) -> do+       _log src LG.ErrorS ((T.pack . show) e)+       E.throw e)++-- * Log Level++levelInfo :: LogLevel+levelInfo = LG.InfoS++levelError :: LogLevel+levelError = LG.ErrorS++levelDebug :: LogLevel+levelDebug = LG.DebugS+
+ lib/ApproveApi/MimeTypes.hs view
@@ -0,0 +1,204 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.MimeTypes+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}++module ApproveApi.MimeTypes where++import qualified Control.Arrow as P (left)+import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BCL+import qualified Data.Data as P (Typeable)+import qualified Data.Proxy as P (Proxy(..))+import qualified Data.String as P+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Media as ME+import qualified Web.FormUrlEncoded as WH+import qualified Web.HttpApiData as WH++import Prelude (($), (.),(<$>),(<*>),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty)+import qualified Prelude as P++-- * ContentType MimeType++data ContentType a = MimeType a => ContentType { unContentType :: a }++-- * Accept MimeType++data Accept a = MimeType a => Accept { unAccept :: a }++-- * Consumes Class++class MimeType mtype => Consumes req mtype where++-- * Produces Class++class MimeType mtype => Produces req mtype where++-- * Default Mime Types++data MimeJSON = MimeJSON deriving (P.Typeable)+data MimeXML = MimeXML deriving (P.Typeable)+data MimePlainText = MimePlainText deriving (P.Typeable)+data MimeFormUrlEncoded = MimeFormUrlEncoded deriving (P.Typeable)+data MimeMultipartFormData = MimeMultipartFormData deriving (P.Typeable)+data MimeOctetStream = MimeOctetStream deriving (P.Typeable)+data MimeNoContent = MimeNoContent deriving (P.Typeable)+data MimeAny = MimeAny deriving (P.Typeable)++-- | A type for responses without content-body.+data NoContent = NoContent+  deriving (P.Show, P.Eq, P.Typeable)+++-- * MimeType Class++class P.Typeable mtype => MimeType mtype  where+  {-# MINIMAL mimeType | mimeTypes #-}++  mimeTypes :: P.Proxy mtype -> [ME.MediaType]+  mimeTypes p =+    case mimeType p of+      Just x -> [x]+      Nothing -> []++  mimeType :: P.Proxy mtype -> Maybe ME.MediaType+  mimeType p =+    case mimeTypes p of+      [] -> Nothing+      (x:_) -> Just x++  mimeType' :: mtype -> Maybe ME.MediaType+  mimeType' _ = mimeType (P.Proxy :: P.Proxy mtype)+  mimeTypes' :: mtype -> [ME.MediaType]+  mimeTypes' _ = mimeTypes (P.Proxy :: P.Proxy mtype)++-- Default MimeType Instances++-- | @application/json; charset=utf-8@+instance MimeType MimeJSON where+  mimeType _ = Just $ P.fromString "application/json"+-- | @application/xml; charset=utf-8@+instance MimeType MimeXML where+  mimeType _ = Just $ P.fromString "application/xml"+-- | @application/x-www-form-urlencoded@+instance MimeType MimeFormUrlEncoded where+  mimeType _ = Just $ P.fromString "application/x-www-form-urlencoded"+-- | @multipart/form-data@+instance MimeType MimeMultipartFormData where+  mimeType _ = Just $ P.fromString "multipart/form-data"+-- | @text/plain; charset=utf-8@+instance MimeType MimePlainText where+  mimeType _ = Just $ P.fromString "text/plain"+-- | @application/octet-stream@+instance MimeType MimeOctetStream where+  mimeType _ = Just $ P.fromString "application/octet-stream"+-- | @"*/*"@+instance MimeType MimeAny where+  mimeType _ = Just $ P.fromString "*/*"+instance MimeType MimeNoContent where+  mimeType _ = Nothing++-- * MimeRender Class++class MimeType mtype => MimeRender mtype x where+    mimeRender  :: P.Proxy mtype -> x -> BL.ByteString+    mimeRender' :: mtype -> x -> BL.ByteString+    mimeRender' _ x = mimeRender (P.Proxy :: P.Proxy mtype) x+++mimeRenderDefaultMultipartFormData :: WH.ToHttpApiData a => a -> BL.ByteString+mimeRenderDefaultMultipartFormData = BL.fromStrict . T.encodeUtf8 . WH.toQueryParam++-- Default MimeRender Instances++-- | `A.encode`+instance A.ToJSON a => MimeRender MimeJSON a where mimeRender _ = A.encode+-- | @WH.urlEncodeAsForm@+instance WH.ToForm a => MimeRender MimeFormUrlEncoded a where mimeRender _ = WH.urlEncodeAsForm++-- | @P.id@+instance MimeRender MimePlainText BL.ByteString where mimeRender _ = P.id+-- | @BL.fromStrict . T.encodeUtf8@+instance MimeRender MimePlainText T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8+-- | @BCL.pack@+instance MimeRender MimePlainText String where mimeRender _ = BCL.pack++-- | @P.id@+instance MimeRender MimeOctetStream BL.ByteString where mimeRender _ = P.id+-- | @BL.fromStrict . T.encodeUtf8@+instance MimeRender MimeOctetStream T.Text where mimeRender _ = BL.fromStrict . T.encodeUtf8+-- | @BCL.pack@+instance MimeRender MimeOctetStream String where mimeRender _ = BCL.pack++instance MimeRender MimeMultipartFormData BL.ByteString where mimeRender _ = P.id++instance MimeRender MimeMultipartFormData Bool where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData Char where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData Double where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData Float where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData Int where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData Integer where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData String where mimeRender _ = mimeRenderDefaultMultipartFormData+instance MimeRender MimeMultipartFormData T.Text where mimeRender _ = mimeRenderDefaultMultipartFormData++-- | @P.Right . P.const NoContent@+instance MimeRender MimeNoContent NoContent where mimeRender _ = P.const BCL.empty+++-- * MimeUnrender Class++class MimeType mtype => MimeUnrender mtype o where+    mimeUnrender :: P.Proxy mtype -> BL.ByteString -> P.Either String o+    mimeUnrender' :: mtype -> BL.ByteString -> P.Either String o+    mimeUnrender' _ x = mimeUnrender (P.Proxy :: P.Proxy mtype) x++-- Default MimeUnrender Instances++-- | @A.eitherDecode@+instance A.FromJSON a => MimeUnrender MimeJSON a where mimeUnrender _ = A.eitherDecode+-- | @P.left T.unpack . WH.urlDecodeAsForm@+instance WH.FromForm a => MimeUnrender MimeFormUrlEncoded a where mimeUnrender _ = P.left T.unpack . WH.urlDecodeAsForm+-- | @P.Right . P.id@++instance MimeUnrender MimePlainText BL.ByteString where mimeUnrender _ = P.Right . P.id+-- | @P.left P.show . TL.decodeUtf8'@+instance MimeUnrender MimePlainText T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict+-- | @P.Right . BCL.unpack@+instance MimeUnrender MimePlainText String where mimeUnrender _ = P.Right . BCL.unpack++-- | @P.Right . P.id@+instance MimeUnrender MimeOctetStream BL.ByteString where mimeUnrender _ = P.Right . P.id+-- | @P.left P.show . T.decodeUtf8' . BL.toStrict@+instance MimeUnrender MimeOctetStream T.Text where mimeUnrender _ = P.left P.show . T.decodeUtf8' . BL.toStrict+-- | @P.Right . BCL.unpack@+instance MimeUnrender MimeOctetStream String where mimeUnrender _ = P.Right . BCL.unpack++-- | @P.Right . P.const NoContent@+instance MimeUnrender MimeNoContent NoContent where mimeUnrender _ = P.Right . P.const NoContent++
+ lib/ApproveApi/Model.hs view
@@ -0,0 +1,392 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.Model+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-}++module ApproveApi.Model where++import ApproveApi.Core+import ApproveApi.MimeTypes++import Data.Aeson ((.:),(.:!),(.:?),(.=))++import qualified Control.Arrow as P (left)+import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.Data as P (Typeable, TypeRep, typeOf, typeRep)+import qualified Data.Foldable as P+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map as Map+import qualified Data.Maybe as P+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Time as TI+import qualified Lens.Micro as L+import qualified Web.FormUrlEncoded as WH+import qualified Web.HttpApiData as WH++import Control.Applicative ((<|>))+import Control.Applicative (Alternative)+import Data.Function ((&))+import Data.Monoid ((<>))+import Data.Text (Text)+import Prelude (($),(/=),(.),(<$>),(<*>),(>>=),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor)++import qualified Prelude as P++++-- * Parameter newtypes+++-- ** Id+newtype Id = Id { unId :: Text } deriving (P.Eq, P.Show)++-- ** LongPoll+newtype LongPoll = LongPoll { unLongPoll :: Bool } deriving (P.Eq, P.Show)++-- * Models+++-- ** AnswerMetadata+-- | AnswerMetadata+data AnswerMetadata = AnswerMetadata+  { answerMetadataIpAddress :: !(Maybe Text) -- ^ "ip_address"+  , answerMetadataBrowser :: !(Maybe Text) -- ^ "browser"+  , answerMetadataOperatingSystem :: !(Maybe Text) -- ^ "operating_system"+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON AnswerMetadata+instance A.FromJSON AnswerMetadata where+  parseJSON = A.withObject "AnswerMetadata" $ \o ->+    AnswerMetadata+      <$> (o .:? "ip_address")+      <*> (o .:? "browser")+      <*> (o .:? "operating_system")++-- | ToJSON AnswerMetadata+instance A.ToJSON AnswerMetadata where+  toJSON AnswerMetadata {..} =+   A.object+      [ "ip_address" .= answerMetadataIpAddress+      , "browser" .= answerMetadataBrowser+      , "operating_system" .= answerMetadataOperatingSystem+      ]+++-- | Construct a value of type 'AnswerMetadata' (by applying it's required fields, if any)+mkAnswerMetadata+  :: AnswerMetadata+mkAnswerMetadata =+  AnswerMetadata+  { answerMetadataIpAddress = Nothing+  , answerMetadataBrowser = Nothing+  , answerMetadataOperatingSystem = Nothing+  }++-- ** CreatePromptRequest+-- | CreatePromptRequest+data CreatePromptRequest = CreatePromptRequest+  { createPromptRequestUser :: !(Text) -- ^ /Required/ "user" - The user to send the approval request to. Can be either an email address or a phone number.+  , createPromptRequestBody :: !(Text) -- ^ /Required/ "body" - The body of the approval request to show the user.+  , createPromptRequestTitle :: !(Maybe Text) -- ^ "title" - The title of an approval request. Defaults to an empty string.+  , createPromptRequestApproveText :: !(Maybe Text) -- ^ "approve_text" - The approve action text. Defaults to &#39;Approve&#39;.+  , createPromptRequestApproveRedirectUrl :: !(Maybe Text) -- ^ "approve_redirect_url" - An HTTPS URL to redirect the user to if the prompt is approved. This URL is kept secret until the user is redirected to it.+  , createPromptRequestRejectText :: !(Maybe Text) -- ^ "reject_text" - The reject action text. If not specified the reject button will NOT be rendered, and the user will only see an approve action button.+  , createPromptRequestRejectRedirectUrl :: !(Maybe Text) -- ^ "reject_redirect_url" - An HTTPS URL to redirect the user to if the prompt is rejected. This URL is kept secret until the user is redirected to it.+  , createPromptRequestLongPoll :: !(Maybe Bool) -- ^ "long_poll" - If true, the request waits (long-polls) until the user responds to the prompt or more than 10 minutes pass. Defaults to false.+  , createPromptRequestExpiresIn :: !(Maybe Double) -- ^ "expires_in" - The number of seconds until this request can no longer be answered.+  , createPromptRequestMetadata :: !(Maybe PromptMetadata) -- ^ "metadata"+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON CreatePromptRequest+instance A.FromJSON CreatePromptRequest where+  parseJSON = A.withObject "CreatePromptRequest" $ \o ->+    CreatePromptRequest+      <$> (o .:  "user")+      <*> (o .:  "body")+      <*> (o .:? "title")+      <*> (o .:? "approve_text")+      <*> (o .:? "approve_redirect_url")+      <*> (o .:? "reject_text")+      <*> (o .:? "reject_redirect_url")+      <*> (o .:? "long_poll")+      <*> (o .:? "expires_in")+      <*> (o .:? "metadata")++-- | ToJSON CreatePromptRequest+instance A.ToJSON CreatePromptRequest where+  toJSON CreatePromptRequest {..} =+   A.object+      [ "user" .= createPromptRequestUser+      , "body" .= createPromptRequestBody+      , "title" .= createPromptRequestTitle+      , "approve_text" .= createPromptRequestApproveText+      , "approve_redirect_url" .= createPromptRequestApproveRedirectUrl+      , "reject_text" .= createPromptRequestRejectText+      , "reject_redirect_url" .= createPromptRequestRejectRedirectUrl+      , "long_poll" .= createPromptRequestLongPoll+      , "expires_in" .= createPromptRequestExpiresIn+      , "metadata" .= createPromptRequestMetadata+      ]+++-- | Construct a value of type 'CreatePromptRequest' (by applying it's required fields, if any)+mkCreatePromptRequest+  :: Text -- ^ 'createPromptRequestUser': The user to send the approval request to. Can be either an email address or a phone number.+  -> Text -- ^ 'createPromptRequestBody': The body of the approval request to show the user.+  -> CreatePromptRequest+mkCreatePromptRequest createPromptRequestUser createPromptRequestBody =+  CreatePromptRequest+  { createPromptRequestUser+  , createPromptRequestBody+  , createPromptRequestTitle = Nothing+  , createPromptRequestApproveText = Nothing+  , createPromptRequestApproveRedirectUrl = Nothing+  , createPromptRequestRejectText = Nothing+  , createPromptRequestRejectRedirectUrl = Nothing+  , createPromptRequestLongPoll = Nothing+  , createPromptRequestExpiresIn = Nothing+  , createPromptRequestMetadata = Nothing+  }++-- ** Error+-- | Error+data Error = Error+  { errorError :: !(Text) -- ^ /Required/ "error" - A human readable API error message.+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON Error+instance A.FromJSON Error where+  parseJSON = A.withObject "Error" $ \o ->+    Error+      <$> (o .:  "error")++-- | ToJSON Error+instance A.ToJSON Error where+  toJSON Error {..} =+   A.object+      [ "error" .= errorError+      ]+++-- | Construct a value of type 'Error' (by applying it's required fields, if any)+mkError+  :: Text -- ^ 'errorError': A human readable API error message.+  -> Error+mkError errorError =+  Error+  { errorError+  }++-- ** Prompt+-- | Prompt+data Prompt = Prompt+  { promptId :: !(Text) -- ^ /Required/ "id" - A unique id for this prompt.+  , promptSentAt :: !(Double) -- ^ /Required/ "sent_at" - The unix timestamp when this prompt was sent.+  , promptIsExpired :: !(Bool) -- ^ /Required/ "is_expired" - Whether the prompt can still be answered.+  , promptAnswer :: !(Maybe PromptAnswer) -- ^ "answer"+  , promptMetadata :: !(Maybe PromptMetadata) -- ^ "metadata"+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON Prompt+instance A.FromJSON Prompt where+  parseJSON = A.withObject "Prompt" $ \o ->+    Prompt+      <$> (o .:  "id")+      <*> (o .:  "sent_at")+      <*> (o .:  "is_expired")+      <*> (o .:? "answer")+      <*> (o .:? "metadata")++-- | ToJSON Prompt+instance A.ToJSON Prompt where+  toJSON Prompt {..} =+   A.object+      [ "id" .= promptId+      , "sent_at" .= promptSentAt+      , "is_expired" .= promptIsExpired+      , "answer" .= promptAnswer+      , "metadata" .= promptMetadata+      ]+++-- | Construct a value of type 'Prompt' (by applying it's required fields, if any)+mkPrompt+  :: Text -- ^ 'promptId': A unique id for this prompt.+  -> Double -- ^ 'promptSentAt': The unix timestamp when this prompt was sent.+  -> Bool -- ^ 'promptIsExpired': Whether the prompt can still be answered.+  -> Prompt+mkPrompt promptId promptSentAt promptIsExpired =+  Prompt+  { promptId+  , promptSentAt+  , promptIsExpired+  , promptAnswer = Nothing+  , promptMetadata = Nothing+  }++-- ** PromptAnswer+-- | PromptAnswer+data PromptAnswer = PromptAnswer+  { promptAnswerResult :: !(Bool) -- ^ /Required/ "result" - The user&#39;s answer to whether or not they approve this prompt.+  , promptAnswerTime :: !(Double) -- ^ /Required/ "time" - The unix timestamp when the user answered the prompt.+  , promptAnswerMetadata :: !(Maybe AnswerMetadata) -- ^ "metadata"+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON PromptAnswer+instance A.FromJSON PromptAnswer where+  parseJSON = A.withObject "PromptAnswer" $ \o ->+    PromptAnswer+      <$> (o .:  "result")+      <*> (o .:  "time")+      <*> (o .:? "metadata")++-- | ToJSON PromptAnswer+instance A.ToJSON PromptAnswer where+  toJSON PromptAnswer {..} =+   A.object+      [ "result" .= promptAnswerResult+      , "time" .= promptAnswerTime+      , "metadata" .= promptAnswerMetadata+      ]+++-- | Construct a value of type 'PromptAnswer' (by applying it's required fields, if any)+mkPromptAnswer+  :: Bool -- ^ 'promptAnswerResult': The user's answer to whether or not they approve this prompt.+  -> Double -- ^ 'promptAnswerTime': The unix timestamp when the user answered the prompt.+  -> PromptAnswer+mkPromptAnswer promptAnswerResult promptAnswerTime =+  PromptAnswer+  { promptAnswerResult+  , promptAnswerTime+  , promptAnswerMetadata = Nothing+  }++-- ** PromptMetadata+-- | PromptMetadata+data PromptMetadata = PromptMetadata+  { promptMetadataLocation :: !(Maybe Text) -- ^ "location" - The physical location, like Oakland, CA, of the action.+  , promptMetadataTime :: !(Maybe Text) -- ^ "time" - The date/time of the action.+  , promptMetadataIpAddress :: !(Maybe Text) -- ^ "ip_address" - The IP address of the computer initiating the action.+  , promptMetadataBrowser :: !(Maybe Text) -- ^ "browser" - The web browser initiating the action, i.e. Chrome.+  , promptMetadataOperatingSystem :: !(Maybe Text) -- ^ "operating_system" - The operating system initiating the action, i.e. Mac OS X.+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON PromptMetadata+instance A.FromJSON PromptMetadata where+  parseJSON = A.withObject "PromptMetadata" $ \o ->+    PromptMetadata+      <$> (o .:? "location")+      <*> (o .:? "time")+      <*> (o .:? "ip_address")+      <*> (o .:? "browser")+      <*> (o .:? "operating_system")++-- | ToJSON PromptMetadata+instance A.ToJSON PromptMetadata where+  toJSON PromptMetadata {..} =+   A.object+      [ "location" .= promptMetadataLocation+      , "time" .= promptMetadataTime+      , "ip_address" .= promptMetadataIpAddress+      , "browser" .= promptMetadataBrowser+      , "operating_system" .= promptMetadataOperatingSystem+      ]+++-- | Construct a value of type 'PromptMetadata' (by applying it's required fields, if any)+mkPromptMetadata+  :: PromptMetadata+mkPromptMetadata =+  PromptMetadata+  { promptMetadataLocation = Nothing+  , promptMetadataTime = Nothing+  , promptMetadataIpAddress = Nothing+  , promptMetadataBrowser = Nothing+  , promptMetadataOperatingSystem = Nothing+  }++-- ** PromptStatus+-- | PromptStatus+data PromptStatus = PromptStatus+  { promptStatusIsAnswered :: !(Bool) -- ^ /Required/ "is_answered" - Whether the prompt has been answered or not.+  , promptStatusIsExpired :: !(Bool) -- ^ /Required/ "is_expired" - Whether the prompt can still be answered.+  } deriving (P.Show, P.Eq, P.Typeable)++-- | FromJSON PromptStatus+instance A.FromJSON PromptStatus where+  parseJSON = A.withObject "PromptStatus" $ \o ->+    PromptStatus+      <$> (o .:  "is_answered")+      <*> (o .:  "is_expired")++-- | ToJSON PromptStatus+instance A.ToJSON PromptStatus where+  toJSON PromptStatus {..} =+   A.object+      [ "is_answered" .= promptStatusIsAnswered+      , "is_expired" .= promptStatusIsExpired+      ]+++-- | Construct a value of type 'PromptStatus' (by applying it's required fields, if any)+mkPromptStatus+  :: Bool -- ^ 'promptStatusIsAnswered': Whether the prompt has been answered or not.+  -> Bool -- ^ 'promptStatusIsExpired': Whether the prompt can still be answered.+  -> PromptStatus+mkPromptStatus promptStatusIsAnswered promptStatusIsExpired =+  PromptStatus+  { promptStatusIsAnswered+  , promptStatusIsExpired+  }+++++-- * Auth Methods++-- ** AuthBasicApiKey+data AuthBasicApiKey =+  AuthBasicApiKey B.ByteString B.ByteString -- ^ username password+  deriving (P.Eq, P.Show, P.Typeable)++instance AuthMethod AuthBasicApiKey where+  applyAuthMethod _ a@(AuthBasicApiKey user pw) req =+    P.pure $+    if (P.typeOf a `P.elem` rAuthTypes req)+      then req `setHeader` toHeader ("Authorization", T.decodeUtf8 cred)+           & L.over rAuthTypesL (P.filter (/= P.typeOf a))+      else req+    where cred = BC.append "Basic " (B64.encode $ BC.concat [ user, ":", pw ])++
+ lib/ApproveApi/ModelLens.hs view
@@ -0,0 +1,211 @@+{-+   ApproveAPISwagger++   The simple API to request a user's approval on anything via email + sms.++   OpenAPI Version: 3.0.0+   ApproveAPISwagger API version: 1.0.1+   Contact: dev@approveapi.com+   Generated by OpenAPI Generator (https://openapi-generator.tech)+-}++{-|+Module : ApproveApi.Lens+-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-}++module ApproveApi.ModelLens where++import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BL+import qualified Data.Data as P (Data, Typeable)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Time as TI++import Data.Text (Text)++import Prelude (($), (.),(<$>),(<*>),(=<<),Maybe(..),Bool(..),Char,Double,FilePath,Float,Int,Integer,String,fmap,undefined,mempty,maybe,pure,Monad,Applicative,Functor)+import qualified Prelude as P++import ApproveApi.Model+import ApproveApi.Core+++-- * AnswerMetadata++-- | 'answerMetadataIpAddress' Lens+answerMetadataIpAddressL :: Lens_' AnswerMetadata (Maybe Text)+answerMetadataIpAddressL f AnswerMetadata{..} = (\answerMetadataIpAddress -> AnswerMetadata { answerMetadataIpAddress, ..} ) <$> f answerMetadataIpAddress+{-# INLINE answerMetadataIpAddressL #-}++-- | 'answerMetadataBrowser' Lens+answerMetadataBrowserL :: Lens_' AnswerMetadata (Maybe Text)+answerMetadataBrowserL f AnswerMetadata{..} = (\answerMetadataBrowser -> AnswerMetadata { answerMetadataBrowser, ..} ) <$> f answerMetadataBrowser+{-# INLINE answerMetadataBrowserL #-}++-- | 'answerMetadataOperatingSystem' Lens+answerMetadataOperatingSystemL :: Lens_' AnswerMetadata (Maybe Text)+answerMetadataOperatingSystemL f AnswerMetadata{..} = (\answerMetadataOperatingSystem -> AnswerMetadata { answerMetadataOperatingSystem, ..} ) <$> f answerMetadataOperatingSystem+{-# INLINE answerMetadataOperatingSystemL #-}++++-- * CreatePromptRequest++-- | 'createPromptRequestUser' Lens+createPromptRequestUserL :: Lens_' CreatePromptRequest (Text)+createPromptRequestUserL f CreatePromptRequest{..} = (\createPromptRequestUser -> CreatePromptRequest { createPromptRequestUser, ..} ) <$> f createPromptRequestUser+{-# INLINE createPromptRequestUserL #-}++-- | 'createPromptRequestBody' Lens+createPromptRequestBodyL :: Lens_' CreatePromptRequest (Text)+createPromptRequestBodyL f CreatePromptRequest{..} = (\createPromptRequestBody -> CreatePromptRequest { createPromptRequestBody, ..} ) <$> f createPromptRequestBody+{-# INLINE createPromptRequestBodyL #-}++-- | 'createPromptRequestTitle' Lens+createPromptRequestTitleL :: Lens_' CreatePromptRequest (Maybe Text)+createPromptRequestTitleL f CreatePromptRequest{..} = (\createPromptRequestTitle -> CreatePromptRequest { createPromptRequestTitle, ..} ) <$> f createPromptRequestTitle+{-# INLINE createPromptRequestTitleL #-}++-- | 'createPromptRequestApproveText' Lens+createPromptRequestApproveTextL :: Lens_' CreatePromptRequest (Maybe Text)+createPromptRequestApproveTextL f CreatePromptRequest{..} = (\createPromptRequestApproveText -> CreatePromptRequest { createPromptRequestApproveText, ..} ) <$> f createPromptRequestApproveText+{-# INLINE createPromptRequestApproveTextL #-}++-- | 'createPromptRequestApproveRedirectUrl' Lens+createPromptRequestApproveRedirectUrlL :: Lens_' CreatePromptRequest (Maybe Text)+createPromptRequestApproveRedirectUrlL f CreatePromptRequest{..} = (\createPromptRequestApproveRedirectUrl -> CreatePromptRequest { createPromptRequestApproveRedirectUrl, ..} ) <$> f createPromptRequestApproveRedirectUrl+{-# INLINE createPromptRequestApproveRedirectUrlL #-}++-- | 'createPromptRequestRejectText' Lens+createPromptRequestRejectTextL :: Lens_' CreatePromptRequest (Maybe Text)+createPromptRequestRejectTextL f CreatePromptRequest{..} = (\createPromptRequestRejectText -> CreatePromptRequest { createPromptRequestRejectText, ..} ) <$> f createPromptRequestRejectText+{-# INLINE createPromptRequestRejectTextL #-}++-- | 'createPromptRequestRejectRedirectUrl' Lens+createPromptRequestRejectRedirectUrlL :: Lens_' CreatePromptRequest (Maybe Text)+createPromptRequestRejectRedirectUrlL f CreatePromptRequest{..} = (\createPromptRequestRejectRedirectUrl -> CreatePromptRequest { createPromptRequestRejectRedirectUrl, ..} ) <$> f createPromptRequestRejectRedirectUrl+{-# INLINE createPromptRequestRejectRedirectUrlL #-}++-- | 'createPromptRequestLongPoll' Lens+createPromptRequestLongPollL :: Lens_' CreatePromptRequest (Maybe Bool)+createPromptRequestLongPollL f CreatePromptRequest{..} = (\createPromptRequestLongPoll -> CreatePromptRequest { createPromptRequestLongPoll, ..} ) <$> f createPromptRequestLongPoll+{-# INLINE createPromptRequestLongPollL #-}++-- | 'createPromptRequestExpiresIn' Lens+createPromptRequestExpiresInL :: Lens_' CreatePromptRequest (Maybe Double)+createPromptRequestExpiresInL f CreatePromptRequest{..} = (\createPromptRequestExpiresIn -> CreatePromptRequest { createPromptRequestExpiresIn, ..} ) <$> f createPromptRequestExpiresIn+{-# INLINE createPromptRequestExpiresInL #-}++-- | 'createPromptRequestMetadata' Lens+createPromptRequestMetadataL :: Lens_' CreatePromptRequest (Maybe PromptMetadata)+createPromptRequestMetadataL f CreatePromptRequest{..} = (\createPromptRequestMetadata -> CreatePromptRequest { createPromptRequestMetadata, ..} ) <$> f createPromptRequestMetadata+{-# INLINE createPromptRequestMetadataL #-}++++-- * Error++-- | 'errorError' Lens+errorErrorL :: Lens_' Error (Text)+errorErrorL f Error{..} = (\errorError -> Error { errorError, ..} ) <$> f errorError+{-# INLINE errorErrorL #-}++++-- * Prompt++-- | 'promptId' Lens+promptIdL :: Lens_' Prompt (Text)+promptIdL f Prompt{..} = (\promptId -> Prompt { promptId, ..} ) <$> f promptId+{-# INLINE promptIdL #-}++-- | 'promptSentAt' Lens+promptSentAtL :: Lens_' Prompt (Double)+promptSentAtL f Prompt{..} = (\promptSentAt -> Prompt { promptSentAt, ..} ) <$> f promptSentAt+{-# INLINE promptSentAtL #-}++-- | 'promptIsExpired' Lens+promptIsExpiredL :: Lens_' Prompt (Bool)+promptIsExpiredL f Prompt{..} = (\promptIsExpired -> Prompt { promptIsExpired, ..} ) <$> f promptIsExpired+{-# INLINE promptIsExpiredL #-}++-- | 'promptAnswer' Lens+promptAnswerL :: Lens_' Prompt (Maybe PromptAnswer)+promptAnswerL f Prompt{..} = (\promptAnswer -> Prompt { promptAnswer, ..} ) <$> f promptAnswer+{-# INLINE promptAnswerL #-}++-- | 'promptMetadata' Lens+promptMetadataL :: Lens_' Prompt (Maybe PromptMetadata)+promptMetadataL f Prompt{..} = (\promptMetadata -> Prompt { promptMetadata, ..} ) <$> f promptMetadata+{-# INLINE promptMetadataL #-}++++-- * PromptAnswer++-- | 'promptAnswerResult' Lens+promptAnswerResultL :: Lens_' PromptAnswer (Bool)+promptAnswerResultL f PromptAnswer{..} = (\promptAnswerResult -> PromptAnswer { promptAnswerResult, ..} ) <$> f promptAnswerResult+{-# INLINE promptAnswerResultL #-}++-- | 'promptAnswerTime' Lens+promptAnswerTimeL :: Lens_' PromptAnswer (Double)+promptAnswerTimeL f PromptAnswer{..} = (\promptAnswerTime -> PromptAnswer { promptAnswerTime, ..} ) <$> f promptAnswerTime+{-# INLINE promptAnswerTimeL #-}++-- | 'promptAnswerMetadata' Lens+promptAnswerMetadataL :: Lens_' PromptAnswer (Maybe AnswerMetadata)+promptAnswerMetadataL f PromptAnswer{..} = (\promptAnswerMetadata -> PromptAnswer { promptAnswerMetadata, ..} ) <$> f promptAnswerMetadata+{-# INLINE promptAnswerMetadataL #-}++++-- * PromptMetadata++-- | 'promptMetadataLocation' Lens+promptMetadataLocationL :: Lens_' PromptMetadata (Maybe Text)+promptMetadataLocationL f PromptMetadata{..} = (\promptMetadataLocation -> PromptMetadata { promptMetadataLocation, ..} ) <$> f promptMetadataLocation+{-# INLINE promptMetadataLocationL #-}++-- | 'promptMetadataTime' Lens+promptMetadataTimeL :: Lens_' PromptMetadata (Maybe Text)+promptMetadataTimeL f PromptMetadata{..} = (\promptMetadataTime -> PromptMetadata { promptMetadataTime, ..} ) <$> f promptMetadataTime+{-# INLINE promptMetadataTimeL #-}++-- | 'promptMetadataIpAddress' Lens+promptMetadataIpAddressL :: Lens_' PromptMetadata (Maybe Text)+promptMetadataIpAddressL f PromptMetadata{..} = (\promptMetadataIpAddress -> PromptMetadata { promptMetadataIpAddress, ..} ) <$> f promptMetadataIpAddress+{-# INLINE promptMetadataIpAddressL #-}++-- | 'promptMetadataBrowser' Lens+promptMetadataBrowserL :: Lens_' PromptMetadata (Maybe Text)+promptMetadataBrowserL f PromptMetadata{..} = (\promptMetadataBrowser -> PromptMetadata { promptMetadataBrowser, ..} ) <$> f promptMetadataBrowser+{-# INLINE promptMetadataBrowserL #-}++-- | 'promptMetadataOperatingSystem' Lens+promptMetadataOperatingSystemL :: Lens_' PromptMetadata (Maybe Text)+promptMetadataOperatingSystemL f PromptMetadata{..} = (\promptMetadataOperatingSystem -> PromptMetadata { promptMetadataOperatingSystem, ..} ) <$> f promptMetadataOperatingSystem+{-# INLINE promptMetadataOperatingSystemL #-}++++-- * PromptStatus++-- | 'promptStatusIsAnswered' Lens+promptStatusIsAnsweredL :: Lens_' PromptStatus (Bool)+promptStatusIsAnsweredL f PromptStatus{..} = (\promptStatusIsAnswered -> PromptStatus { promptStatusIsAnswered, ..} ) <$> f promptStatusIsAnswered+{-# INLINE promptStatusIsAnsweredL #-}++-- | 'promptStatusIsExpired' Lens+promptStatusIsExpiredL :: Lens_' PromptStatus (Bool)+promptStatusIsExpiredL f PromptStatus{..} = (\promptStatusIsExpired -> PromptStatus { promptStatusIsExpired, ..} ) <$> f promptStatusIsExpired+{-# INLINE promptStatusIsExpiredL #-}++
+ openapi.yaml view
@@ -0,0 +1,330 @@+openapi: 3.0.0+info:+  contact:+    email: dev@approveapi.com+  description: The simple API to request a user's approval on anything via email + sms.+  title: ApproveAPISwagger+  version: 1.0.1+servers:+- url: https://approve.sh+paths:+  /prompt:+    post:+      description: Creates a prompt and pushes it to the user (sends via email, sms, or other supported protocols).+      operationId: CreatePrompt+      requestBody:+        content:+          application/json:+            schema:+              $ref: '#/components/schemas/CreatePromptRequest'+        required: true+      responses:+        200:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Prompt'+          description: OK+        400:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: Invalid parameters+        401:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: Missing or invalid API key in the username basic auth field+        504:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: Polling timed out with no user response+      security:+      - apiKey: []+      summary: Sending a prompt+      tags:+      - approve+  /prompt/{id}:+    get:+      description: Retrieve the prompt object with the given ID.+      operationId: GetPrompt+      parameters:+      - description: The identifier for a pending or completed prompt. This is returned when you create a prompt.+        explode: false+        in: path+        name: id+        required: true+        schema:+          type: string+        style: simple+      - description: If true, the request waits (long-polls) until the user responds to the prompt or more than 10 minutes pass. Defaults to false.+        explode: true+        in: query+        name: long_poll+        required: false+        schema:+          type: boolean+        style: form+      responses:+        200:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Prompt'+          description: OK+        400:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: Invalid parameters+        404:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: A prompt with this identifier could not be found+      security:+      - apiKey: []+      summary: Retrieve a prompt+      tags:+      - approve+  /prompt/{id}/status:+    get:+      description: Returns whether a prompt has been completed by the user. This request does not require authentication, and so can be used client-side without sharing API credentials.+      operationId: GetPromptStatus+      parameters:+      - description: The prompt identifier.+        explode: false+        in: path+        name: id+        required: true+        schema:+          type: string+        style: simple+      responses:+        200:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/PromptStatus'+          description: OK+        400:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: Invalid parameters+        404:+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'+          description: A prompt with this identifier could not be found+      summary: Check prompt status+      tags:+      - approve+components:+  responses:+    Unauthorized:+      content:+        application/json:+          schema:+            $ref: '#/components/schemas/Error'+      description: Missing or invalid API key in the username basic auth field+    BadRequest:+      content:+        application/json:+          schema:+            $ref: '#/components/schemas/Error'+      description: Invalid parameters+    PollTimeout:+      content:+        application/json:+          schema:+            $ref: '#/components/schemas/Error'+      description: Polling timed out with no user response+    PromptNotFound:+      content:+        application/json:+          schema:+            $ref: '#/components/schemas/Error'+      description: A prompt with this identifier could not be found+  schemas:+    Prompt:+      example:+        sent_at: 0.8008281904610115+        metadata:+          browser: browser+          operating_system: operating_system+          location: location+          time: time+          ip_address: ip_address+        is_expired: true+        answer:+          result: true+          metadata:+            browser: browser+            operating_system: operating_system+            ip_address: ip_address+          time: 6.027456183070403+        id: id+      properties:+        id:+          description: A unique id for this prompt.+          type: string+        sent_at:+          description: The unix timestamp when this prompt was sent.+          type: number+        is_expired:+          description: Whether the prompt can still be answered.+          type: boolean+        answer:+          $ref: '#/components/schemas/PromptAnswer'+        metadata:+          $ref: '#/components/schemas/PromptMetadata'+      required:+      - id+      - is_expired+      - sent_at+      type: object+    CreatePromptRequest:+      example:+        metadata:+          browser: browser+          operating_system: operating_system+          location: location+          time: time+          ip_address: ip_address+        long_poll: true+        reject_text: reject_text+        approve_redirect_url: approve_redirect_url+        reject_redirect_url: reject_redirect_url+        approve_text: approve_text+        body: body+        title: title+        user: user+        expires_in: 0.8008281904610115+      properties:+        user:+          description: The user to send the approval request to. Can be either an email address or a phone number.+          type: string+        body:+          description: The body of the approval request to show the user.+          type: string+        title:+          description: The title of an approval request. Defaults to an empty string.+          type: string+        approve_text:+          description: The approve action text. Defaults to 'Approve'.+          type: string+        approve_redirect_url:+          description: An HTTPS URL to redirect the user to if the prompt is approved. This URL is kept secret until the user is redirected to it.+          type: string+        reject_text:+          description: The reject action text. If not specified the reject button will NOT be rendered, and the user will only see an approve action button.+          type: string+        reject_redirect_url:+          description: An HTTPS URL to redirect the user to if the prompt is rejected. This URL is kept secret until the user is redirected to it.+          type: string+        long_poll:+          description: If true, the request waits (long-polls) until the user responds to the prompt or more than 10 minutes pass. Defaults to false.+          type: boolean+        expires_in:+          description: The number of seconds until this request can no longer be answered.+          type: number+        metadata:+          $ref: '#/components/schemas/PromptMetadata'+      required:+      - body+      - user+      type: object+    PromptMetadata:+      example:+        browser: browser+        operating_system: operating_system+        location: location+        time: time+        ip_address: ip_address+      properties:+        location:+          description: The physical location, like Oakland, CA, of the action.+          type: string+        time:+          description: The date/time of the action.+          type: string+        ip_address:+          description: The IP address of the computer initiating the action.+          type: string+        browser:+          description: The web browser initiating the action, i.e. Chrome.+          type: string+        operating_system:+          description: The operating system initiating the action, i.e. Mac OS X.+          type: string+      type: object+    PromptAnswer:+      example:+        result: true+        metadata:+          browser: browser+          operating_system: operating_system+          ip_address: ip_address+        time: 6.027456183070403+      properties:+        result:+          description: The user's answer to whether or not they approve this prompt.+          type: boolean+        time:+          description: The unix timestamp when the user answered the prompt.+          type: number+        metadata:+          $ref: '#/components/schemas/AnswerMetadata'+      required:+      - result+      - time+      type: object+    AnswerMetadata:+      example:+        browser: browser+        operating_system: operating_system+        ip_address: ip_address+      properties:+        ip_address:+          type: string+        browser:+          type: string+        operating_system:+          type: string+      type: object+    PromptStatus:+      example:+        is_expired: true+        is_answered: true+      properties:+        is_answered:+          description: Whether the prompt has been answered or not.+          type: boolean+        is_expired:+          description: Whether the prompt can still be answered.+          type: boolean+      required:+      - is_answered+      - is_expired+      type: object+    Error:+      properties:+        error:+          description: A human readable API error message.+          type: string+      required:+      - error+      type: object+  securitySchemes:+    apiKey:+      scheme: basic+      type: http
+ tests/ApproxEq.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ApproxEq where++import Data.Text (Text)+import Data.Time.Clock+import Test.QuickCheck+import GHC.Generics as G++(==~)+  :: (ApproxEq a, Show a)+  => a -> a -> Property+a ==~ b = counterexample (show a ++ " !=~ " ++ show b) (a =~ b)++class GApproxEq f  where+  gApproxEq :: f a -> f a -> Bool++instance GApproxEq U1 where+  gApproxEq U1 U1 = True++instance (GApproxEq a, GApproxEq b) =>+         GApproxEq (a :+: b) where+  gApproxEq (L1 a) (L1 b) = gApproxEq a b+  gApproxEq (R1 a) (R1 b) = gApproxEq a b+  gApproxEq _ _ = False++instance (GApproxEq a, GApproxEq b) =>+         GApproxEq (a :*: b) where+  gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2++instance (ApproxEq a) =>+         GApproxEq (K1 i a) where+  gApproxEq (K1 a) (K1 b) = a =~ b++instance (GApproxEq f) =>+         GApproxEq (M1 i t f) where+  gApproxEq (M1 a) (M1 b) = gApproxEq a b++class ApproxEq a  where+  (=~) :: a -> a -> Bool+  default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool+  a =~ b = gApproxEq (G.from a) (G.from b)++instance ApproxEq Text where+  (=~) = (==)++instance ApproxEq Char where+  (=~) = (==)++instance ApproxEq Bool where+  (=~) = (==)++instance ApproxEq Int where+  (=~) = (==)++instance ApproxEq Double where+  (=~) = (==)++instance ApproxEq a =>+         ApproxEq (Maybe a)++instance ApproxEq UTCTime where+  (=~) = (==)++instance ApproxEq a =>+         ApproxEq [a] where+  as =~ bs = and (zipWith (=~) as bs)++instance (ApproxEq l, ApproxEq r) =>+         ApproxEq (Either l r) where+  Left a =~ Left b = a =~ b+  Right a =~ Right b = a =~ b+  _ =~ _ = False++instance (ApproxEq l, ApproxEq r) =>+         ApproxEq (l, r) where+  (=~) (l1, r1) (l2, r2) = l1 =~ l2 && r1 =~ r2
+ tests/Instances.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Instances where++import ApproveApi.Model+import ApproveApi.Core++import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Time as TI+import qualified Data.Vector as V++import Control.Monad+import Data.Char (isSpace)+import Data.List (sort)+import Test.QuickCheck++import ApproxEq++instance Arbitrary T.Text where+  arbitrary = T.pack <$> arbitrary++instance Arbitrary TI.Day where+  arbitrary = TI.ModifiedJulianDay . (2000 +) <$> arbitrary+  shrink = (TI.ModifiedJulianDay <$>) . shrink . TI.toModifiedJulianDay++instance Arbitrary TI.UTCTime where+  arbitrary =+    TI.UTCTime <$> arbitrary <*> (TI.secondsToDiffTime <$> choose (0, 86401))++instance Arbitrary BL.ByteString where+    arbitrary = BL.pack <$> arbitrary+    shrink xs = BL.pack <$> shrink (BL.unpack xs)++instance Arbitrary ByteArray where+    arbitrary = ByteArray <$> arbitrary+    shrink (ByteArray xs) = ByteArray <$> shrink xs++instance Arbitrary Binary where+    arbitrary = Binary <$> arbitrary+    shrink (Binary xs) = Binary <$> shrink xs++instance Arbitrary DateTime where+    arbitrary = DateTime <$> arbitrary+    shrink (DateTime xs) = DateTime <$> shrink xs++instance Arbitrary Date where+    arbitrary = Date <$> arbitrary+    shrink (Date xs) = Date <$> shrink xs++-- | A naive Arbitrary instance for A.Value:+instance Arbitrary A.Value where+  arbitrary = frequency [(3, simpleTypes), (1, arrayTypes), (1, objectTypes)]+    where+      simpleTypes :: Gen A.Value+      simpleTypes =+        frequency+          [ (1, return A.Null)+          , (2, liftM A.Bool (arbitrary :: Gen Bool))+          , (2, liftM (A.Number . fromIntegral) (arbitrary :: Gen Int))+          , (2, liftM (A.String . T.pack) (arbitrary :: Gen String))+          ]+      mapF (k, v) = (T.pack k, v)+      simpleAndArrays = frequency [(1, sized sizedArray), (4, simpleTypes)]+      arrayTypes = sized sizedArray+      objectTypes = sized sizedObject+      sizedArray n = liftM (A.Array . V.fromList) $ replicateM n simpleTypes+      sizedObject n =+        liftM (A.object . map mapF) $+        replicateM n $ (,) <$> (arbitrary :: Gen String) <*> simpleAndArrays+    +-- | Checks if a given list has no duplicates in _O(n log n)_.+hasNoDups+  :: (Ord a)+  => [a] -> Bool+hasNoDups = go Set.empty+  where+    go _ [] = True+    go s (x:xs)+      | s' <- Set.insert x s+      , Set.size s' > Set.size s = go s' xs+      | otherwise = False++instance ApproxEq TI.Day where+  (=~) = (==)++-- * Models+ +instance Arbitrary AnswerMetadata where+  arbitrary =+    AnswerMetadata+      <$> arbitrary -- answerMetadataIpAddress :: Maybe Text+      <*> arbitrary -- answerMetadataBrowser :: Maybe Text+      <*> arbitrary -- answerMetadataOperatingSystem :: Maybe Text+    +instance Arbitrary CreatePromptRequest where+  arbitrary =+    CreatePromptRequest+      <$> arbitrary -- createPromptRequestUser :: Text+      <*> arbitrary -- createPromptRequestBody :: Text+      <*> arbitrary -- createPromptRequestTitle :: Maybe Text+      <*> arbitrary -- createPromptRequestApproveText :: Maybe Text+      <*> arbitrary -- createPromptRequestApproveRedirectUrl :: Maybe Text+      <*> arbitrary -- createPromptRequestRejectText :: Maybe Text+      <*> arbitrary -- createPromptRequestRejectRedirectUrl :: Maybe Text+      <*> arbitrary -- createPromptRequestLongPoll :: Maybe Bool+      <*> arbitrary -- createPromptRequestExpiresIn :: Maybe Double+      <*> arbitrary -- createPromptRequestMetadata :: Maybe PromptMetadata+    +instance Arbitrary Error where+  arbitrary =+    Error+      <$> arbitrary -- errorError :: Text+    +instance Arbitrary Prompt where+  arbitrary =+    Prompt+      <$> arbitrary -- promptId :: Text+      <*> arbitrary -- promptSentAt :: Double+      <*> arbitrary -- promptIsExpired :: Bool+      <*> arbitrary -- promptAnswer :: Maybe PromptAnswer+      <*> arbitrary -- promptMetadata :: Maybe PromptMetadata+    +instance Arbitrary PromptAnswer where+  arbitrary =+    PromptAnswer+      <$> arbitrary -- promptAnswerResult :: Bool+      <*> arbitrary -- promptAnswerTime :: Double+      <*> arbitrary -- promptAnswerMetadata :: Maybe AnswerMetadata+    +instance Arbitrary PromptMetadata where+  arbitrary =+    PromptMetadata+      <$> arbitrary -- promptMetadataLocation :: Maybe Text+      <*> arbitrary -- promptMetadataTime :: Maybe Text+      <*> arbitrary -- promptMetadataIpAddress :: Maybe Text+      <*> arbitrary -- promptMetadataBrowser :: Maybe Text+      <*> arbitrary -- promptMetadataOperatingSystem :: Maybe Text+    +instance Arbitrary PromptStatus where+  arbitrary =+    PromptStatus+      <$> arbitrary -- promptStatusIsAnswered :: Bool+      <*> arbitrary -- promptStatusIsExpired :: Bool+    ++
+ tests/PropMime.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module PropMime where++import Data.Aeson+import Data.Aeson.Types (parseEither)+import Data.Monoid ((<>))+import Data.Typeable (Proxy(..), typeOf, Typeable)+import qualified Data.ByteString.Lazy.Char8 as BL8+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Property+import Test.Hspec.QuickCheck (prop)++import ApproveApi.MimeTypes++import ApproxEq++-- * Type Aliases++type ArbitraryMime mime a = ArbitraryRoundtrip (MimeUnrender mime) (MimeRender mime) a++type ArbitraryRoundtrip from to a = (from a, to a, Arbitrary' a)++type Arbitrary' a = (Arbitrary a, Show a, Typeable a)++-- * Mime++propMime+  :: forall a b mime.+     (ArbitraryMime mime a, Testable b)+  => String -> (a -> a -> b) -> mime -> Proxy a -> Spec+propMime eqDescr eq m _ =+  prop+    (show (typeOf (undefined :: a)) <> " " <> show (typeOf (undefined :: mime)) <> " roundtrip " <> eqDescr) $+  \(x :: a) ->+     let rendered = mimeRender' m x+         actual = mimeUnrender' m rendered+         expected = Right x+         failMsg =+           "ACTUAL: " <> show actual <> "\nRENDERED: " <> BL8.unpack rendered+     in counterexample failMsg $+        either reject property (eq <$> actual <*> expected)+  where+    reject = property . const rejected++propMimeEq :: (ArbitraryMime mime a, Eq a) => mime -> Proxy a -> Spec+propMimeEq = propMime "(EQ)" (==)
+ tests/Test.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Main where++import Data.Typeable (Proxy(..))+import Test.Hspec+import Test.Hspec.QuickCheck++import PropMime+import Instances ()++import ApproveApi.Model+import ApproveApi.MimeTypes++main :: IO ()+main =+  hspec $ modifyMaxSize (const 5) $ do+    describe "JSON instances" $ do+      pure ()+      propMimeEq MimeJSON (Proxy :: Proxy AnswerMetadata)+      propMimeEq MimeJSON (Proxy :: Proxy CreatePromptRequest)+      propMimeEq MimeJSON (Proxy :: Proxy Error)+      propMimeEq MimeJSON (Proxy :: Proxy Prompt)+      propMimeEq MimeJSON (Proxy :: Proxy PromptAnswer)+      propMimeEq MimeJSON (Proxy :: Proxy PromptMetadata)+      propMimeEq MimeJSON (Proxy :: Proxy PromptStatus)+