jordan-servant (empty) → 0.1.0.0

raw patch · 11 files changed

+1138/−0 lines, 11 filesdep +QuickCheckdep +attoparsecdep +base

Dependencies added: QuickCheck, attoparsec, base, bytestring, contravariant, hspec, http-media, http-types, jordan, jordan-servant, parallel, quickcheck-text, scientific, servant, text, transformers

Files

• CHANGELOG.md +18/−0
• LICENSE +20/−0
• jordan-servant.cabal +73/−0
• lib/Jordan/Servant.hs +84/−0
• lib/Jordan/Servant/Query.hs +90/−0
• lib/Jordan/Servant/Query/Parse.hs +348/−0
• lib/Jordan/Servant/Query/Render.hs +110/−0
• lib/Jordan/Servant/Response.hs +39/−0
• test/Jordan/Servant/Query/ParseSpec.hs +107/−0
• test/Jordan/Servant/Query/RoundtripSpec.hs +242/−0
• test/Jordan/ServantSpec.hs +7/−0

@@ -0,0 +1,18 @@+# Revision history for jordan-servant++## 0.1.0.0 -- 2022-07-04++* First version.+* Query rendering, including:+  * `renderQueryAtKey`+  * `renderQueryAtKeyWith`+* Query parsing, including:+  * `parseQueryAtKey`+  * `parseQueryAtKeyWith`+  * `hasKeyAtKey`+* Query combinators, including:+  * `JordanQuery'`+  * `OptionalJordanQuery`+  * `RequiredJordanQuery`+* `JordanJSON` and friends+* `ReportingRequestBody` and friends.

@@ -0,0 +1,20 @@+Copyright (c) 2021 Anthony Super++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.

@@ -0,0 +1,73 @@+cabal-version:      2.4+name:               jordan-servant+version:            0.1.0.0+synopsis:           Servant Combinators for Jordan++-- A longer description of the package.+description:+  Jordan Servant provides servant combinators for Jordan types, allowing you+  to use Jordan to build web APIs.+  .+  It has sister packages which provide server or client functionality.+  This package just provides the types, as well as a mechanism to serialize or parse JSON.+homepage:++-- A URL where users can report bugs.+-- bug-reports:+license:            MIT+license-file:       LICENSE+author:             Anthony Super+maintainer:         anthony@noided.media++-- A copyright notice.+-- copyright:+category:           Web+extra-source-files: CHANGELOG.md++common build-deps+  build-depends:+    , attoparsec >= 0.14.1 && <0.15+    , bytestring >= 0.10.8.1 && <0.12+    , contravariant >= 1.5.5 && <1.6+    , jordan >= 0.2.0.0 && <0.3+    , servant >= 0.18 && <0.20+    , text >= 1.2.3.0 && <1.3+    , scientific >= 0.3.7 && <0.4+    , http-types >= 0.12.2 && <0.13+    , http-media >= 0.7 && <0.9+    , transformers >=0.5.5 && <= 0.7+    , parallel >= 3.2 && <=3.3+    , base >= 4.14.1 && <4.17++library+    import: build-deps+    exposed-modules:+        Jordan.Servant+      , Jordan.Servant.Response+      , Jordan.Servant.Query+      , Jordan.Servant.Query.Parse+      , Jordan.Servant.Query.Render++    -- Modules included in this library but not exported.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:+    hs-source-dirs:   lib+    default-language: Haskell2010++test-suite jordan-servant-test+    import: build-deps+    other-modules:+        Jordan.Servant.Query.ParseSpec+      , Jordan.Servant.Query.RoundtripSpec++    build-depends:+        hspec+      , jordan-servant+      , QuickCheck+      , quickcheck-text+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Jordan/ServantSpec.hs

@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Jordan.Servant+  ( JordanJSON,+    ReportingRequestBody,+    JordanQuery',+    RequiredJordanQuery,+    OptionalJordanQuery,+    ViaJordan (..),+  )+where++import Data.Attoparsec.ByteString.Lazy (parseOnly)+import Data.Proxy (Proxy (..))+import Data.Typeable (Proxy (..))+import Jordan.FromJSON.Attoparsec (attoparsecParser)+import Jordan.FromJSON.Class (FromJSON (..))+import Jordan.FromJSON.UnboxedReporting (parseOrReport)+import Jordan.Servant.Query+  ( JordanQuery',+    OptionalJordanQuery,+    RequiredJordanQuery,+  )+import Jordan.Servant.Response (ViaJordan (..))+import Jordan.ToJSON.Builder (toJSONViaBuilder)+import Jordan.ToJSON.Class (ToJSON (..))+import Jordan.Types.JSONError (JSONError)+import Network.HTTP.Media (matchContent)+import Network.HTTP.Media.MediaType ((//), (/:))+import Network.HTTP.Types.Header (hContentType)+import Servant.API+  ( Accept (..),+    HasLink (..),+    MimeRender (..),+    MimeUnrender (..),+    type (:>),+  )++-- | Servant content type that lets you render or parse via Jordan.+--+-- Note: It is generally better to use 'ViaJordan' instead, which gets you nice API documentation.+-- However, you might want to slowly migrate your API to Jordan.+-- In this case, you can use this as a content type.+data JordanJSON++-- | Jordan JSON will have a content type of @ application/json; haskell-encoder=jordan; encoding=utf-8 @.+-- This allows you to conditionally request the Jordanified response.+instance Accept JordanJSON where+  contentType Proxy = "application" // "json" /: ("haskell-encoder", "jordan") /: ("encoding", "utf-8")+  contentTypes p@Proxy =+    pure (contentType p)+      <> pure (("application" // "json") /: ("encoding", "utf-8"))+      <> pure ("application" // "json")++-- | Uses 'Jordan.toJSONViaBuilder'+instance (ToJSON a) => MimeRender JordanJSON a where+  mimeRender Proxy = toJSONViaBuilder++-- | Parses directly from a lazy bytestring via Attoparsec+instance (FromJSON a) => MimeUnrender JordanJSON a where+  mimeUnrender Proxy = parseOnly attoparsecParser+  mimeUnrenderWithType Proxy _ = parseOnly attoparsecParser++-- | A parameter for use with Servant, which lets you parse the request body or report parse errors to the user.+-- It is different from using the existing ReqBody param from Servant in that it will give a detailed report of why the format of the request+-- body was wrong if need be.+--+-- This will use 'Jordan.parseJSONReporting' for its work.+-- This is generally a little slower than direct attoparsec parsing, but avoids us having to parse twice.+data ReportingRequestBody a++instance HasLink sub => HasLink (ReportingRequestBody a :> sub) where+  type MkLink (ReportingRequestBody a :> sub) r = MkLink sub r+  toLink toA (Proxy :: Proxy (ReportingRequestBody a :> sub)) = toLink toA (Proxy @sub)

@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Jordan.Servant.Query+  ( -- * Servant Combinators+    JordanQuery',+    OptionalJordanQuery,+    RequiredJordanQuery,++    -- * Using Jordan with query strings+    -- $queries++    -- ** Parsing Queries+    parseQueryAtKey,+    parseQueryAtKeyWith,+    hasQueryAtKey,++    -- ** Rendering queries+    renderQueryAtKey,+    renderQueryAtKeyWith,+  )+where++import Data.Proxy (Proxy (..))+import GHC.TypeLits (Symbol)+import Jordan.Servant.Query.Parse+  ( hasQueryAtKey,+    parseQueryAtKey,+    parseQueryAtKeyWith,+  )+import Jordan.Servant.Query.Render+  ( renderQueryAtKey,+    renderQueryAtKeyWith,+  )+import Servant.API.Modifiers (Required)++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> :set -XOverloadedStrings+-- >>> :set -XTypeApplications+-- >>> import GHC.Generics+-- >>> import Jordan+-- >>> import Network.HTTP.Types.URI+-- >>> data Person = Person { firstName :: String, lastName :: String } deriving (Show, Read, Eq, Ord, Generic)+-- >>> instance FromJSON Person+-- >>> instance ToJSON Person++-- $queries+--+-- This module provides a way to use Jordan to parse to or render from query strings.+--+-- An example is helpful:+--+-- >>> renderQueryAtKey "person" (Person { firstName = "Rich", lastName = "Evans" })+-- [("person[firstName]",Just "Rich"),("person[lastName]",Just "Evans")]+--+-- >>> renderQuery True $ renderQueryAtKey "person" (Person { firstName = "Rich", lastName = "Evans" })+-- "?person%5BfirstName%5D=Rich&person%5BlastName%5D=Evans"+--+-- >>> parseQueryAtKey @Person "person" $ renderQueryAtKey "person" (Person { firstName = "Mike", lastName = "Stoklassa" })+-- Right (Person {firstName = "Mike", lastName = "Stoklassa"})+--+-- The format of parsed and rendered queries is designed to be \"similar enough\" to how Rails does it, which is+-- also used in several other libraries.++-- | A query argument at some key, that will be parsed via Jordan.+-- If the query needs to contain nested data, it will all be nested under the same key.+--+-- We do not support lenient queries as figuring out what to return in the case where the Jordan parser+-- would have parsed nested keys is too difficult.+--+-- Note: this type *does not* have a 'HasLink' instance, because unfortunately Servant is way too restrictive of what it exports,+-- making such an instance impossible to write. I will open up a PR against Servant to fix this soon.+data JordanQuery' (baseStr :: Symbol) (options :: [*]) (a :: *)++-- | A query argument that is required.+--+-- Will render an error message, in JSON format, if the query was bad in some way.+type RequiredJordanQuery (baseStr :: Symbol) (a :: *) = JordanQuery' baseStr '[Required] a++-- | A query argument that is *optional*.+--+-- Will render an error message, in JSON format, if the query was bad in some way.+type OptionalJordanQuery (baseStr :: Symbol) (a :: *) = JordanQuery' (baseStr :: Symbol) '[] (a :: *)

@@ -0,0 +1,348 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++-- | Turn your jordan parsers into query-string parsers.+--+-- This module should be considered internal.+-- Import Jordan.Servant.Query instead.+module Jordan.Servant.Query.Parse where++import Control.Applicative (Alternative (..), Applicative (..))+import Control.Monad+import Control.Parallel+import qualified Data.Attoparsec.ByteString as AP+import Data.Bifunctor+import qualified Data.ByteString as BS+import Data.Functor+import Data.Maybe (mapMaybe)+import Data.Monoid+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Debug.Trace+import GHC.Generics+import Jordan (parseViaAttoparsec)+import Jordan.FromJSON.Class+import Jordan.FromJSON.Internal.Permutation+import Jordan.Types.Internal.AccumE+import Jordan.Types.JSONError+import Network.HTTP.Types.URI++data QueryKeyComponent+  = RawValue T.Text+  | EmptyBraces+  | BracedValue T.Text+  deriving (Show, Read, Eq, Ord, Generic)++newtype QueryKey = QueryKey {queryKeyComponents :: [QueryKeyComponent]}+  deriving (Show, Read, Eq, Ord, Generic)++labelParser = (AP.<?>)++escapedBrace :: AP.Parser BS.ByteString+escapedBrace = do+  AP.string "]]" `labelParser` "escaped ending brace"+  ("]" <>) <$> afterBrace++afterBrace :: AP.Parser BS.ByteString+afterBrace = do+  taken <- AP.takeWhile (/= 93)+  AP.string "]"+  pure (urlDecode False taken)++escapedBraceEnding :: AP.Parser BS.ByteString+escapedBraceEnding = do+  r <- AP.string "[[" $> "["+  (r <>) <$> unbracedValueInner++unbracedValueInner :: AP.Parser BS.ByteString+unbracedValueInner = do+  keyChars <- AP.takeWhile (/= 91) `labelParser` "until starting brace"+  pure $ urlDecode False keyChars++unbracedValue :: AP.Parser T.Text+unbracedValue = do+  inner <- unbracedValueInner+  case decodeUtf8' inner of+    Left err -> fail (show err)+    Right res+      | res == mempty -> fail "empty unbraced value, invalid"+      | otherwise -> pure res++bracedValue :: AP.Parser T.Text+bracedValue = do+  AP.word8 91 `labelParser` "starting brace"+  after <- afterBrace+  case decodeUtf8' after of+    Left err -> fail $ show err+    Right txt -> pure txt++emptyBraces = do+  AP.string "[]"+  m <- AP.peekWord8+  case m of+    Nothing -> pure EmptyBraces+    Just 93 -> fail "escaped brace"+    Just _ -> pure EmptyBraces++queryComponent :: AP.Parser QueryKeyComponent+queryComponent =+  emptyBraces+    <|> (RawValue <$> unbracedValue)+    <|> (BracedValue <$> bracedValue)++parseQueryKey :: AP.Parser QueryKey+parseQueryKey = QueryKey <$> some queryComponent++newtype QueryParser a = QueryParser+  { runQueryParser ::+      (QueryKey -> Maybe QueryKey) ->+      [(QueryKey, Maybe BS.ByteString)] ->+      Either String (a, [(QueryKey, Maybe BS.ByteString)])+  }++deriving instance Functor QueryParser++instance Applicative QueryParser where+  pure a = QueryParser $ \_ q -> Right (a, q)+  (<*>) = ap++instance Monad QueryParser where+  cb >>= transform = QueryParser $ \read q ->+    case runQueryParser cb read q of+      Left s -> Left s+      Right (a, q') -> runQueryParser (transform a) read q'++-- | Alternative tries the left, than the right.+--+-- Both brances will be sparked off and tried in parallel.+instance Alternative QueryParser where+  empty = QueryParser $ \_ _ -> Left "Alternative.Empty"+  lhs <|> rhs = QueryParser $ \bs q ->+    let lhsR = runQueryParser lhs bs q+        rhsR = runQueryParser rhs bs q+     in rhsR `par` lhsR `pseq` lhsR <|> rhsR++peekTransformedKeyHead :: QueryParser QueryKey+peekTransformedKeyHead = QueryParser $ \transform q ->+  case q of+    [] -> Left "no query elements to peek"+    r@((k, _) : rest) ->+      case transform k of+        Nothing -> Left "could not transform head"+        Just v -> Right (v, r)++readBracketKey :: QueryKey -> QueryParser (T.Text, QueryKeyComponent)+readBracketKey (QueryKey query) = do+  case query of+    (b@(BracedValue val) : rest) -> pure (val, b)+    (b@EmptyBraces : rest) -> pure (mempty, b)+    _ -> failParse "no braced value to consume"++modifyTransformed :: (QueryKey -> Maybe QueryKey) -> QueryParser a -> QueryParser a+modifyTransformed tf (QueryParser cb) = QueryParser $ \transform key ->+  cb (transform >=> tf) key++droppingItem :: QueryKeyComponent -> QueryParser a -> QueryParser a+droppingItem item = modifyTransformed modify+  where+    modify (QueryKey (i : xs))+      | i == item = Just (QueryKey xs)+      | otherwise = Nothing+    modify _ = Nothing++droppingFirst :: QueryParser a -> QueryParser a+droppingFirst = modifyTransformed dropHead+  where+    dropHead (QueryKey (x : xs)) = Just (QueryKey xs)+    dropHead _ = Nothing++asTuple :: QueryParser a -> QueryParser (T.Text, a)+asTuple qp = do+  keyHead <- peekTransformedKeyHead+  (parsedText, item) <- readBracketKey keyHead+  (parsedText,) <$> droppingItem item qp++getTransform :: QueryParser (QueryKey -> Maybe QueryKey)+getTransform = QueryParser $ curry Right++failParse msg = QueryParser $ \_ _ -> Left msg++-- | Take the value at the head, ensuring along the way that the entire query matches.+takeValue :: QueryParser (Maybe BS.ByteString)+takeValue = QueryParser $ \transform queries ->+  case queries of+    [] -> Left "no values to take"+    ((k, v) : rest) ->+      case transform k of+        Nothing -> Left "bad transform"+        Just (QueryKey []) -> Right (v, rest)+        Just r -> Left $ "more query elements to consume: " <> show r++takeElement :: QueryParser BS.ByteString+takeElement = do+  r <- takeValue+  case r of+    Nothing -> failParse "No value"+    Just bs -> pure bs++takeNull :: QueryParser ()+takeNull = do+  r <- takeValue+  case r of+    Nothing -> pure ()+    Just x+      | x == "null" -> pure ()+      | otherwise -> failParse "encountered values where null was expected"++orParseError :: (Show err) => QueryParser (Either err a) -> QueryParser a+orParseError (QueryParser cb) = QueryParser $ \transform query ->+  case cb transform query of+    Left s -> Left s+    Right (r, q) -> case r of+      Left err -> Left $ show err+      Right a -> Right (a, q)++{-+manyEnding parser = many_v+  where+    many_v = some_v <|> (endpure []+    some_v = liftA2 (:) parser many_v+    -}++ensureConsumes :: QueryParser a -> QueryParser a+ensureConsumes a = QueryParser $ \transform q ->+  case runQueryParser a transform q of+    Left s -> Left s+    r@(Right (res, nq))+      | nq == q -> Left "did not consume input"+      | otherwise -> r++newtype JordanQueryParser a = JordanQueryParser {runJordanQueryParser :: QueryParser a}+  deriving (Functor, Applicative) via QueryParser+  deriving (Semigroup) via (Alt QueryParser a)++newtype JordanQueryObjectParser a = JordanQueryObjectParser {runJordanQueryObjectParser :: Permutation QueryParser a}+  deriving (Functor, Applicative) via (Permutation QueryParser)++addArrayBrackets :: QueryParser q -> QueryParser q+addArrayBrackets = modifyTransformed cb+  where+    cb (QueryKey (EmptyBraces : rest)) = Just (QueryKey rest)+    cb _ = Nothing++addJSONKey :: T.Text -> QueryParser q -> QueryParser q+addJSONKey k = modifyTransformed cb+  where+    cb (QueryKey (BracedValue val : rest))+      | val == k = Just (QueryKey rest)+      | otherwise = Nothing+    cb _ = Nothing++instance JSONObjectParser JordanQueryObjectParser where+  parseFieldWith field = \(JordanQueryParser q) ->+    JordanQueryObjectParser $+      asPermutation $+        addJSONKey field q+  parseFieldWithDefault f = \(JordanQueryParser q) def ->+    JordanQueryObjectParser $+      asPermutationWithDefault+        (addJSONKey f q)+        def++toBool :: BS.ByteString -> Either JSONError Bool+toBool "t" = pure True+toBool "true" = pure True+toBool "f" = pure False+toBool "false" = pure False+toBool _ = Left ErrorInvalidJSON++takeText :: QueryParser T.Text+takeText =+  orParseError $+    decodeUtf8' <$> takeElement++instance JSONTupleParser JordanQueryParser where+  consumeItemWith = \x -> x++instance JSONParser JordanQueryParser where+  parseTuple (JordanQueryParser p) =+    JordanQueryParser $+      addArrayBrackets p+  parseObject = \(JordanQueryObjectParser perm) ->+    JordanQueryParser $+      asParser perm+  parseArrayWith = \(JordanQueryParser parse) ->+    JordanQueryParser $ many $ ensureConsumes (addArrayBrackets parse)+  parseNull = JordanQueryParser takeNull+  parseText = JordanQueryParser takeText+  parseBool =+    JordanQueryParser $+      orParseError $ toBool <$> takeElement+  parseDictionary = \(JordanQueryParser parseValue) ->+    JordanQueryParser $ many $ ensureConsumes (asTuple parseValue)+  validateJSON (JordanQueryParser qp) =+    JordanQueryParser $+      orParseError qp+  parseNumber =+    JordanQueryParser $+      orParseError $+        first (const "not a valid number")+          . parseViaAttoparsec+          <$> takeElement++parseQueryToKeys :: Query -> [(QueryKey, Maybe BS.ByteString)]+parseQueryToKeys = mapMaybe transformElement+  where+    transformElement (k, v) = case AP.parseOnly parseQueryKey k of+      Left s -> Nothing+      Right qk -> Just (qk, v)++filterToStarting :: T.Text -> [(QueryKey, Maybe BS.ByteString)] -> [(QueryKey, Maybe BS.ByteString)]+filterToStarting key = mapMaybe keepElement+  where+    keepElement (k, v) =+      case k of+        (QueryKey (RawValue r : rest))+          | r == key -> Just (QueryKey rest, v)+          | otherwise -> Nothing+        _ -> Nothing++transformToKey key = filterToStarting key . parseQueryToKeys++-- | Use Jordan to parse a query at a given \"base\" key.+--+-- We need a base key in case the JSON type is \"just an int\" or something.+parseQueryAtKeyWith ::+  -- | JSON parser to use.+  -- Note the rank-N type.+  (forall jsonParser. (JSONParser jsonParser) => jsonParser a) ->+  -- | Base key to use in the query string.+  T.Text ->+  -- | Query string+  Query ->+  -- | Either a value, or a brief (not super helpful) description of what went wrong.+  Either String a+parseQueryAtKeyWith (JordanQueryParser (QueryParser q)) key queryString = do+  fst <$> q Just (transformToKey key queryString)++-- | Determine if there are any query keys that match this base key.+--+-- >>> hasQueryAtKey "foo" (parseQuery "foo[bar][baz]=true")+-- True+--+-- >>> hasQueryAtKey "foo" (parseQuery "bar[baz]=true&bar[foo]=true&foo=true")+-- True+--+-- >>> hasQueryAtKey "foo" (parseQuery "bar[baz]=true&bar[foo]=true")+-- False+hasQueryAtKey :: T.Text -> Query -> Bool+hasQueryAtKey k q = not (null $ transformToKey k q)++-- | Like 'parseQueryAtKeyWith', but uses the 'FromJSON' instance, which is what you want 90% of the time.+parseQueryAtKey :: (FromJSON a) => T.Text -> Query -> Either String a+parseQueryAtKey = parseQueryAtKeyWith fromJSON

@@ -0,0 +1,110 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Jordan.Servant.Query.Render where++import Data.Bifunctor+import qualified Data.ByteString as BS+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Builder.Scientific+import Data.ByteString.Lazy (toStrict)+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Void+import Jordan.ToJSON.Builder+import Jordan.ToJSON.Class+import Network.HTTP.Types.URI++newtype QueryRender a = QueryRender {runQueryRender :: a -> Query}+  deriving (Semigroup, Monoid) via (a -> Query)++instance Contravariant QueryRender where+  contramap f (QueryRender a) = QueryRender $ a . f++instance Divisible QueryRender where+  conquer = QueryRender mempty+  divide div (QueryRender renderB) (QueryRender renderC) = QueryRender $ \a ->+    let (b, c) = div a in renderB b <> renderC c++instance Selectable QueryRender where+  giveUp f = QueryRender $ absurd . f+  select sel renderL renderR =+    QueryRender $+      either+        (runQueryRender renderL)+        (runQueryRender renderR)+        . sel++escapeBracketComponent :: T.Text -> BS.ByteString+escapeBracketComponent text = urlEncode False encoded+  where+    encoded = encodeUtf8 text+    backsEscaped = BS.intercalate "\\" $ BS.split 92 encoded+    firstEscaped = case BS.stripPrefix "[" backsEscaped of+      Nothing -> encoded+      Just bs -> "\\[" <> bs+    endsEscaped = BS.intercalate "]]" $ BS.split 93 firstEscaped++escapeRawComponent :: T.Text -> BS.ByteString+escapeRawComponent text = urlEncode False encoded+  where+    encoded = encodeUtf8 text++addBracked :: T.Text -> BS.ByteString -> BS.ByteString+addBracked key v =+  "[" <> escapeBracketComponent key <> "]" <> v++addArray :: BS.ByteString -> BS.ByteString+addArray v =+  "[]" <> v++instance JSONObjectSerializer QueryRender where+  serializeFieldWith name = \(QueryRender f) -> QueryRender $ \other ->+    map (first $ addBracked name) $ f other+  serializeJust name qr = QueryRender $ \case+    Nothing -> []+    Just a -> map (first $ addBracked name) $ runQueryRender qr a++instance JSONTupleSerializer QueryRender where+  serializeItemWith = \(QueryRender f) -> QueryRender $ \other ->+    map (first addArray) $ f other++instance JSONSerializer QueryRender where+  serializeObject = \x -> x+  serializeTuple = \x -> x+  serializeTextConstant t = QueryRender $ const [(mempty, Just (encodeUtf8 t))]+  serializeArray =+    QueryRender $+      foldMap $ fmap (first addArray) . runQueryRender toJSON+  serializeNumber = QueryRender $ \num ->+    [(mempty, Just $ toStrict $ toLazyByteString $ scientificBuilder num)]+  serializeNull = QueryRender $ const [(mempty, Nothing)]+  serializeText = QueryRender $ \t ->+    [(mempty, Just (encodeUtf8 t))]+  serializeBool = QueryRender $ \b ->+    pure+      (mempty, if b then Just "t" else Just "f")+  serializeDictionary = \(QueryRender renderItem) -> QueryRender $+    foldMap $ \(key, v) ->+      first (addBracked key) <$> renderItem v++--- | Render a query with a given base key.+renderQueryAtKeyWith ::+  -- | Query renderer to use.+  (forall jsonSerializer. (JSONSerializer jsonSerializer) => jsonSerializer a) ->+  -- | Base key+  T.Text ->+  -- | Value to serialize+  a ->+  -- | Query+  Query+renderQueryAtKeyWith (QueryRender k) key =+  fmap (first (escapeRawComponent key <>)) . k++-- | Render a query at a given key, using the 'ToJSON' instance, which is what you want most of the time.+renderQueryAtKey :: (ToJSON a) => T.Text -> a -> Query+renderQueryAtKey = renderQueryAtKeyWith toJSON

@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++-- | Helpers for rendering responses via Jordan.+module Jordan.Servant.Response where++import Data.Attoparsec.ByteString.Lazy (parseOnly)+import Data.Proxy+import GHC.Generics+import Jordan+import Servant.API+import Servant.API.ContentTypes+import Servant.API.Modifiers++-- | Wrapper to perform JSON serialization via Jordan.+--+-- Types used with this wrapper should have isomorphic 'Jordan.ToJSON' and 'Jordan.FromJSON' instances.+-- A utility is provided to check this.+newtype ViaJordan a = ViaJordan {getViaJordan :: a}+  deriving (Show, Read, Eq, Ord, Generic)++instance FromJSON a => FromJSON (ViaJordan a) where+  fromJSON = ViaJordan <$> fromJSON++instance ToJSON a => ToJSON (ViaJordan a) where+  toJSON = contramap getViaJordan toJSON++instance (HasStatus a) => HasStatus (ViaJordan a) where+  type StatusOf (ViaJordan a) = StatusOf a++-- | Overlapping instance: sidestep Aeson, use Jordan.+instance {-# OVERLAPPING #-} (ToJSON a) => MimeRender JSON (ViaJordan a) where+  mimeRender Proxy = toJSONViaBuilder . getViaJordan++-- | Overlapping instance: sidestep Aeson, just Jordan.+instance {-# OVERLAPPING #-} (FromJSON a) => MimeUnrender JSON (ViaJordan a) where+  mimeUnrender Proxy = parseOnly (ViaJordan <$> attoparsecParser)+  mimeUnrenderWithType Proxy _ = parseOnly (ViaJordan <$> attoparsecParser)

@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}++module Jordan.Servant.Query.ParseSpec where++import qualified Data.Attoparsec.ByteString as AP+import Data.ByteString (ByteString)+import Data.Text (Text)+import GHC.Generics+import Jordan.FromJSON.Class+import Jordan.Servant.Query+import Jordan.Servant.Query.Parse+import Network.HTTP.Types.URI+import Test.Hspec++data CategoryName = CategoryName {category :: Text, name :: Text}+  deriving (Show, Eq, Ord, Generic)+  deriving anyclass (FromJSON)++data CoolFilter = CoolFilter {filterName :: Maybe Text, filterDesc :: Maybe Text}+  deriving (Show, Eq, Ord, Generic)++instance FromJSON CoolFilter where+  fromJSON =+    parseObject $+      CoolFilter+        <$> parseFieldWithDefault "name" (Just <$> fromJSON) Nothing+        <*> parseFieldWithDefault "desc" (Just <$> fromJSON) Nothing++newtype CoolFilters = CoolFilters {getCoolFilters :: [CoolFilter]}+  deriving (Show, Eq, Ord, Generic)++instance FromJSON CoolFilters where+  fromJSON = CoolFilters <$> fromJSON++data IntRange+  = UnboundedAfter Int+  | UnboundedBefore Int+  | Within Int Int+  deriving (Show, Eq, Ord, Generic)++instance FromJSON IntRange where+  fromJSON =+    parseObject (Within <$> parseField "s" <*> parseField "e")+      <> parseObject (UnboundedAfter <$> parseField "s")+      <> parseObject (UnboundedBefore <$> parseField "e")++newtype IntMultiRange = IntMultiRange {getRanges :: [IntRange]}+  deriving (Show, Eq, Ord, Generic)++instance FromJSON IntMultiRange where+  fromJSON = IntMultiRange <$> fromJSON++newtype FilterValues = FilterValues {getFilterValues :: [(Text, Int)]}+  deriving (Show, Eq, Ord, Generic)++instance FromJSON FilterValues where+  fromJSON = FilterValues <$> parseDictionary fromJSON++newtype DictRange = DictRange {getDictRange :: [(Text, IntRange)]}+  deriving (Show, Eq, Ord, Generic)++instance FromJSON DictRange where+  fromJSON = DictRange <$> parseDictionary fromJSON++parsesQTo :: (Show a, Eq a, FromJSON a) => ByteString -> a -> SpecWith ()+parsesQTo bs a =+  it ("parses query string " <> show bs <> " to " <> show a) $+    parseQueryAtKey "q" (parseQueryReplacePlus False bs) `shouldBe` Right a++spec :: Spec+spec = describe "Jordan.Servant.Query" $ do+  stringParsing++stringParsing :: Spec+stringParsing = describe "parsing query strings" $ do+  describe "basic single-field parsing" $ do+    "q=10" `parsesQTo` (10 :: Int)+    "q=foo" `parsesQTo` ("foo" :: Text)+  describe "object parsing with no defaults" $ do+    "q[category]=posts&q[name]=bob" `parsesQTo` CategoryName "posts" "bob"+    "q[name]=joe&q[category]=videos" `parsesQTo` CategoryName "videos" "joe"+  describe "array parsing" $ do+    "q[]=1" `parsesQTo` [1 :: Int]+    "q[]=1&q[]=2" `parsesQTo` [1 :: Int, 2]+  describe "object parsing with two defaults" $ do+    "q[s]=100" `parsesQTo` UnboundedAfter 100+    "q[e]=10" `parsesQTo` UnboundedBefore 10+    "q[e]=10&q[s]=1" `parsesQTo` Within 1 10+  describe "arrays of object parsing" $ do+    "q[][s]=1&q[][e]=10&q[][s]=25" `parsesQTo` IntMultiRange [Within 1 10, UnboundedAfter 25]+  describe "arrays of non-failing objects" $ do+    "q[][name]=wow" `parsesQTo` CoolFilters [CoolFilter (Just "wow") Nothing]+    "" `parsesQTo` CoolFilters []+  describe "simple dictionaries" $ do+    "q[foo]=10&q[bar]=11" `parsesQTo` FilterValues [("foo", 10), ("bar", 11)]+    "" `parsesQTo` FilterValues []+    "q[foo]=100" `parsesQTo` FilterValues [("foo", 100)]+  describe "dictionaries of objects" $ do+    "q[var][e]=10&q[bar][s]=11&q[bar][e]=100" `parsesQTo` DictRange [("var", UnboundedBefore 10), ("bar", Within 11 100)]++parsesAsKey :: ByteString -> QueryKey -> SpecWith ()+parsesAsKey input output =+  it ("should parse " <> show input <> " to query key " <> show output) $+    AP.parseOnly parseQueryKey input `shouldBe` Right output

@@ -0,0 +1,242 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module Jordan.Servant.Query.RoundtripSpec where++import Control.Applicative+import Control.Monad (guard)+import Data.Attoparsec.ByteString (parseOnly)+import Data.Coerce+import Data.Functor.Contravariant+import Data.Proxy+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import GHC.Generics+import Jordan+import Jordan.Servant.Query.Parse (bracedValue, parseQueryAtKey, parseQueryToKeys, transformToKey, unbracedValue)+import Jordan.Servant.Query.Render (addBracked, escapeRawComponent, renderQueryAtKey)+import Network.HTTP.Types.URI+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Utf8++data Color = Red | Green | Blue | Black | Orange | Yellow | White+  deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)+  deriving anyclass (ToJSON, FromJSON)++data HomogenousCoord = HomogenousCoord {x :: Int, y :: Int, z :: Int}+  deriving (Show, Read, Eq, Ord, Generic)++instance FromJSON HomogenousCoord where+  fromJSON =+    parseObject+      ( HomogenousCoord+          <$> parseField "x"+          <*> parseField "y"+          <*> parseFieldWithDefault "z" fromJSON 0+      )++instance ToJSON HomogenousCoord where+  toJSON =+    serializeObject $+      divide+        (\(HomogenousCoord x y z) -> (x, (y, z)))+        (serializeField "x")+        $ divide+          id+          (serializeField "y")+          $ contramap+            (\x -> if x == 0 then Nothing else Just x)+            (serializeJust "z" toJSON)++instance Arbitrary HomogenousCoord where+  arbitrary =+    HomogenousCoord+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary+  shrink (HomogenousCoord x y z) =+    HomogenousCoord <$> shrink x <*> shrink y <*> shrink z++newtype Coords = Coords {getCoords :: [HomogenousCoord]}+  deriving (Show, Read, Eq, Ord, Generic)+  deriving (Arbitrary) via [HomogenousCoord]++deriving via [HomogenousCoord] instance (FromJSON Coords)++deriving via [HomogenousCoord] instance (ToJSON Coords)++instance Arbitrary Color where+  arbitrary = arbitraryBoundedEnum++shrinkText :: T.Text -> [T.Text]+shrinkText t+  | T.length t == 0 = []+  | T.length t == 1 = [mempty]+  | otherwise = mempty : (T.pack . pure <$> T.unpack t)++data Person = Person+  { firstName :: T.Text,+    lastName :: T.Text,+    age :: Int+  }+  deriving (Show, Read, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Arbitrary Person where+  arbitrary = Person <$> genValidUtf8 <*> genValidUtf8 <*> arbitrary+  shrink (Person fn ln a) = Person <$> shrinkText fn <*> shrinkText ln <*> shrink a++data WeirdEnum+  = WeirdNothing+  | WeirdDuo Person Person+  | WeirdSingle Person+  | WeirdColor Color+  deriving (Show, Read, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Arbitrary WeirdEnum where+  arbitrary =+    oneof+      [ pure WeirdNothing,+        WeirdDuo <$> arbitrary <*> arbitrary,+        WeirdSingle <$> arbitrary,+        WeirdColor <$> arbitrary+      ]+  shrink (WeirdDuo lhs rhs) =+    (WeirdDuo <$> shrink lhs <*> shrink rhs)+      <|> (WeirdDuo lhs <$> shrink rhs)+      <|> (WeirdDuo <$> shrink lhs <*> pure rhs)+  shrink (WeirdSingle a) = WeirdSingle <$> shrink a+  shrink _ = []++newtype Feedback = Feedback {ratings :: [(T.Text, Int)]}+  deriving (Show, Read, Eq, Ord, Generic)++instance FromJSON Feedback where+  fromJSON = Feedback <$> parseDictionary fromJSON++instance ToJSON Feedback where+  toJSON = contramap ratings $ serializeDictionary toJSON++instance Arbitrary Feedback where+  arbitrary = Feedback <$> liftArbitrary ((,) <$> genValidUtf8 <*> arbitrary)+  shrink (Feedback xs) = Feedback <$> liftShrink shrinkPair xs+    where+      shrinkPair (l, k) = do+        l' <- shrinkText l+        k' <- shrink k+        pure (l', k')++data PersonFeedback = PersonFeedback {feedbackGiver :: Person, feedbackGiven :: Feedback}+  deriving (Show, Read, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Arbitrary PersonFeedback where+  arbitrary = PersonFeedback <$> arbitrary <*> arbitrary+  shrink (PersonFeedback p f) = PersonFeedback <$> shrink p <*> shrink f++data CoverBases+  = CoverNest PersonFeedback+  | CoverNull ()+  | CoverArray [PersonFeedback]+  deriving (Show, Read, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Arbitrary CoverBases where+  arbitrary =+    oneof+      [ CoverNest <$> arbitrary,+        pure (CoverNull ()),+        CoverArray <$> arbitrary+      ]+  shrink = \case+    CoverNest pf -> CoverNest <$> shrink pf+    CoverNull x0 -> []+    CoverArray xs -> CoverArray <$> shrink xs++robustShrinkWith :: (a -> [a]) -> [a] -> [[a]]+robustShrinkWith _ [] = []+robustShrinkWith shrink (x : xs) =+  robustShrinkWith shrink xs+    ++ [x : xs' | xs' <- robustShrinkWith shrink xs]+    ++ [x' : xs | x' <- shrink x]+    ++ [shrink x]++newtype QueryKey = QueryKey {getQueryKey :: T.Text}+  deriving (Show, Read, Eq, Ord, Generic)++instance Arbitrary QueryKey where+  arbitrary =+    QueryKey+      <$> genValidUtf8 `suchThat` (\t -> T.length t /= 0)+  shrink (QueryKey k)+    | T.length k < 2 = []+    | otherwise = QueryKey . T.pack . pure <$> T.unpack k++queryEquals :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Property+queryEquals (Proxy :: Proxy a) = forAllShrink arbitrary shrink cb+  where+    cb :: (QueryKey, a) -> Property+    cb (key, v) =+      let key' = getQueryKey key+          renderedKey = urlEncode True (encodeUtf8 key')+          unrenderedKey = decodeUtf8 $ urlDecode True renderedKey+          rendered = renderQuery False $ renderQueryAtKey key' v+          parsedBS = parseQuery rendered+          transformed = transformToKey key' parsedBS+          toKeys = parseQueryToKeys parsedBS+          parsed = parseQueryAtKey @a key' $ parseQuery rendered+       in counterexample+            ("Raw was " <> show rendered)+            (parsed === Right v)++serializesInBraces :: T.Text -> Bool+serializesInBraces t =+  let inBraces = addBracked t mempty+      outOfBraces = parseOnly bracedValue inBraces+   in outOfBraces == Right t++testBraces :: T.Text -> Spec+testBraces t =+  it ("properly serializes the key " <> show t <> " in braces") $+    let inBraces = addBracked t mempty+        outOfBraces = parseOnly bracedValue inBraces+     in outOfBraces `shouldBe` Right t++spec :: Spec+spec = do+  it "round-trips the base key" $+    property $+      forAll arbitrary $ \k ->+        let key = getQueryKey k+            escaped = escapeRawComponent key+         in counterexample ("Escaped was " <> show escaped) $+              parseOnly unbracedValue escaped === Right key+  describe "round-tripping" $ do+    it "works for enums" $ queryEquals (Proxy @Color)+    it "works for structs" $ queryEquals (Proxy @Person)+    it "works for weird stuff" $ queryEquals (Proxy @WeirdEnum)+    it "works for dictionaries" $ queryEquals (Proxy @Feedback)+    it "works for person feedback" $ queryEquals (Proxy @PersonFeedback)+    it "works for a weird sum type crap" $ queryEquals (Proxy @CoverBases)+  describe "round-tripping bracked values" $ do+    testBraces "[foo"+    testBraces "\\[foo"+    testBraces "foo]"+    testBraces "[foo]"+    it "works for arbitrary values" $+      forAllShrink genValidUtf8 shrinkText $ \t ->+        let inBraces = addBracked t mempty+            outOfBraces = parseOnly bracedValue inBraces+         in outOfBraces == Right t

@@ -0,0 +1,7 @@+import qualified Jordan.Servant.Query.ParseSpec as PS+import qualified Jordan.Servant.Query.RoundtripSpec as RTS+import Test.Hspec++main = hspec $ do+  PS.spec+  RTS.spec