diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/approveapi.cabal b/approveapi.cabal new file mode 100644 --- /dev/null +++ b/approveapi.cabal @@ -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 diff --git a/lib/ApproveApi.hs b/lib/ApproveApi.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi.hs @@ -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 diff --git a/lib/ApproveApi/API.hs b/lib/ApproveApi/API.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/API.hs @@ -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 diff --git a/lib/ApproveApi/API/Approve.hs b/lib/ApproveApi/API/Approve.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/API/Approve.hs @@ -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 + diff --git a/lib/ApproveApi/Client.hs b/lib/ApproveApi/Client.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/Client.hs @@ -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) + _ -> "") + 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 diff --git a/lib/ApproveApi/Core.hs b/lib/ApproveApi/Core.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/Core.hs @@ -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 diff --git a/lib/ApproveApi/Logging.hs b/lib/ApproveApi/Logging.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/Logging.hs @@ -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 + diff --git a/lib/ApproveApi/MimeTypes.hs b/lib/ApproveApi/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/MimeTypes.hs @@ -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 + + diff --git a/lib/ApproveApi/Model.hs b/lib/ApproveApi/Model.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/Model.hs @@ -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 'Approve'. + , 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'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 ]) + + diff --git a/lib/ApproveApi/ModelLens.hs b/lib/ApproveApi/ModelLens.hs new file mode 100644 --- /dev/null +++ b/lib/ApproveApi/ModelLens.hs @@ -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 #-} + + diff --git a/openapi.yaml b/openapi.yaml new file mode 100644 --- /dev/null +++ b/openapi.yaml @@ -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 diff --git a/tests/ApproxEq.hs b/tests/ApproxEq.hs new file mode 100644 --- /dev/null +++ b/tests/ApproxEq.hs @@ -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 diff --git a/tests/Instances.hs b/tests/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Instances.hs @@ -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 + + + diff --git a/tests/PropMime.hs b/tests/PropMime.hs new file mode 100644 --- /dev/null +++ b/tests/PropMime.hs @@ -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)" (==) diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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) +