servant-util-beam-pg (empty) → 0.1.0

raw patch · 11 files changed

+547/−0 lines, 11 filesdep +QuickCheckdep +basedep +beam-core

Dependencies added: QuickCheck, base, beam-core, beam-postgres, containers, hspec, servant, servant-client, servant-client-core, servant-server, servant-util, servant-util-beam-pg, text, universum

Files

• CHANGES.md +6/−0
• README.md +136/−0
• examples/Main.hs +6/−0
• servant-util-beam-pg.cabal +106/−0
• src/Servant/Util/Beam/Postgres.hs +1/−0
• src/Servant/Util/Beam/Postgres/Filtering.hs +174/−0
• src/Servant/Util/Beam/Postgres/Pagination.hs +30/−0
• src/Servant/Util/Beam/Postgres/Sorting.hs +58/−0
• tests/Main.hs +7/−0
• tests/Spec.hs +1/−0
• tests/Tests/Servant/Filtering/LikeSpec.hs +22/−0

@@ -0,0 +1,6 @@+Unreleased+=====++* Add implementation of sorting.+* Add implementation of pagination.+* Add implementation of filtering.

@@ -0,0 +1,136 @@+# Servant-util-beam-pg++This package contains backend implementation for API combinators of `servant-util` package via 'beam-postgres'.++## Build Instructions++Run `stack build servant-util-beam-pg` to build everything.++## Usage++### Sorting++We will demonstrate this on the [previously shown example](/servant-util/README.md#sorting):++```haskell++type instance SortingParamBaseOf Book =+    ["name" ?: Isbn, "author" ?: Text]+type instance SortingParamProvidedOf Book =+    ["isbn" ?: Asc Isbn]++type GetBooks+    :> SortingParamsOf Book+    =  Get '[JSON] [Book]++```++Let's assume that `Book` definition is extended to a Beam table (this is not necessary,+but simplifies our example):++```haskell+data BookT f = Book+    { isbn :: C f Isbn+    , bookName :: C f Text+    , author :: C f Text+    } deriving (Generic)++type Book = BookT Identity+```++Implementation will look like++```haskell++import Servant.Util (SortingSpecOf, HNil, (.*.))+import Servant.Util.Beam.Postgres (fieldSort)++-- some code++getBooks :: _ => SortingSpecOf Book -> m [Book]+getBooks sorting =+    runSelect . select $+        sortBy_ sorting sortingApp $+        all_ (books booksSchema)+  where+    sortingApp Book{..} =+        fieldSort @"name" bookName .*.+        fieldSort @"author" author .*.+        fieldSort @"isbn" isbn .*.+        HNil++```++Function `sortingApp` specifies how to correlate user-provided specification with fields+of our table. For each field which we allow to sort on, we specify a Beam field from the+table.++If one of the fields lacks such specification in `sortingApp` definition or order of+fields is incorrect then compile error is raised. The same happens when field types in API+and schema definition mismatch.++Annotating `fieldSort` calls with a field name is fully optional but may save you in case+when several fields of the same type participate in sorting; this also improves readability.++### Filtering++Filtering is implemented pretty much like sorting.++Let's consider the [previously shown example](/servant-util/README.md#filtering):++```haskell++type instance SortingParamTypesOf Book =+    ["isbn" ?: Word64, "name" ?: Text, "hasLongName" ?: Bool]++type GetBooks+    :> SortingParamsOf Book+    =  Get '[JSON] [Book]++```++Implementation can look like++```haskell++import Servant.Util (FilteringSpecOf, HNil, (.*.))+import Servant.Util.Beam.Postgres (filterOn, manualFilter, matches_)++-- some code++getBooks :: _ => FilteringSpecOf Book -> m [Book]+getBooks filters =+    runSelect . select $ do+        book <- all_ (books booksSchema)+        guard_ $ matches_ filters (filteringApp book)+        return book+  where+    filteringApp Book{..} =+        filterOn @"isbn" isbn .*.+        filterOn @"name" bookName .*.+        manualFilter @"hasLongName"+            (\hasLongName -> hasLongName ==. (charLength_ bookName >=. 10)) .*.+        HNil++```++Again, for each possible user-provided filter you have to provide an implementation.+Automatic filters require only a corresponding field of response, they will apply the required+operation to it themselves. On the other hand, manual filters carry the value that+user provides, and you implement the predicate on this value.++Again, type annotations in `filterOn` and `manualFilter` calls are optional.++### Pagination++Pagination can be applied simply with `paginate_` function.++## For Contributors++Please see [CONTRIBUTING.md](/.github/CONTRIBUTING.md) for more information.++## About Serokell++Servant-util is maintained and funded with :heart: by [Serokell](https://serokell.io/). The names and logo for Serokell are trademark of Serokell OÜ.++We love open source software! See [our other projects](https://serokell.io/community?utm_source=github) or [hire us](https://serokell.io/hire-us?utm_source=github) to design, develop and grow your idea!

@@ -0,0 +1,6 @@+module Main where++import Universum++main :: IO ()+main = pass

@@ -0,0 +1,106 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6d07832d48e5a3f9a5d1880bdde23df7a5c0af680f58336a1d5d874de0732ca1++name:           servant-util-beam-pg+version:        0.1.0+synopsis:       Implementation of servant-util primitives for beam-postgres.+category:       Servant, Web, Database+homepage:       https://github.com/serokell/servant-util#readme+bug-reports:    https://github.com/serokell/servant-util/issues+author:         Serokell+maintainer:     hi@serokell.io+copyright:      2019-2021 Serokell OÜ+license:        MPL-2.0+build-type:     Simple+extra-source-files:+    README.md+    CHANGES.md++source-repository head+  type: git+  location: https://github.com/serokell/servant-util++library+  exposed-modules:+      Servant.Util.Beam.Postgres+      Servant.Util.Beam.Postgres.Filtering+      Servant.Util.Beam.Postgres.Pagination+      Servant.Util.Beam.Postgres.Sorting+  other-modules:+      Paths_servant_util_beam_pg+  hs-source-dirs:+      src+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications+  ghc-options: -Wall+  build-tool-depends:+      autoexporter:autoexporter+  build-depends:+      base >=4.7 && <5+    , beam-core+    , beam-postgres+    , containers+    , servant+    , servant-client+    , servant-client-core+    , servant-server+    , servant-util >=0.1.0 && <0.2+    , text+    , universum+  default-language: Haskell2010++executable servant-util-beam-pg-examples+  main-is: Main.hs+  other-modules:+      Paths_servant_util_beam_pg+  hs-source-dirs:+      examples+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2+  build-depends:+      base >=4.7 && <5+    , beam-core+    , beam-postgres+    , containers+    , servant+    , servant-client+    , servant-client-core+    , servant-server+    , servant-util >=0.1.0 && <0.2+    , text+    , universum+  default-language: Haskell2010++test-suite servant-util-beam-pg-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Spec+      Tests.Servant.Filtering.LikeSpec+      Paths_servant_util_beam_pg+  hs-source-dirs:+      tests+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , beam-core+    , beam-postgres+    , containers+    , hspec+    , servant+    , servant-client+    , servant-client-core+    , servant-server+    , servant-util >=0.1.0 && <0.2+    , servant-util-beam-pg+    , text+    , universum+  default-language: Haskell2010

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter -Wno-dodgy-exports -Wno-unused-imports #-}

@@ -0,0 +1,174 @@+{- | Implements filtering with beam-postgres.++When setting filtering for an endpoint, you usually need to construct a filtering spec+application first, which describes how to perform filtering over your rows:++@+filteringSpecApp+    :: FilteringSpecApp+        (QExprFilterBackend syntax s)+        [ "course" ?: 'AutoFilter Course+        , "desc" ?: 'AutoFilter Text+        , "isAwesome" ?: 'ManualFilter Bool+        ]+filteringSpecApp =+    filterOn_ @"course" courseField .*.+    filterOn_ @"desc" descField .*.+    customFilter_ @"isAwesome"+        (\isAwesome -> (courseAwesomeness >. val_ 42) ==. val_ isAwesome) .*.+    HNil+@++Annotating 'filterOn' and 'customFilter' calls with parameter name is fully optional+and used only to visually disambiguate filters of the same types.++Next, you use 'matches_' or 'filterGuard_' to build a filtering expression understandable+by Beam.+-}+module Servant.Util.Beam.Postgres.Filtering+    ( matches_+    , filtersGuard_+    , filterOn+    , manualFilter++      -- * Internals+    , likeToSqlPattern+    ) where++import Universum++import Database.Beam.Backend.SQL (BeamSqlBackend, BeamSqlBackendIsString, BeamSqlBackendSyntax,+                                  HasSqlValueSyntax, Sql92ExpressionValueSyntax,+                                  Sql92SelectSelectTableSyntax, Sql92SelectTableExpressionSyntax)+import Database.Beam.Backend.SQL.SQL92 (Sql92SelectSyntax)+import Database.Beam.Query (HasSqlEqualityCheck, Q, guard_, in_, like_, val_, (&&.), (/=.), (<.),+                            (<=.), (==.), (>.), (>=.))+import Database.Beam.Query.Internal (QExpr)++import Servant.Util.Combinators.Filtering.Backend+import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Filters++-- | Implements filters via Beam query expressions ('QExpr').+data QExprFilterBackend be s++instance FilterBackend (QExprFilterBackend be s) where++    type AutoFilteredValue (QExprFilterBackend be s) a =+        QExpr be s a++    type MatchPredicate (QExprFilterBackend be s) =+        QExpr be s Bool++instance ( HasSqlEqualityCheck be a+         , HasSqlValueSyntax+            (Sql92ExpressionValueSyntax+              (Sql92SelectTableExpressionSyntax+                  (Sql92SelectSelectTableSyntax+                    (Sql92SelectSyntax+                        (Database.Beam.Backend.SQL.BeamSqlBackendSyntax be)))))+           a+         ) =>+         AutoFilterSupport (QExprFilterBackend be s) FilterMatching a where+    autoFilterSupport = \case+        FilterMatching v    -> (==. val_ v)+        FilterNotMatching v -> (/=. val_ v)+        FilterItemsIn vs    -> (`in_` map val_ vs)++instance ( BeamSqlBackend be+         , HasSqlValueSyntax+            (Sql92ExpressionValueSyntax+              (Sql92SelectTableExpressionSyntax+                  (Sql92SelectSelectTableSyntax+                    (Sql92SelectSyntax+                        (Database.Beam.Backend.SQL.BeamSqlBackendSyntax be)))))+           a+         ) =>+         AutoFilterSupport (QExprFilterBackend be s) FilterComparing a where+    autoFilterSupport = \case+        FilterGT v  -> (>. val_ v)+        FilterLT v  -> (<. val_ v)+        FilterGTE v -> (>=. val_ v)+        FilterLTE v -> (<=. val_ v)++-- For now we do not support custom escape characters.+pattern PgEsc :: Char+pattern PgEsc = '\\'++likeToSqlPattern :: LikePattern -> String+likeToSqlPattern = go . toString . unLikePattern+  where+    go = \case+        Esc : '.' : r -> '.' : go r+        Esc : '*' : r -> '*' : go r+        Esc : c : r   -> Esc : c : go r++        '_' : r       -> PgEsc : '_' : go r+        '%' : r       -> PgEsc : '%' : go r++        '.' : r       -> '_' : go r+        '*' : r       -> '%' : go r++        c : r         -> c : go r+        []            -> []++instance ( IsString text+         , BeamSqlBackend be+         , BeamSqlBackendIsString be text+         , HasSqlValueSyntax+            (Sql92ExpressionValueSyntax+              (Sql92SelectTableExpressionSyntax+                  (Sql92SelectSelectTableSyntax+                    (Sql92SelectSyntax+                        (Database.Beam.Backend.SQL.BeamSqlBackendSyntax be)))))+           text+         ) =>+         AutoFilterSupport (QExprFilterBackend be s) FilterLike text where+    autoFilterSupport = \case+        FilterLike (CaseSensitivity True) pat ->+            let sqlPat = fromString $ likeToSqlPattern pat+            in (`like_` val_ sqlPat)+        FilterLike (CaseSensitivity False) _ ->+            -- TODO: allow disabling this at parsing stage+            error "Case-insensitive filters are not supported by this backend."++-- | Applies a whole filtering specification to a set of response fields.+-- Resulting value can be put to 'guard_' or 'filter_' function.+matches_+    :: ( BeamSqlBackend be+       , backend ~ QExprFilterBackend be s+       , BackendApplySomeFilter backend params+       )+    => FilteringSpec params+    -> FilteringSpecApp backend params+    -> QExpr be s Bool+matches_ = foldr (&&.) (val_ True) ... backendApplyFilters++-- | Implements filters via Beam query monad ('Q').+data QFilterBackend be (db :: (* -> *) -> *) s++instance FilterBackend (QFilterBackend be db s) where++    type AutoFilteredValue (QFilterBackend be db s) a =+        QExpr be s a++    type MatchPredicate (QFilterBackend be db s) =+        Q be db s ()++instance ( BeamSqlBackend be+         , AutoFilterSupport (QExprFilterBackend be s) filter a+         ) =>+         AutoFilterSupport (QFilterBackend be db s) filter a where+    autoFilterSupport =+      guard_ ... autoFilterSupport @(QExprFilterBackend _ _)++-- | Applies a whole filtering specification to a set of response fields.+-- Resulting value can be monadically binded with the remaining query (just like 'guard_').+filtersGuard_+    :: ( backend ~ QFilterBackend be db s+       , BackendApplySomeFilter backend params+       )+    => FilteringSpec params+    -> FilteringSpecApp backend params+    -> Q be db s ()+filtersGuard_ = sequence_ ... backendApplyFilters

@@ -0,0 +1,30 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++-- | Implements pagination in terms of `beam-postgres`.+module Servant.Util.Beam.Postgres.Pagination+    ( paginate_+    ) where++import Universum++import Database.Beam.Query (Q, limit_, offset_)+import Database.Beam.Query.Internal (QNested)++import Servant.Util.Combinators.Pagination+import Servant.Util.Internal.Util++-- | Truncate response according to the given pagination specification.+paginate_+    :: _+    => PaginationSpec+    -> Q select db (QNested (QNested s)) a+    -> Q select db s _+paginate_ PaginationSpec{..} =+    limit_ (maybe maxLimit (fromIntegral . unPositive) psLimit) .+    offset_ (fromIntegral psOffset)+  where+    -- We cannot just omit 'limit_' (types won't match),+    -- negative value does not work as well.+    -- So applying max value which can be passed to limit.+    maxLimit = fromIntegral (maxBound @Int64)

@@ -0,0 +1,58 @@+-- | Converting a sorting specification to a value understandable by Beam.+module Servant.Util.Beam.Postgres.Sorting+    ( SortingSpecApp+    , fieldSort+    , sortBy_+    ) where++import Universum++import Data.Coerce (coerce)+import Database.Beam.Backend.SQL (BeamSqlBackend)+import Database.Beam.Query (SqlOrderable, asc_, desc_, orderBy_)+import Database.Beam.Query.Internal (Projectible, Q, QExpr, QNested, QOrd, ThreadRewritable,+                                     WithRewrittenThread)++import Servant.Util.Combinators.Sorting.Backend+import Servant.Util.Combinators.Sorting.Base++-- | Implements sorting for beam-postgres package.+data BeamSortingBackend be s++instance (BeamSqlBackend be) =>+         SortingBackend (BeamSortingBackend be s) where++    type SortedValue (BeamSortingBackend be s) a =+        QExpr be s a++    type BackendOrdering (BeamSortingBackend be s) =+        QOrd be s Void++    backendFieldSort field = SortingApp $ \(SortingItemTagged (SortingItem _name order)) ->+        let applyOrder = case order of+                Ascendant  -> asc_+                Descendant -> desc_++        -- TODO [DSCP-425]+        -- Ordering NULLs is not supported by SQLite :peka:+        -- nullsOrder = case siNullsOrder of+        --     Nothing         -> id+        --     Just NullsFirst -> nullsFirst_+        --     Just NullsLast  -> nullsLast_++        in applyOrder (coerce field)++-- | Applies 'orderBy_' according to the given sorting specification.+sortBy_+    :: ( backend ~ BeamSortingBackend syntax0 s0+       , allParams ~ AllSortingParams provided base+       , ApplyToSortItem backend allParams+       , Projectible be a+       , SqlOrderable be (BackendOrdering backend)+       , ThreadRewritable (QNested s) a+       )+    => SortingSpec provided base+    -> (a -> SortingSpecApp backend allParams)+    -> Q be db (QNested s) a+    -> Q be db s (WithRewrittenThread (QNested s) s a)+sortBy_ spec app = orderBy_ (backendApplySorting spec . app)

@@ -0,0 +1,7 @@+import Spec (spec)+import Test.Hspec (hspec)++import Universum++main :: IO ()+main = hspec spec

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,22 @@+module Tests.Servant.Filtering.LikeSpec where++import Universum++import Servant.Util.Beam.Postgres.Filtering++import Test.Hspec (Spec, describe, it)+import Test.QuickCheck ((===))++spec :: Spec+spec = do+    describe "Plain regex to SQL like syntax is converted fine" $ do+        it "No spec characters" $+            likeToSqlPattern "abc" === "abc"+        it "Simple replacement" $+            likeToSqlPattern "a.b*c" === "a_b%c"+        it "Escaping in source" $+            likeToSqlPattern "a\\.b\\*c" === "a.b*c"+        it "Escaping escaping in source" $+            likeToSqlPattern "a\\\\.b\\\\*c" === "a\\\\_b\\\\%c"+        it "Escaping" $+            likeToSqlPattern "a_b%c" === "a\\_b\\%c"