545 lines
20 KiB
Haskell
545 lines
20 KiB
Haskell
{-
|
|
Kubernetes
|
|
|
|
No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator)
|
|
|
|
OpenAPI Version: 3.0.1
|
|
Kubernetes API version: v1.14.2
|
|
Generated by OpenAPI Generator (https://openapi-generator.tech)
|
|
-}
|
|
|
|
{-|
|
|
Module : Kubernetes.OpenAPI.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 Kubernetes.OpenAPI.Core where
|
|
|
|
import Kubernetes.OpenAPI.MimeTypes
|
|
import Kubernetes.OpenAPI.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)
|
|
|
|
-- * KubernetesClientConfig
|
|
|
|
-- |
|
|
data KubernetesClientConfig = KubernetesClientConfig
|
|
{ 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 KubernetesClientConfig where
|
|
show c =
|
|
T.printf
|
|
"{ configHost = %v, configUserAgent = %v, ..}"
|
|
(show (configHost c))
|
|
(show (configUserAgent c))
|
|
|
|
-- | constructs a default KubernetesClientConfig
|
|
--
|
|
-- configHost:
|
|
--
|
|
-- @http://localhost@
|
|
--
|
|
-- configUserAgent:
|
|
--
|
|
-- @"kubernetes-client-core/0.1.0.0"@
|
|
--
|
|
newConfig :: IO KubernetesClientConfig
|
|
newConfig = do
|
|
logCxt <- initLogContext
|
|
return $ KubernetesClientConfig
|
|
{ configHost = "http://localhost"
|
|
, configUserAgent = "kubernetes-client-core/0.1.0.0"
|
|
, configLogExecWithContext = runDefaultLogExecWithContext
|
|
, configLogContext = logCxt
|
|
, configAuthMethods = []
|
|
, configValidateAuthMethods = True
|
|
}
|
|
|
|
-- | updates config use AuthMethod on matching requests
|
|
addAuthMethod :: AuthMethod auth => KubernetesClientConfig -> auth -> KubernetesClientConfig
|
|
addAuthMethod config@KubernetesClientConfig {configAuthMethods = as} a =
|
|
config { configAuthMethods = AnyAuthMethod a : as}
|
|
|
|
-- | updates the config to use stdout logging
|
|
withStdoutLogging :: KubernetesClientConfig -> IO KubernetesClientConfig
|
|
withStdoutLogging p = do
|
|
logCxt <- stdoutLoggingContext (configLogContext p)
|
|
return $ p { configLogExecWithContext = stdoutLoggingExec, configLogContext = logCxt }
|
|
|
|
-- | updates the config to use stderr logging
|
|
withStderrLogging :: KubernetesClientConfig -> IO KubernetesClientConfig
|
|
withStderrLogging p = do
|
|
logCxt <- stderrLoggingContext (configLogContext p)
|
|
return $ p { configLogExecWithContext = stderrLoggingExec, configLogContext = logCxt }
|
|
|
|
-- | updates the config to disable logging
|
|
withNoLogging :: KubernetesClientConfig -> KubernetesClientConfig
|
|
withNoLogging p = p { configLogExecWithContext = runNullLogExec}
|
|
|
|
-- * KubernetesRequest
|
|
|
|
-- | Represents a request.
|
|
--
|
|
-- Type Variables:
|
|
--
|
|
-- * req - request operation
|
|
-- * contentType - 'MimeType' associated with request body
|
|
-- * res - response model
|
|
-- * accept - 'MimeType' associated with response body
|
|
data KubernetesRequest req contentType res accept = KubernetesRequest
|
|
{ rMethod :: NH.Method -- ^ Method of KubernetesRequest
|
|
, rUrlPath :: [BCL.ByteString] -- ^ Endpoint of KubernetesRequest
|
|
, rParams :: Params -- ^ params of KubernetesRequest
|
|
, rAuthTypes :: [P.TypeRep] -- ^ types of auth methods
|
|
}
|
|
deriving (P.Show)
|
|
|
|
-- | 'rMethod' Lens
|
|
rMethodL :: Lens_' (KubernetesRequest req contentType res accept) NH.Method
|
|
rMethodL f KubernetesRequest{..} = (\rMethod -> KubernetesRequest { rMethod, ..} ) <$> f rMethod
|
|
{-# INLINE rMethodL #-}
|
|
|
|
-- | 'rUrlPath' Lens
|
|
rUrlPathL :: Lens_' (KubernetesRequest req contentType res accept) [BCL.ByteString]
|
|
rUrlPathL f KubernetesRequest{..} = (\rUrlPath -> KubernetesRequest { rUrlPath, ..} ) <$> f rUrlPath
|
|
{-# INLINE rUrlPathL #-}
|
|
|
|
-- | 'rParams' Lens
|
|
rParamsL :: Lens_' (KubernetesRequest req contentType res accept) Params
|
|
rParamsL f KubernetesRequest{..} = (\rParams -> KubernetesRequest { rParams, ..} ) <$> f rParams
|
|
{-# INLINE rParamsL #-}
|
|
|
|
-- | 'rParams' Lens
|
|
rAuthTypesL :: Lens_' (KubernetesRequest req contentType res accept) [P.TypeRep]
|
|
rAuthTypesL f KubernetesRequest{..} = (\rAuthTypes -> KubernetesRequest { 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) => KubernetesRequest req contentType res accept -> param -> KubernetesRequest 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 :: KubernetesRequest req contentType res accept -> param -> KubernetesRequest req contentType res accept
|
|
applyOptionalParam = (-&-)
|
|
{-# INLINE applyOptionalParam #-}
|
|
|
|
-- | infix operator \/ alias for 'addOptionalParam'
|
|
(-&-) :: KubernetesRequest req contentType res accept -> param -> KubernetesRequest 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)
|
|
|
|
-- ** KubernetesRequest Utils
|
|
|
|
_mkRequest :: NH.Method -- ^ Method
|
|
-> [BCL.ByteString] -- ^ Endpoint
|
|
-> KubernetesRequest req contentType res accept -- ^ req: Request Type, res: Response Type
|
|
_mkRequest m u = KubernetesRequest m u _mkParams []
|
|
|
|
_mkParams :: Params
|
|
_mkParams = Params [] [] ParamBodyNone
|
|
|
|
setHeader :: KubernetesRequest req contentType res accept -> [NH.Header] -> KubernetesRequest req contentType res accept
|
|
setHeader req header =
|
|
req `removeHeader` P.fmap P.fst header &
|
|
L.over (rParamsL . paramsHeadersL) (header P.++)
|
|
|
|
removeHeader :: KubernetesRequest req contentType res accept -> [NH.HeaderName] -> KubernetesRequest 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 => KubernetesRequest req contentType res accept -> KubernetesRequest 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 => KubernetesRequest req contentType res accept -> KubernetesRequest 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 :: KubernetesRequest req contentType res accept -> [NH.QueryItem] -> KubernetesRequest 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 :: KubernetesRequest req contentType res accept -> WH.Form -> KubernetesRequest 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 :: KubernetesRequest req contentType res accept -> NH.Part -> KubernetesRequest 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 :: KubernetesRequest req contentType res accept -> B.ByteString -> KubernetesRequest req contentType res accept
|
|
_setBodyBS req body =
|
|
req & L.set (rParamsL . paramsBodyL) (ParamBodyB body)
|
|
|
|
_setBodyLBS :: KubernetesRequest req contentType res accept -> BL.ByteString -> KubernetesRequest req contentType res accept
|
|
_setBodyLBS req body =
|
|
req & L.set (rParamsL . paramsBodyL) (ParamBodyBL body)
|
|
|
|
_hasAuthType :: AuthMethod authMethod => KubernetesRequest req contentType res accept -> P.Proxy authMethod -> KubernetesRequest 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
|
|
:: KubernetesClientConfig
|
|
-> a
|
|
-> KubernetesRequest req contentType res accept
|
|
-> IO (KubernetesRequest 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
|
|
:: KubernetesRequest req contentType res accept
|
|
-> KubernetesClientConfig
|
|
-> IO (KubernetesRequest req contentType res accept)
|
|
_applyAuthMethods req config@(KubernetesClientConfig {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.formatISO8601Micros@
|
|
_showDateTime :: (t ~ TI.UTCTime, TI.FormatTime t) => t -> String
|
|
_showDateTime =
|
|
TI.formatISO8601Micros
|
|
{-# 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
|