├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── cabal.project ├── composite-aeson-path ├── Setup.hs ├── composite-aeson-path.cabal ├── package.nix ├── package.yaml └── src │ └── Composite │ └── Aeson │ └── Path.hs ├── composite-aeson-refined ├── Setup.hs ├── composite-aeson-refined.cabal ├── package.nix ├── package.yaml └── src │ └── Composite │ └── Aeson │ └── Refined.hs ├── composite-aeson ├── Setup.hs ├── composite-aeson.cabal ├── package.nix ├── package.yaml ├── src │ └── Composite │ │ ├── Aeson.hs │ │ └── Aeson │ │ ├── Base.hs │ │ ├── CoRecord.hs │ │ ├── DateTimeFormatUtils.hs │ │ ├── Enum.hs │ │ ├── Formats │ │ ├── DateTime.hs │ │ ├── Default.hs │ │ ├── Generic.hs │ │ ├── InternalTH.hs │ │ └── Provided.hs │ │ ├── Record.hs │ │ └── TH.hs └── test │ ├── DateTimeSpec.hs │ ├── EnumSpec.hs │ ├── FieldSpec.hs │ ├── Main.hs │ ├── RecordSpec.hs │ ├── THSpec.hs │ └── TupleSpec.hs ├── composite-base ├── Setup.hs ├── composite-base.cabal ├── package.nix ├── package.yaml ├── src │ ├── Composite.hs │ ├── Composite │ │ ├── CoRecord.hs │ │ ├── Record.hs │ │ └── TH.hs │ └── Control │ │ └── Monad │ │ └── Composite │ │ └── Context.hs └── test │ ├── Main.hs │ ├── RecordSpec.hs │ └── THSpec.hs ├── composite-binary ├── Setup.hs ├── composite-binary.cabal ├── package.nix ├── package.yaml └── src │ └── Composite │ └── Record │ └── Binary.hs ├── composite-ekg ├── Setup.hs ├── composite-ekg.cabal ├── package.nix ├── package.yaml ├── src │ └── Composite │ │ └── Ekg.hs └── stack.yaml ├── composite-hashable ├── Setup.hs ├── composite-hashable.cabal ├── package.nix ├── package.yaml └── src │ └── Composite │ └── Record │ └── Hashable.hs ├── composite-opaleye ├── Setup.hs ├── composite-opaleye.cabal ├── package.nix ├── package.yaml ├── src │ └── Composite │ │ ├── Opaleye.hs │ │ └── Opaleye │ │ ├── ProductProfunctors.hs │ │ ├── RecordTable.hs │ │ ├── TH.hs │ │ ├── Update.hs │ │ └── Util.hs └── test │ ├── Main.hs │ └── UpdateSpec.hs ├── composite-reflex ├── .gitignore ├── Setup.hs ├── composite-reflex.cabal ├── package.nix ├── package.yaml ├── platform.nix ├── shell.nix └── src │ └── Composite │ ├── DMap.hs │ ├── Reflex.hs │ └── Reflex │ ├── AuthWrapper.hs │ └── Routing.hs ├── composite-swagger ├── Setup.hs ├── composite-swagger.cabal ├── package.nix ├── package.yaml ├── src │ └── Composite │ │ ├── Swagger.hs │ │ └── Swagger │ │ ├── Base.hs │ │ ├── OrphanInstances.hs │ │ └── TH.hs └── test │ ├── Main.hs │ └── THSpec.hs ├── default.nix ├── example ├── .gitignore ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── example.sql ├── myawesomeserver.cabal ├── package.nix ├── package.yaml ├── scripts │ └── generate-swagger.hs └── src │ ├── Api.hs │ ├── ApiOrphans.hs │ ├── App.hs │ ├── Foundation.hs │ ├── Logging.hs │ ├── Metrics.hs │ └── Types.hs ├── stack-8.10.2.yaml ├── stack-8.6.5.yaml ├── stack-8.6.5.yaml.lock ├── stack-8.8.3.yaml ├── stack-8.8.3.yaml.lock ├── stack.yaml ├── stack.yaml.lock ├── update-build-shell.nix └── update-build.sh /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | _sdists/ 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # https://nixos.wiki/wiki/Nix_on_Travis 2 | language: nix 3 | cache: 4 | directories: 5 | - $HOME/nix.store 6 | os: linux 7 | dist: bionic 8 | 9 | before_install: 10 | - sudo mkdir -p /etc/nix 11 | - echo "substituters = https://cache.nixos.org/ file://$HOME/nix.store" | sudo tee -a /etc/nix/nix.conf > /dev/null 12 | - echo 'require-sigs = false' | sudo tee -a /etc/nix/nix.conf > /dev/null 13 | - nix-env -iA nixpkgs.stack 14 | 15 | before_cache: 16 | - mkdir -p $HOME/nix.store 17 | - nix copy --to file://$HOME/nix.store -f default.nix buildInputs 18 | 19 | before_script: 20 | - sudo mkdir -p /etc/nix && echo 'sandbox = true' | sudo tee /etc/nix/nix.conf 21 | 22 | script: 23 | - make build 24 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## 0.8.0.0 4 | 5 | * Support GHC 9.2.2, and with that make breaking aeson changes 6 | 7 | ## 0.7.6.0 8 | 9 | * Code now compiles with Stackage LTS 19.7 10 | * Add support for contravariant functors and lenses 11 | 12 | Thanks to @locallycompact! 13 | 14 | ## 0.7.5.0 15 | 16 | * Update stack resolver and lens upper bound. 17 | * Added travis CI support. 18 | 19 | Thanks to @locallycompact @peterbecich! 20 | 21 | ## 0.7.4.0 22 | 23 | * Update Stackage nightly support to 2020-08-13, widended dependency version bounds. 24 | * Add NFData instances for `(:->)` and `Record` / `Rec Identity`. 25 | * Add `composite-aeson-path` with JSON formats for the `path` package. 26 | * Add `composite-binary` with orphan instances for the `binary` package. 27 | * Add `composite-hashable` with orphan instances for the `hashable` package. 28 | * Add `IsoHKD Identity (s :-> a)` instance. 29 | 30 | Thanks to @locallycompact! 31 | 32 | ## 0.7.3.0 33 | 34 | * Support GHC 8.10 / Stackage nightly 2020-07-19, widened dependency version bounds. 35 | 36 | Thanks to @locallycompact! 37 | 38 | ## 0.7.2.0 39 | 40 | * Support GHC 8.8 / LTS-16.5, widened dependency version bounds. 41 | 42 | Thanks to @locallycompact! 43 | 44 | ## 0.7.1.0 45 | 46 | * Split out fieldJsonFormat and sumJsonFormat into encode-only and decode-only versions. 47 | 48 | ## 0.7.0.0 49 | 50 | * Round out functions for working with decode-only or encode-only records. 51 | * Rename ToField to ToJsonField and FromField to FromJsonField. 52 | 53 | ## 0.6.2.0 54 | 55 | * Widen vinyl bound to >= 0.5.3 && < 0.13 (was < 0.12) 56 | * Unbreak deriveOpaleyeEnum for newer PostgreSQL which won't implicitly convert text to an enum. 57 | 58 | ## 0.6.1.0 59 | 60 | * Code now compiles with Stackage LTS 14.20 61 | 62 | ## 0.6.0.0 63 | 64 | * Code now compiles with the lastest Stackage LTS (14.3) 65 | * Incorporates underlying Vinyl framework typeclasses instead of proxies. This has resulted in a few 66 | breaking changes to the composite API, mostly in the `-base` project. 67 | * [reifyVal](http://hackage.haskell.org/package/composite-base-0.6.0.0/docs/Composite-Record.html#v:reifyVal) 68 | provided to assist with compiler inference. 69 | 70 | Thanks to @dfithian! 71 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Confer Health, Inc. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Confer Health nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: build update-build clean reallyclean sdist 3 | 4 | build: update-build 5 | stack test --nix --no-interleaved-output --ghc-options="-Wall -Werror" 6 | 7 | update-build: 8 | nix-shell update-build-shell.nix --run ./update-build.sh 9 | 10 | clean: 11 | stack clean 12 | 13 | reallyclean: 14 | rm -rf .stack-work */.stack-work _sdists 15 | 16 | sdist: reallyclean build 17 | stack sdist 18 | mkdir -p _sdists 19 | cp */.stack-work/dist/*/*/*.tar.gz _sdists 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | > :warning: **This project has moved to https://github.com/composite-hs.** 2 | 3 | ## composite 4 | 5 | [![Build Status](https://travis-ci.com/ConferOpenSource/composite.svg?branch=master)](https://travis-ci.com/ConferOpenSource/composite) 6 | 7 | Composite is a group of libraries focusing on practical uses of composite records, in particular [Vinyl](https://github.com/VinylRecords/Vinyl/), such as querying records from a database and converting them to JSON. These libraries are based on the excellent [Frames](https://github.com/acowley/Frames) style use of Vinyl records, though composite implements its own derived from Frames to make for a smaller dependency graph, as Frames is a full CSV parsing/printing and data manipulation library. 8 | 9 | ### `composite-aeson` 10 | 11 | `composite-aeson` provides JSON formatting facilities for records. JSON formats can be derived automatically when default formats are available, explicitly assembled, combined, or a mix. Aeson's use of `FromJSON`/`ToJSON` type classes is mostly avoided to make using JSON formats first-class while still convenient. 12 | 13 | Example: 14 | 15 | ```haskell 16 | {-# LANGUAGE DataKinds, OverloadedStrings, PatternSynonyms, TypeOperators #-} 17 | import qualified Data.Aeson as Aeson 18 | import Composite.Aeson (JsonFormat, defaultJsonFormatRecord, recordJsonFormat, toJsonWithFormat) 19 | import Composite.Record (Record, Rec(RNil), (:->), pattern (:*:)) 20 | import Data.Text (Text) 21 | 22 | type FId = "id" :-> Int 23 | type FName = "name" :-> Text 24 | type User = '[FId, FName] 25 | 26 | userFormat :: JsonFormat e (Record User) 27 | userFormat = recordJsonFormat defaultJsonFormatRecord 28 | 29 | alice :: Record User 30 | alice = 1 :*: "Alice" :*: RNil 31 | 32 | aliceJson :: Aeson.Value 33 | aliceJson = toJsonWithFormat userFormat alice 34 | ``` 35 | 36 | ### `composite-aeson-path` 37 | 38 | `composite-aeson` support for the [path](https://hackage.haskell.org/package/path) library. 39 | 40 | ### `composite-aeson-refined` 41 | 42 | `composite-aeson` support for the [refined](https://hackage.haskell.org/package/refined) library. 43 | 44 | ### `composite-base` 45 | 46 | Definitions shared by the other composite libraries or generally useful when using Vinyl records. Includes some Template Haskell splices to generate various optics for records, as well as a specialization of `MonadReader` which works on a context record, providing general environment for a computation. 47 | 48 | ### `composite-binary` 49 | 50 | Instance of `Binary` from the [binary](https://hackage.haskell.org/package/binary) library for composite records. 51 | 52 | ### `composite-ekg` 53 | 54 | Autoconfiguration of [EKG](https://hackage.haskell.org/package/ekg) from a record of EKG metrics. 55 | 56 | ### `composite-hashable` 57 | 58 | Instance of `Hashable` from the [hashable](https://hackage.haskell.org/package/hashable) library for composite records. 59 | 60 | ### `composite-opaleye` 61 | 62 | `composite-opaleye` provides the necessary instances to use a Vinyl record with the [opaleye](https://github.com/tomjaguarpaw/haskell-opaleye) library, letting you use records for query expressions as well as result rows. 63 | 64 | Example: 65 | 66 | ```haskell 67 | {-# LANGUAGE Arrows, DataKinds, FlexibleContexts, OverloadedStrings, PatternSynonyms, TemplateHaskell, TypeOperators #-} 68 | import Control.Arrow (returnA) 69 | import Composite.Opaleye (defaultRecTable) 70 | import Composite.Record (Record, (:->)) 71 | import Composite.TH (withLensesAndProxies) 72 | import Control.Lens (view) 73 | import Data.Int (Int64) 74 | import Data.Proxy (Proxy(Proxy)) 75 | import Data.Text (Text) 76 | import Opaleye (Column, PGInt8, PGText, Query, Table(Table), (./=), asc, constant, orderBy, queryTable, restrict) 77 | 78 | -- For each field type defined with, withLensesAndProxies will expand to the type, a record lens for the type, 79 | -- and a proxy for the type, so for example FId is the type, fId is a lens which accesses the "id" field of any 80 | -- record which contains that field, and fId_ is a proxy for the field type in case it's needed. 81 | withLensesAndProxies [d| 82 | type FId = "id" :-> Int64 83 | type CId = "id" :-> Column PGInt8 84 | type FName = "name" :-> Text 85 | type CName = "name" :-> Column PGText 86 | |] 87 | 88 | type User = '[FId, FName] 89 | type UserCols = '[CId, CName] 90 | 91 | userTable :: Table (Record UserCols) (Record UserCols) 92 | userTable = Table "users" defaultRecTable 93 | 94 | userQuery :: Query (Record UserCols) 95 | userQuery = 96 | orderBy (asc $ view cName) $ proc () -> do 97 | user <- queryTable userTable -< () 98 | let recId = view cId user 99 | restrict -< recId ./= constant (1 :: Int64) 100 | returnA -< user 101 | ``` 102 | 103 | ### `composite-swagger` 104 | 105 | Automatic derivation of Swagger 2 (ala [swagger2](https://hackage.haskell.org/package/swagger2)) definitions for composite records. 106 | 107 | ### Related work 108 | 109 | - [`compdoc`](https://hackage.haskell.org/package/compdoc) provides functionality for reading a Pandoc into a record. 110 | - [`composite-dhall`](https://hackage.haskell.org/package/composite-dhall) provides `ToDhall` and `FromDhall` instances for composite records. 111 | - [`composite-tuple`](https://hackage.haskell.org/package/composite-tuple) provides utility functions for treating composite records as tuples, ala `Relude.Extra.Tuple` from [relude](https://hackage.haskell.org/package/relude). 112 | - [`fcf-composite`](https://hackage.haskell.org/package/fcf-composite) provides integration with first-class-families for type-level computation of records. 113 | - [`polysemy-methodology-composite`](https://hackage.haskell.org/package/polysemy-methodology-composite) provides functions for using polysemy-methodology with composite. 114 | 115 | ### `example` 116 | 117 | A small servant based server which uses `composite-opaleye` to pull records from the database, reshape 118 | the record to an API type, and send the records out to the client as JSON via `composite-aeson`. 119 | 120 | ## Maturity 121 | 122 | As of writing, we use these libraries in all our Haskell projects internally and have had no major issues. There are spots using either composite or vinyl where the compiler error messages could use improvement. There are certain use cases that can cause the simplifier to crash, though we have not observed any runtime errors as yet. They have not been proven out for performance at larger scale. We'd appreciate any fixes, improvements, or experience reports. 123 | 124 | ## Contributing 125 | 126 | Contributions and feedback welcome! File an issue or make a PR. 127 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | composite-aeson/ 3 | composite-aeson-path/ 4 | composite-aeson-refined/ 5 | composite-base/ 6 | composite-binary/ 7 | composite-hashable/ 8 | composite-opaleye/ 9 | -- TODO fix when reflex-dom is on 9.2.2 10 | -- composite-reflex/ 11 | composite-swagger/ 12 | -------------------------------------------------------------------------------- /composite-aeson-path/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-aeson-path/composite-aeson-path.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: ceba640b155026970b1166714ba98325345257eb13386d58a90cc229aae6477f 8 | 9 | name: composite-aeson-path 10 | version: 0.8.0.0 11 | synopsis: Formatting data for the path library. 12 | description: JsonFormat for Path. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Aeson.Path 24 | other-modules: 25 | Paths_composite_aeson_path 26 | hs-source-dirs: 27 | src 28 | default-extensions: 29 | DataKinds 30 | FlexibleContexts 31 | FlexibleInstances 32 | GeneralizedNewtypeDeriving 33 | LambdaCase 34 | MultiParamTypeClasses 35 | MultiWayIf 36 | OverloadedStrings 37 | PatternSynonyms 38 | PolyKinds 39 | QuasiQuotes 40 | RankNTypes 41 | ScopedTypeVariables 42 | StandaloneDeriving 43 | StrictData 44 | TemplateHaskell 45 | TupleSections 46 | TypeFamilies 47 | TypeOperators 48 | ViewPatterns 49 | ghc-options: -Wall -O2 50 | build-depends: 51 | base >=4.12 && <5 52 | , composite-aeson ==0.8.* 53 | , path >=0.6 && <0.9 54 | default-language: Haskell2010 55 | -------------------------------------------------------------------------------- /composite-aeson-path/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, composite-aeson, hpack, lib, path }: 2 | mkDerivation { 3 | pname = "composite-aeson-path"; 4 | version = "0.8.0.0"; 5 | src = ./.; 6 | libraryHaskellDepends = [ base composite-aeson path ]; 7 | libraryToolDepends = [ hpack ]; 8 | prePatch = "hpack"; 9 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 10 | description = "Formatting data for the path library"; 11 | license = lib.licenses.bsd3; 12 | } 13 | -------------------------------------------------------------------------------- /composite-aeson-path/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-aeson-path 2 | version: 0.8.0.0 3 | synopsis: Formatting data for the path library. 4 | description: JsonFormat for Path. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - path >= 0.6 && < 0.9 15 | - composite-aeson >= 0.8 && < 0.9 16 | 17 | default-extensions: 18 | - DataKinds 19 | - FlexibleContexts 20 | - FlexibleInstances 21 | - GeneralizedNewtypeDeriving 22 | - LambdaCase 23 | - MultiParamTypeClasses 24 | - MultiWayIf 25 | - OverloadedStrings 26 | - PatternSynonyms 27 | - PolyKinds 28 | - QuasiQuotes 29 | - RankNTypes 30 | - ScopedTypeVariables 31 | - StandaloneDeriving 32 | - StrictData 33 | - TemplateHaskell 34 | - TupleSections 35 | - TypeFamilies 36 | - TypeOperators 37 | - ViewPatterns 38 | 39 | ghc-options: -Wall -O2 40 | 41 | library: 42 | source-dirs: src 43 | -------------------------------------------------------------------------------- /composite-aeson-path/src/Composite/Aeson/Path.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Composite.Aeson.Path where 3 | 4 | import Composite.Aeson(JsonFormat, aesonJsonFormat, DefaultJsonFormat(defaultJsonFormat)) 5 | import Path(Path, Rel, Abs, File, Dir) 6 | 7 | relFileJsonFormat :: JsonFormat e (Path Rel File) 8 | relFileJsonFormat = aesonJsonFormat 9 | 10 | relDirJsonFormat :: JsonFormat e (Path Rel Dir) 11 | relDirJsonFormat = aesonJsonFormat 12 | 13 | absFileJsonFormat :: JsonFormat e (Path Abs File) 14 | absFileJsonFormat = aesonJsonFormat 15 | 16 | absDirJsonFormat :: JsonFormat e (Path Abs Dir) 17 | absDirJsonFormat = aesonJsonFormat 18 | 19 | instance DefaultJsonFormat (Path Rel File) where 20 | defaultJsonFormat = relFileJsonFormat 21 | 22 | instance DefaultJsonFormat (Path Rel Dir) where 23 | defaultJsonFormat = relDirJsonFormat 24 | 25 | instance DefaultJsonFormat (Path Abs File) where 26 | defaultJsonFormat = absFileJsonFormat 27 | 28 | instance DefaultJsonFormat (Path Abs Dir) where 29 | defaultJsonFormat = absDirJsonFormat 30 | -------------------------------------------------------------------------------- /composite-aeson-refined/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-aeson-refined/composite-aeson-refined.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: e9a07aa1f023040725900891f055198ed341827aa2bce1a988462c49d84a6e3c 8 | 9 | name: composite-aeson-refined 10 | version: 0.8.0.0 11 | synopsis: composite-aeson support for Refined from the refined package 12 | description: JsonFormat and DefaultJsonFormat for Refined 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Aeson.Refined 24 | other-modules: 25 | Paths_composite_aeson_refined 26 | hs-source-dirs: 27 | src 28 | default-extensions: 29 | DataKinds 30 | FlexibleContexts 31 | FlexibleInstances 32 | GeneralizedNewtypeDeriving 33 | LambdaCase 34 | MultiParamTypeClasses 35 | MultiWayIf 36 | OverloadedStrings 37 | PatternSynonyms 38 | PolyKinds 39 | QuasiQuotes 40 | RankNTypes 41 | ScopedTypeVariables 42 | StandaloneDeriving 43 | StrictData 44 | TemplateHaskell 45 | TupleSections 46 | TypeFamilies 47 | TypeOperators 48 | ViewPatterns 49 | ghc-options: -Wall -O2 50 | build-depends: 51 | aeson-better-errors >=0.9.1.0 && <0.10 52 | , base >=4.12 && <5 53 | , composite-aeson ==0.8.* 54 | , mtl >=2.2.1 && <2.3 55 | , refined >=0.1.2.1 && <0.7 56 | default-language: Haskell2010 57 | -------------------------------------------------------------------------------- /composite-aeson-refined/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson-better-errors, base, composite-aeson, hpack 2 | , lib, mtl, refined 3 | }: 4 | mkDerivation { 5 | pname = "composite-aeson-refined"; 6 | version = "0.8.0.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | aeson-better-errors base composite-aeson mtl refined 10 | ]; 11 | libraryToolDepends = [ hpack ]; 12 | prePatch = "hpack"; 13 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 14 | description = "composite-aeson support for Refined from the refined package"; 15 | license = lib.licenses.bsd3; 16 | } 17 | -------------------------------------------------------------------------------- /composite-aeson-refined/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-aeson-refined 2 | version: 0.8.0.0 3 | synopsis: composite-aeson support for Refined from the refined package 4 | description: JsonFormat and DefaultJsonFormat for Refined 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - aeson-better-errors >= 0.9.1.0 && < 0.10 15 | - composite-aeson >= 0.8 && < 0.9 16 | - mtl >= 2.2.1 && < 2.3 17 | - refined >= 0.1.2.1 && < 0.7 18 | 19 | default-extensions: 20 | - DataKinds 21 | - FlexibleContexts 22 | - FlexibleInstances 23 | - GeneralizedNewtypeDeriving 24 | - LambdaCase 25 | - MultiParamTypeClasses 26 | - MultiWayIf 27 | - OverloadedStrings 28 | - PatternSynonyms 29 | - PolyKinds 30 | - QuasiQuotes 31 | - RankNTypes 32 | - ScopedTypeVariables 33 | - StandaloneDeriving 34 | - StrictData 35 | - TemplateHaskell 36 | - TupleSections 37 | - TypeFamilies 38 | - TypeOperators 39 | - ViewPatterns 40 | 41 | ghc-options: -Wall -O2 42 | 43 | library: 44 | source-dirs: src 45 | -------------------------------------------------------------------------------- /composite-aeson-refined/src/Composite/Aeson/Refined.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP #-} 3 | module Composite.Aeson.Refined (refinedJsonFormat) where 4 | 5 | import Composite.Aeson (DefaultJsonFormat, defaultJsonFormat, JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor)) 6 | import Control.Monad.Error.Class (throwError) 7 | import qualified Data.Aeson.BetterErrors as ABE 8 | import Refined 9 | ( Predicate, Refined, refine, unrefine 10 | #if MIN_VERSION_refined(0,2,0) 11 | , displayRefineException 12 | #endif 13 | ) 14 | 15 | -- |Given a @'JsonFormat' e a@, produce a @JsonFormat e ('Refined' p a)@ where @p@ is some 'Predicate' from the refined library for @a@. 16 | -- 17 | -- This maps to the same JSON as the given 'JsonFormat', but when parsing it will apply 'refine' to assert that the incoming JSON value conforms to the 18 | -- predicate, failing to parse if not. 19 | refinedJsonFormat :: Predicate p a => JsonFormat e a -> JsonFormat e (Refined p a) 20 | refinedJsonFormat (JsonFormat (JsonProfunctor oa ia)) = JsonFormat $ JsonProfunctor o i 21 | where 22 | o = oa . unrefine 23 | #if MIN_VERSION_refined(0,2,0) 24 | i = either (toss . show . displayRefineException) pure . refine =<< ia 25 | #else 26 | i = either toss pure . refine =<< ia 27 | #endif 28 | toss = throwError . ABE.BadSchema [] . ABE.FromAeson 29 | 30 | instance (DefaultJsonFormat a, Predicate p a) => DefaultJsonFormat (Refined p a) where 31 | defaultJsonFormat = refinedJsonFormat defaultJsonFormat 32 | -------------------------------------------------------------------------------- /composite-aeson/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-aeson/composite-aeson.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 15940f55e4ff012339686c8d68ef398a5eb7acbcd09b10646b4b1f92cf09604f 8 | 9 | name: composite-aeson 10 | version: 0.8.0.0 11 | synopsis: JSON for Vinyl records 12 | description: Integration between Aeson and Vinyl records allowing records to be easily converted to JSON using automatic derivation, explicit formats, or a mix of both. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Aeson 24 | Composite.Aeson.Base 25 | Composite.Aeson.CoRecord 26 | Composite.Aeson.DateTimeFormatUtils 27 | Composite.Aeson.Enum 28 | Composite.Aeson.Formats.DateTime 29 | Composite.Aeson.Formats.Default 30 | Composite.Aeson.Formats.Generic 31 | Composite.Aeson.Formats.InternalTH 32 | Composite.Aeson.Formats.Provided 33 | Composite.Aeson.Record 34 | Composite.Aeson.TH 35 | other-modules: 36 | Paths_composite_aeson 37 | hs-source-dirs: 38 | src 39 | default-extensions: 40 | DataKinds 41 | FlexibleContexts 42 | FlexibleInstances 43 | GeneralizedNewtypeDeriving 44 | LambdaCase 45 | MultiParamTypeClasses 46 | MultiWayIf 47 | OverloadedStrings 48 | PatternSynonyms 49 | PolyKinds 50 | QuasiQuotes 51 | RankNTypes 52 | ScopedTypeVariables 53 | StandaloneDeriving 54 | StrictData 55 | TemplateHaskell 56 | TupleSections 57 | TypeApplications 58 | TypeFamilies 59 | TypeOperators 60 | ViewPatterns 61 | ghc-options: -Wall -O2 62 | build-depends: 63 | aeson >=1.1.2.0 && <2.1 64 | , aeson-better-errors >=0.9.1.0 && <0.10 65 | , base >=4.12 && <5 66 | , composite-base ==0.8.* 67 | , containers >=0.5.7.0 && <0.7 68 | , contravariant >=1.4 && <1.6 69 | , generic-deriving >=1.11.2 && <1.15 70 | , hashable >=1.2.6.1 && <1.4 71 | , lens >=4.15.4 && <5.2 72 | , mmorph >=1.0.9 && <1.2 73 | , mtl >=2.2.1 && <2.3 74 | , profunctors >=5.2.1 && <5.7 75 | , scientific >=0.3.5.1 && <0.4 76 | , tagged >=0.8.5 && <0.9 77 | , template-haskell >=2.11.1.0 && <2.19 78 | , text >=1.2.2.2 && <1.3 79 | , time >=1.6.0.1 && <1.12 80 | , unordered-containers >=0.2.8.0 && <0.3 81 | , vector >=0.12.0.1 && <0.13 82 | , vinyl >=0.5.3 && <0.15 83 | default-language: Haskell2010 84 | 85 | test-suite composite-aeson-test 86 | type: exitcode-stdio-1.0 87 | main-is: Main.hs 88 | other-modules: 89 | DateTimeSpec 90 | EnumSpec 91 | FieldSpec 92 | RecordSpec 93 | THSpec 94 | TupleSpec 95 | Paths_composite_aeson 96 | hs-source-dirs: 97 | test 98 | default-extensions: 99 | DataKinds 100 | FlexibleContexts 101 | FlexibleInstances 102 | GeneralizedNewtypeDeriving 103 | LambdaCase 104 | MultiParamTypeClasses 105 | MultiWayIf 106 | OverloadedStrings 107 | PatternSynonyms 108 | PolyKinds 109 | QuasiQuotes 110 | RankNTypes 111 | ScopedTypeVariables 112 | StandaloneDeriving 113 | StrictData 114 | TemplateHaskell 115 | TupleSections 116 | TypeApplications 117 | TypeFamilies 118 | TypeOperators 119 | ViewPatterns 120 | ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 121 | build-depends: 122 | QuickCheck 123 | , aeson >=1.1.2.0 && <2.1 124 | , aeson-better-errors >=0.9.1.0 && <0.10 125 | , aeson-qq 126 | , base >=4.12 && <5 127 | , composite-aeson 128 | , composite-base ==0.8.* 129 | , containers >=0.5.7.0 && <0.7 130 | , contravariant >=1.4 && <1.6 131 | , generic-deriving >=1.11.2 && <1.15 132 | , hashable >=1.2.6.1 && <1.4 133 | , hspec 134 | , lens >=4.15.4 && <5.2 135 | , mmorph >=1.0.9 && <1.2 136 | , mtl >=2.2.1 && <2.3 137 | , profunctors >=5.2.1 && <5.7 138 | , scientific >=0.3.5.1 && <0.4 139 | , tagged >=0.8.5 && <0.9 140 | , template-haskell >=2.11.1.0 && <2.19 141 | , text >=1.2.2.2 && <1.3 142 | , time >=1.6.0.1 && <1.12 143 | , unordered-containers >=0.2.8.0 && <0.3 144 | , vector >=0.12.0.1 && <0.13 145 | , vinyl >=0.5.3 && <0.15 146 | default-language: Haskell2010 147 | -------------------------------------------------------------------------------- /composite-aeson/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, aeson-better-errors, aeson-qq, base 2 | , composite-base, containers, contravariant, generic-deriving 3 | , hashable, hpack, hspec, lens, lib, mmorph, mtl, profunctors 4 | , QuickCheck, scientific, tagged, template-haskell, text, time 5 | , unordered-containers, vector, vinyl 6 | }: 7 | mkDerivation { 8 | pname = "composite-aeson"; 9 | version = "0.8.0.0"; 10 | src = ./.; 11 | libraryHaskellDepends = [ 12 | aeson aeson-better-errors base composite-base containers 13 | contravariant generic-deriving hashable lens mmorph mtl profunctors 14 | scientific tagged template-haskell text time unordered-containers 15 | vector vinyl 16 | ]; 17 | libraryToolDepends = [ hpack ]; 18 | testHaskellDepends = [ 19 | aeson aeson-better-errors aeson-qq base composite-base containers 20 | contravariant generic-deriving hashable hspec lens mmorph mtl 21 | profunctors QuickCheck scientific tagged template-haskell text time 22 | unordered-containers vector vinyl 23 | ]; 24 | prePatch = "hpack"; 25 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 26 | description = "JSON for Vinyl records"; 27 | license = lib.licenses.bsd3; 28 | } 29 | -------------------------------------------------------------------------------- /composite-aeson/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-aeson 2 | version: 0.8.0.0 3 | synopsis: JSON for Vinyl records 4 | description: Integration between Aeson and Vinyl records allowing records to be easily converted to JSON using automatic derivation, explicit formats, or a mix of both. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - aeson >= 1.1.2.0 && < 2.1 15 | - aeson-better-errors >= 0.9.1.0 && < 0.10 16 | - composite-base >= 0.8 && < 0.9 17 | - containers >= 0.5.7.0 && < 0.7 18 | - contravariant >= 1.4 && < 1.6 19 | - generic-deriving >= 1.11.2 && < 1.15 20 | - hashable >= 1.2.6.1 && < 1.4 21 | - lens >= 4.15.4 && < 5.2 22 | - mmorph >= 1.0.9 && < 1.2 23 | - mtl >= 2.2.1 && < 2.3 24 | - profunctors >= 5.2.1 && < 5.7 25 | - scientific >= 0.3.5.1 && < 0.4 26 | - tagged >= 0.8.5 && < 0.9 27 | - template-haskell >= 2.11.1.0 && < 2.19 28 | - text >= 1.2.2.2 && < 1.3 29 | - time >= 1.6.0.1 && < 1.12 30 | - unordered-containers >= 0.2.8.0 && < 0.3 31 | - vector >= 0.12.0.1 && < 0.13 32 | - vinyl >= 0.5.3 && < 0.15 33 | 34 | default-extensions: 35 | - DataKinds 36 | - FlexibleContexts 37 | - FlexibleInstances 38 | - GeneralizedNewtypeDeriving 39 | - LambdaCase 40 | - MultiParamTypeClasses 41 | - MultiWayIf 42 | - OverloadedStrings 43 | - PatternSynonyms 44 | - PolyKinds 45 | - QuasiQuotes 46 | - RankNTypes 47 | - ScopedTypeVariables 48 | - StandaloneDeriving 49 | - StrictData 50 | - TemplateHaskell 51 | - TupleSections 52 | - TypeApplications 53 | - TypeFamilies 54 | - TypeOperators 55 | - ViewPatterns 56 | 57 | ghc-options: -Wall -O2 58 | 59 | library: 60 | source-dirs: src 61 | 62 | tests: 63 | composite-aeson-test: 64 | source-dirs: test 65 | main: Main.hs 66 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 67 | dependencies: 68 | - QuickCheck 69 | - aeson-qq 70 | - composite-aeson 71 | - hspec 72 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson.hs: -------------------------------------------------------------------------------- 1 | module Composite.Aeson 2 | ( module Composite.Aeson.Base 3 | , module Composite.Aeson.CoRecord 4 | , module Composite.Aeson.Enum 5 | , module Composite.Aeson.Formats.DateTime 6 | , module Composite.Aeson.Formats.Default 7 | , module Composite.Aeson.Formats.Generic 8 | , module Composite.Aeson.Formats.Provided 9 | , module Composite.Aeson.Record 10 | ) where 11 | 12 | import Composite.Aeson.Base 13 | import Composite.Aeson.CoRecord 14 | import Composite.Aeson.Enum 15 | import Composite.Aeson.Formats.DateTime 16 | import Composite.Aeson.Formats.Default 17 | import Composite.Aeson.Formats.Generic 18 | import Composite.Aeson.Formats.Provided 19 | import Composite.Aeson.Record 20 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/Base.hs: -------------------------------------------------------------------------------- 1 | module Composite.Aeson.Base 2 | ( ToJson(..), FromJson(..), JsonProfunctor(..), _JsonProfunctor, JsonFormat(..) 3 | , toJsonWithFormat, fromJsonWithFormat, parseJsonWithFormat, parseJsonWithFormat' 4 | , dimapJsonFormat, jsonFormatWithIso, wrapJsonFormat, jsonFormatWithoutCustomError, wrappedJsonFormat 5 | ) where 6 | 7 | import Control.Lens (AnIso', Iso, _2, Wrapped(type Unwrapped), _Wrapped', _Wrapped, iso, over, withIso) 8 | import Control.Lens.TH (makeWrapped) 9 | import Control.Monad.Except (withExceptT) 10 | import Control.Monad.Morph (hoist) 11 | import qualified Data.Aeson as Aeson 12 | import qualified Data.Aeson.Types as Aeson 13 | import qualified Data.Aeson.BetterErrors as ABE 14 | import qualified Data.Aeson.BetterErrors.Internal as ABEI 15 | import Data.Functor.Contravariant (Contravariant, contramap) 16 | import Data.Profunctor (Profunctor(dimap)) 17 | import Data.Text (Text) 18 | import Data.Void (Void) 19 | 20 | -- |Type of functions which take a value @a@ and convert it to an 'Aeson.Value'. 21 | -- 22 | -- Wrapper around a function of type @a -> Aeson.Value@. 23 | -- 24 | -- Doesn't currently include support for the newer Aeson Encoding machinery, but should. 25 | newtype ToJson a = ToJson { unToJson :: a -> Aeson.Value } 26 | 27 | instance Contravariant ToJson where 28 | contramap f (ToJson g) = ToJson (g . f) 29 | 30 | -- |Type of parsers which might emit some custom error of type @e@ and produce a value of type @a@ on success. 31 | -- 32 | -- @a@ is the type of value that can be parsed from JSON using this profunctor, and @e@ is the type of custom error that can be produced when the JSON is 33 | -- unacceptable. If your parser doesn't produce any custom errors, leave this type polymorphic. 34 | -- 35 | -- Wrapper about an @aeson-better-errors@ 'ABE.Parse' @e@ @a@. 36 | newtype FromJson e a = FromJson { unFromJson :: ABE.Parse e a } 37 | 38 | deriving instance Functor (FromJson e) 39 | 40 | -- |Type of profunctors which produce and consume JSON, a composition of @ToJson@ and @FromJson@. 41 | -- 42 | -- @a@ is the type of value that can be converted to 'Aeson.Value' using this profunctor. 43 | -- @b@ is the type of value that can be parsed from JSON using this profunctor, and @e@ is the type of custom error that can be produced when the JSON is 44 | -- unacceptable. If your parser doesn't produce any custom errors, leave this type polymorphic. 45 | -- 46 | -- Profunctors must have two type parameters @a@ and @b@ so this type has two, but @JsonProfunctor@s with different types aren't useful for JSON processing 47 | -- directly. See 'JsonFormat' for a wrapper which fixes the two types. 48 | -- 49 | -- Doesn't currently include support for the newer Aeson Encoding machinery, but should. 50 | data JsonProfunctor e a b = JsonProfunctor (a -> Aeson.Value) (ABE.Parse e b) 51 | 52 | instance Profunctor (JsonProfunctor e) where 53 | dimap f g (JsonProfunctor o i) = JsonProfunctor (o . f) (g <$> i) 54 | 55 | -- |Observe that a 'JsonProfunctor' is isomorphic to a pair with a @ToJson@ and @FromJson@. 56 | _JsonProfunctor :: Iso (JsonProfunctor e a b) (JsonProfunctor e' a' b') (ToJson a, FromJson e b) (ToJson a', FromJson e' b') 57 | _JsonProfunctor = 58 | iso (\ (JsonProfunctor o i) -> (ToJson o, FromJson i)) 59 | (\ (ToJson o, FromJson i) -> JsonProfunctor o i) 60 | 61 | -- |Wrapper around 'JsonProfunctor' for use in JSON processing when the profunctor represents a bijection between JSON and a single type @a@, i.e. for 62 | -- @JsonProfunctor e a a@. 63 | newtype JsonFormat e a = JsonFormat { unJsonFormat :: JsonProfunctor e a a } 64 | 65 | -- |Given a 'JsonFormat' for @a@, convert a value of @a@ into an 'Aeson.Value'. 66 | toJsonWithFormat :: JsonFormat e a -> a -> Aeson.Value 67 | toJsonWithFormat (JsonFormat (JsonProfunctor o _)) = o 68 | 69 | -- |Given a 'JsonFormat' for @a@ which can produce custom errors of type @e@, yield an @aeson-better-errors@ 'ABE.Parse' which can be used to consume JSON. 70 | fromJsonWithFormat :: JsonFormat e a -> ABE.Parse e a 71 | fromJsonWithFormat (JsonFormat (JsonProfunctor _ i)) = i 72 | 73 | -- |Given a 'JsonFormat' for @a@ which produces custom errors of type @e@ and some function to format those errors as messages, produce an Aeson parser function 74 | -- @Value -> Parser a@. 75 | parseJsonWithFormat :: (e -> Text) -> JsonFormat e a -> Aeson.Value -> Aeson.Parser a 76 | parseJsonWithFormat showError = ABE.toAesonParser showError . fromJsonWithFormat 77 | 78 | -- |Given a 'JsonFormat' for @a@ which doesn't produce custom errors, produce an Aeson parser function @Value -> Parser a@. 79 | parseJsonWithFormat' :: JsonFormat Void a -> Aeson.Value -> Aeson.Parser a 80 | parseJsonWithFormat' = ABE.toAesonParser' . fromJsonWithFormat 81 | 82 | makeWrapped ''ToJson 83 | makeWrapped ''FromJson 84 | makeWrapped ''JsonFormat 85 | 86 | -- |Wrap a 'JsonFormat' for type @a@ in a pair of functions representing an isomorphism between @a@ and @b@ to produce a new @JsonFormat@ for @b@. 87 | dimapJsonFormat :: (b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b 88 | dimapJsonFormat f g = over _Wrapped (dimap f g) 89 | 90 | -- |Given a @'JsonFormat' e a@ and a pair of functions @b -> a@ and @a -> Either e b@, produce a @'JsonFormat' e b@. 91 | -- 92 | -- This is for the common case of a @newtype@ wrapper which asserts some kind of validation has been done, e.g.: 93 | -- 94 | -- @ 95 | -- newtype MyType = MyType { unMyType :: Int } 96 | -- 97 | -- mkMyType :: Int -> Either Text MyType 98 | -- mkMyType i | i <= 0 = Left "must be positive!" 99 | -- | otherwise = Right (MyType i) 100 | -- 101 | -- myTypeJsonFormat :: JsonFormat e MyType 102 | -- myTypeJsonFormat = wrapJsonFormat intJsonFormat mkMyType unMyType 103 | -- @ 104 | wrapJsonFormat :: JsonFormat e a -> (a -> Either e b) -> (b -> a) -> JsonFormat e b 105 | wrapJsonFormat (JsonFormat (JsonProfunctor oa ia)) ab ba = JsonFormat (JsonProfunctor ob ib) 106 | where 107 | ob = oa . ba 108 | ib = either ABE.throwCustomError pure . ab =<< ia 109 | 110 | -- |Take a 'JsonFormat' which produces some 'Show'-able custom error and convert any custom errors into Aeson 'fail' style errors. Since the custom errors 111 | -- are never generated by the resulting 'JsonFormat', any custom error type can be assumed. 112 | -- 113 | -- This is commonly used to take a more specific @'JsonFormat' MyError MyType@ and make it a more generic @'JsonFormat' e MyType@, e.g. to be used as a 114 | -- 'Composite.Aeson.Default.defaultJsonFormat'. 115 | jsonFormatWithoutCustomError :: Show e => JsonFormat e a -> JsonFormat e' a 116 | jsonFormatWithoutCustomError = 117 | over (_Wrapped . _JsonProfunctor . _2 . _Wrapped) $ 118 | ABEI.mapParseT $ hoist $ withExceptT $ \ case 119 | ABEI.BadSchema pos (ABEI.KeyMissing k) -> ABEI.BadSchema pos (ABEI.KeyMissing k) 120 | ABEI.BadSchema pos (ABEI.OutOfBounds i) -> ABEI.BadSchema pos (ABEI.OutOfBounds i) 121 | ABEI.BadSchema pos (ABEI.WrongType t v) -> ABEI.BadSchema pos (ABEI.WrongType t v) 122 | ABEI.BadSchema pos (ABEI.ExpectedIntegral d) -> ABEI.BadSchema pos (ABEI.ExpectedIntegral d) 123 | ABEI.BadSchema pos (ABEI.FromAeson e) -> ABEI.BadSchema pos (ABEI.FromAeson e) 124 | ABEI.BadSchema pos (ABEI.CustomError e) -> ABEI.BadSchema pos (ABEI.FromAeson (show e)) 125 | 126 | ABEI.InvalidJSON msg -> ABEI.InvalidJSON msg 127 | 128 | -- |Wrap a 'JsonFormat' for type @a@ in an isomorphism to produce a new @JsonFormat@ for @b@. 129 | jsonFormatWithIso :: AnIso' b a -> JsonFormat e a -> JsonFormat e b 130 | jsonFormatWithIso i = withIso i dimapJsonFormat 131 | 132 | -- |Given a format for the value type inside some wrapper type @a@ which instances 'Wrapped', produce a format which works on the wrapper type. 133 | wrappedJsonFormat :: Wrapped a => JsonFormat e (Unwrapped a) -> JsonFormat e a 134 | wrappedJsonFormat = jsonFormatWithIso _Wrapped' 135 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/CoRecord.hs: -------------------------------------------------------------------------------- 1 | module Composite.Aeson.CoRecord 2 | ( ToJsonFormatField, FromJsonFormatField, JsonFormatField 3 | , DefaultJsonFormatField(defaultJsonFormatField) 4 | , fieldToJson, fieldFromJson, fieldJsonFormat 5 | ) where 6 | 7 | import Composite.Aeson.Base (FromJson(FromJson), JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), ToJson(ToJson), wrappedJsonFormat) 8 | import Composite.Aeson.Formats.Default (DefaultJsonFormat, defaultJsonFormat) 9 | import Composite.Aeson.Formats.Generic (SumStyle, jsonSumFormat, sumToJson, sumFromJson) 10 | import Composite.CoRecord (CoRec(CoVal), Field, fieldToRec) 11 | import Composite.Record ((:->), Rec((:&), RNil), RecWithContext(rmapWithContext), recordToNonEmpty, ReifyNames, reifyNames) 12 | import Data.Aeson (Value) 13 | import qualified Data.Aeson.BetterErrors as ABE 14 | import Data.Functor.Identity (Identity(Identity)) 15 | import Data.List.NonEmpty (NonEmpty) 16 | import Data.Maybe (catMaybes, fromMaybe, listToMaybe) 17 | import Data.Text (Text) 18 | import Data.Vinyl (RApply, RMap, RecApplicative, RecordToList, rapply, recordToList, (<<&>>)) 19 | import Data.Vinyl.Functor (Compose(Compose), (:.), Const(Const), Lift(Lift)) 20 | import Data.Vinyl.Lens (type (∈)) 21 | import Data.Proxy (Proxy(Proxy)) 22 | 23 | -- |Type of records which contain JSON encoders for each element of @rs@. 24 | type ToJsonFormatField rs = Rec ToJson rs 25 | 26 | -- |Type of records which contain JSON decoders for each element of @rs@. 27 | type FromJsonFormatField e rs = Rec (FromJson e) rs 28 | 29 | -- |Type of records which contain JSON formats for each element of @rs@. 30 | type JsonFormatField e rs = Rec (JsonFormat e) rs 31 | 32 | -- |Class which makes up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@. 33 | class DefaultJsonFormatField (rs :: [*]) where 34 | -- |Make up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@. 35 | defaultJsonFormatField :: JsonFormatField e rs 36 | 37 | instance DefaultJsonFormatField '[] where 38 | defaultJsonFormatField = RNil 39 | 40 | instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where 41 | defaultJsonFormatField = wrappedJsonFormat defaultJsonFormat :& (defaultJsonFormatField :: JsonFormatField e rs) 42 | 43 | -- |Make a @'Field' rs -> 'Value'@ given how to map the sum type to JSON along with a record with encoders for each value the field could have. 44 | fieldToJson 45 | :: forall (rs :: [*]) r' (rs' :: [*]). 46 | ( rs ~ (r' ': rs'), RApply rs, RMap rs 47 | , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs ) 48 | => SumStyle -> ToJsonFormatField rs -> Field rs -> Value 49 | fieldToJson sumStyle fmts = sumToJson sumStyle o 50 | where 51 | namedFmts :: Rec ((,) Text :. ToJson) rs 52 | namedFmts = reifyNames fmts 53 | 54 | o :: Field rs -> (Text, Value) 55 | o = fromMaybe (error "fieldToRec somehow produced all Nothings") 56 | . listToMaybe . catMaybes 57 | . (recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)]) 58 | . rapply outputs 59 | . fieldToRec 60 | 61 | outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs 62 | outputs = namedFmts <<&>> \ (Compose (name, ToJson oa)) -> 63 | Lift $ Const . fmap ((name,) . oa) 64 | 65 | -- |Make a @'ABE.Parse' e (Field rs)@ given how to map the sum type from JSON along with a record with decoders for each value the field could have. 66 | fieldFromJson 67 | :: forall (rs :: [*]) r' (rs' :: [*]) e. 68 | ( rs ~ (r' ': rs'), RApply rs, RMap rs 69 | , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs ) 70 | => SumStyle -> FromJsonFormatField e rs -> ABE.Parse e (Field rs) 71 | fieldFromJson sumStyle fmts = sumFromJson sumStyle i 72 | where 73 | namedFmts :: Rec ((,) Text :. FromJson e) rs 74 | namedFmts = reifyNames fmts 75 | 76 | i :: NonEmpty (Text, FromJson e (Field rs)) 77 | i = recordToNonEmpty $ rmapWithContext (Proxy @rs) oneCase namedFmts 78 | where 79 | oneCase :: forall r. r ∈ rs => ((,) Text :. FromJson e) r -> Const (Text, FromJson e (Field rs)) r 80 | oneCase (Compose (name, FromJson ia)) = 81 | Const (name, FromJson (CoVal . Identity <$> ia)) 82 | 83 | -- |Make a @'JsonFormat' e (Field rs)@ given how to map the sum type to JSON along with a record with formatters for each value the field could have. 84 | fieldJsonFormat 85 | :: forall (rs :: [*]) r' (rs' :: [*]) e. 86 | ( rs ~ (r' ': rs'), RApply rs, RMap rs 87 | , RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs ) 88 | => SumStyle -> JsonFormatField e rs -> JsonFormat e (Field rs) 89 | fieldJsonFormat sumStyle fmts = jsonSumFormat sumStyle o i 90 | where 91 | namedFmts :: Rec ((,) Text :. JsonFormat e) rs 92 | namedFmts = reifyNames fmts 93 | 94 | o :: Field rs -> (Text, Value) 95 | o = fromMaybe (error "fieldToRec somehow produced all Nothings") 96 | . listToMaybe . catMaybes 97 | . (recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)]) 98 | . rapply outputs 99 | . fieldToRec 100 | 101 | outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs 102 | outputs = namedFmts <<&>> \ (Compose (name, JsonFormat (JsonProfunctor oa _))) -> 103 | Lift $ Const . fmap ((name,) . oa) 104 | 105 | i :: NonEmpty (Text, FromJson e (Field rs)) 106 | i = recordToNonEmpty $ rmapWithContext (Proxy @rs) oneCase namedFmts 107 | where 108 | oneCase :: forall r. r ∈ rs => ((,) Text :. JsonFormat e) r -> Const (Text, FromJson e (Field rs)) r 109 | oneCase (Compose (name, JsonFormat (JsonProfunctor _ ia))) = 110 | Const (name, FromJson (CoVal . Identity <$> ia)) 111 | 112 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/DateTimeFormatUtils.hs: -------------------------------------------------------------------------------- 1 | module Composite.Aeson.DateTimeFormatUtils 2 | ( fixupTzIn, fixupTzOut, fixupMs 3 | ) where 4 | 5 | import Data.Char (isDigit) 6 | import Data.Function (fix) 7 | import Data.List (stripPrefix) 8 | 9 | -- |Given a string, remove a trailing @Z@ (which is ISO8601 acceptable) and replace it with @+00:00@ (which is @ParseTime@ acceptable) 10 | fixupTzIn :: String -> String 11 | fixupTzIn s = maybe s ((++ "+00:00") . reverse) $ stripPrefix "Z" (reverse s) 12 | 13 | -- |Given a string, remove a trailing @+00:00@ (which @FormatTime@) and replace it with @Z@ (which is ISO8601 standard) 14 | fixupTzOut :: String -> String 15 | fixupTzOut s = maybe s ((++ "Z") . reverse) $ stripPrefix "00:00+" (reverse s) 16 | 17 | -- |Given a ISO8601-ish string generated by @FormatTime@ with @%Q@, generating between no decimal and 12 digits of decimal, normalize it to exactly 18 | -- three digits. 19 | -- 20 | -- E.g. from @2017-03-30T13:00:00Z@ generate @2017-03-30T13:00:00.000Z@, and from @2017-03-30T13:00:00.123456789Z@ generate @2017-03-30T12:00:00.123Z@ 21 | fixupMs :: String -> String 22 | fixupMs (':':s10:s1:tzChar:rest) | tzChar == 'Z' || tzChar == '+' || tzChar == '-' = 23 | ':':s10:s1:'.':'0':'0':'0':tzChar:rest 24 | fixupMs (':':s10:s1:'.':digitsAndRest) = 25 | let (digits, rest) = span isDigit digitsAndRest 26 | newDigits = take 3 (digits ++ fix ('0':)) 27 | in ':':s10:s1:'.':(newDigits ++ rest) 28 | fixupMs (c:cs) = c : fixupMs cs 29 | fixupMs [] = [] 30 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/Enum.hs: -------------------------------------------------------------------------------- 1 | module Composite.Aeson.Enum where 2 | 3 | import Control.Monad.Error.Class (throwError) 4 | import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor)) 5 | import qualified Data.Aeson as Aeson 6 | import qualified Data.Aeson.BetterErrors as ABE 7 | import qualified Data.HashMap.Strict as HM 8 | import Data.List (intercalate, stripPrefix) 9 | import qualified Data.Map.Strict as M 10 | import Data.Text (Text, pack, unpack) 11 | import GHC.Generics (Generic(type Rep)) 12 | import Generics.Deriving.ConNames (ConNames, conNameOf) 13 | import Generics.Deriving.Enum (Enum', genumDefault) 14 | 15 | -- |For some type @a@ which represents an enumeration (i.e. all nullary constructors) generate a 'JsonFormat' which maps that type to strings in JSON. 16 | -- 17 | -- Each constructor will be mapped to a string with the same value as its name with some prefix removed. 18 | -- 19 | -- For example, given: 20 | -- 21 | -- > data MyEnum = MyEnumFoo | MyEnumBar 22 | -- > myEnumFormat :: JsonFormat e MyEnum 23 | -- > myEnumFormat = enumJsonFormat "MyEnum" 24 | -- 25 | -- Then: 26 | -- 27 | -- > toJsonWithFormat myEnumFormat MyEnumFoo == Aeson.String "Foo" 28 | enumJsonFormat :: forall e a. (Show a, Ord a, Generic a, ConNames (Rep a), Enum' (Rep a)) => String -> JsonFormat e a 29 | enumJsonFormat prefix = 30 | let removePrefix s 31 | | Just suffix <- stripPrefix prefix s = suffix 32 | | otherwise = s 33 | values = genumDefault 34 | names = map (pack . removePrefix . conNameOf) values 35 | lookupText = flip HM.lookup . HM.fromList $ zip names values 36 | lookupValue = flip M.lookup . M.fromList $ zip values names 37 | expectedValues = "one of " ++ (intercalate ", " . map unpack $ names) 38 | in enumMapJsonFormat lookupText lookupValue expectedValues 39 | 40 | -- |For some type @a@ which bidirectional mapping functions can be provided, produce a 'JsonFormat' which maps to JSON strings. 41 | enumMapJsonFormat :: Show a => (Text -> Maybe a) -> (a -> Maybe Text) -> String -> JsonFormat e a 42 | enumMapJsonFormat lookupText lookupValue expectedText = JsonFormat $ JsonProfunctor toJson fromJson 43 | where 44 | toJson a = 45 | case lookupValue a of 46 | Nothing -> error $ "unrecognized enum value " ++ show a -- eugh 47 | Just t -> Aeson.String t 48 | 49 | fromJson = do 50 | t <- ABE.asText 51 | case lookupText t of 52 | Nothing -> throwError $ ABE.BadSchema [] $ ABE.FromAeson $ 53 | "expected " ++ expectedText ++ ", not " ++ unpack t 54 | Just v -> pure v 55 | 56 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/Formats/DateTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Composite.Aeson.Formats.DateTime 3 | ( DateTimeFormat(..), regularDateTimeFormat 4 | , dateTimeJsonFormat 5 | , iso8601DateJsonFormat, iso8601DateTimeJsonFormat, iso8601TimeJsonFormat 6 | ) where 7 | 8 | import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor)) 9 | import Composite.Aeson.DateTimeFormatUtils (fixupTzIn, fixupTzOut, fixupMs) 10 | import Composite.Aeson.Formats.Provided (stringJsonFormat) 11 | import Control.Monad.Error.Class (throwError) 12 | import qualified Data.Aeson.BetterErrors as ABE 13 | import Data.Either (partitionEithers) 14 | import Data.List (intercalate) 15 | import Data.List.NonEmpty (NonEmpty((:|))) 16 | import qualified Data.List.NonEmpty as NEL 17 | import Data.Time.Calendar (Day) 18 | import Data.Time.Clock (UTCTime) 19 | import Data.Time.Format (FormatTime, ParseTime, TimeLocale, defaultTimeLocale, formatTime, parseTimeM) 20 | import Data.Time.LocalTime (TimeOfDay) 21 | 22 | -- |Structure carrying the date/time format string along with an example for error messaging and functions which optionally permute the input or output 23 | -- before using the format. 24 | data DateTimeFormat = DateTimeFormat 25 | { dateTimeFormat :: String 26 | , dateTimeFormatExample :: String 27 | , dateTimeFormatPreParse :: String -> String 28 | , dateTimeFormatPostFormat :: String -> String 29 | } 30 | 31 | -- |Construct a 'DateTimeFormat' with no pre- or post- processing. 32 | regularDateTimeFormat :: String -> String -> DateTimeFormat 33 | regularDateTimeFormat format example = DateTimeFormat format example id id 34 | 35 | -- |'JsonFormat' for any type which 'ParseTime' and 'FormatTime' are defined for which maps to JSON via the first format given and maps from JSON via 36 | -- any format given. 37 | dateTimeJsonFormat :: (ParseTime t, FormatTime t) => TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t 38 | dateTimeJsonFormat locale formats@(outFormat :| otherInFormats) = JsonFormat (JsonProfunctor dayOut dayIn) 39 | where 40 | formatsList = NEL.toList formats 41 | JsonFormat (JsonProfunctor stringOut stringIn) = stringJsonFormat 42 | dayOut = stringOut . dateTimeFormatPostFormat outFormat . formatTime locale (dateTimeFormat outFormat) 43 | dayIn = do 44 | s <- stringIn 45 | let attempt format = successOrFail Left Right $ parseTimeM True locale (dateTimeFormat format) (dateTimeFormatPreParse format s) 46 | attempts = map attempt formatsList 47 | case partitionEithers attempts of 48 | (_, a : _) -> 49 | pure a 50 | (es, _) | null otherInFormats -> 51 | toss $ "expected date/time string formatted as " <> dateTimeFormatExample outFormat <> ", but: " <> intercalate ", " es 52 | (es, _) -> 53 | toss $ "expected date/time string formatted as one of " 54 | <> intercalate ", " (map dateTimeFormatExample formatsList) 55 | <> ", but: " <> intercalate ", " es 56 | toss = throwError . ABE.BadSchema [] . ABE.FromAeson 57 | 58 | -- |ISO8601 extended date format (@yyyy-mm-dd@). 59 | iso8601DateJsonFormat :: JsonFormat e Day 60 | iso8601DateJsonFormat = 61 | dateTimeJsonFormat defaultTimeLocale (fmt :| []) 62 | where 63 | fmt = regularDateTimeFormat "%F" "yyyy-mm-dd" 64 | 65 | -- |ISO8601 extended date/time format (@yyyy-mm-ddThh:mm:ss.sssZ@ or @yyyy-mm-ttThh:mm:ssZ@) 66 | iso8601DateTimeJsonFormat :: JsonFormat e UTCTime 67 | iso8601DateTimeJsonFormat = 68 | dateTimeJsonFormat defaultTimeLocale (withMs :| [withoutMs]) 69 | where 70 | withMs = DateTimeFormat "%FT%T%Q%z" "yyyy-mm-ddThh:mm:ss.sssZ" fixupTzIn (fixupTzOut . fixupMs) 71 | withoutMs = DateTimeFormat "%FT%T%z" "yyyy-mm-ddThh:mm:ssZ" fixupTzIn fixupTzOut 72 | 73 | -- |ISO8601 extended time format (@hh:mm:ss.sss@ or @hh:mm:ss@) 74 | iso8601TimeJsonFormat :: JsonFormat e TimeOfDay 75 | iso8601TimeJsonFormat = 76 | dateTimeJsonFormat defaultTimeLocale (withMs :| [withoutMs]) 77 | where 78 | withMs = DateTimeFormat "%T%Q%z" "hh:mm:ss.sss" id fixupMs 79 | withoutMs = DateTimeFormat "%T%Q" "hh:mm:ss" id id 80 | 81 | 82 | -- |Monad for capturing uses of 'fail', because @Data.Time.Format@ has a poorly factored interface. 83 | data SuccessOrFail a = Fail String | Success a 84 | 85 | instance Functor SuccessOrFail where 86 | fmap f (Success a) = Success (f a) 87 | fmap _ (Fail f) = Fail f 88 | 89 | instance Applicative SuccessOrFail where 90 | pure = Success 91 | Success f <*> Success a = Success (f a) 92 | Success _ <*> Fail f = Fail f 93 | Fail f <*> _ = Fail f 94 | 95 | instance Monad SuccessOrFail where 96 | return = Success 97 | Success a >>= k = k a 98 | Fail f >>= _ = Fail f 99 | #if MIN_VERSION_base(4,13,0) 100 | instance MonadFail SuccessOrFail where 101 | #endif 102 | fail = Fail 103 | 104 | -- |Evaluate some action of type @Monad m => m a@ and apply either the first or second function based on whether the computation completed or used @fail@. 105 | #if MIN_VERSION_base(4,13,0) 106 | successOrFail :: (String -> b) -> (a -> b) -> (forall m. MonadFail m => m a) -> b 107 | #else 108 | successOrFail :: (String -> b) -> (a -> b) -> (forall m. Monad m => m a) -> b 109 | #endif 110 | successOrFail _ f (Success a) = f a 111 | successOrFail f _ (Fail s) = f s 112 | #if __GLASGOW_HASKELL__ >= 810 113 | successOrFail f _ _ = f "pattern matching should have been exhaustive, but GHC disagreed" 114 | #endif 115 | 116 | 117 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/Formats/Default.hs: -------------------------------------------------------------------------------- 1 | module Composite.Aeson.Formats.Default 2 | ( DefaultJsonFormat(..) 3 | ) where 4 | 5 | import Composite.Aeson.Base (JsonFormat, wrappedJsonFormat) 6 | import Composite.Aeson.Formats.InternalTH (makeTupleDefaults) 7 | import Composite.Aeson.Formats.Provided -- sorry 8 | import qualified Data.Aeson as Aeson 9 | import Data.Fixed (Fixed, HasResolution) 10 | import Data.Functor.Compose (Compose) 11 | import Data.Functor.Const (Const) 12 | import Data.Functor.Identity (Identity) 13 | import Data.HashMap.Strict (HashMap) 14 | import Data.Int (Int8, Int16, Int32, Int64) 15 | import Data.IntSet (IntSet) 16 | import Data.List.NonEmpty (NonEmpty) 17 | import Data.Map (Map) 18 | import qualified Data.Monoid as Monoid 19 | import Data.Scientific (Scientific) 20 | import qualified Data.Semigroup as Semigroup 21 | import Data.Sequence (Seq) 22 | import Data.Tagged (Tagged) 23 | import Data.Text (Text) 24 | import qualified Data.Text.Lazy as TL 25 | import Data.Vector (Vector) 26 | import Data.Version (Version) 27 | import Data.Word (Word8, Word16, Word32, Word64) 28 | import Numeric.Natural (Natural) 29 | 30 | -- |Class for associating a default JSON format with a type. 31 | -- 32 | -- DO NOT use this as the primary interface. It should only be used for defaulting in contexts where an explicit choice can also be used. 33 | -- 34 | -- Instances of this class are (hopefully) provided for each type with an obviously correct interpretation, for example 'Text', 'Int', etc. Conversely types 35 | -- without an obviously correct interpretation and in particular those with many contradictory interpretations are not included, for example 'UTCTime', 36 | -- forcing you to choose one. 37 | -- 38 | -- For types with surprising JSON mapping characteristics, take time and consider whether it would be better to explicitly configure what format to use 39 | -- instead of providing a default. 40 | class DefaultJsonFormat a where 41 | -- |Produce the default 'JsonFormat' for type @a@, which must not produce any custom errors. 42 | defaultJsonFormat :: JsonFormat e a 43 | 44 | -- |Produce the default 'JsonFormat' for a list of @a@, which must not produce any custom errors. 45 | -- This function does not usually need to be implemented as it has a sensible default. It exists to avoid overlapping instances, e.g. for @Char@ 46 | -- and @String ~ [Char]@. The default implementation uses 'listJsonFormat'. 47 | defaultJsonFormatList :: JsonFormat e [a] 48 | defaultJsonFormatList = listJsonFormat defaultJsonFormat 49 | 50 | instance DefaultJsonFormat a => DefaultJsonFormat (Identity a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 51 | instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Min a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 52 | instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Max a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 53 | instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.First a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 54 | instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.Last a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 55 | instance DefaultJsonFormat a => DefaultJsonFormat (Semigroup.WrappedMonoid a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 56 | instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Dual a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 57 | instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Sum a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 58 | instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Product a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 59 | instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.First a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 60 | instance DefaultJsonFormat a => DefaultJsonFormat (Monoid.Last a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 61 | instance DefaultJsonFormat a => DefaultJsonFormat (Const a b) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 62 | instance DefaultJsonFormat a => DefaultJsonFormat (Tagged b a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 63 | instance DefaultJsonFormat a => DefaultJsonFormat (Maybe a) where defaultJsonFormat = maybeJsonFormat defaultJsonFormat 64 | instance DefaultJsonFormat a => DefaultJsonFormat (NonEmpty a) where defaultJsonFormat = nonEmptyListJsonFormat defaultJsonFormat 65 | instance DefaultJsonFormat a => DefaultJsonFormat (Seq a) where defaultJsonFormat = seqJsonFormat defaultJsonFormat 66 | instance DefaultJsonFormat a => DefaultJsonFormat (Vector a) where defaultJsonFormat = vectorJsonFormat defaultJsonFormat 67 | 68 | instance DefaultJsonFormat (f (g a)) => DefaultJsonFormat (Compose f g a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 69 | 70 | instance DefaultJsonFormat (f a) => DefaultJsonFormat (Monoid.Alt f a) where defaultJsonFormat = wrappedJsonFormat defaultJsonFormat 71 | 72 | instance DefaultJsonFormat a => DefaultJsonFormat (Map Text a) where 73 | defaultJsonFormat = strictMapJsonFormat id pure defaultJsonFormat 74 | instance DefaultJsonFormat a => DefaultJsonFormat (HashMap Text a) where 75 | defaultJsonFormat = strictHashMapJsonFormat id pure defaultJsonFormat 76 | 77 | instance HasResolution a => DefaultJsonFormat (Fixed a) where defaultJsonFormat = fixedJsonFormat 78 | 79 | $makeTupleDefaults 80 | 81 | instance DefaultJsonFormat Monoid.All where defaultJsonFormat = wrappedJsonFormat boolJsonFormat 82 | instance DefaultJsonFormat Monoid.Any where defaultJsonFormat = wrappedJsonFormat boolJsonFormat 83 | 84 | instance DefaultJsonFormat Aeson.Value where defaultJsonFormat = aesonValueJsonFormat 85 | instance DefaultJsonFormat Bool where defaultJsonFormat = boolJsonFormat 86 | instance DefaultJsonFormat IntSet where defaultJsonFormat = intSetJsonFormat 87 | instance DefaultJsonFormat Int where defaultJsonFormat = integralJsonFormat 88 | instance DefaultJsonFormat Int8 where defaultJsonFormat = integralJsonFormat 89 | instance DefaultJsonFormat Int16 where defaultJsonFormat = integralJsonFormat 90 | instance DefaultJsonFormat Int32 where defaultJsonFormat = integralJsonFormat 91 | instance DefaultJsonFormat Int64 where defaultJsonFormat = integralJsonFormat 92 | instance DefaultJsonFormat Integer where defaultJsonFormat = integralJsonFormat 93 | instance DefaultJsonFormat Word where defaultJsonFormat = integralJsonFormat 94 | instance DefaultJsonFormat Word8 where defaultJsonFormat = integralJsonFormat 95 | instance DefaultJsonFormat Word16 where defaultJsonFormat = integralJsonFormat 96 | instance DefaultJsonFormat Word32 where defaultJsonFormat = integralJsonFormat 97 | instance DefaultJsonFormat Word64 where defaultJsonFormat = integralJsonFormat 98 | instance DefaultJsonFormat TL.Text where defaultJsonFormat = lazyTextJsonFormat 99 | instance DefaultJsonFormat Natural where defaultJsonFormat = naturalJsonFormat 100 | instance DefaultJsonFormat Ordering where defaultJsonFormat = orderingJsonFormat 101 | instance DefaultJsonFormat Float where defaultJsonFormat = realFloatJsonFormat 102 | instance DefaultJsonFormat Double where defaultJsonFormat = realFloatJsonFormat 103 | instance DefaultJsonFormat Scientific where defaultJsonFormat = scientificJsonFormat 104 | instance DefaultJsonFormat Text where defaultJsonFormat = textJsonFormat 105 | instance DefaultJsonFormat () where defaultJsonFormat = unitJsonFormat 106 | instance DefaultJsonFormat Version where defaultJsonFormat = versionJsonFormat 107 | 108 | instance DefaultJsonFormat Char where 109 | defaultJsonFormat = charJsonFormat 110 | defaultJsonFormatList = stringJsonFormat 111 | 112 | instance DefaultJsonFormat a => DefaultJsonFormat [a] where 113 | defaultJsonFormat = defaultJsonFormatList 114 | -------------------------------------------------------------------------------- /composite-aeson/src/Composite/Aeson/Formats/InternalTH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Composite.Aeson.Formats.InternalTH 3 | ( makeTupleDefaults, makeTupleFormats, makeNamedTupleFormats 4 | ) where 5 | 6 | import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor)) 7 | import Control.Monad.Except (throwError) 8 | import qualified Data.Aeson as Aeson 9 | import qualified Data.Aeson.Key as Aeson.Key 10 | import qualified Data.Aeson.KeyMap as Aeson.KeyMap 11 | import qualified Data.Aeson.BetterErrors as ABE 12 | import Data.List (foldl') 13 | import Data.Text (Text) 14 | import qualified Data.Vector as V 15 | import Language.Haskell.TH 16 | ( Name, mkName, newName, tupleDataName 17 | , Q 18 | , cxt, clause, normalB 19 | , Dec, funD, instanceD, sigD, valD 20 | , Exp(AppE, ConE, VarE), appE, doE, lamE, listE, varE 21 | , conP, varP, wildP 22 | , bindS, noBindS 23 | , Type(AppT, ArrowT, ConT, ForallT, TupleT, VarT), appT, conT, varT 24 | , TyVarBndr(PlainTV) 25 | #if MIN_VERSION_template_haskell(2,17,0) 26 | , Specificity(SpecifiedSpec) 27 | #endif 28 | ) 29 | import Language.Haskell.TH.Syntax (lift) 30 | 31 | djfClassName :: Name 32 | djfClassName = mkName "Composite.Aeson.Formats.Default.DefaultJsonFormat" 33 | 34 | djfFunName :: Name 35 | djfFunName = mkName "Composite.Aeson.Formats.Default.defaultJsonFormat" 36 | 37 | -- |Splice which inserts the @DefaultJsonFormat@ instances for tuples. 38 | makeTupleDefaults :: Q [Dec] 39 | makeTupleDefaults = traverse makeTupleDefault [2..59] 40 | where 41 | makeTupleDefault arity = do 42 | names <- traverse (newName . ("a" ++) . show) [1..arity] 43 | let constraints = map (\ n -> appT (conT djfClassName) (varT n)) names 44 | instanceHead = appT (conT djfClassName) (pure $ foldl' AppT (TupleT arity) (map VarT names)) 45 | implName = mkName $ "Composite.Aeson.Formats.Provided.tuple" <> show arity <> "JsonFormat" 46 | instanceD (cxt constraints) instanceHead 47 | [ funD (mkName "defaultJsonFormat") 48 | [ clause 49 | [] 50 | (normalB (pure $ foldl' (\ lhs _ -> AppE lhs (VarE djfFunName)) (VarE implName) [1..arity])) 51 | [] 52 | ] 53 | ] 54 | 55 | -- |Splice which inserts the @tupleNJsonFormat@ implementations for tuples. 56 | makeTupleFormats :: Q [Dec] 57 | makeTupleFormats = concat <$> traverse makeTupleFormat [2..59] 58 | where 59 | makeTupleFormat arity = do 60 | tyNames <- traverse (newName . ("t" ++) . show) [1..arity] 61 | oNames <- traverse (newName . ("o" ++) . show) [1..arity] 62 | iNames <- traverse (newName . ("i" ++) . show) [1..arity] 63 | oTupName <- newName "oTup" 64 | iTupName <- newName "iTup" 65 | valNames <- traverse (newName . ("v" ++) . show) [1..arity] 66 | tyErrName <- newName "e" 67 | 68 | let name = mkName $ "tuple" <> show arity <> "JsonFormat" 69 | tupleType = foldl' AppT (TupleT arity) (map VarT tyNames) 70 | funType = 71 | ForallT 72 | #if MIN_VERSION_template_haskell(2,17,0) 73 | (PlainTV tyErrName SpecifiedSpec : map (flip PlainTV SpecifiedSpec) tyNames) 74 | #else 75 | (PlainTV tyErrName : map PlainTV tyNames) 76 | #endif 77 | [] 78 | (foldr (\ tyName rest -> ArrowT `AppT` (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tyName) `AppT` rest) 79 | (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tupleType) 80 | (map VarT tyNames)) 81 | oTupImpl = 82 | lamE 83 | [conP (tupleDataName arity) (map varP valNames)] 84 | [| (Aeson.Array . V.fromList) $(listE $ map (\ (varName, oName) -> appE (varE oName) (varE varName)) (zip valNames oNames)) |] 85 | iTupImpl = 86 | doE 87 | $ [ bindS wildP [| 88 | ABE.withArray Right >>= \ a -> 89 | if V.length a == $(lift arity) 90 | then pure () 91 | else throwError $ ABE.InvalidJSON $ $(lift $ "expected an array of exactly " <> show arity <> " elements") 92 | |] 93 | ] 94 | ++ map ( \ (n, valName, iName) -> 95 | bindS (varP valName) [| ABE.nth $(lift (n :: Int)) $(varE iName) |] ) 96 | (zip3 [0..] valNames iNames) 97 | ++ [ noBindS (appE (varE 'pure) (pure $ foldl' AppE (ConE (tupleDataName arity)) (map VarE valNames))) ] 98 | sequence 99 | [ sigD name (pure funType) 100 | , funD name 101 | [ clause 102 | (map (\ (oName, iName) -> conP 'JsonFormat [conP 'JsonProfunctor [varP oName, varP iName]]) (zip oNames iNames)) 103 | (normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |]) 104 | [ valD (varP oTupName) (normalB oTupImpl) [] 105 | , valD (varP iTupName) (normalB iTupImpl) [] 106 | ] 107 | ] 108 | ] 109 | 110 | -- |Splice which inserts the @namedTupleNJsonFormat@ implementations for tuples. 111 | makeNamedTupleFormats :: Q [Dec] 112 | makeNamedTupleFormats = concat <$> traverse makeNamedTupleFormat [2..59] 113 | where 114 | makeNamedTupleFormat arity = do 115 | tyNames <- traverse (newName . ("t" ++) . show) [1..arity] 116 | fNames <- traverse (newName . ("f" ++) . show) [1..arity] 117 | oNames <- traverse (newName . ("o" ++) . show) [1..arity] 118 | iNames <- traverse (newName . ("i" ++) . show) [1..arity] 119 | oTupName <- newName "oTup" 120 | iTupName <- newName "iTup" 121 | valNames <- traverse (newName . ("v" ++) . show) [1..arity] 122 | tyErrName <- newName "e" 123 | 124 | let name = mkName $ "namedTuple" <> show arity <> "JsonFormat" 125 | tupleType = foldl' AppT (TupleT arity) (map VarT tyNames) 126 | funType = 127 | ForallT 128 | #if MIN_VERSION_template_haskell(2,17,0) 129 | (PlainTV tyErrName SpecifiedSpec : map (flip PlainTV SpecifiedSpec) tyNames) 130 | #else 131 | (PlainTV tyErrName : map PlainTV tyNames) 132 | #endif 133 | [] 134 | (foldr (\ tyName rest -> ArrowT `AppT` ConT ''Text `AppT` (ArrowT `AppT` (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tyName) `AppT` rest)) 135 | (ConT ''JsonFormat `AppT` VarT tyErrName `AppT` tupleType) 136 | (map VarT tyNames)) 137 | oTupImpl = 138 | lamE 139 | [conP (tupleDataName arity) (map varP valNames)] 140 | [| (Aeson.Object . Aeson.KeyMap.fromList) 141 | $(listE $ map (\ (fName, varName, oName) -> [| (Aeson.Key.fromText $(varE fName), $(varE oName) $(varE varName)) |]) 142 | (zip3 fNames valNames oNames)) |] 143 | iTupImpl = 144 | doE 145 | $ map ( \ (fName, valName, iName) -> 146 | bindS (varP valName) [| ABE.key $(varE fName) $(varE iName) |] ) 147 | (zip3 fNames valNames iNames) 148 | ++ [ noBindS (appE (varE 'pure) (pure $ foldl' AppE (ConE (tupleDataName arity)) (map VarE valNames))) ] 149 | sequence 150 | [ sigD name (pure funType) 151 | , funD name 152 | [ clause 153 | (foldr (\ (fName, oName, iName) rest -> varP fName : conP 'JsonFormat [conP 'JsonProfunctor [varP oName, varP iName]] : rest) 154 | [] 155 | (zip3 fNames oNames iNames)) 156 | (normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |]) 157 | [ valD (varP oTupName) (normalB oTupImpl) [] 158 | , valD (varP iTupName) (normalB iTupImpl) [] 159 | ] 160 | ] 161 | ] 162 | -------------------------------------------------------------------------------- /composite-aeson/test/DateTimeSpec.hs: -------------------------------------------------------------------------------- 1 | module DateTimeSpec where 2 | 3 | import Composite.Aeson (parseJsonWithFormat', toJsonWithFormat) 4 | import Composite.Aeson.Formats.DateTime (iso8601DateTimeJsonFormat) 5 | import Data.Aeson.Types (parseEither) 6 | import Data.Aeson.QQ (aesonQQ) 7 | import Data.Time.Calendar (Day(ModifiedJulianDay)) 8 | import Data.Time.Clock (UTCTime(UTCTime)) 9 | import Test.Hspec (Spec, describe, it, shouldBe) 10 | 11 | 12 | testDate :: UTCTime 13 | testDate = UTCTime (ModifiedJulianDay 58025) (fromRational 72151.986) 14 | 15 | dateTimeSuite :: Spec 16 | dateTimeSuite = do 17 | describe "Composite.Aeson.Formats.DateTime" $ do 18 | it "encodes ISO8601 date time format for a test date" $ 19 | toJsonWithFormat iso8601DateTimeJsonFormat testDate `shouldBe` [aesonQQ|"2017-09-29T20:02:31.986+0000"|] 20 | it "decodes ISO8601 date time format for a test date" $ 21 | parseEither (parseJsonWithFormat' iso8601DateTimeJsonFormat) [aesonQQ|"2017-09-29T20:02:31.986+0000"|] `shouldBe` Right testDate 22 | -------------------------------------------------------------------------------- /composite-aeson/test/EnumSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module EnumSpec where 3 | 4 | import Data.Void (Void) 5 | import Data.Aeson (Value(String)) 6 | import GHC.Generics (Generic) 7 | import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat) 8 | import Composite.Aeson.Enum (enumJsonFormat) 9 | import Composite.Aeson.Formats.Provided (listJsonFormat) 10 | import qualified Data.Aeson.BetterErrors as ABE 11 | import Data.Aeson.QQ (aesonQQ) 12 | import Test.Hspec (Spec, describe, it, shouldBe) 13 | 14 | data TestEnum = A | B deriving (Show, Eq, Ord, Generic) 15 | 16 | data LargerTestEnum = D | E | F | G deriving (Show, Eq, Ord, Generic) 17 | 18 | testEnumFormat :: JsonFormat Void TestEnum 19 | testEnumFormat = enumJsonFormat "" 20 | 21 | largerTestEnumFormat :: JsonFormat Void LargerTestEnum 22 | largerTestEnumFormat = enumJsonFormat "" 23 | 24 | enumSuite :: Spec 25 | enumSuite = 26 | describe "enumJsonFormat" $ do 27 | describe "when mapping ADTs with more than two branches" $ do 28 | it "should encode each value correctly" $ 29 | toJsonWithFormat (listJsonFormat largerTestEnumFormat) [D,E,F,G] 30 | `shouldBe` [aesonQQ|["D", "E", "F", "G"]|] 31 | 32 | it "should decode each value correctly" $ 33 | ABE.parseValue (fromJsonWithFormat (listJsonFormat largerTestEnumFormat)) [aesonQQ|["D", "E", "F", "G"]|] 34 | `shouldBe` Right [D,E,F,G] 35 | 36 | describe "when input value does not match any of enum constructors" $ 37 | it "should return a parse error, not throw an exception" $ 38 | ABE.parseValue (fromJsonWithFormat testEnumFormat) (String "C") 39 | `shouldBe` Left (ABE.BadSchema [] (ABE.FromAeson "expected one of A, B, not C")) 40 | -------------------------------------------------------------------------------- /composite-aeson/test/FieldSpec.hs: -------------------------------------------------------------------------------- 1 | module FieldSpec where 2 | 3 | import Composite ((:->)) 4 | import Composite.CoRecord (Field) 5 | import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat) 6 | import Composite.Aeson.CoRecord (defaultJsonFormatField, fieldJsonFormat) 7 | import Composite.Aeson.Formats.Generic (SumStyle(SumStyleFieldName)) 8 | import Composite.TH (withPrismsAndProxies) 9 | import Control.Lens (_Right, review) 10 | import Data.Aeson.BetterErrors (parseValue) 11 | import Data.Aeson.QQ (aesonQQ) 12 | import Data.Void (Void) 13 | import Test.Hspec (Spec, describe, it, shouldBe) 14 | 15 | withPrismsAndProxies [d| 16 | type FFoo = "foo" :-> Int 17 | type FBar = "bar" :-> Maybe String 18 | |] 19 | type TestField = '["foo" :-> Int, "bar" :-> Maybe String] 20 | 21 | fieldSuite :: Spec 22 | fieldSuite = 23 | describe "Field support" $ do 24 | let defaultFmt :: JsonFormat Void (Field TestField) 25 | defaultFmt = fieldJsonFormat SumStyleFieldName defaultJsonFormatField 26 | 27 | it "works for encoding FFoo" $ do 28 | toJsonWithFormat defaultFmt (review _FFoo 123) `shouldBe` [aesonQQ| {foo: 123} |] 29 | it "works for encoding FBar" $ do 30 | toJsonWithFormat defaultFmt (review _FBar (Just "hi")) `shouldBe` [aesonQQ| {bar: "hi"} |] 31 | it "works for decoding FFoo" $ do 32 | parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123} |] `shouldBe` review (_Right . _FFoo) 123 33 | it "works for decoding FBar" $ do 34 | parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {bar: "hi"} |] `shouldBe` review (_Right . _FBar) (Just "hi") 35 | -------------------------------------------------------------------------------- /composite-aeson/test/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec (hspec) 2 | 3 | import DateTimeSpec (dateTimeSuite) 4 | import EnumSpec (enumSuite) 5 | import RecordSpec (recordSuite) 6 | import THSpec (thSuite) 7 | import TupleSpec (tupleSuite, namedTupleSuite) 8 | 9 | main :: IO () 10 | main = hspec $ do 11 | dateTimeSuite 12 | enumSuite 13 | namedTupleSuite 14 | recordSuite 15 | thSuite 16 | tupleSuite 17 | -------------------------------------------------------------------------------- /composite-aeson/test/RecordSpec.hs: -------------------------------------------------------------------------------- 1 | module RecordSpec where 2 | 3 | import Composite (Rec(RNil), Record, (:->), pattern (:*:)) 4 | import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat) 5 | import Composite.Aeson.Formats.Provided (stringJsonFormat) 6 | import Composite.Aeson.Record (defaultJsonFormatRecord, recordJsonFormat, optionalField) 7 | import Composite.TH (withLensesAndProxies) 8 | import Control.Lens (Lens', set) 9 | import Data.Aeson.BetterErrors (parseValue) 10 | import Data.Aeson.QQ (aesonQQ) 11 | import Data.Vinyl.Lens (rlens) 12 | import Data.Void (Void) 13 | import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe) 14 | 15 | withLensesAndProxies [d| 16 | type FFoo = "foo" :-> Int 17 | type FBar = "bar" :-> Maybe String 18 | |] 19 | type TestRec = '["foo" :-> Int, "bar" :-> Maybe String] 20 | 21 | recordSuite :: Spec 22 | recordSuite = 23 | describe "Record support" $ do 24 | let fBar' :: Lens' (Rec f TestRec) (f FBar) 25 | fBar' = rlens 26 | defaultFmt, optionalFmt :: JsonFormat Void (Record TestRec) 27 | defaultFmt = recordJsonFormat defaultJsonFormatRecord 28 | optionalFmt = recordJsonFormat $ set fBar' (optionalField stringJsonFormat) defaultJsonFormatRecord 29 | 30 | it "by default requires all fields" $ do 31 | parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123, bar: "abc"} |] `shouldBe` Right (123 :*: Just "abc" :*: RNil) 32 | parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123, bar: null} |] `shouldBe` Right (123 :*: Nothing :*: RNil) 33 | parseValue (fromJsonWithFormat defaultFmt) [aesonQQ| {foo: 123} |] `shouldNotBe` Right (123 :*: Nothing :*: RNil) 34 | 35 | it "by default encodes all fields" $ do 36 | toJsonWithFormat defaultFmt (123 :*: Just "abc" :*: RNil) `shouldBe` [aesonQQ| {foo: 123, bar: "abc"} |] 37 | toJsonWithFormat defaultFmt (123 :*: Nothing :*: RNil) `shouldBe` [aesonQQ| {foo: 123, bar: null} |] 38 | 39 | it "can make fields optional" $ do 40 | parseValue (fromJsonWithFormat optionalFmt) [aesonQQ| {foo: 123, bar: "abc"} |] `shouldBe` Right (123 :*: Just "abc" :*: RNil) 41 | parseValue (fromJsonWithFormat optionalFmt) [aesonQQ| {foo: 123, bar: null} |] `shouldBe` Right (123 :*: Nothing :*: RNil) 42 | parseValue (fromJsonWithFormat optionalFmt) [aesonQQ| {foo: 123} |] `shouldBe` Right (123 :*: Nothing :*: RNil) 43 | 44 | it "omits Nothing fields when they're made optional" $ do 45 | toJsonWithFormat optionalFmt (123 :*: Just "abc" :*: RNil) `shouldBe` [aesonQQ| {foo: 123, bar: "abc"} |] 46 | toJsonWithFormat optionalFmt (123 :*: Nothing :*: RNil) `shouldBe` [aesonQQ| {foo: 123} |] 47 | -------------------------------------------------------------------------------- /composite-aeson/test/THSpec.hs: -------------------------------------------------------------------------------- 1 | module THSpec where 2 | 3 | import Composite.Aeson.Base (dimapJsonFormat, fromJsonWithFormat, toJsonWithFormat) 4 | import Composite.Aeson.CoRecord (JsonFormatField) 5 | import Composite.Aeson.Formats.Default (defaultJsonFormat) 6 | import Composite.Aeson.Formats.Generic (SumStyle(SumStyleFieldName)) 7 | import Composite.Aeson.Formats.Provided (integralJsonFormat) 8 | import Composite.Aeson.Record (JsonFormatRecord, field) 9 | import Composite.Aeson.TH (makeFieldJsonWrapper, makeFieldJsonWrapperExplicit, makeRecordJsonWrapper, makeRecordJsonWrapperExplicit) 10 | import Composite.Record ((:->), Rec((:&), RNil), pattern (:*:)) 11 | import Composite.TH (withOpticsAndProxies) 12 | import Control.Lens (review) 13 | import qualified Data.Aeson as Aeson 14 | import qualified Data.Aeson.Types as Aeson 15 | import qualified Data.Aeson.BetterErrors as ABE 16 | import Data.Aeson.QQ (aesonQQ) 17 | import Data.Void (Void) 18 | import Test.Hspec (Spec, describe, it, shouldBe) 19 | 20 | withOpticsAndProxies [d| 21 | type FFoo = "foo" :-> Int 22 | |] 23 | 24 | type Foo = '[FFoo] 25 | 26 | explicitFooJsonFormatRecord :: JsonFormatRecord e Foo 27 | explicitFooJsonFormatRecord 28 | = field (dimapJsonFormat (+10) (subtract 10) integralJsonFormat) 29 | :& RNil 30 | 31 | explicitFooJsonFormatField :: JsonFormatField e Foo 32 | explicitFooJsonFormatField 33 | = dimapJsonFormat (+10) (subtract 10) integralJsonFormat 34 | :& RNil 35 | 36 | makeRecordJsonWrapper "FooRecordDefaultJson" ''Foo 37 | makeRecordJsonWrapperExplicit "FooRecordExplicitJson" ''Foo [| explicitFooJsonFormatRecord |] 38 | makeFieldJsonWrapper "FooFieldDefaultJson" ''Foo SumStyleFieldName 39 | makeFieldJsonWrapperExplicit "FooFieldExplicitJson" ''Foo SumStyleFieldName [| explicitFooJsonFormatField |] 40 | 41 | deriving instance Eq FooRecordDefaultJson 42 | deriving instance Eq FooRecordExplicitJson 43 | deriving instance Eq FooFieldDefaultJson 44 | deriving instance Eq FooFieldExplicitJson 45 | 46 | deriving instance Show FooRecordDefaultJson 47 | deriving instance Show FooRecordExplicitJson 48 | deriving instance Show FooFieldDefaultJson 49 | deriving instance Show FooFieldExplicitJson 50 | 51 | thSuite :: Spec 52 | thSuite = do 53 | describe "Composite.Aeson.TH" $ do 54 | it "decodes via FromJSON using makeRecordJsonWrapper" $ do 55 | Aeson.parseEither Aeson.parseJSON [aesonQQ| {foo: 123} |] `shouldBe` Right (FooRecordDefaultJson $ 123 :*: RNil) 56 | it "encodes via ToJSON using makeRecordJsonWrapper" $ do 57 | Aeson.toJSON (FooRecordDefaultJson $ 123 :*: RNil) `shouldBe` [aesonQQ| {foo: 123} |] 58 | it "decodes via DefaultJsonFormat using makeRecordJsonWrapper" $ do 59 | ABE.parseValue @Void (fromJsonWithFormat defaultJsonFormat) [aesonQQ| {foo: 123} |] `shouldBe` Right (FooRecordDefaultJson $ 123 :*: RNil) 60 | it "encodes via DefaultJsonFormat using makeRecordJsonWrapper" $ do 61 | toJsonWithFormat defaultJsonFormat (FooRecordDefaultJson $ 123 :*: RNil) `shouldBe` [aesonQQ| {foo: 123} |] 62 | 63 | it "decodes via FromJSON using makeRecordJsonWrapperExplicit" $ do 64 | Aeson.parseEither Aeson.parseJSON [aesonQQ| {foo: 123} |] `shouldBe` Right (FooRecordExplicitJson $ 113 :*: RNil) 65 | it "encodes via ToJSON using makeRecordJsonWrapperExplicit" $ do 66 | Aeson.toJSON (FooRecordExplicitJson $ 113 :*: RNil) `shouldBe` [aesonQQ| {foo: 123} |] 67 | it "decodes via DefaultJsonFormat using makeRecordJsonWrapperExplicit" $ do 68 | ABE.parseValue @Void (fromJsonWithFormat defaultJsonFormat) [aesonQQ| {foo: 123} |] `shouldBe` Right (FooRecordExplicitJson $ 113 :*: RNil) 69 | it "encodes via DefaultJsonFormat using makeRecordJsonWrapperExplicit" $ do 70 | toJsonWithFormat defaultJsonFormat (FooRecordExplicitJson $ 113 :*: RNil) `shouldBe` [aesonQQ| {foo: 123} |] 71 | 72 | it "decodes via FromJSON using makeFieldJsonWrapper" $ do 73 | Aeson.parseEither Aeson.parseJSON [aesonQQ| {foo: 123} |] `shouldBe` Right (FooFieldDefaultJson $ review _FFoo 123) 74 | it "encodes via ToJSON using makeFieldJsonWrapper" $ do 75 | Aeson.toJSON (FooFieldDefaultJson $ review _FFoo 123) `shouldBe` [aesonQQ| {foo: 123} |] 76 | it "decodes via DefaultJsonFormat using makeFieldJsonWrapper" $ do 77 | ABE.parseValue @Void (fromJsonWithFormat defaultJsonFormat) [aesonQQ| {foo: 123} |] `shouldBe` Right (FooFieldDefaultJson $ review _FFoo 123) 78 | it "encodes via DefaultJsonFormat using makeFieldJsonWrapper" $ do 79 | toJsonWithFormat defaultJsonFormat (FooFieldDefaultJson $ review _FFoo 123) `shouldBe` [aesonQQ| {foo: 123} |] 80 | 81 | it "decodes via FromJSON using makeFieldJsonWrapperExplicit" $ do 82 | Aeson.parseEither Aeson.parseJSON [aesonQQ| {foo: 123} |] `shouldBe` Right (FooFieldExplicitJson $ review _FFoo 113) 83 | it "encodes via ToJSON using makeFieldJsonWrapperExplicit" $ do 84 | Aeson.toJSON (FooFieldExplicitJson $ review _FFoo 113) `shouldBe` [aesonQQ| {foo: 123} |] 85 | it "decodes via DefaultJsonFormat using makeFieldJsonWrapperExplicit" $ do 86 | ABE.parseValue @Void (fromJsonWithFormat defaultJsonFormat) [aesonQQ| {foo: 123} |] `shouldBe` Right (FooFieldExplicitJson $ review _FFoo 113) 87 | it "encodes via DefaultJsonFormat using makeFieldJsonWrapperExplicit" $ do 88 | toJsonWithFormat defaultJsonFormat (FooFieldExplicitJson $ review _FFoo 113) `shouldBe` [aesonQQ| {foo: 123} |] 89 | -------------------------------------------------------------------------------- /composite-aeson/test/TupleSpec.hs: -------------------------------------------------------------------------------- 1 | module TupleSpec where 2 | 3 | import Composite.Aeson.Base (JsonFormat, fromJsonWithFormat, toJsonWithFormat) 4 | import Composite.Aeson.Formats.Provided (tuple3JsonFormat, namedTuple3JsonFormat, integralJsonFormat, stringJsonFormat, charJsonFormat) 5 | import Data.Aeson.BetterErrors (parseValue) 6 | import Data.Aeson.QQ (aesonQQ) 7 | import Data.Void (Void) 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | import Test.QuickCheck (property) 10 | 11 | tupleSuite :: Spec 12 | tupleSuite = 13 | describe "Tuple formats" $ do 14 | it "works for 3-tuples" $ do 15 | let fmt :: JsonFormat Void (Int, String, Char) 16 | fmt = tuple3JsonFormat integralJsonFormat stringJsonFormat charJsonFormat 17 | property $ \ t -> 18 | parseValue (fromJsonWithFormat fmt) (toJsonWithFormat fmt t) `shouldBe` Right t 19 | 20 | namedTupleSuite :: Spec 21 | namedTupleSuite = 22 | describe "Named tuple formats" $ do 23 | let fmt :: JsonFormat Void (String, String, String) 24 | fmt = namedTuple3JsonFormat "foo" stringJsonFormat "bar" stringJsonFormat "baz" stringJsonFormat 25 | 26 | it "round trips" $ 27 | property $ \ t -> 28 | parseValue (fromJsonWithFormat fmt) (toJsonWithFormat fmt t) `shouldBe` Right t 29 | 30 | it "property names the fields" $ 31 | toJsonWithFormat fmt ("a", "b", "c") `shouldBe` [aesonQQ| {foo: "a", bar: "b", baz: "c"} |] 32 | -------------------------------------------------------------------------------- /composite-base/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-base/composite-base.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: da6b479a20217b518ebbd91837b9c0a301f0bdef21bbc050013198b028cb8868 8 | 9 | name: composite-base 10 | version: 0.8.0.0 11 | synopsis: Shared utilities for composite-* packages. 12 | description: Shared helpers for the various composite packages. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc. 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite 24 | Composite.CoRecord 25 | Composite.Record 26 | Composite.TH 27 | Control.Monad.Composite.Context 28 | other-modules: 29 | Paths_composite_base 30 | hs-source-dirs: 31 | src 32 | default-extensions: 33 | ConstraintKinds 34 | DataKinds 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | MultiParamTypeClasses 41 | NamedFieldPuns 42 | OverloadedStrings 43 | PatternSynonyms 44 | PolyKinds 45 | RankNTypes 46 | RecordWildCards 47 | ScopedTypeVariables 48 | StandaloneDeriving 49 | StrictData 50 | TemplateHaskell 51 | TupleSections 52 | TypeApplications 53 | TypeFamilies 54 | TypeOperators 55 | ViewPatterns 56 | ghc-options: -Wall -O2 57 | build-depends: 58 | base >=4.12 && <5 59 | , deepseq ==1.4.* 60 | , exceptions >=0.8.3 && <0.11 61 | , lens >=4.15.4 && <5.2 62 | , monad-control >=1.0.2.2 && <1.1 63 | , mtl >=2.2.1 && <2.3 64 | , profunctors >=5.2.1 && <5.7 65 | , template-haskell >=2.11.1.0 && <2.19 66 | , text >=1.2.2.2 && <1.3 67 | , transformers >=0.5.2.0 && <0.6 68 | , transformers-base >=0.4.4 && <0.5 69 | , unliftio-core >=0.1.0.0 && <0.3.0.0 70 | , vinyl >=0.5.3 && <0.15 71 | default-language: Haskell2010 72 | 73 | test-suite composite-base-test 74 | type: exitcode-stdio-1.0 75 | main-is: Main.hs 76 | other-modules: 77 | RecordSpec 78 | THSpec 79 | Paths_composite_base 80 | hs-source-dirs: 81 | test 82 | default-extensions: 83 | ConstraintKinds 84 | DataKinds 85 | FlexibleContexts 86 | FlexibleInstances 87 | FunctionalDependencies 88 | GADTs 89 | GeneralizedNewtypeDeriving 90 | MultiParamTypeClasses 91 | NamedFieldPuns 92 | OverloadedStrings 93 | PatternSynonyms 94 | PolyKinds 95 | RankNTypes 96 | RecordWildCards 97 | ScopedTypeVariables 98 | StandaloneDeriving 99 | StrictData 100 | TemplateHaskell 101 | TupleSections 102 | TypeApplications 103 | TypeFamilies 104 | TypeOperators 105 | ViewPatterns 106 | ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 107 | build-depends: 108 | QuickCheck 109 | , base >=4.12 && <5 110 | , composite-base 111 | , deepseq ==1.4.* 112 | , exceptions >=0.8.3 && <0.11 113 | , hspec 114 | , lens >=4.15.4 && <5.2 115 | , monad-control >=1.0.2.2 && <1.1 116 | , mtl >=2.2.1 && <2.3 117 | , profunctors >=5.2.1 && <5.7 118 | , template-haskell >=2.11.1.0 && <2.19 119 | , text >=1.2.2.2 && <1.3 120 | , transformers >=0.5.2.0 && <0.6 121 | , transformers-base >=0.4.4 && <0.5 122 | , unliftio-core >=0.1.0.0 && <0.3.0.0 123 | , vinyl >=0.5.3 && <0.15 124 | default-language: Haskell2010 125 | -------------------------------------------------------------------------------- /composite-base/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, deepseq, exceptions, hpack, hspec, lens, lib 2 | , monad-control, mtl, profunctors, QuickCheck, template-haskell 3 | , text, transformers, transformers-base, unliftio-core, vinyl 4 | }: 5 | mkDerivation { 6 | pname = "composite-base"; 7 | version = "0.8.0.0"; 8 | src = ./.; 9 | libraryHaskellDepends = [ 10 | base deepseq exceptions lens monad-control mtl profunctors 11 | template-haskell text transformers transformers-base unliftio-core 12 | vinyl 13 | ]; 14 | libraryToolDepends = [ hpack ]; 15 | testHaskellDepends = [ 16 | base deepseq exceptions hspec lens monad-control mtl profunctors 17 | QuickCheck template-haskell text transformers transformers-base 18 | unliftio-core vinyl 19 | ]; 20 | prePatch = "hpack"; 21 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 22 | description = "Shared utilities for composite-* packages"; 23 | license = lib.licenses.bsd3; 24 | } 25 | -------------------------------------------------------------------------------- /composite-base/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-base 2 | version: 0.8.0.0 3 | synopsis: Shared utilities for composite-* packages. 4 | description: Shared helpers for the various composite packages. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc. 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - deepseq >= 1.4 && < 1.5 15 | - exceptions >= 0.8.3 && < 0.11 16 | - lens >= 4.15.4 && < 5.2 17 | - monad-control >= 1.0.2.2 && < 1.1 18 | - mtl >= 2.2.1 && < 2.3 19 | - profunctors >= 5.2.1 && < 5.7 20 | - template-haskell >= 2.11.1.0 && < 2.19 21 | - text >= 1.2.2.2 && < 1.3 22 | - transformers >= 0.5.2.0 && < 0.6 23 | - transformers-base >= 0.4.4 && < 0.5 24 | - unliftio-core >= 0.1.0.0 && < 0.3.0.0 25 | - vinyl >= 0.5.3 && < 0.15 26 | 27 | default-extensions: 28 | - ConstraintKinds 29 | - DataKinds 30 | - FlexibleContexts 31 | - FlexibleInstances 32 | - FunctionalDependencies 33 | - GADTs 34 | - GeneralizedNewtypeDeriving 35 | - MultiParamTypeClasses 36 | - NamedFieldPuns 37 | - OverloadedStrings 38 | - PatternSynonyms 39 | - PolyKinds 40 | - RankNTypes 41 | - RecordWildCards 42 | - ScopedTypeVariables 43 | - StandaloneDeriving 44 | - StrictData 45 | - TemplateHaskell 46 | - TupleSections 47 | - TypeApplications 48 | - TypeFamilies 49 | - TypeOperators 50 | - ViewPatterns 51 | 52 | ghc-options: -Wall -O2 53 | 54 | library: 55 | source-dirs: src 56 | 57 | tests: 58 | composite-base-test: 59 | source-dirs: test 60 | main: Main.hs 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 62 | dependencies: 63 | - QuickCheck 64 | - composite-base 65 | - hspec 66 | -------------------------------------------------------------------------------- /composite-base/src/Composite.hs: -------------------------------------------------------------------------------- 1 | module Composite 2 | ( module Composite.Record 3 | ) where 4 | 5 | import Composite.Record 6 | 7 | -------------------------------------------------------------------------------- /composite-base/test/Main.hs: -------------------------------------------------------------------------------- 1 | import RecordSpec (recordSuite) 2 | import THSpec (thSuite) 3 | import Test.Hspec (hspec) 4 | 5 | main :: IO () 6 | main = hspec $ do 7 | recordSuite 8 | thSuite 9 | 10 | -------------------------------------------------------------------------------- /composite-base/test/RecordSpec.hs: -------------------------------------------------------------------------------- 1 | module RecordSpec where 2 | 3 | import Composite.Record 4 | import Composite.TH (withLensesAndProxies) 5 | import Control.Lens (set, view, _Just) 6 | import Data.Functor.Contravariant (Predicate (Predicate, getPredicate)) 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | withLensesAndProxies [d| 10 | type FFoo = "foo" :-> Int 11 | type FBar = "bar" :-> String 12 | |] 13 | 14 | type TestRec = '["foo" :-> Int, "bar" :-> String] 15 | 16 | recordSuite :: Spec 17 | recordSuite = do 18 | describe "Basic record utilities" $ do 19 | it "Supports construction and deconstruction of a Rec Identity" $ do 20 | let rec = 123 :*: "foo" :*: RNil :: Record TestRec 21 | foo :*: bar :*: RNil = rec 22 | foo `shouldBe` 123 23 | bar `shouldBe` "foo" 24 | 25 | it "Supports construction and deconstruction of a Rec f" $ do 26 | let rec = Just 123 :^: Nothing :^: RNil :: Rec Maybe TestRec 27 | Just foo :^: Nothing :^: RNil = rec 28 | foo `shouldBe` 123 29 | 30 | it "Supports construction and deconstruction of a Rec f (Contravariant)" $ do 31 | let rec = Predicate even :!: Predicate (even . length) :!: RNil :: Rec Predicate TestRec 32 | foo :!: bar :!: RNil = rec 33 | getPredicate foo 123 `shouldBe` False 34 | getPredicate bar "foo" `shouldBe` False 35 | 36 | it "Supports lensing in a Rec Identity" $ do 37 | let rec = 123 :*: "foo" :*: RNil :: Record TestRec 38 | view (rlens fFoo_) rec `shouldBe` 123 39 | view (rlens fBar_) rec `shouldBe` "foo" 40 | set (rlens fFoo_) 321 rec `shouldBe` (321 :*: "foo" :*: RNil) 41 | set (rlens fBar_) "bar" rec `shouldBe` (123 :*: "bar" :*: RNil) 42 | 43 | it "Supports lensing in a Rec Maybe" $ do 44 | let rec = Just 123 :^: Nothing :^: RNil :: Rec Maybe TestRec 45 | view (rlensCo fFoo_) rec `shouldBe` Just 123 46 | view (rlensCo fBar_) rec `shouldBe` Nothing 47 | set (rlensCo fFoo_ . _Just) 321 rec `shouldBe` (Just 321 :^: Nothing :^: RNil) 48 | set (rlensCo fBar_ . _Just) "bar" rec `shouldBe` (Just 123 :^: Nothing :^: RNil) 49 | 50 | it "Supports lensing in a Rec Predicate" $ do 51 | let rec = Predicate even :!: Predicate (even . length) :!: RNil :: Rec Predicate TestRec 52 | getPredicate (view (rlensContra fFoo_) rec) 123 `shouldBe` False 53 | getPredicate (view (rlensContra fBar_) rec) "foo" `shouldBe` False 54 | getPredicate (view (rlensContra fFoo_) (set (rlensContra fFoo_) (Predicate odd) rec)) 123 `shouldBe` True 55 | getPredicate (view (rlensContra fBar_) (set (rlensContra fBar_) (Predicate (odd . length)) rec)) "foo" `shouldBe` True 56 | -------------------------------------------------------------------------------- /composite-base/test/THSpec.hs: -------------------------------------------------------------------------------- 1 | module THSpec where 2 | 3 | import Composite.CoRecord (Field, field) 4 | import Composite.Record ((:->)(Val), Rec(RNil), Record, pattern (:*:), rlens) 5 | import Composite.TH 6 | import Control.Lens (preview, review, view) 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | -- test that withLensesAndProxies works in the simple case 10 | withLensesAndProxies [d| 11 | type FConcrete = "foo" :-> Int 12 | |] 13 | 14 | -- test that withLensesAndProxies ignores non-conformant shapes (without :->) in the declaration 15 | withLensesAndProxies [d| 16 | type ConcreteRec = '[FConcrete] 17 | type FConcreteRec = "foo" :-> Record ConcreteRec 18 | |] 19 | 20 | -- test that withLensesAndProxies works with parameterized fields (and unrelated types) 21 | withLensesAndProxies [d| 22 | type FParameterized a = "foo" :-> a 23 | type ParameterizedRec a = '[FParameterized a] 24 | type FParameterizedRec a = "foo" :-> Record (ParameterizedRec a) 25 | |] 26 | 27 | -- test that withOpticsAndProxies works in the simple case 28 | withOpticsAndProxies [d| 29 | type FOptical = "foo" :-> Int 30 | |] 31 | 32 | thSuite :: Spec 33 | thSuite = do 34 | describe "withLensesAndProxies" $ do 35 | it "works for simple fields" $ do 36 | let r :: Record '[FConcrete] 37 | r = 123 :*: RNil 38 | view fConcrete r `shouldBe` 123 39 | view (rlens fConcrete_) r `shouldBe` 123 40 | 41 | it "works for declaration blocks with non-fields in them" $ do 42 | let r :: Record ConcreteRec 43 | r = 123 :*: RNil 44 | r2 :: Record '[FConcreteRec] 45 | r2 = r :*: RNil 46 | view ( fConcreteRec . fConcrete) r2 `shouldBe` 123 47 | view (rlens fConcreteRec_ . fConcrete) r2 `shouldBe` 123 48 | 49 | it "works with parameterized fields" $ do 50 | let ra :: Record '[FParameterized Int] 51 | ra = 123 :*: RNil 52 | ra2 :: Record '[FParameterizedRec Int] 53 | ra2 = ra :*: RNil 54 | rb :: Record '[FParameterized Bool] 55 | rb = True :*: RNil 56 | rb2 :: Record '[FParameterizedRec Bool] 57 | rb2 = rb :*: RNil 58 | 59 | view ( (fParameterized @Int )) ra `shouldBe` 123 60 | view ( rlens (fParameterized_ @Int )) ra `shouldBe` 123 61 | view ( (fParameterized @Bool)) rb `shouldBe` True 62 | view ( rlens (fParameterized_ @Bool)) rb `shouldBe` True 63 | view ( (fParameterizedRec @Int ). (fParameterized @Int )) ra2 `shouldBe` 123 64 | view (rlens (fParameterizedRec_ @Int ). (fParameterized @Int )) ra2 `shouldBe` 123 65 | view ( (fParameterizedRec @Bool). (fParameterized @Bool)) rb2 `shouldBe` True 66 | view (rlens (fParameterizedRec_ @Bool). (fParameterized @Bool)) rb2 `shouldBe` True 67 | 68 | describe "withOpticsAndProxies" $ do 69 | it "works for simple fields" $ do 70 | let f :: Field '[FOptical] 71 | f = field (Val 123 :: FOptical) 72 | preview _FOptical f `shouldBe` Just 123 73 | review _FOptical 123 `shouldBe` f 74 | 75 | 76 | -------------------------------------------------------------------------------- /composite-binary/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-binary/composite-binary.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: f4dffa2b16365e1ad7fd8457dde7fbb2e897d5b182dc1bd62351227c5c9b6bcf 8 | 9 | name: composite-binary 10 | version: 0.8.0.0 11 | synopsis: Orphan binary instances. 12 | description: Binary instance for (:->) and Record. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Record.Binary 24 | other-modules: 25 | Paths_composite_binary 26 | hs-source-dirs: 27 | src 28 | default-extensions: 29 | DataKinds 30 | FlexibleContexts 31 | FlexibleInstances 32 | GeneralizedNewtypeDeriving 33 | LambdaCase 34 | MultiParamTypeClasses 35 | MultiWayIf 36 | OverloadedStrings 37 | PatternSynonyms 38 | PolyKinds 39 | QuasiQuotes 40 | RankNTypes 41 | ScopedTypeVariables 42 | StandaloneDeriving 43 | StrictData 44 | TemplateHaskell 45 | TupleSections 46 | TypeFamilies 47 | TypeOperators 48 | ViewPatterns 49 | ghc-options: -Wall -O2 50 | build-depends: 51 | base >=4.12 && <5 52 | , binary ==0.8.* 53 | , composite-base ==0.8.* 54 | default-language: Haskell2010 55 | -------------------------------------------------------------------------------- /composite-binary/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, binary, composite-base, hpack, lib }: 2 | mkDerivation { 3 | pname = "composite-binary"; 4 | version = "0.8.0.0"; 5 | src = ./.; 6 | libraryHaskellDepends = [ base binary composite-base ]; 7 | libraryToolDepends = [ hpack ]; 8 | prePatch = "hpack"; 9 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 10 | description = "Orphan binary instances"; 11 | license = lib.licenses.bsd3; 12 | } 13 | -------------------------------------------------------------------------------- /composite-binary/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-binary 2 | version: 0.8.0.0 3 | synopsis: Orphan binary instances. 4 | description: Binary instance for (:->) and Record. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - binary >= 0.8 && < 0.9 15 | - composite-base >= 0.8 && < 0.9 16 | 17 | default-extensions: 18 | - DataKinds 19 | - FlexibleContexts 20 | - FlexibleInstances 21 | - GeneralizedNewtypeDeriving 22 | - LambdaCase 23 | - MultiParamTypeClasses 24 | - MultiWayIf 25 | - OverloadedStrings 26 | - PatternSynonyms 27 | - PolyKinds 28 | - QuasiQuotes 29 | - RankNTypes 30 | - ScopedTypeVariables 31 | - StandaloneDeriving 32 | - StrictData 33 | - TemplateHaskell 34 | - TupleSections 35 | - TypeFamilies 36 | - TypeOperators 37 | - ViewPatterns 38 | 39 | ghc-options: -Wall -O2 40 | 41 | library: 42 | source-dirs: src 43 | -------------------------------------------------------------------------------- /composite-binary/src/Composite/Record/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module Composite.Record.Binary where 4 | 5 | import Composite.Record((:->), Record, Rec((:&)), val, getVal) 6 | import Control.Applicative(liftA2) 7 | import Data.Binary(Binary(put, get)) 8 | import Data.Functor.Identity(runIdentity) 9 | 10 | instance Binary a => Binary (s :-> a) where 11 | put = put . getVal 12 | get = fmap (runIdentity . val) get 13 | 14 | instance Binary (Record '[]) 15 | 16 | instance (Binary x, Binary (Record xs)) => Binary (Record (x : xs)) where 17 | put (x :& xs) = put x >> put xs 18 | get = liftA2 (:&) get get 19 | -------------------------------------------------------------------------------- /composite-ekg/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-ekg/composite-ekg.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 1a4b44c6f42691d27aaa4c03e516aaf01c057a1b86f68186d1a1733e68d8679e 8 | 9 | name: composite-ekg 10 | version: 0.8.0.0 11 | synopsis: EKG Metrics for Vinyl records 12 | description: Integration between EKG and Vinyl records allowing records holding registered metrics to be easily constructed from a type declaration. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Ekg 24 | other-modules: 25 | Paths_composite_ekg 26 | hs-source-dirs: 27 | src 28 | default-extensions: 29 | DataKinds 30 | FlexibleContexts 31 | FlexibleInstances 32 | GeneralizedNewtypeDeriving 33 | MultiParamTypeClasses 34 | OverloadedStrings 35 | PolyKinds 36 | ScopedTypeVariables 37 | StandaloneDeriving 38 | StrictData 39 | TemplateHaskell 40 | TupleSections 41 | TypeFamilies 42 | TypeOperators 43 | ViewPatterns 44 | ghc-options: -Wall -O2 45 | build-depends: 46 | base >=4.12 && <5 47 | , composite-base ==0.8.* 48 | , ekg-core >=0.1.1.3 && <0.5 49 | , lens >=4.15.4 && <5.1 50 | , text >=1.2.2.2 && <1.3 51 | , vinyl >=0.5.3 && <0.14 52 | default-language: Haskell2010 53 | -------------------------------------------------------------------------------- /composite-ekg/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, composite-base, ekg-core, hpack, lens, lib 2 | , text, vinyl 3 | }: 4 | mkDerivation { 5 | pname = "composite-ekg"; 6 | version = "0.8.0.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base composite-base ekg-core lens text vinyl 10 | ]; 11 | libraryToolDepends = [ hpack ]; 12 | prePatch = "hpack"; 13 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 14 | description = "EKG Metrics for Vinyl records"; 15 | license = lib.licenses.bsd3; 16 | } 17 | -------------------------------------------------------------------------------- /composite-ekg/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-ekg 2 | version: 0.8.0.0 3 | synopsis: EKG Metrics for Vinyl records 4 | description: Integration between EKG and Vinyl records allowing records holding registered metrics to be easily constructed from a type declaration. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - composite-base >= 0.8 && < 0.9 15 | - ekg-core >= 0.1.1.3 && < 0.5 16 | - lens >= 4.15.4 && < 5.1 17 | - text >= 1.2.2.2 && < 1.3 18 | - vinyl >= 0.5.3 && < 0.14 19 | 20 | default-extensions: 21 | - DataKinds 22 | - FlexibleContexts 23 | - FlexibleInstances 24 | - GeneralizedNewtypeDeriving 25 | - MultiParamTypeClasses 26 | - OverloadedStrings 27 | - PolyKinds 28 | - ScopedTypeVariables 29 | - StandaloneDeriving 30 | - StrictData 31 | - TemplateHaskell 32 | - TupleSections 33 | - TypeFamilies 34 | - TypeOperators 35 | - ViewPatterns 36 | 37 | ghc-options: -Wall -O2 38 | 39 | library: 40 | source-dirs: src 41 | -------------------------------------------------------------------------------- /composite-ekg/src/Composite/Ekg.hs: -------------------------------------------------------------------------------- 1 | module Composite.Ekg (EkgMetric(ekgMetric)) where 2 | 3 | import Composite.Record ((:->)(Val), Rec((:&), RNil), Record) 4 | import Data.Char (isUpper, toLower) 5 | import Data.Functor.Identity (Identity(Identity)) 6 | import qualified Data.Text as Text 7 | import Data.Proxy (Proxy(Proxy)) 8 | import Data.Text (Text, pack) 9 | import GHC.TypeLits (KnownSymbol, symbolVal) 10 | import System.Metrics (Store, createCounter, createGauge, createLabel, createDistribution) 11 | import System.Metrics.Counter (Counter) 12 | import System.Metrics.Gauge (Gauge) 13 | import System.Metrics.Label (Label) 14 | import System.Metrics.Distribution (Distribution) 15 | 16 | -- |Type class for constructing a configured EKG metric store for record type of named fields 17 | -- 18 | -- For example, given: 19 | -- 20 | -- > type FActiveUsers = "activeUsers" :-> Gauge 21 | -- > type FResponseTimes = "endpointResponseTimes" :-> Distribution 22 | -- > type FOrdersPlaced = "ordersPlaced" :-> Counter 23 | -- > type EkgMetrics = '[FActiveUsers, FResponseTimes, FRevenue] 24 | -- 25 | -- And then used in: 26 | -- 27 | -- > configureMetrics :: IO (Rec EkgMetrics) 28 | -- > configureMetrics = do 29 | -- > store <- newStore 30 | -- > metrics <- ekgMetric "myapp" store 31 | -- > _ <- forkServerWith store "localhost" 8080 32 | -- > pure metrics 33 | -- 34 | -- Compare to a more traditional: 35 | -- 36 | -- > metrics <- EkgMetrics 37 | -- > <$> createGauge "myapp.active_users store 38 | -- > <*> createDistribution "myapp.endpoint_response_times" store 39 | -- > <*> createCounter "myapp.orders_placed" store 40 | -- 41 | -- The former is more concise and harder to make naming errors particularly in larger store sets 42 | class EkgMetric a where 43 | ekgMetric :: Text -> Store -> IO a 44 | 45 | instance forall a s rs. (EkgMetric a, EkgMetric (Record rs), KnownSymbol s) => EkgMetric (Record ((s :-> a) ': rs)) where 46 | ekgMetric prefix store = 47 | (:&) 48 | <$> (Identity . Val <$> ekgMetric (prefix <> "." <> (upperScores . pack . symbolVal) (Proxy :: Proxy s)) store) 49 | <*> ekgMetric prefix store 50 | 51 | instance EkgMetric (Record '[]) where 52 | ekgMetric _ _ = pure RNil 53 | 54 | instance EkgMetric Counter where 55 | ekgMetric = createCounter 56 | 57 | instance EkgMetric Gauge where 58 | ekgMetric = createGauge 59 | 60 | instance EkgMetric Label where 61 | ekgMetric = createLabel 62 | 63 | instance EkgMetric Distribution where 64 | ekgMetric = createDistribution 65 | 66 | upperScores :: Text -> Text 67 | upperScores = Text.dropWhile (== '_') . Text.concatMap score 68 | where score :: Char -> Text 69 | score c | isUpper c = "_" <> Text.singleton (toLower c) 70 | score c = Text.singleton c 71 | -------------------------------------------------------------------------------- /composite-ekg/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.18 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /composite-hashable/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-hashable/composite-hashable.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 350dba1d289752afceac3b7155578ef1471dbb95ef3a60998216a06fe5cba6d2 8 | 9 | name: composite-hashable 10 | version: 0.8.0.0 11 | synopsis: Orphan hashable instances. 12 | description: Hashable instance for (:->) and Record. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Record.Hashable 24 | other-modules: 25 | Paths_composite_hashable 26 | hs-source-dirs: 27 | src 28 | default-extensions: 29 | DataKinds 30 | FlexibleContexts 31 | FlexibleInstances 32 | GeneralizedNewtypeDeriving 33 | LambdaCase 34 | MultiParamTypeClasses 35 | MultiWayIf 36 | OverloadedStrings 37 | PatternSynonyms 38 | PolyKinds 39 | QuasiQuotes 40 | RankNTypes 41 | ScopedTypeVariables 42 | StandaloneDeriving 43 | StrictData 44 | TemplateHaskell 45 | TupleSections 46 | TypeFamilies 47 | TypeOperators 48 | ViewPatterns 49 | ghc-options: -Wall -O2 50 | build-depends: 51 | base >=4.12 && <5 52 | , composite-base ==0.8.* 53 | , hashable >=1.1.1 && <1.4 54 | default-language: Haskell2010 55 | -------------------------------------------------------------------------------- /composite-hashable/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, composite-base, hashable, hpack, lib }: 2 | mkDerivation { 3 | pname = "composite-hashable"; 4 | version = "0.8.0.0"; 5 | src = ./.; 6 | libraryHaskellDepends = [ base composite-base hashable ]; 7 | libraryToolDepends = [ hpack ]; 8 | prePatch = "hpack"; 9 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 10 | description = "Orphan hashable instances"; 11 | license = lib.licenses.bsd3; 12 | } 13 | -------------------------------------------------------------------------------- /composite-hashable/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-hashable 2 | version: 0.8.0.0 3 | synopsis: Orphan hashable instances. 4 | description: Hashable instance for (:->) and Record. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - hashable >= 1.1.1 && < 1.4 15 | - composite-base >= 0.8 && < 0.9 16 | 17 | default-extensions: 18 | - DataKinds 19 | - FlexibleContexts 20 | - FlexibleInstances 21 | - GeneralizedNewtypeDeriving 22 | - LambdaCase 23 | - MultiParamTypeClasses 24 | - MultiWayIf 25 | - OverloadedStrings 26 | - PatternSynonyms 27 | - PolyKinds 28 | - QuasiQuotes 29 | - RankNTypes 30 | - ScopedTypeVariables 31 | - StandaloneDeriving 32 | - StrictData 33 | - TemplateHaskell 34 | - TupleSections 35 | - TypeFamilies 36 | - TypeOperators 37 | - ViewPatterns 38 | 39 | ghc-options: -Wall -O2 40 | 41 | library: 42 | source-dirs: src 43 | -------------------------------------------------------------------------------- /composite-hashable/src/Composite/Record/Hashable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module Composite.Record.Hashable where 4 | 5 | import Composite.Record((:->), Record, Rec(RNil, (:&)), getVal) 6 | import Data.Hashable(Hashable(hashWithSalt)) 7 | 8 | instance Hashable a => Hashable (s :-> a) where 9 | hashWithSalt n x = hashWithSalt n $ getVal x 10 | 11 | instance Hashable (Record '[]) where 12 | hashWithSalt n RNil = n `hashWithSalt` () 13 | 14 | instance (Hashable x, Hashable (Record xs)) => Hashable (Record (x : xs)) where 15 | hashWithSalt n (x :& xs) = n `hashWithSalt` x `hashWithSalt` xs 16 | -------------------------------------------------------------------------------- /composite-opaleye/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-opaleye/composite-opaleye.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 03ab7de21f52bc22bd073870d37886f0591c8fa2ee7a704f32d4e385ecbcc622 8 | 9 | name: composite-opaleye 10 | version: 0.8.0.0 11 | synopsis: Opaleye SQL for Vinyl records 12 | description: Integration between Vinyl records and Opaleye SQL, allowing records to be stored, retrieved, and queried from PostgreSQL. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc. 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Opaleye 24 | Composite.Opaleye.ProductProfunctors 25 | Composite.Opaleye.RecordTable 26 | Composite.Opaleye.TH 27 | Composite.Opaleye.Update 28 | Composite.Opaleye.Util 29 | other-modules: 30 | Paths_composite_opaleye 31 | hs-source-dirs: 32 | src 33 | default-extensions: 34 | DataKinds 35 | FlexibleContexts 36 | FlexibleInstances 37 | LambdaCase 38 | MultiParamTypeClasses 39 | OverloadedStrings 40 | PatternSynonyms 41 | PolyKinds 42 | ScopedTypeVariables 43 | StrictData 44 | TemplateHaskell 45 | TypeFamilies 46 | TypeOperators 47 | ViewPatterns 48 | ghc-options: -Wall -O2 49 | build-depends: 50 | base >=4.12 && <5 51 | , bytestring >=0.10.8.1 && <0.12 52 | , composite-base ==0.8.* 53 | , lens >=4.15.4 && <5.2 54 | , opaleye >=0.5.4.0 && <0.10 55 | , postgresql-simple >=0.5.3.0 && <0.7 56 | , product-profunctors >=0.8.0.3 && <0.12 57 | , profunctors >=5.2.1 && <5.7 58 | , template-haskell >=2.11.1.0 && <2.19 59 | , text >=1.2.2.2 && <1.3 60 | , vinyl >=0.5.3 && <0.15 61 | default-language: Haskell2010 62 | 63 | test-suite composite-opaleye-test 64 | type: exitcode-stdio-1.0 65 | main-is: Main.hs 66 | other-modules: 67 | UpdateSpec 68 | Paths_composite_opaleye 69 | hs-source-dirs: 70 | test 71 | default-extensions: 72 | DataKinds 73 | FlexibleContexts 74 | FlexibleInstances 75 | LambdaCase 76 | MultiParamTypeClasses 77 | OverloadedStrings 78 | PatternSynonyms 79 | PolyKinds 80 | ScopedTypeVariables 81 | StrictData 82 | TemplateHaskell 83 | TypeFamilies 84 | TypeOperators 85 | ViewPatterns 86 | ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 87 | build-depends: 88 | QuickCheck 89 | , base >=4.12 && <5 90 | , bytestring >=0.10.8.1 && <0.12 91 | , composite-base ==0.8.* 92 | , composite-opaleye 93 | , hspec 94 | , lens >=4.15.4 && <5.2 95 | , opaleye >=0.5.4.0 && <0.10 96 | , postgresql-simple >=0.5.3.0 && <0.7 97 | , product-profunctors >=0.8.0.3 && <0.12 98 | , profunctors >=5.2.1 && <5.7 99 | , template-haskell >=2.11.1.0 && <2.19 100 | , text >=1.2.2.2 && <1.3 101 | , vinyl >=0.5.3 && <0.15 102 | default-language: Haskell2010 103 | -------------------------------------------------------------------------------- /composite-opaleye/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, composite-base, hpack, hspec 2 | , lens, lib, opaleye, postgresql-simple, product-profunctors 3 | , profunctors, QuickCheck, template-haskell, text, vinyl 4 | }: 5 | mkDerivation { 6 | pname = "composite-opaleye"; 7 | version = "0.8.0.0"; 8 | src = ./.; 9 | libraryHaskellDepends = [ 10 | base bytestring composite-base lens opaleye postgresql-simple 11 | product-profunctors profunctors template-haskell text vinyl 12 | ]; 13 | libraryToolDepends = [ hpack ]; 14 | testHaskellDepends = [ 15 | base bytestring composite-base hspec lens opaleye postgresql-simple 16 | product-profunctors profunctors QuickCheck template-haskell text 17 | vinyl 18 | ]; 19 | prePatch = "hpack"; 20 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 21 | description = "Opaleye SQL for Vinyl records"; 22 | license = lib.licenses.bsd3; 23 | } 24 | -------------------------------------------------------------------------------- /composite-opaleye/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-opaleye 2 | version: 0.8.0.0 3 | synopsis: Opaleye SQL for Vinyl records 4 | description: Integration between Vinyl records and Opaleye SQL, allowing records to be stored, retrieved, and queried from PostgreSQL. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc. 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - bytestring >= 0.10.8.1 && < 0.12 15 | - composite-base >= 0.8 && < 0.9 16 | - lens >= 4.15.4 && < 5.2 17 | - opaleye >= 0.5.4.0 && < 0.10 18 | - postgresql-simple >= 0.5.3.0 && < 0.7 19 | - product-profunctors >= 0.8.0.3 && < 0.12 20 | - profunctors >= 5.2.1 && < 5.7 21 | - template-haskell >= 2.11.1.0 && < 2.19 22 | - text >= 1.2.2.2 && < 1.3 23 | - vinyl >= 0.5.3 && < 0.15 24 | 25 | default-extensions: 26 | - DataKinds 27 | - FlexibleContexts 28 | - FlexibleInstances 29 | - LambdaCase 30 | - MultiParamTypeClasses 31 | - OverloadedStrings 32 | - PatternSynonyms 33 | - PolyKinds 34 | - ScopedTypeVariables 35 | - StrictData 36 | - TemplateHaskell 37 | - TypeFamilies 38 | - TypeOperators 39 | - ViewPatterns 40 | 41 | ghc-options: -Wall -O2 42 | 43 | library: 44 | source-dirs: src 45 | 46 | tests: 47 | composite-opaleye-test: 48 | source-dirs: test 49 | main: Main.hs 50 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 51 | dependencies: 52 | - QuickCheck 53 | - composite-opaleye 54 | - hspec 55 | -------------------------------------------------------------------------------- /composite-opaleye/src/Composite/Opaleye.hs: -------------------------------------------------------------------------------- 1 | module Composite.Opaleye 2 | ( module Composite.Opaleye.ProductProfunctors 3 | , module Composite.Opaleye.RecordTable 4 | , module Composite.Opaleye.Update 5 | ) where 6 | 7 | import Composite.Opaleye.ProductProfunctors 8 | import Composite.Opaleye.RecordTable 9 | import Composite.Opaleye.Update 10 | -------------------------------------------------------------------------------- /composite-opaleye/src/Composite/Opaleye/ProductProfunctors.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Composite.Opaleye.ProductProfunctors where 3 | 4 | import Composite.Record ((:->)(Val), Rec((:&), RNil)) 5 | import Data.Functor.Identity (Identity(Identity)) 6 | import Data.Profunctor (dimap) 7 | import Data.Profunctor.Product (ProductProfunctor, (***!)) 8 | import qualified Data.Profunctor.Product as PP 9 | import Data.Profunctor.Product.Default (Default(def)) 10 | 11 | -- |Type class implementing traversal of a record, yanking individual product profunctors @Record [p a b]@ 12 | -- (though with distinct @a@ and @b@ at each position) up to @p (Record as) (Record bs)@. 13 | -- 14 | -- This is similar to the @pN@ functions on tuples provided by the @product-profunctors@ library. 15 | class ProductProfunctor p => PRec p rs where 16 | -- |Record fields @rs@ with the profunctor removed yielding the contravariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@ 17 | type PRecContra p rs :: [*] 18 | -- |Record fields @rs@ with the profunctor removed yielding the covariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@ 19 | type PRecCo p rs :: [*] 20 | 21 | -- |Traverse the record, transposing the profunctors @p@ within to the outside like 'traverse' does for Applicative effects. 22 | -- 23 | -- Roughly equivalent to @Record '[p a b, p c d, …] -> p (Record '[a, c, …]) (Record '[b, d, …])@ 24 | pRec :: Rec Identity rs -> p (Rec Identity (PRecContra p rs)) (Rec Identity (PRecCo p rs)) 25 | 26 | instance ProductProfunctor p => PRec p '[] where 27 | type PRecContra p '[] = '[] 28 | type PRecCo p '[] = '[] 29 | 30 | pRec RNil = dimap (const ()) (const RNil) PP.empty 31 | 32 | instance (ProductProfunctor p, PRec p rs) => PRec p (s :-> p a b ': rs) where 33 | type PRecContra p (s :-> p a b ': rs) = (s :-> a ': PRecContra p rs) 34 | type PRecCo p (s :-> p a b ': rs) = (s :-> b ': PRecCo p rs) 35 | 36 | pRec (Identity (Val p) :& rs) = 37 | dimap (\ (Identity (Val a) :& aRs) -> (a, aRs)) 38 | (\ (b, bRs) -> (Identity (Val b) :& bRs)) 39 | (p ***! pRec rs) 40 | 41 | instance ProductProfunctor p => Default p (Rec Identity '[]) (Rec Identity '[]) where 42 | def = dimap (const ()) (const RNil) PP.empty 43 | 44 | instance forall p s a b rsContra rsCo. (ProductProfunctor p, Default p a b, Default p (Rec Identity rsContra) (Rec Identity rsCo)) 45 | => Default p (Rec Identity (s :-> a ': rsContra)) (Rec Identity (s :-> b ': rsCo)) where 46 | def = 47 | dimap (\ (Identity (Val a) :& aRs) -> (a, aRs)) 48 | (\ (b, bRs) -> (Identity (Val b) :& bRs)) 49 | (step ***! recur) 50 | where 51 | step :: p a b 52 | step = def 53 | recur :: p (Rec Identity rsContra) (Rec Identity rsCo) 54 | recur = def 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /composite-opaleye/src/Composite/Opaleye/RecordTable.hs: -------------------------------------------------------------------------------- 1 | module Composite.Opaleye.RecordTable where 2 | 3 | import Composite.Record ((:->)(Val), Rec((:&), RNil)) 4 | import Data.Functor.Identity (Identity(Identity)) 5 | import Data.Profunctor (dimap) 6 | import Data.Profunctor.Product ((***!)) 7 | import qualified Data.Profunctor.Product as PP 8 | import Data.Proxy (Proxy(Proxy)) 9 | import GHC.TypeLits (KnownSymbol, symbolVal) 10 | import Opaleye (Field, requiredTableField, optionalTableField) 11 | import Opaleye.Internal.Table (TableFields) 12 | 13 | -- |Helper typeclass which picks which of 'requiredTableField' or 'optionalTableField' to use for a pair of write column type and read column type. 14 | -- 15 | -- @DefaultRecTableField (Maybe (Field a)) (Field a)@ uses 'optionalTableField'. 16 | -- @DefaultRecTableField (Field a) (Field a)@ uses 'requiredTableField'. 17 | class DefaultRecTableField write read where 18 | defaultRecTableField :: String -> TableFields write read 19 | 20 | instance DefaultRecTableField (Maybe (Field a)) (Field a) where 21 | defaultRecTableField = optionalTableField 22 | 23 | instance DefaultRecTableField (Field a) (Field a) where 24 | defaultRecTableField = requiredTableField 25 | 26 | -- |Type class for producing a default 'TableFields' schema for some expected record types. 'requiredTableField' and 'optionalTableField' are chosen automatically and the 27 | -- column is named after the record fields, using 'NamedField' to reflect the field names. 28 | -- 29 | -- For example, given: 30 | -- 31 | -- > type WriteRec = Record '["id" :-> Maybe (Field PGInt8), "name" :-> Field PGText] 32 | -- > type ReadRec = Record '["id" :-> Field PGInt8 , "name" :-> Field PGText] 33 | -- 34 | -- This: 35 | -- 36 | -- > defaultRecTable :: TableFields WriteRec ReadRec 37 | -- 38 | -- Is equivalent to: 39 | -- 40 | -- > pRec (optionalTableField "id" &: requiredTableField "name" &: Nil) 41 | -- 42 | -- 43 | -- Alternately, use 'Composite.Opaleye.ProductProfunctors.pRec' and the usual Opaleye 'requiredTableField' and 'optionalTableField'. 44 | class DefaultRecTable write read where 45 | defaultRecTable :: TableFields (Rec Identity write) (Rec Identity read) 46 | 47 | instance DefaultRecTable '[] '[] where 48 | defaultRecTable = dimap (const ()) (const RNil) PP.empty 49 | 50 | instance 51 | forall s r reads w writes. 52 | ( KnownSymbol s 53 | , DefaultRecTableField w r 54 | , DefaultRecTable writes reads 55 | ) => DefaultRecTable (s :-> w ': writes) (s :-> r ': reads) where 56 | defaultRecTable = 57 | dimap (\ (Identity (Val w) :& writeRs) -> (w, writeRs)) 58 | (\ (r, readRs) -> (Identity (Val r) :& readRs)) 59 | (step ***! recur) 60 | where 61 | step :: TableFields w r 62 | step = defaultRecTableField $ symbolVal (Proxy :: Proxy s) 63 | recur :: TableFields (Rec Identity writes) (Rec Identity reads) 64 | recur = defaultRecTable 65 | -------------------------------------------------------------------------------- /composite-opaleye/src/Composite/Opaleye/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Composite.Opaleye.TH where 3 | 4 | import Control.Lens ((<&>)) 5 | import qualified Data.ByteString.Char8 as BSC8 6 | import Data.Maybe (fromMaybe) 7 | import Data.Profunctor.Product.Default (Default, def) 8 | import Data.Traversable (for) 9 | import Database.PostgreSQL.Simple (ResultError(ConversionFailed, Incompatible, UnexpectedNull)) 10 | import Database.PostgreSQL.Simple.FromField (FromField, fromField, typename, returnError) 11 | import Language.Haskell.TH 12 | ( Q, Name, mkName, nameBase, newName, pprint, reify 13 | , Info(TyConI), Dec(DataD), Con(NormalC) 14 | , conT 15 | , dataD, instanceD 16 | , lamE, varE, caseE, conE 17 | , conP, varP, wildP, litP, stringL 18 | , caseE, match 19 | , funD, clause 20 | , normalB, normalGE, guardedB 21 | , cxt 22 | ) 23 | import Language.Haskell.TH.Syntax (lift) 24 | import Opaleye 25 | ( Column, DefaultFromField, ToFields, fromPGSFromField, defaultFromField 26 | ) 27 | import Opaleye.Internal.PGTypes (IsSqlType, showSqlType, literalColumn) 28 | import Opaleye.Internal.HaskellDB.PrimQuery (Literal(StringLit)) 29 | 30 | -- |Derive the various instances required to make a Haskell enumeration map to a PostgreSQL @enum@ type. 31 | -- 32 | -- In @deriveOpaleyeEnum ''HaskellType "schema.sqltype" hsConToSqlValue@, @''HaskellType@ is the sum type (data declaration) to make instances for, 33 | -- @"schema.sqltype"@ is the PostgreSQL type name, and @hsConToSqlValue@ is a function to map names of constructors to SQL values. 34 | -- 35 | -- The function @hsConToSqlValue@ is of the type @String -> Maybe String@ in order to make using 'stripPrefix' convenient. The function is applied to each 36 | -- constructor name and for @Just value@ that value is used, otherwise for @Nothing@ the constructor name is used. 37 | -- 38 | -- For example, given the Haskell type: 39 | -- 40 | -- @ 41 | -- data MyEnum = MyFoo | MyBar 42 | -- @ 43 | -- 44 | -- And PostgreSQL type: 45 | -- 46 | -- @ 47 | -- CREATE TYPE myenum AS ENUM('foo', 'bar'); 48 | -- @ 49 | -- 50 | -- The splice: 51 | -- 52 | -- @ 53 | -- deriveOpaleyeEnum ''MyEnum "myschema.myenum" ('stripPrefix' "my" . 'map' 'toLower') 54 | -- @ 55 | -- 56 | -- Will create @PGMyEnum@ and instances required to use @MyEnum@ / @Column MyEnum@ in Opaleye. 57 | -- 58 | -- The Haskell generated by this splice for the example is something like: 59 | -- 60 | -- @ 61 | -- data PGMyEnum 62 | -- 63 | -- instance 'IsSqlType' PGMyEnum where 64 | -- 'showSqlType' _ = "myschema.myenum" 65 | -- 66 | -- instance 'FromField' MyEnum where 67 | -- 'fromField' f mbs = do 68 | -- tname <- 'typename' f 69 | -- case mbs of 70 | -- _ | tname /= "myenum" -> 'returnError' 'Incompatible' f "" 71 | -- Just "foo" -> pure MyFoo 72 | -- Just "bar" -> pure MyBar 73 | -- Just other -> 'returnError' 'ConversionFailed' f ("Unexpected myschema.myenum value: " <> 'BSC8.unpack' other) 74 | -- Nothing -> 'returnError' 'UnexpectedNull' f "" 75 | -- 76 | -- instance 'DefaultFromField' PGMyEnum MyEnum where 77 | -- defaultFromField = 'fromPGSFromField' 78 | -- 79 | -- instance 'Default' 'ToFields' MyEnum ('Column' PGMyEnum) where 80 | -- def = 'ToFields' $ \ a -> 81 | -- 'literalColumn' . 'stringLit' $ case a of 82 | -- MyFoo -> "foo" 83 | -- MyBar -> "bar" 84 | -- @ 85 | deriveOpaleyeEnum :: Name -> String -> (String -> Maybe String) -> Q [Dec] 86 | deriveOpaleyeEnum hsName sqlName hsConToSqlValue = do 87 | let sqlTypeName = mkName $ "PG" ++ nameBase hsName 88 | sqlType = conT sqlTypeName 89 | hsType = conT hsName 90 | 91 | rawCons <- reify hsName >>= \ case 92 | TyConI (DataD _cxt _name _tvVarBndrs _maybeKind cons _derivingCxt) -> 93 | pure cons 94 | other -> 95 | fail $ "expected " <> show hsName <> " to name a data declaration, not:\n" <> pprint other 96 | 97 | nullaryCons <- for rawCons $ \ case 98 | NormalC conName [] -> 99 | pure conName 100 | other -> 101 | fail $ "expected every constructor of " <> show hsName <> " to be a regular nullary constructor, not:\n" <> pprint other 102 | 103 | let conPairs = nullaryCons <&> \ conName -> 104 | (conName, fromMaybe (nameBase conName) (hsConToSqlValue (nameBase conName))) 105 | 106 | sqlTypeDecl <- 107 | dataD 108 | (cxt []) 109 | sqlTypeName 110 | [] 111 | Nothing 112 | [] 113 | #if MIN_VERSION_template_haskell(2,12,0) 114 | [] 115 | #else 116 | (cxt []) 117 | #endif 118 | 119 | isSqlTypeInst <- instanceD (cxt []) [t| IsSqlType $sqlType |] . (:[]) $ do 120 | funD 'showSqlType 121 | [ clause 122 | [wildP] 123 | (normalB (lift sqlName)) 124 | [] 125 | ] 126 | 127 | fromFieldInst <- instanceD (cxt []) [t| FromField $hsType |] . (:[]) $ do 128 | field <- newName "field" 129 | mbs <- newName "mbs" 130 | tname <- newName "tname" 131 | other <- newName "other" 132 | 133 | let bodyCase = caseE (varE mbs) $ 134 | [ match 135 | wildP 136 | (guardedB [ normalGE [| $(varE tname) /= $(lift sqlName) |] 137 | [| returnError Incompatible $(varE field) "" |] ]) 138 | [] 139 | ] ++ 140 | ( 141 | conPairs <&> \ (conName, value) -> 142 | match 143 | [p| Just $(litP $ stringL value) |] 144 | (normalB [| pure $(conE conName) |]) 145 | [] 146 | ) ++ 147 | [ match 148 | [p| Just $(varP other) |] 149 | (normalB [| returnError ConversionFailed $(varE field) ("Unexpected " <> $(lift sqlName) <> " value: " <> BSC8.unpack $(varE other)) |]) 150 | [] 151 | , match 152 | [p| Nothing |] 153 | (normalB [| returnError UnexpectedNull $(varE field) "" |]) 154 | [] 155 | ] 156 | 157 | funD 'fromField 158 | [ clause 159 | [varP field, varP mbs] 160 | (normalB [| 161 | do 162 | $(varP tname) <- typename $(varE field) 163 | $bodyCase 164 | |]) 165 | [] 166 | ] 167 | 168 | defaultFromFieldInst <- instanceD (cxt []) [t| DefaultFromField $sqlType $hsType |] . (:[]) $ 169 | funD 'defaultFromField 170 | [ clause 171 | [] 172 | (normalB [| fromPGSFromField |]) 173 | [] 174 | ] 175 | 176 | defaultInst <- instanceD (cxt []) [t| Default ToFields $hsType (Column $sqlType) |] . (:[]) $ do 177 | s <- newName "s" 178 | let body = lamE [varP s] $ 179 | caseE (varE s) $ 180 | conPairs <&> \ (conName, value) -> 181 | match 182 | (conP conName []) 183 | (normalB $ lift value) 184 | [] 185 | 186 | funD 'def 187 | [ clause 188 | [] 189 | (normalB [| ToFields (literalColumn . StringLit . $body) |]) 190 | [] 191 | ] 192 | 193 | pure [sqlTypeDecl, isSqlTypeInst, fromFieldInst, defaultFromFieldInst, defaultInst] 194 | -------------------------------------------------------------------------------- /composite-opaleye/src/Composite/Opaleye/Update.hs: -------------------------------------------------------------------------------- 1 | -- |Module which provides utilities for processing updates using Opaleye and Composite 2 | module Composite.Opaleye.Update 3 | ( RecordToUpdate, recordToUpdate 4 | ) where 5 | 6 | import Composite.Record ((:->)(Val), Rec((:&), RNil), Record) 7 | import Data.Functor.Identity (Identity(Identity)) 8 | 9 | -- |Typeclass which allows transformation of a record from its select form to neutral update form, which boils down to wrapping fields that have defaults 10 | -- with 'Just'. 11 | class RecordToUpdate (rs :: [*]) (ss :: [*]) where 12 | -- |Transform a @'Record' rs@ obtained from the database to a @'Record' ss@ representing an updated version of the row. 13 | -- 14 | -- Opaleye's @runUpdate@ family of functions all take an update function of the type @columnsR -> columnsW@, which this function implements generically 15 | -- for a no-op update. 16 | -- 17 | -- Typically this function is composed with one or more lens @set@s which update the fields after the transformation. 18 | recordToUpdate :: Record rs -> Record ss 19 | 20 | -- |For an empty record, just act as 'id'. 21 | instance RecordToUpdate '[] '[] where 22 | recordToUpdate RNil = RNil 23 | {-# INLINE recordToUpdate #-} 24 | 25 | -- |For a field whose type doesn't change between selection and update, just pass the field unchanged and then recurse. 26 | instance RecordToUpdate rs ss => RecordToUpdate (r ': rs) (r ': ss) where 27 | recordToUpdate (r :& rs) = r :& recordToUpdate rs 28 | {-# INLINE recordToUpdate #-} 29 | 30 | -- |For a field whose type at selection is @s :-> a@ but at update is @s :-> Maybe a@ (a field which has a default value) add in a 'Just' and recurse. 31 | instance RecordToUpdate rs ss => RecordToUpdate (s :-> a ': rs) (s :-> Maybe a ': ss) where 32 | recordToUpdate (Identity (Val a) :& rs) = Identity (Val (Just a)) :& recordToUpdate rs 33 | {-# INLINE recordToUpdate #-} 34 | 35 | -------------------------------------------------------------------------------- /composite-opaleye/src/Composite/Opaleye/Util.hs: -------------------------------------------------------------------------------- 1 | module Composite.Opaleye.Util where 2 | 3 | import Data.Profunctor (dimap) 4 | import Opaleye (Field, ToFields, unsafeCoerceColumn) 5 | 6 | -- |Coerce one type of 'Column' 'ToFields' profunctor to another using by just asserting the changed type on the column side and using the given function 7 | -- on the Haskell side. Useful when the PG value representation is the same but the Haskell type changes, e.g. for enums. 8 | constantColumnUsing :: ToFields haskell (Field sqlType) 9 | -> (haskell' -> haskell) 10 | -> ToFields haskell' (Field sqlType') 11 | constantColumnUsing oldToFields f = dimap f unsafeCoerceColumn oldToFields 12 | -------------------------------------------------------------------------------- /composite-opaleye/test/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec (hspec) 2 | 3 | import UpdateSpec (updateSuite) 4 | 5 | main :: IO () 6 | main = hspec $ do 7 | updateSuite 8 | -------------------------------------------------------------------------------- /composite-opaleye/test/UpdateSpec.hs: -------------------------------------------------------------------------------- 1 | module UpdateSpec where 2 | 3 | import Composite.Opaleye.Update (recordToUpdate) 4 | import Composite.Record ((:->), Rec(RNil), Record, pattern (:*:)) 5 | import Composite.TH (withLensesAndProxies) 6 | import Test.Hspec (Spec, describe, it, shouldBe) 7 | 8 | withLensesAndProxies [d| 9 | type FFoo = "foo" :-> Int 10 | type FFooMay = "foo" :-> Maybe Int 11 | type FBar = "bar" :-> String 12 | type FBaz = "baz" :-> Maybe Double 13 | type FBazMay = "baz" :-> Maybe (Maybe Double) 14 | type FQux = "qux" :-> Maybe Bool 15 | |] 16 | 17 | type ForSelect1 = '[] 18 | type ForUpdate1 = '[] 19 | 20 | type ForSelect2 = '[FBar] 21 | type ForUpdate2 = '[FBar] 22 | 23 | type ForSelect3 = '[FFoo] 24 | type ForUpdate3 = '[FFooMay] 25 | 26 | type ForSelect4 = '[FFoo , FBar, FBaz , FQux] 27 | type ForUpdate4 = '[FFooMay, FBar, FBazMay, FQux] 28 | 29 | type ForSelect5 = '[FBar, FFoo , FQux, FBaz ] 30 | type ForUpdate5 = '[FBar, FFooMay, FQux, FBazMay] 31 | 32 | updateSuite :: Spec 33 | updateSuite = do 34 | describe "Composite.Opaleye.Update" $ do 35 | it "should compute the update version of an empty record" $ do 36 | recordToUpdate ( RNil :: Record ForSelect1) 37 | `shouldBe` ( RNil :: Record ForUpdate1) 38 | it "should compute the update version of a record with no defaulted fields" $ do 39 | recordToUpdate ("hi" :*: RNil :: Record ForSelect2) 40 | `shouldBe` ("hi" :*: RNil :: Record ForUpdate2) 41 | it "should compute the update version of a record with a defaulted field" $ do 42 | recordToUpdate ( 123 :*: RNil :: Record ForSelect3) 43 | `shouldBe` (Just 123 :*: RNil :: Record ForUpdate3) 44 | it "should compute the update version of a record with mixed fields" $ do 45 | recordToUpdate ( 123 :*: "hi" :*: Nothing :*: Just True :*: RNil :: Record ForSelect4) 46 | `shouldBe` (Just 123 :*: "hi" :*: Just Nothing :*: Just True :*: RNil :: Record ForUpdate4) 47 | it "should compute the update version of a record with mixed fields and different ordering" $ do 48 | recordToUpdate ("hi" :*: 123 :*: Just True :*: Nothing :*: RNil :: Record ForSelect5) 49 | `shouldBe` ("hi" :*: Just 123 :*: Just True :*: Just Nothing :*: RNil :: Record ForUpdate5) 50 | 51 | -------------------------------------------------------------------------------- /composite-reflex/.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | -------------------------------------------------------------------------------- /composite-reflex/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-reflex/composite-reflex.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 1632173cda742772774fe836d9d512d00a5b0be77665d2a4cb6ea2ff2ddc0e26 8 | 9 | name: composite-reflex 10 | version: 0.8.0.0 11 | synopsis: Utilities for using composite records and corecords with Reflex 12 | description: Utilities for using composite records and corecords with Reflex 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Confer Health, Inc 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.DMap 24 | Composite.Reflex 25 | Composite.Reflex.AuthWrapper 26 | Composite.Reflex.Routing 27 | other-modules: 28 | Paths_composite_reflex 29 | hs-source-dirs: 30 | src 31 | default-extensions: 32 | DataKinds 33 | FlexibleContexts 34 | FlexibleInstances 35 | GADTs 36 | GeneralizedNewtypeDeriving 37 | LambdaCase 38 | MultiParamTypeClasses 39 | MultiWayIf 40 | NamedFieldPuns 41 | OverloadedStrings 42 | PatternSynonyms 43 | PolyKinds 44 | QuasiQuotes 45 | RankNTypes 46 | RecordWildCards 47 | RecursiveDo 48 | ScopedTypeVariables 49 | StandaloneDeriving 50 | StrictData 51 | TemplateHaskell 52 | TupleSections 53 | TypeApplications 54 | TypeFamilies 55 | TypeOperators 56 | ViewPatterns 57 | ghc-options: -Wall -O2 58 | build-depends: 59 | base >=4.12 && <5 60 | , composite-base ==0.8.* 61 | , data-default >=0.7.1.1 && <0.8 62 | , dependent-map >=0.2.4.0 && <0.3 63 | , dependent-sum ==0.4.* 64 | , http-api-data >=0.3.7.1 && <0.5 65 | , lens >=4.15.4 && <5.2 66 | , reflex 67 | , reflex-dom 68 | , text >=1.2.2.2 && <1.3 69 | , vinyl >=0.5.3 && <0.15 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /composite-reflex/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, composite-base, data-default, dependent-map 2 | , dependent-sum, hpack, http-api-data, lens, lib, reflex 3 | , reflex-dom, text, vinyl 4 | }: 5 | mkDerivation { 6 | pname = "composite-reflex"; 7 | version = "0.8.0.0"; 8 | src = ./.; 9 | libraryHaskellDepends = [ 10 | base composite-base data-default dependent-map dependent-sum 11 | http-api-data lens reflex reflex-dom text vinyl 12 | ]; 13 | libraryToolDepends = [ hpack ]; 14 | prePatch = "hpack"; 15 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 16 | description = "Utilities for using composite records and corecords with Reflex"; 17 | license = lib.licenses.bsd3; 18 | } 19 | -------------------------------------------------------------------------------- /composite-reflex/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-reflex 2 | version: 0.8.0.0 3 | synopsis: Utilities for using composite records and corecords with Reflex 4 | description: Utilities for using composite records and corecords with Reflex 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - composite-base >= 0.8 && < 0.9 15 | - data-default >= 0.7.1.1 && < 0.8 16 | - dependent-map >= 0.2.4.0 && < 0.3 17 | - dependent-sum >= 0.4 && < 0.5 18 | - http-api-data >= 0.3.7.1 && < 0.5 19 | - lens >= 4.15.4 && < 5.2 20 | - reflex 21 | - reflex-dom 22 | - text >= 1.2.2.2 && < 1.3 23 | - vinyl >= 0.5.3 && < 0.15 24 | 25 | default-extensions: 26 | - DataKinds 27 | - FlexibleContexts 28 | - FlexibleInstances 29 | - GADTs 30 | - GeneralizedNewtypeDeriving 31 | - LambdaCase 32 | - MultiParamTypeClasses 33 | - MultiWayIf 34 | - NamedFieldPuns 35 | - OverloadedStrings 36 | - PatternSynonyms 37 | - PolyKinds 38 | - QuasiQuotes 39 | - RankNTypes 40 | - RecordWildCards 41 | - RecursiveDo 42 | - ScopedTypeVariables 43 | - StandaloneDeriving 44 | - StrictData 45 | - TemplateHaskell 46 | - TupleSections 47 | - TypeApplications 48 | - TypeFamilies 49 | - TypeOperators 50 | - ViewPatterns 51 | 52 | ghc-options: -Wall -O2 53 | 54 | library: 55 | source-dirs: src 56 | -------------------------------------------------------------------------------- /composite-reflex/platform.nix: -------------------------------------------------------------------------------- 1 | { reflex-platform 2 | , base-platform ? reflex-platform.ghcjs 3 | , ... 4 | }: 5 | 6 | with { 7 | inherit (reflex-platform.nixpkgs) fetchgitPrivate fetchFromGitHub; 8 | inherit (reflex-platform.nixpkgs.haskell.lib) dontCheck; 9 | inherit (builtins) fromJSON readFile; 10 | }; 11 | 12 | let 13 | composite = ./..; 14 | in 15 | 16 | base-platform.override { 17 | overrides = self: super: { 18 | composite-aeson = self.callPackage (composite + /composite-aeson/package.nix) {}; 19 | composite-base = self.callPackage (composite + /composite-base/package.nix) {}; 20 | # http-api-data = dontCheck (self.callPackage ./http-api-data.nix {}); 21 | # frost-shared = self.callPackage ../shared/package.nix {}; 22 | # servant = dontCheck (self.callPackage ../servant.nix {}); 23 | # servant-reflex = self.callPackage ./servant-reflex.nix {}; 24 | }; 25 | } 26 | 27 | -------------------------------------------------------------------------------- /composite-reflex/shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | reflex-platform = import {}; 3 | 4 | ghc-platform = import ./platform.nix { inherit reflex-platform; base-platform = reflex-platform.ghc; }; 5 | ghcjs-platform = import ./platform.nix { inherit reflex-platform; }; 6 | 7 | ghc-env = reflex-platform.workOn ghc-platform (ghc-platform.callPackage ./package.nix {}); 8 | ghcjs-env = reflex-platform.workOn ghcjs-platform (ghcjs-platform.callPackage ./package.nix {}); 9 | in 10 | ghcjs-env // { ghc = ghc-env; ghcjs-env = ghcjs-env; } 11 | -------------------------------------------------------------------------------- /composite-reflex/src/Composite/DMap.hs: -------------------------------------------------------------------------------- 1 | -- |Contains functionality to interoperate with DMap and DSum from dependent-map and dependent-sum. 2 | module Composite.DMap 3 | ( Witness(WitnessHead, WitnessTail) 4 | , RecDSums(recToDSums, sortedDSumsToRec), recToDMap, dmapToRec 5 | ) where 6 | 7 | import Prelude 8 | import Composite.Record (Rec((:&), RNil)) 9 | import Data.Dependent.Map (DMap) 10 | import qualified Data.Dependent.Map as DMap 11 | import Data.Dependent.Sum (DSum((:=>))) 12 | import Data.GADT.Compare (GCompare, gcompare, GEq, geq, GOrdering(GEQ, GLT, GGT)) 13 | import Data.Type.Equality ((:~:)(Refl)) 14 | import Data.Vinyl.Functor (Compose(Compose), (:.)) 15 | 16 | -- |Witness that a particular position in a list of types is a particular type, used as a DMap/DSum key witness 17 | data Witness (rs :: [u]) (r :: u) where 18 | -- |The target type @r@ is at the head of the type list. 19 | WitnessHead :: Witness (r ': rs) r 20 | -- |The target type @r@ is further down the type list, as proven by the argument @Witness@ 21 | WitnessTail :: Witness rs r -> Witness (h ': rs) r 22 | 23 | -- |Allow for generalized equality testing for 'Witness' keys 24 | instance GEq (Witness rs) where 25 | WitnessHead `geq` WitnessHead = Just Refl 26 | WitnessHead `geq` _ = Nothing 27 | _ `geq` WitnessHead = Nothing 28 | WitnessTail a `geq` WitnessTail b = a `geq` b 29 | {-# INLINE geq #-} 30 | 31 | -- |Allow for comparison of 'Witness' keys, which are ordered by their position in the original type list (record fields) 32 | instance GCompare (Witness rs) where 33 | WitnessHead `gcompare` WitnessHead = GEQ 34 | WitnessHead `gcompare` _ = GLT 35 | _ `gcompare` WitnessHead = GGT 36 | WitnessTail a `gcompare` WitnessTail b = a `gcompare` b 37 | {-# INLINE gcompare #-} 38 | 39 | -- |Class which allows @'Rec' f rs@s to be broken down into lists of @'DSum' ('Witness' rs) f@ and for (sorted) lists of @'DSum' ('Witness' rs) f@ to be 40 | -- reconstituted into a @'Rec' ('Maybe' ':.' f) rs@. 41 | class RecDSums (rs :: [u]) where 42 | -- |Decompose a @'Rec' f rs@ into a list of @'DSum' ('Witness' rs) f@, one for each field of the record. 43 | recToDSums :: forall (f :: u -> *). Rec f rs -> [DSum (Witness rs) f] 44 | 45 | -- |Assemble a list of @'DSum' ('Witness' rs) f@ which have been sorted according to the 'Witness' ordering back into a @'Rec' ('Maybe' :. f) rs@. 46 | -- 47 | -- The resulting record is composed with 'Maybe' because there's no guarantee that the list of DSums covers all fields. 48 | -- 49 | -- If more than one DSum given has the same Witness, the resulting field will take the first value. 50 | sortedDSumsToRec :: forall (f :: u -> *). [DSum (Witness rs) f] -> Rec (Maybe :. f) rs 51 | 52 | instance RecDSums '[] where 53 | recToDSums _ = [] 54 | {-# INLINE recToDSums #-} 55 | 56 | sortedDSumsToRec _ = RNil 57 | {-# INLINE sortedDSumsToRec #-} 58 | 59 | instance forall (r :: u) (rs :: [u]). RecDSums rs => RecDSums (r ': rs) where 60 | recToDSums (r :& rs) = (WitnessHead :=> r) : fmap (\ (t :=> v) -> WitnessTail t :=> v) (recToDSums rs) 61 | {-# INLINE recToDSums #-} 62 | 63 | sortedDSumsToRec sums = 64 | case splitSums sums of 65 | (fa : _, ts) -> Compose (Just fa) :& sortedDSumsToRec ts 66 | ([] , ts) -> Compose Nothing :& sortedDSumsToRec ts 67 | where 68 | splitSums :: [DSum (Witness (r ': rs)) f] -> ([f r], [DSum (Witness rs) f]) 69 | splitSums ((WitnessHead :=> a) : rest) = let (as, ts) = splitSums rest in (a : as, ts) 70 | splitSums ((WitnessTail t :=> a) : rest) = let ( _, ts) = splitSums rest in ( [], (t :=> a) : ts) 71 | splitSums [] = ([], []) 72 | {-# INLINE sortedDSumsToRec #-} 73 | 74 | recToDMap :: RecDSums rs => Rec f rs -> DMap (Witness rs) f 75 | recToDMap = DMap.fromAscList . recToDSums 76 | {-# INLINE recToDMap #-} 77 | 78 | -- |Convert a @'DMap' ('Witness' rs) f@ into a into a @'Rec' ('Maybe' :. f) rs@. 79 | -- 80 | -- The resulting record is composed with 'Maybe' because there's no guarantee that the fields of the DMap covers all fields required by the record. 81 | -- 82 | -- If more than one DSum given has the same Witness, the resulting field will take the first value. 83 | dmapToRec :: RecDSums rs => DMap (Witness rs) f -> Rec (Maybe :. f) rs 84 | dmapToRec = sortedDSumsToRec . DMap.toAscList 85 | {-# INLINE dmapToRec #-} 86 | -------------------------------------------------------------------------------- /composite-reflex/src/Composite/Reflex.hs: -------------------------------------------------------------------------------- 1 | -- |Module containing Reflex utilites for working with composite records and corecords. 2 | module Composite.Reflex 3 | ( distributeRecOverDyn, dynCase 4 | ) where 5 | 6 | import Composite.CoRecord (Case'(Case'), Cases', CoRec(CoVal), Field, asA, fieldToRec) 7 | import Composite.DMap (RecDSums, dmapToRec, recToDMap) 8 | import Composite.Record (Rec, Record) 9 | import Control.Lens ((<&>)) 10 | import Data.Function (on) 11 | import Data.Functor.Identity (Identity, runIdentity) 12 | import Data.Maybe (fromMaybe, isJust) 13 | import Data.Proxy (Proxy(Proxy)) 14 | import Data.Vinyl (RecApplicative, recordToList, rmap) 15 | import Data.Vinyl.Functor ((:.), getCompose, Const(Const)) 16 | import Data.Vinyl.Lens (rget) 17 | import Reflex.Dom (DomBuilder, Dynamic, Event, MonadHold, PostBuild, Reflex, distributeDMapOverDynPure, dyn, fmapMaybe, holdDyn, uniqDynBy, updated) 18 | 19 | -- FIXME recDyn version with Rec (Dynamic t :. f) once distributeDMapOverDynPure is more generalized 20 | 21 | -- |Given a @'Rec' ('Dynamic' t) rs@, transpose into a @'Dynamic' t ('Rec' 'Maybe' rs)@ which updates any time one of the 'Dynamic's inside the input record 22 | -- updates. 23 | distributeRecOverDyn :: forall t rs. (Reflex t, RecDSums rs) => Rec (Dynamic t) rs -> Dynamic t (Record rs) 24 | distributeRecOverDyn r = rmap recoverField . dmapToRec <$> distributeDMapOverDynPure (recToDMap r) 25 | where 26 | recoverField :: (Maybe :. Identity) a -> Identity a 27 | recoverField 28 | = fromMaybe (error "distributeDMapOverDynPure returned a DMap of a different shape than the input") 29 | . getCompose 30 | 31 | -- |Given a @'Dynamic' t ('Field' rs)@ (which must be nonempty) case split on @rs@, passing the each value to each widget given as a subsidiary 'Dynamic'. 32 | -- 33 | -- The intent is to push uses of 'dyn' down as far as possible, switching which DOM hierarchy is active only when the constructors change and letting each 34 | -- hierarchy choose what to make dynamic. 35 | -- 36 | -- For example, given @df :: 'Dynamic' t ('Field' '[Int, String])@: 37 | -- 38 | -- @ 39 | -- dynCase df 40 | -- $ Case' (\ di -> void $ text "it's an int: " >> dyn (display di)) 41 | -- :& Case' (\ ds -> void $ text "it's a string: " >> dyn (display ds)) 42 | -- :& RNil 43 | -- @ 44 | -- 45 | -- In this example, which hierarchy to use would switch based on whether @df@ carried an @Int@ or @String@, but the hierarchy doesn't switch if the value 46 | -- changes but stays on the same selector. In other words, if @df@ had @"hi!"@ at time 0, @"hello!"@ at time 1, and @123@ at time 2, the text node @it's a 47 | -- string@ would be inserted into the DOM at time 0, remain in the DOM at time 1, and only be replaced at time 2. 48 | -- 49 | -- @dynCase@ yields an 'Event' which fires each time @df@ changes selector (e.g. from @Int@ to @String@ or vice versa in the above example) and carries 50 | -- the value produced by the particular case. 51 | dynCase 52 | :: forall t m r rs a. 53 | ( Reflex t 54 | , DomBuilder t m 55 | , MonadHold t m 56 | , PostBuild t m 57 | , RecApplicative (r ': rs) 58 | ) 59 | => Dynamic t (Field (r ': rs)) 60 | -> Cases' (Dynamic t) (r ': rs) (m a) 61 | -> m (Event t a) 62 | dynCase d cases = do 63 | let selector = uniqDynBy distinctSelector d 64 | dyn $ selector <&> \ (CoVal (initial :: Identity r')) -> do 65 | da <- holdDyn (runIdentity initial) (fmapMaybe (asA (Proxy @r')) (updated d)) 66 | let Case' k = rget (Proxy @r') cases 67 | k da 68 | where 69 | distinctSelector :: Field (r ': rs) -> Field (r ': rs) -> Bool 70 | distinctSelector = (==) `on` (recordToList . rmap (Const . isJust) . fieldToRec) 71 | -------------------------------------------------------------------------------- /composite-reflex/src/Composite/Reflex/AuthWrapper.hs: -------------------------------------------------------------------------------- 1 | module Composite.Reflex.AuthWrapper 2 | ( NotAuthedDetail(Authing, FailedAuth), _Authing, _FailedAuth 3 | , AuthState, _NotAuthed, _Authed 4 | , AuthEvents(AuthEvents), _authLoggingIn, _authCancel, authLoggingIn, authCancel 5 | , authWrapper 6 | ) where 7 | 8 | import Composite.CoRecord (Case'(Case'), Field, fieldPrism) 9 | import Composite.Record (Rec((:&), RNil), (:->), getVal) 10 | import Composite.Reflex (dynCase) 11 | import Control.Lens (Prism', (<&>), _Left, _Right, _Wrapped, has, preview, review) 12 | import Control.Lens.TH (makeLenses, makePrisms) 13 | import Data.Default (Default, def) 14 | import Data.Functor (($>)) 15 | import Data.Proxy (Proxy(Proxy)) 16 | import Reflex.Dom (Behavior, hold, switch, Dynamic, holdDyn, updated, Event, ffilter, fmapMaybe, leftmost, never, MonadWidget, Reflex) 17 | 18 | -- |Detail about why the current state is @NotAuthed@. See 'AuthState' for more. 19 | data NotAuthedDetail err 20 | = Authing 21 | | FailedAuth err 22 | makePrisms ''NotAuthedDetail 23 | 24 | -- FIXME prism boilerplate 25 | 26 | -- |Not currently authenticated, with possible detail explaining why. 27 | type FNotAuthed err = "not_authed" :-> Maybe (NotAuthedDetail err) 28 | 29 | -- |Current authenticated with some context information only available while authenticated. 30 | type FAuthed ctx = "authed" :-> ctx 31 | 32 | -- |Not currently authenticated, with possible detail explaining why. 33 | _NotAuthed :: forall err ctx. Prism' (Field (AuthState err ctx)) (Maybe (NotAuthedDetail err)) 34 | _NotAuthed = fieldPrism (Proxy @(FNotAuthed err)) . _Wrapped 35 | 36 | -- |Current authenticated with some context information only available while authenticated. 37 | _Authed :: forall err ctx. Prism' (Field (AuthState err ctx)) ctx 38 | _Authed = fieldPrism (Proxy @(FAuthed ctx)) . _Wrapped 39 | 40 | -- |State representing either being authenticated (@Authed@) or not (@NotAuthed@). 41 | -- 42 | -- Being authenticated carries some context @ctx@, while being not authenticated has a reason why: 43 | -- 44 | -- * @Nothing@ indicates there's no particular reason why - either fresh visit to the app or logged out. 45 | -- * @Just Authing@ indicates that an authentication attempt is currently in progress, which can be cancelled by a logout. 46 | -- * @Just (FailedAuth err)@ indicates an authentication attempt failed. 47 | type AuthState err ctx = '[FNotAuthed err, FAuthed ctx] 48 | 49 | -- |Carrier holding event streams related to authentication, provided by the not authed page to 'authWrapper' to control login and logout. 50 | data AuthEvents t res = AuthEvents 51 | { _authLoggingIn :: Event t (Event t res) 52 | -- ^Event which indicates that a login attempt has begun, giving the event which will fire when the login attempt completes. 53 | , _authCancel :: Event t () 54 | -- ^Event which indicates a cancel. 55 | } 56 | makeLenses ''AuthEvents 57 | 58 | instance Reflex t => Default (AuthEvents t res) where 59 | def = AuthEvents never never 60 | 61 | -- |Wrap the main logged-in portion of the app so that users see the login screens when they don't have an active auth context. 62 | authWrapper 63 | :: forall t m res err ctx a. MonadWidget t m 64 | => Event t () 65 | -- ^Event to trigger a logout, e.g. from a menu 66 | -> (Dynamic t (Maybe (NotAuthedDetail err)) -> m (AuthEvents t res)) 67 | -- ^The not logged in widget, which emits events to trigger log in and log out 68 | -> (res -> Either err ctx) 69 | -- ^Interpretation of the authentication result @res@ into either an @err@ or successful auth @ctx@. 70 | -> (Dynamic t ctx -> m a) 71 | -- ^The logged-in app router to use when there is an established auth context. The additional Event can trigger a logout. 72 | -> m (Dynamic t (Field (AuthState err ctx)), Event t (Maybe a)) 73 | -- ^Event which fires any time the auth context is established or broken 74 | authWrapper logOut notAuthedWidget interpretAuthResponse authedWidget = do 75 | rec 76 | -- Event fired when the current login attempt finishes. 77 | currentLoginAttempt :: Behavior t (Event t res) <- 78 | hold never $ -- no initial attempt to log in 79 | leftmost 80 | -- if a logout is triggered, cancel a login in progress 81 | [ loggedOut $> never 82 | -- stop trying to log in if a login finishes 83 | , ffilter (has _Authed) (updated currentAuthState) $> never 84 | -- when a new login attempt is trigged, use that 85 | , loggingIn 86 | ] 87 | 88 | -- Current state of authentication 89 | currentAuthState :: Dynamic t (Field (AuthState err ctx)) <- 90 | holdDyn (review _NotAuthed Nothing) $ -- start out not authenticated 91 | leftmost 92 | -- immediately clear the auth context if a logout occurs 93 | [ loggedOut $> review _NotAuthed Nothing 94 | -- otherwise, if there's a response from the auth attempt use it to switch states 95 | , switch currentLoginAttempt <&> either (review _NotAuthed . Just . FailedAuth) (review _Authed) . interpretAuthResponse 96 | -- and finally switch to authing if a new attempt is occuring 97 | , loggingIn $> review _NotAuthed (Just Authing) 98 | ] 99 | 100 | -- Result of switching based on the auth state to build the correct UI 101 | result :: Event t (Either (AuthEvents t res) a) <- 102 | dynCase currentAuthState 103 | $ Case' (fmap Left . notAuthedWidget . fmap getVal) 104 | :& Case' (fmap Right . authedWidget . fmap getVal) 105 | :& RNil 106 | 107 | loggingIn <- switch <$> hold never (fmapMaybe (preview $ _Left . authLoggingIn) result) 108 | cancel <- switch <$> hold never (fmapMaybe (preview $ _Left . authCancel) result) 109 | let loggedOut = leftmost [cancel, logOut] 110 | appResult = preview _Right <$> result 111 | 112 | pure (currentAuthState, appResult) 113 | 114 | -------------------------------------------------------------------------------- /composite-reflex/src/Composite/Reflex/Routing.hs: -------------------------------------------------------------------------------- 1 | -- |Tools for implementing type-safe routing using corecord 'Field's. 2 | module Composite.Reflex.Routing where 3 | 4 | import Composite.CoRecord (CoRec(CoVal), Field, FoldRec, firstField) 5 | import Composite.Record ((:->)(Val), getVal) 6 | import Control.Lens (view) 7 | import Control.Monad (mfilter, mplus) 8 | import Data.Functor.Identity (Identity(Identity)) 9 | import Data.Proxy (Proxy(Proxy)) 10 | import Data.Text (Text) 11 | import Data.Vinyl (Rec, rlens, rmap) 12 | import Web.HttpApiData (FromHttpApiData(parseUrlPiece), ToHttpApiData(toUrlPiece)) 13 | 14 | -- |Structure of a route with type @a@, which provides how to take @a@, make a relative path out of it or parse it from a relative path. 15 | data Route a = Route 16 | { routePrint :: a -> [Text] 17 | -- ^Format @a@ as a list of URL segments, e.g. @["customers", "22", "logistic"]@. 18 | , routeParse :: [Text] -> Maybe a 19 | -- ^Parse a list of URL segments into a @Just a@, or @Nothing@ if the URL segments don't correspond to this route. 20 | } 21 | 22 | -- |Left-biased composition of two routes such that printing uses the left hand route, and parsing prefers the left hand one but tries the right hand one 23 | -- if the left hand one parses @Nothing@. 24 | orAccept :: Route a -> Route a -> Route a 25 | orAccept (Route o i1) (Route _ i2) = Route o (\ segs -> i1 segs `mplus` i2 segs) 26 | 27 | -- |Multiple parallel routes are represented as a record bounded with 'Route' 28 | type Routes = Rec Route 29 | 30 | -- |A single chosen path is represented by a 'Field' corecord. 31 | type Path = Field 32 | 33 | -- |Given multiple routes to choose from @'Routes' rs@, compose them into a single @'Route' ('Path' rs)@. 34 | choose :: FoldRec rs rs => Routes rs -> Route (Path rs) 35 | choose routes = Route o i 36 | where 37 | o (CoVal (Identity (a :: a))) = routePrint (view (rlens (Proxy @a)) routes) a 38 | i segs = firstField $ rmap (flip routeParse segs) routes 39 | 40 | -- |Represent a single path segment @a@ using its 'FromHttpApiData' instance to parse and 'ToHttpApiData' instance to print. 41 | capture :: (FromHttpApiData a, ToHttpApiData a) => Route b -> Route (a, b) 42 | capture rest = Route o i 43 | where 44 | o (a, b) = toUrlPiece a : routePrint rest b 45 | i (s : ss) = (,) <$> either (const Nothing) Just (parseUrlPiece s) 46 | <*> routeParse rest ss 47 | i [] = Nothing 48 | 49 | -- |Lift up a @'Route' a@ to a @'Route' (s :-> a)@ which just applies or removes the @:->@ constructor. 50 | field :: Route a -> Route (s :-> a) 51 | field (Route o i) = Route (o . getVal) (fmap Val . i) 52 | 53 | -- |Represent the end of a path, i.e. print as @[]@ and only parse @[]@. 54 | end :: Route (s :-> ()) 55 | end = Route (const []) (fmap (const $ Val ()) . mfilter null . Just) 56 | 57 | -- |Represent a segment with a fixed text value. 58 | seg :: Text -> Route a -> Route a 59 | seg p (Route {..}) = 60 | Route ((p:) . routePrint) $ \ case 61 | (p':rest) | p' == p -> routeParse rest 62 | _ -> Nothing 63 | -------------------------------------------------------------------------------- /composite-swagger/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /composite-swagger/composite-swagger.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 08065488688ff2ae8ec25cc97eda4b11bab8fb52ab2e5baca105f010a05be45e 8 | 9 | name: composite-swagger 10 | version: 0.8.0.0 11 | synopsis: Swagger for Vinyl records 12 | description: Integration between Swagger and Vinyl records allowing easily derivable/explicit Swagger definitions for records. 13 | category: Records 14 | homepage: https://github.com/ConferOpenSource/composite#readme 15 | author: Dan Fithian 16 | maintainer: oss@vitalbio.com 17 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 18 | license: BSD3 19 | build-type: Simple 20 | 21 | library 22 | exposed-modules: 23 | Composite.Swagger 24 | Composite.Swagger.Base 25 | Composite.Swagger.OrphanInstances 26 | Composite.Swagger.TH 27 | other-modules: 28 | Paths_composite_swagger 29 | hs-source-dirs: 30 | src 31 | default-extensions: 32 | DataKinds 33 | FlexibleContexts 34 | FlexibleInstances 35 | GeneralizedNewtypeDeriving 36 | MultiParamTypeClasses 37 | OverloadedStrings 38 | PolyKinds 39 | ScopedTypeVariables 40 | StandaloneDeriving 41 | StrictData 42 | TemplateHaskell 43 | TupleSections 44 | TypeFamilies 45 | TypeOperators 46 | ViewPatterns 47 | ghc-options: -Wall -O2 48 | build-depends: 49 | base >=4.12 && <5 50 | , composite-base ==0.8.* 51 | , insert-ordered-containers >=0.2.1.0 && <0.3 52 | , lens >=4.15.4 && <5.2 53 | , swagger2 >=2.1.6 && <2.9 54 | , template-haskell >=2.11.1.0 && <2.19 55 | , text >=1.2.2.2 && <1.3 56 | , vinyl >=0.5.3 && <0.15 57 | default-language: Haskell2010 58 | 59 | test-suite composite-swagger-test 60 | type: exitcode-stdio-1.0 61 | main-is: Main.hs 62 | other-modules: 63 | THSpec 64 | Paths_composite_swagger 65 | hs-source-dirs: 66 | test 67 | default-extensions: 68 | DataKinds 69 | FlexibleContexts 70 | FlexibleInstances 71 | GeneralizedNewtypeDeriving 72 | MultiParamTypeClasses 73 | OverloadedStrings 74 | PolyKinds 75 | ScopedTypeVariables 76 | StandaloneDeriving 77 | StrictData 78 | TemplateHaskell 79 | TupleSections 80 | TypeFamilies 81 | TypeOperators 82 | ViewPatterns 83 | ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 84 | build-depends: 85 | QuickCheck 86 | , base >=4.12 && <5 87 | , composite-aeson 88 | , composite-base 89 | , composite-swagger 90 | , hspec 91 | , insert-ordered-containers >=0.2.1.0 && <0.3 92 | , lens >=4.15.4 && <5.2 93 | , swagger2 >=2.1.6 && <2.9 94 | , template-haskell >=2.11.1.0 && <2.19 95 | , text >=1.2.2.2 && <1.3 96 | , vinyl >=0.5.3 && <0.15 97 | default-language: Haskell2010 98 | -------------------------------------------------------------------------------- /composite-swagger/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, composite-aeson, composite-base, hpack, hspec 2 | , insert-ordered-containers, lens, lib, QuickCheck, swagger2 3 | , template-haskell, text, vinyl 4 | }: 5 | mkDerivation { 6 | pname = "composite-swagger"; 7 | version = "0.8.0.0"; 8 | src = ./.; 9 | libraryHaskellDepends = [ 10 | base composite-base insert-ordered-containers lens swagger2 11 | template-haskell text vinyl 12 | ]; 13 | libraryToolDepends = [ hpack ]; 14 | testHaskellDepends = [ 15 | base composite-aeson composite-base hspec insert-ordered-containers 16 | lens QuickCheck swagger2 template-haskell text vinyl 17 | ]; 18 | prePatch = "hpack"; 19 | homepage = "https://github.com/ConferOpenSource/composite#readme"; 20 | description = "Swagger for Vinyl records"; 21 | license = lib.licenses.bsd3; 22 | } 23 | -------------------------------------------------------------------------------- /composite-swagger/package.yaml: -------------------------------------------------------------------------------- 1 | name: composite-swagger 2 | version: 0.8.0.0 3 | synopsis: Swagger for Vinyl records 4 | description: Integration between Swagger and Vinyl records allowing easily derivable/explicit Swagger definitions for records. 5 | homepage: https://github.com/ConferOpenSource/composite#readme 6 | license: BSD3 7 | author: Dan Fithian 8 | maintainer: oss@vitalbio.com 9 | copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences 10 | category: Records 11 | 12 | dependencies: 13 | - base >= 4.12 && < 5 14 | - composite-base >= 0.8 && < 0.9 15 | - insert-ordered-containers >= 0.2.1.0 && < 0.3 16 | - lens >= 4.15.4 && < 5.2 17 | - swagger2 >= 2.1.6 && < 2.9 18 | - template-haskell >= 2.11.1.0 && < 2.19 19 | - text >= 1.2.2.2 && < 1.3 20 | - vinyl >= 0.5.3 && < 0.15 21 | 22 | default-extensions: 23 | - DataKinds 24 | - FlexibleContexts 25 | - FlexibleInstances 26 | - GeneralizedNewtypeDeriving 27 | - MultiParamTypeClasses 28 | - OverloadedStrings 29 | - PolyKinds 30 | - ScopedTypeVariables 31 | - StandaloneDeriving 32 | - StrictData 33 | - TemplateHaskell 34 | - TupleSections 35 | - TypeFamilies 36 | - TypeOperators 37 | - ViewPatterns 38 | 39 | ghc-options: -Wall -O2 40 | 41 | library: 42 | source-dirs: src 43 | 44 | tests: 45 | composite-swagger-test: 46 | source-dirs: test 47 | main: Main.hs 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans 49 | dependencies: 50 | - QuickCheck 51 | - composite-aeson 52 | - composite-base 53 | - composite-swagger 54 | - hspec 55 | -------------------------------------------------------------------------------- /composite-swagger/src/Composite/Swagger.hs: -------------------------------------------------------------------------------- 1 | module Composite.Swagger 2 | ( module Composite.Swagger.Base 3 | ) where 4 | 5 | import Composite.Swagger.Base 6 | -------------------------------------------------------------------------------- /composite-swagger/src/Composite/Swagger/Base.hs: -------------------------------------------------------------------------------- 1 | module Composite.Swagger.Base where 2 | 3 | import Control.Lens (Unwrapped, Wrapped, (&), (?~)) 4 | import Composite.Swagger.OrphanInstances () 5 | import Data.Proxy (Proxy (Proxy)) 6 | import Data.Swagger 7 | ( Definitions, NamedSchema(NamedSchema), Schema, SwaggerType(SwaggerObject), ToSchema 8 | , declareSchema, type_ ) 9 | import Data.Swagger.Declare (Declare) 10 | import qualified Data.Text as Text 11 | 12 | -- |Given a 'Control.Lens.Wrapped' and an underlying 'Data.Swagger.ToSchema' instance, create a 13 | -- Schema with the given name surrounding the underlying instance. 14 | wrappedSchema :: (Wrapped wrap, ToSchema (Unwrapped wrap)) => Proxy wrap -> String -> Declare (Definitions Schema) NamedSchema 15 | wrappedSchema (Proxy :: Proxy wrap) name = do 16 | s <- declareSchema (Proxy :: Proxy (Unwrapped wrap)) 17 | pure $ NamedSchema (Just $ Text.pack name) s 18 | & type_ ?~ SwaggerObject 19 | -------------------------------------------------------------------------------- /composite-swagger/src/Composite/Swagger/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Composite.Swagger.OrphanInstances where 4 | 5 | import Composite ((:->), Record) 6 | import Control.Lens ((%~), (&)) 7 | import qualified Data.HashMap.Strict.InsOrd as I 8 | import Data.Proxy (Proxy (Proxy)) 9 | import Data.Swagger 10 | ( NamedSchema (NamedSchema), ToSchema 11 | , declareNamedSchema, declareSchemaRef, properties, schema ) 12 | import qualified Data.Text as Text 13 | import GHC.TypeLits (KnownSymbol, symbolVal) 14 | 15 | -- Orphan instances for 'Data.Vinyl.Record' that stuff a name/parameter schema into a 16 | -- 'Data.Swagger.Schema' object. 17 | 18 | instance ToSchema (Record '[]) where 19 | declareNamedSchema _ = pure $ NamedSchema Nothing mempty 20 | 21 | instance forall a s rs. (ToSchema a, ToSchema (Record rs), KnownSymbol s) => ToSchema (Record ((s :-> a) ': rs)) where 22 | declareNamedSchema _ = do 23 | xs <- declareNamedSchema (Proxy :: Proxy (Record rs)) 24 | x <- declareSchemaRef (Proxy :: Proxy a) 25 | let name = Text.pack $ symbolVal (Proxy :: Proxy s) 26 | pure $ xs 27 | & schema.properties %~ I.insert name x 28 | -------------------------------------------------------------------------------- /composite-swagger/src/Composite/Swagger/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Composite.Swagger.TH where 3 | 4 | import Composite.CoRecord (Field) 5 | import Composite.Swagger.Base (wrappedSchema) 6 | import Data.Proxy (Proxy (Proxy)) 7 | import Data.Swagger (ToSchema, declareNamedSchema) 8 | import Language.Haskell.TH 9 | ( Dec, Name, Q, mkName 10 | , bang, bangType, clause, conT, cxt, funD, instanceD, newtypeD, normalB, recC, varBangType , wildP 11 | , noSourceStrictness, noSourceUnpackedness ) 12 | 13 | -- |TH splice which makes it more convenient to define 'ToSchema' instance for 'Record' types. 14 | -- 15 | -- For example: 16 | -- 17 | -- @ 18 | -- type MyRecord = '[FFoo, FBar] 19 | -- newtype MyRecordWrapper = MyRecordWrapper { unMyRecordWrapper :: Record MyRecord } 20 | -- makeToSchema "MyRecordWrapper" ''MyRecordWrapper 21 | -- @ 22 | -- 23 | -- is equivalent to: 24 | -- 25 | -- @ 26 | -- instance ToSchema MyRecordWrapper where 27 | -- declareNamedSchema = wrappedSchema (Proxy :: Proxy MyRecordWrapper) "MyRecordWrapper" 28 | -- @ 29 | makeToSchema :: String -> Name -> Q [Dec] 30 | makeToSchema schemaName wrapperName = 31 | sequence 32 | [ instanceD 33 | (cxt []) 34 | [t| ToSchema $(conT wrapperName) |] 35 | [ funD 36 | 'declareNamedSchema 37 | [ clause [wildP] (normalB [| wrappedSchema (Proxy :: Proxy $(conT wrapperName)) schemaName |]) [] ] 38 | ] 39 | ] 40 | 41 | -- |TH splice which makes it more convenient to define 'ToSchema' instance for 'Record' types. 42 | -- 43 | -- For example: 44 | -- 45 | -- @ 46 | -- type MyRecord = '[FFoo, FBar] 47 | -- makeToSchemaWrapper "MyRecordWrapper" ''MyRecord 48 | -- @ 49 | -- 50 | -- is equivalent to: 51 | -- 52 | -- @ 53 | -- newtype MyRecordWrapper = MyRecordWrapper { unMyRecordWrapper :: Record MyRecord } 54 | -- instance ToSchema MyRecordWrapper where 55 | -- declareNamedSchema = wrappedSchema (Proxy :: Proxy MyRecordWrapper) "MyRecordWrapper" 56 | -- @ 57 | makeToSchemaWrapper :: String -> Name -> Q [Dec] 58 | makeToSchemaWrapper wrapperNameStr fieldsTyName = do 59 | let wrapperName = mkName wrapperNameStr 60 | extractorName = mkName $ "un" <> wrapperNameStr 61 | fieldTy = [t| Field $(conT fieldsTyName) |] 62 | wrapperNewtype <- newtypeD 63 | (cxt []) 64 | wrapperName 65 | [] -- TyVarBndrs 66 | Nothing -- kind 67 | (recC wrapperName [varBangType extractorName (bangType (bang noSourceUnpackedness noSourceStrictness) fieldTy)]) 68 | #if MIN_VERSION_template_haskell(2,12,0) 69 | [] -- deriving context 70 | #else 71 | (cxt []) 72 | #endif 73 | wrapperInstances <- makeToSchema wrapperNameStr wrapperName 74 | pure $ wrapperNewtype:wrapperInstances 75 | -------------------------------------------------------------------------------- /composite-swagger/test/Main.hs: -------------------------------------------------------------------------------- 1 | import THSpec (thSuite) 2 | import Test.Hspec (hspec) 3 | 4 | main :: IO () 5 | main = hspec $ do 6 | thSuite 7 | -------------------------------------------------------------------------------- /composite-swagger/test/THSpec.hs: -------------------------------------------------------------------------------- 1 | module THSpec where 2 | 3 | import Composite 4 | import Composite.Aeson.TH (makeRecordJsonWrapper) 5 | import Composite.Swagger.TH (makeToSchema) 6 | import Composite.TH (withLensesAndProxies) 7 | import Control.Lens.TH (makeWrapped) 8 | import Data.Swagger (validateToJSON) 9 | import Test.Hspec (Spec, describe, it, shouldBe) 10 | 11 | withLensesAndProxies [d| 12 | type FFoo = "foo" :-> Int 13 | type FBar = "bar" :-> String 14 | |] 15 | type TestRec = '["foo" :-> Int, "bar" :-> String] 16 | 17 | makeRecordJsonWrapper "TestRecJson" ''TestRec 18 | makeWrapped ''TestRecJson 19 | makeToSchema "TestRecJson" ''TestRecJson 20 | 21 | thSuite :: Spec 22 | thSuite = do 23 | describe "Swagger Record Support" $ do 24 | it "encodes all fields" $ do 25 | let x = TestRecJson $ 1 :*: "a" :*: RNil 26 | validateToJSON x `shouldBe` mempty 27 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | packages = { 3 | aeson = import ./composite-aeson/package.nix; 4 | aeson-refined = import ./composite-aeson-refined/package.nix; 5 | base = import ./composite-base/package.nix; 6 | ekg = import ./composite-ekg/package.nix; 7 | opaleye = import ./composite-opaleye/package.nix; 8 | reflex = import ./composite-reflex/package.nix; 9 | }; 10 | in 11 | packages // { 12 | overrides = self: super: { 13 | composite-aeson = self.callPackage packages.aeson {}; 14 | composite-aeson-refined = self.callPackage packages.aeson-refined {}; 15 | composite-base = self.callPackage packages.base {}; 16 | composite-ekg = self.callPackage packages.ekg {}; 17 | composite-opaleye = self.callPackage packages.opaleye {}; 18 | composite-reflex = self.callPackage packages.reflex {}; 19 | }; 20 | } 21 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | client 2 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | ## Example Server 2 | 3 | This is a small example project showing a 4 | [Servant](http://haskell-servant.readthedocs.io/en/stable/) based web server along with the 5 | Composite libraries and [Opaleye](http://github.com/tomjaguarpaw/haskell-opaleye/) talking to 6 | [PostgreSQL](https://www.postgresql.org). 7 | 8 | ### Running the Server 9 | 10 | 1. Start PostgreSQL. If you don't have one running, install it via Nix, brew, your package manager, 11 | download, etc. Then do these two commands to initialize an empty data directory and run 12 | PostgreSQL: 13 | 14 | 1. `initdb exampledb` 15 | 2. `postgres -D exampledb` 16 | 17 | 2. Create the `example` database and schema using the provided script `example.sql`: `psql postgres 18 | < example.sql` 19 | 20 | 3. Compile the example server if you haven't already using `stack build`. If you don't have 21 | [stack](https://docs.haskellstack.org/en/stable/README/), you'll need to install that as well. 22 | 23 | * A few warnings about hpack versions are a-okay. 24 | 25 | 4. Run the server via `stack exec myawesomeserver-exe`. It should start listening on port 8080. 26 | 27 | 5. You can now access the API with `curl` or whatever you like to make HTTP requests with. For 28 | example, `curl http://localhost:8080/users`. 29 | 30 | ### Swagger 31 | 32 | You can access the Swagger documentation at http://localhost:8080/. Assuming you have the Swagger 33 | code generation JAR, you can generate a Python client as well, using the `generate-swagger.hs` 34 | script in `example/scripts/`: 35 | 36 | ```bash 37 | stack example/scripts/generate-swagger.hs \ 38 | --output-dir example/client/ \ 39 | --swagger-codegen-jar-path 40 | ``` 41 | 42 | Test out the client (first `cd` to `example/client/myawesomeserver_gen`): 43 | 44 | ```python 45 | >>> from myawesomeserver import api, api_client, configuration 46 | >>> config = configuration.Configuration() 47 | >>> config.host = 'http://localhost:8080' 48 | >>> client = api_client.ApiClient(configuration=config) 49 | >>> my_api = api.DefaultApi(api_client=client) 50 | >>> my_api.users_get() 51 | [{'login': 'string', 'usertype': 'Owner'}, {'login': 'Cathy', 'usertype': 'Regular'}] 52 | ``` 53 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | 5 | import App 6 | 7 | main :: IO () 8 | main = startApp 9 | -------------------------------------------------------------------------------- /example/example.sql: -------------------------------------------------------------------------------- 1 | create database example; 2 | 3 | create user example; 4 | 5 | grant all privileges on database example to example; 6 | 7 | \c example 8 | 9 | create type usertype as enum('Owner', 'Manager', 'Regular'); 10 | create sequence user_ids; 11 | 12 | create table users ( 13 | id integer primary key default nextval('user_ids'), 14 | login varchar not null, 15 | usertype usertype not null 16 | ); 17 | 18 | alter sequence user_ids owner to example; 19 | alter table users owner to example; 20 | 21 | copy users (id, login, usertype) from stdin; 22 | 1 Alice Owner 23 | 2 Bob Manager 24 | 3 Cathy Regular 25 | \. 26 | -------------------------------------------------------------------------------- /example/myawesomeserver.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.5. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: myawesomeserver 8 | version: 0.0.2 9 | synopsis: It's a server! 10 | description: Example for usage of composite. 11 | category: Records 12 | homepage: https://github.com/ConferHealth/composite#readme 13 | author: Confer Health, Inc. 14 | maintainer: oss@confer.health 15 | copyright: 2017 Confer Health, Inc. 16 | license: BSD3 17 | build-type: Simple 18 | 19 | library 20 | exposed-modules: 21 | Api 22 | ApiOrphans 23 | App 24 | Foundation 25 | Logging 26 | Metrics 27 | Types 28 | other-modules: 29 | Paths_myawesomeserver 30 | hs-source-dirs: 31 | src 32 | default-extensions: 33 | Arrows 34 | ConstraintKinds 35 | DataKinds 36 | DeriveGeneric 37 | FlexibleContexts 38 | FlexibleInstances 39 | GADTs 40 | GeneralizedNewtypeDeriving 41 | LambdaCase 42 | MultiParamTypeClasses 43 | NoImplicitPrelude 44 | OverloadedStrings 45 | PatternSynonyms 46 | QuasiQuotes 47 | RankNTypes 48 | ScopedTypeVariables 49 | StandaloneDeriving 50 | TemplateHaskell 51 | TypeApplications 52 | TypeFamilies 53 | TypeOperators 54 | ViewPatterns 55 | ghc-options: -Wall 56 | build-depends: 57 | aeson >=1.1.2.0 && <1.6 58 | , base >=4.12 && <5 59 | , bytestring >=0.10.8.1 && <0.11 60 | , classy-prelude >=1.2.0.1 && <1.6 61 | , composite-aeson ==0.8.* 62 | , composite-base ==0.8.* 63 | , composite-ekg ==0.8.* 64 | , composite-opaleye ==0.8.* 65 | , composite-swagger ==0.8.* 66 | , configurator >=0.3.0.0 && <0.4 67 | , ekg >=0.1.1.3 && <0.5 68 | , ekg-core >=0.1.1.3 && <0.5 69 | , exceptions >=0.8.3 && <0.11 70 | , fast-logger >=2.4.10 && <3.1 71 | , http-api-data >=0.3.7.1 && <0.5 72 | , insert-ordered-containers >=0.2.1.0 && <0.3 73 | , lens >=4.15.4 && <5.1 74 | , monad-control >=1.0.2.2 && <1.1 75 | , monad-logger >=0.3.25.1 && <0.4 76 | , mtl >=2.2.1 && <2.3 77 | , opaleye >=0.5.4.0 && <0.8 78 | , postgresql-simple >=0.5.3.0 && <0.7 79 | , product-profunctors >=0.8.0.3 && <0.12 80 | , profunctors >=5.2.1 && <5.7 81 | , resource-pool >=0.2.3.2 && <0.3 82 | , servant >=0.11 && <0.19 83 | , servant-server >=0.11.0.1 && <0.19 84 | , servant-swagger >=1.1.4 && <1.5 85 | , servant-swagger-ui >=0.2.4.3.4.0 && <0.4 86 | , swagger2 >=2.1.6 && <2.7 87 | , text >=1.2.2.2 && <1.3 88 | , vinyl >=0.5.3 && <0.14 89 | , warp >=3.2.13 && <3.4 90 | default-language: Haskell2010 91 | 92 | executable myawesomeserver-exe 93 | main-is: Main.hs 94 | other-modules: 95 | Paths_myawesomeserver 96 | hs-source-dirs: 97 | app 98 | default-extensions: 99 | Arrows 100 | ConstraintKinds 101 | DataKinds 102 | DeriveGeneric 103 | FlexibleContexts 104 | FlexibleInstances 105 | GADTs 106 | GeneralizedNewtypeDeriving 107 | LambdaCase 108 | MultiParamTypeClasses 109 | NoImplicitPrelude 110 | OverloadedStrings 111 | PatternSynonyms 112 | QuasiQuotes 113 | RankNTypes 114 | ScopedTypeVariables 115 | StandaloneDeriving 116 | TemplateHaskell 117 | TypeApplications 118 | TypeFamilies 119 | TypeOperators 120 | ViewPatterns 121 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 122 | build-depends: 123 | aeson >=1.1.2.0 && <1.6 124 | , base >=4.12 && <5 125 | , bytestring >=0.10.8.1 && <0.11 126 | , classy-prelude >=1.2.0.1 && <1.6 127 | , composite-aeson ==0.8.* 128 | , composite-base ==0.8.* 129 | , composite-ekg ==0.8.* 130 | , composite-opaleye ==0.8.* 131 | , composite-swagger ==0.8.* 132 | , configurator >=0.3.0.0 && <0.4 133 | , ekg >=0.1.1.3 && <0.5 134 | , ekg-core >=0.1.1.3 && <0.5 135 | , exceptions >=0.8.3 && <0.11 136 | , fast-logger >=2.4.10 && <3.1 137 | , http-api-data >=0.3.7.1 && <0.5 138 | , insert-ordered-containers >=0.2.1.0 && <0.3 139 | , lens >=4.15.4 && <5.1 140 | , monad-control >=1.0.2.2 && <1.1 141 | , monad-logger >=0.3.25.1 && <0.4 142 | , mtl >=2.2.1 && <2.3 143 | , myawesomeserver 144 | , opaleye >=0.5.4.0 && <0.8 145 | , postgresql-simple >=0.5.3.0 && <0.7 146 | , product-profunctors >=0.8.0.3 && <0.12 147 | , profunctors >=5.2.1 && <5.7 148 | , resource-pool >=0.2.3.2 && <0.3 149 | , servant >=0.11 && <0.19 150 | , servant-server >=0.11.0.1 && <0.19 151 | , servant-swagger >=1.1.4 && <1.5 152 | , servant-swagger-ui >=0.2.4.3.4.0 && <0.4 153 | , swagger2 >=2.1.6 && <2.7 154 | , text >=1.2.2.2 && <1.3 155 | , vinyl >=0.5.3 && <0.14 156 | , warp >=3.2.13 && <3.4 157 | default-language: Haskell2010 158 | -------------------------------------------------------------------------------- /example/package.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, base, bytestring, classy-prelude 2 | , composite-aeson, composite-base, composite-ekg, composite-opaleye 3 | , composite-swagger, configurator, ekg, ekg-core, exceptions 4 | , fast-logger, hpack, http-api-data, insert-ordered-containers 5 | , lens, lib, monad-control, monad-logger, mtl, opaleye 6 | , postgresql-simple, product-profunctors, profunctors 7 | , resource-pool, servant, servant-server, servant-swagger 8 | , servant-swagger-ui, swagger2, text, vinyl, warp 9 | }: 10 | mkDerivation { 11 | pname = "myawesomeserver"; 12 | version = "0.0.2"; 13 | src = ./.; 14 | isLibrary = true; 15 | isExecutable = true; 16 | libraryHaskellDepends = [ 17 | aeson base bytestring classy-prelude composite-aeson composite-base 18 | composite-ekg composite-opaleye composite-swagger configurator ekg 19 | ekg-core exceptions fast-logger http-api-data 20 | insert-ordered-containers lens monad-control monad-logger mtl 21 | opaleye postgresql-simple product-profunctors profunctors 22 | resource-pool servant servant-server servant-swagger 23 | servant-swagger-ui swagger2 text vinyl warp 24 | ]; 25 | libraryToolDepends = [ hpack ]; 26 | executableHaskellDepends = [ 27 | aeson base bytestring classy-prelude composite-aeson composite-base 28 | composite-ekg composite-opaleye composite-swagger configurator ekg 29 | ekg-core exceptions fast-logger http-api-data 30 | insert-ordered-containers lens monad-control monad-logger mtl 31 | opaleye postgresql-simple product-profunctors profunctors 32 | resource-pool servant servant-server servant-swagger 33 | servant-swagger-ui swagger2 text vinyl warp 34 | ]; 35 | prePatch = "hpack"; 36 | homepage = "https://github.com/ConferHealth/composite#readme"; 37 | description = "It's a server!"; 38 | license = lib.licenses.bsd3; 39 | } 40 | -------------------------------------------------------------------------------- /example/package.yaml: -------------------------------------------------------------------------------- 1 | name: myawesomeserver 2 | version: 0.0.2 3 | synopsis: It's a server! 4 | description: Example for usage of composite. 5 | homepage: https://github.com/ConferHealth/composite#readme 6 | license: BSD3 7 | author: Confer Health, Inc. 8 | maintainer: oss@confer.health 9 | copyright: 2017 Confer Health, Inc. 10 | category: Records 11 | 12 | default-extensions: 13 | - Arrows 14 | - ConstraintKinds 15 | - DataKinds 16 | - DeriveGeneric 17 | - FlexibleContexts 18 | - FlexibleInstances 19 | - GADTs 20 | - GeneralizedNewtypeDeriving 21 | - LambdaCase 22 | - MultiParamTypeClasses 23 | - NoImplicitPrelude 24 | - OverloadedStrings 25 | - PatternSynonyms 26 | - QuasiQuotes 27 | - RankNTypes 28 | - ScopedTypeVariables 29 | - StandaloneDeriving 30 | - TemplateHaskell 31 | - TypeApplications 32 | - TypeFamilies 33 | - TypeOperators 34 | - ViewPatterns 35 | 36 | dependencies: 37 | - base >= 4.12 && < 5 38 | - aeson >= 1.1.2.0 && < 1.6 39 | - bytestring >= 0.10.8.1 && < 0.11 40 | - classy-prelude >= 1.2.0.1 && < 1.6 41 | - composite-aeson >= 0.8 && < 0.9 42 | - composite-base >= 0.8 && < 0.9 43 | - composite-ekg >= 0.8 && < 0.9 44 | - composite-opaleye >= 0.8 && < 0.9 45 | - composite-swagger >= 0.8 && < 0.9 46 | - configurator >= 0.3.0.0 && < 0.4 47 | - ekg >= 0.1.1.3 && < 0.5 48 | - ekg-core >= 0.1.1.3 && < 0.5 49 | - exceptions >= 0.8.3 && < 0.11 50 | - fast-logger >= 2.4.10 && < 3.1 51 | - http-api-data >= 0.3.7.1 && < 0.5 52 | - insert-ordered-containers >= 0.2.1.0 && < 0.3 53 | - lens >= 4.15.4 && < 5.1 54 | - monad-control >= 1.0.2.2 && < 1.1 55 | - monad-logger >= 0.3.25.1 && < 0.4 56 | - mtl >= 2.2.1 && < 2.3 57 | - opaleye >= 0.5.4.0 && < 0.8 58 | - postgresql-simple >= 0.5.3.0 && < 0.7 59 | - product-profunctors >= 0.8.0.3 && < 0.12 60 | - profunctors >= 5.2.1 && < 5.7 61 | - resource-pool >= 0.2.3.2 && < 0.3 62 | - servant >= 0.11 && < 0.19 63 | - servant-server >= 0.11.0.1 && < 0.19 64 | - servant-swagger >= 1.1.4 && < 1.5 65 | - servant-swagger-ui >= 0.2.4.3.4.0 && < 0.4 66 | - swagger2 >= 2.1.6 && < 2.7 67 | - text >= 1.2.2.2 && < 1.3 68 | - vinyl >= 0.5.3 && < 0.14 69 | - warp >= 3.2.13 && < 3.4 70 | 71 | ghc-options: 72 | - -Wall 73 | 74 | executables: 75 | myawesomeserver-exe: 76 | source-dirs: app 77 | main: Main.hs 78 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 79 | dependencies: myawesomeserver 80 | 81 | library: 82 | source-dirs: src 83 | other-modules: Paths_myawesomeserver 84 | -------------------------------------------------------------------------------- /example/scripts/generate-swagger.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | {- stack --resolver lts-9.20 --install-ghc runghc --package myawesomeserver -} 3 | {-# OPTIONS_GHC -Wall -Werror #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | 9 | import ClassyPrelude 10 | import Data.Aeson (encode) 11 | import qualified Options.Applicative as O 12 | import Turtle (procs) 13 | 14 | import Api (swaggerApiDefinition) 15 | 16 | data Opts = Opts 17 | { optsOutputDir :: Text 18 | , optsSwaggerJarPath :: FilePath 19 | } 20 | 21 | parseArgs :: IO Opts 22 | parseArgs = 23 | let parser = Opts 24 | <$> textField "output-dir" "directory where swagger specs will be written" 25 | <*> stringField "swagger-codegen-jar-path" "path to swagger codegen" 26 | in createParser "Generate swagger specs" parser 27 | 28 | where 29 | createParser d p = O.execParser $ O.info (O.helper <*> p) (O.fullDesc <> O.progDesc d) 30 | stringField l h = O.strOption (O.long l <> O.metavar (toUpper l) <> O.help h) 31 | textField l h = pack <$> stringField l h 32 | 33 | main :: IO () 34 | main = do 35 | Opts {..} <- parseArgs 36 | let specName = "swagger.json" 37 | pkgName = "myawesomeserver" 38 | specPathStr = optsOutputDir <> "/" <> specName 39 | genPathStr = optsOutputDir <> "/" <> pkgName <> "_gen" 40 | 41 | writeFile (unpack specPathStr) . toStrict . encode $ swaggerApiDefinition 42 | putStrLn $ "wrote API spec: " <> specPathStr 43 | 44 | procs "java" [ "-jar", pack optsSwaggerJarPath 45 | , "generate", "-i", specPathStr 46 | , "-l", "python" 47 | , "-D", "packageName=" <> pkgName 48 | , "-o", genPathStr ] mempty 49 | -------------------------------------------------------------------------------- /example/src/Api.hs: -------------------------------------------------------------------------------- 1 | module Api where 2 | 3 | import ClassyPrelude 4 | import Composite.Record (pattern (:*:), (:->) (Val), Record, getVal) 5 | import Control.Arrow (returnA) 6 | import Control.Lens (each, toListOf, view, (&), (.~), (?~), _Unwrapping) 7 | import Control.Monad.Except (MonadError, throwError) 8 | import Control.Monad.Logger (logInfo) 9 | import Data.Aeson (ToJSON, object, toJSON, (.=)) 10 | import qualified Data.HashMap.Strict.InsOrd as I 11 | import Data.Proxy (Proxy (Proxy)) 12 | import Data.Swagger 13 | ( NamedSchema (NamedSchema), Referenced (Inline), Swagger, SwaggerType (SwaggerObject, SwaggerString), ToSchema 14 | , declareNamedSchema, description, enum_, info, license, properties, title, type_, version ) 15 | import Data.Version (showVersion) 16 | import Data.Vinyl.Lens (rsubset) 17 | import Foundation 18 | ( AppStackM, appMetrics, withDb 19 | , fUserCreateRequests, fUserDeleteRequests, fUserEnumerateRequests, fUserRetrieveRequests, fUserUpdateRequests ) 20 | import Opaleye 21 | ( constant, desc, limit, orderBy, queryTable, restrict 22 | , runDelete, runInsertMany, runQuery, runUpdate 23 | , (.&&), (.==) ) 24 | import qualified Paths_myawesomeserver 25 | import Servant ((:<|>), (:>), Capture, Delete, Get, JSON, Post, Put, QueryParam, ReqBody) 26 | import Servant.Server (ServerError, err307, err404, errHeaders) 27 | import Servant.Swagger (toSwagger) 28 | import Servant.Swagger.UI (SwaggerSchemaUI) 29 | import qualified System.Metrics.Counter as Counter 30 | import Types 31 | ( ApiUser, ApiUserJson (ApiUserJson), DbUser, DbUserInsCols, FId, FIdMay, FLogin, FUserType 32 | , cId, cLogin, cUserType, userTable ) 33 | 34 | -- |A catastrophically simple type for API responses, definitely don't use this in real code 35 | data Result = Result 36 | instance ToJSON Result where 37 | toJSON _ = object [ "result" .= asText "accepted" ] 38 | instance ToSchema Result where 39 | declareNamedSchema _ = 40 | let accepted = Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ ["accepted"] 41 | inner = mempty & type_ ?~ SwaggerObject & properties .~ I.singleton "result" accepted 42 | in pure $ NamedSchema (Just "Result") inner 43 | 44 | type API = "users" :> ( ReqBody '[JSON] ApiUserJson :> Post '[JSON] Result 45 | :<|> Capture "userKey" FId :> Get '[JSON] ApiUserJson 46 | :<|> Capture "userKey" FId :> ReqBody '[JSON] ApiUserJson :> Put '[JSON] Result 47 | :<|> Capture "userKey" FId :> Delete '[JSON] Result 48 | :<|> QueryParam "login" FLogin :> QueryParam "type" FUserType :> Get '[JSON] [ApiUserJson] 49 | ) 50 | 51 | -- |Routing for an API along with its Swagger documentation and a redirect from root to the docs. 52 | type DocumentedApi api docsDir = 53 | api :<|> 54 | SwaggerSchemaUI docsDir "swagger.json" :<|> 55 | Get '[JSON] () 56 | 57 | -- |Always redirect to the given location. 58 | redirect :: (MonadError ServerError m) => Text -> m a 59 | redirect loc = throwError $ err307 { errHeaders = [("Location", fromString $ unpack loc)] } 60 | 61 | api :: Proxy API 62 | api = Proxy 63 | 64 | swaggerApi :: Proxy (DocumentedApi API "dev") 65 | swaggerApi = Proxy 66 | 67 | swaggerApiDefinition :: Swagger 68 | swaggerApiDefinition = 69 | toSwagger api 70 | & info.title .~ "Example API" 71 | & info.version .~ pack (showVersion Paths_myawesomeserver.version) 72 | & info.description ?~ "An example API" 73 | & info.license ?~ "BSD3" 74 | 75 | -- |Convert an id-less User to something that may have a key if it's provided on input; needed 76 | -- because @Opaleye.Table.TableProperties@ uses writer columns for inserts and deletes 77 | toWrite :: Maybe FId -> Record ApiUser -> Record DbUserInsCols 78 | toWrite userKeyMay user = 79 | let convert = constant :: Record (FIdMay ': ApiUser) -> Record DbUserInsCols 80 | in convert $ case userKeyMay of 81 | Just (Val userKey) -> Just userKey :*: user 82 | Nothing -> Nothing :*: user 83 | 84 | -- |Create a user from some fields 85 | createUser :: ApiUserJson -> AppStackM Result 86 | createUser (ApiUserJson user) = do 87 | $logInfo "received create request" 88 | -- Increment the user create requests ekg counter 89 | liftIO . Counter.inc =<< asks (view fUserCreateRequests . appMetrics) 90 | 91 | void $ withDb $ \ conn -> liftIO $ runInsertMany conn userTable [toWrite Nothing user] 92 | pure Result 93 | 94 | -- |Retrieve a user by key 95 | retrieveUser :: FId -> AppStackM ApiUserJson 96 | retrieveUser (Val userKey) = do 97 | $logInfo "received retrieve request" 98 | -- Increment the user retrieve requests ekg counter 99 | liftIO . Counter.inc =<< asks (view fUserRetrieveRequests . appMetrics) 100 | 101 | users <- withDb $ \ conn -> liftIO $ 102 | runQuery conn . limit 1 $ proc () -> do 103 | user <- queryTable userTable -< () 104 | restrict -< view cId user .== constant userKey 105 | returnA -< user 106 | 107 | let _ = users :: [Record DbUser] 108 | case headMay users of 109 | Just user -> pure $ view (rsubset . _Unwrapping ApiUserJson) user 110 | Nothing -> throwError err404 111 | 112 | -- |Replace a user by key 113 | updateUser :: FId -> ApiUserJson -> AppStackM Result 114 | updateUser uId@(Val userKey) (ApiUserJson user) = do 115 | $logInfo "received update request" 116 | -- Increment the user update requests ekg counter 117 | liftIO . Counter.inc =<< asks (view fUserUpdateRequests . appMetrics) 118 | 119 | void $ withDb $ \ conn -> liftIO $ runUpdate conn userTable (const $ toWrite (Just uId) user) $ 120 | \ u -> view cId u .== constant userKey 121 | pure Result 122 | 123 | -- |Delete a user by key 124 | deleteUser :: FId -> AppStackM Result 125 | deleteUser (Val userKey) = do 126 | $logInfo "received delete request" 127 | -- Increment the user delete requests ekg counter 128 | liftIO . Counter.inc =<< asks (view fUserDeleteRequests . appMetrics) 129 | 130 | void $ withDb $ \ conn -> liftIO $ runDelete conn userTable $ 131 | \ u -> view cId u .== constant userKey 132 | pure Result 133 | 134 | -- |List users - omitting query parameters results in unbounded query 135 | enumerateUsers :: Maybe FLogin -> Maybe FUserType -> AppStackM [ApiUserJson] 136 | enumerateUsers login userType = do 137 | $logInfo "received enumerate request" 138 | -- Increment the user enumerate requests ekg counter 139 | liftIO . Counter.inc =<< asks (view fUserEnumerateRequests . appMetrics) 140 | 141 | users <- withDb $ \ conn -> liftIO $ runQuery conn . orderBy (desc $ view cLogin) $ proc () -> do 142 | user <- queryTable userTable -< () 143 | restrict -< maybe (constant True) ((.== view cUserType user) . constant . getVal) userType 144 | .&& maybe (constant True) ((.== view cLogin user) . constant . getVal) login 145 | returnA -< user 146 | 147 | let _ = users :: [Record DbUser] 148 | pure $ toListOf (each . rsubset . _Unwrapping ApiUserJson) users 149 | -------------------------------------------------------------------------------- /example/src/ApiOrphans.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module ApiOrphans where 3 | 4 | import Composite.Record ((:->)(Val)) 5 | import Data.Proxy (Proxy(Proxy)) 6 | import Data.Swagger (ToParamSchema, toParamSchema) 7 | import Web.HttpApiData (ToHttpApiData, FromHttpApiData) 8 | 9 | -- Orphan instances for using `s :-> a` as a @Servant.Capture@ or @Servant.QueryParam@ 10 | instance ToParamSchema a => ToParamSchema (s :-> a) where 11 | toParamSchema _ = toParamSchema (Proxy :: Proxy a) 12 | deriving instance ToHttpApiData a => ToHttpApiData (s :-> a) 13 | deriving instance FromHttpApiData a => FromHttpApiData (s :-> a) 14 | -------------------------------------------------------------------------------- /example/src/App.hs: -------------------------------------------------------------------------------- 1 | module App (startApp) where 2 | 3 | import ClassyPrelude hiding (Handler) 4 | 5 | import Api 6 | ( api, swaggerApiDefinition, redirect, swaggerApi 7 | , createUser, retrieveUser, updateUser, deleteUser, enumerateUsers ) 8 | import Control.Monad.Logger (askLoggerIO, logInfo) 9 | import Control.Monad.Trans.Control (MonadBaseControl(..)) 10 | import Data.Pool (Pool) 11 | import qualified Data.Pool as Pool 12 | import qualified Database.PostgreSQL.Simple as PG 13 | import Foundation (AppData(AppData), AppStackM, configureMetrics) 14 | import Logging (LogFunction, withLogger, withLoggingFunc) 15 | import Network.Wai.Handler.Warp (run) 16 | import Servant ((:<|>)((:<|>)), Handler, serve) 17 | import Servant.Server (hoistServer) 18 | import Servant.Swagger.UI (swaggerSchemaUIServer) 19 | 20 | -- |Perform app initialization and then begin serving the API 21 | startApp :: IO () 22 | startApp = do 23 | withLogger $ do 24 | metrics <- liftIO configureMetrics 25 | withPostgresqlPool "host=localhost port=5432 user=example dbname=example" 5 $ \ connPool -> do 26 | let appData = AppData connPool metrics 27 | logFn <- askLoggerIO 28 | $logInfo $ "Starting server on port 8080" 29 | liftIO . run 8080 . serve swaggerApi 30 | $ hoistServer api (appStackToHandler appData logFn) ( createUser :<|> retrieveUser :<|> updateUser :<|> deleteUser :<|> enumerateUsers ) 31 | :<|> swaggerSchemaUIServer swaggerApiDefinition -- serve the Swagger docs 32 | :<|> redirect "/dev/index.html" -- redirect to the Swagger docs at '/' 33 | 34 | withPostgresqlPool :: MonadBaseControl IO m => ByteString -> Int -> (Pool PG.Connection -> m a) -> m a 35 | withPostgresqlPool connStr nConns action = do 36 | stm <- liftBaseWith $ \ runInBase -> liftIO $ 37 | bracket createPool Pool.destroyAllResources (runInBase . action) 38 | restoreM stm 39 | where 40 | createPool = Pool.createPool (PG.connectPostgreSQL connStr) PG.close 1 20 nConns 41 | 42 | appStackToHandler' :: forall a. AppData -> LogFunction -> AppStackM a -> Handler a 43 | appStackToHandler' appData logger action = withLoggingFunc logger $ runReaderT action appData 44 | 45 | appStackToHandler :: AppData -> LogFunction -> (forall a . AppStackM a -> Handler a) 46 | appStackToHandler ad lf = appStackToHandler' ad lf 47 | -------------------------------------------------------------------------------- /example/src/Foundation.hs: -------------------------------------------------------------------------------- 1 | module Foundation 2 | ( AppStackM 3 | , AppData(AppData, appConnPool, appMetrics), withDb 4 | , module Metrics 5 | ) where 6 | 7 | import ClassyPrelude hiding (Handler) 8 | import Composite.Record (Record) 9 | import Control.Monad.Logger (LoggingT) 10 | import Control.Monad.Trans.Control (MonadBaseControl(..)) 11 | import Data.Pool (Pool, withResource) 12 | import Database.PostgreSQL.Simple (Connection) 13 | import Metrics 14 | ( configureMetrics, EkgMetrics, fActiveUsers, fResponseTimes 15 | , fUserCreateRequests, fUserRetrieveRequests, fUserUpdateRequests 16 | , fUserDeleteRequests, fUserEnumerateRequests ) 17 | import Servant (Handler) 18 | 19 | 20 | -- |The context in which all requests will be evaluated to allow logging and accessing the application state 21 | type AppStackM = ReaderT AppData (LoggingT Handler) 22 | 23 | -- |The global application state 24 | data AppData = AppData 25 | { appConnPool :: Pool Connection 26 | , appMetrics :: Record EkgMetrics 27 | } 28 | 29 | withDb :: (MonadBaseControl IO m, MonadReader AppData m) => (Connection -> m a) -> m a 30 | withDb action = do 31 | pool <- asks appConnPool 32 | withResource pool action 33 | -------------------------------------------------------------------------------- /example/src/Logging.hs: -------------------------------------------------------------------------------- 1 | module Logging (LogFunction, withLogger, withLoggingFunc) where 2 | 3 | import ClassyPrelude 4 | import Control.Monad.Catch (MonadMask(..)) 5 | import Control.Monad.Logger 6 | ( LoggingT(runLoggingT), LogLevel, LogSource 7 | , Loc(loc_package, loc_module, loc_filename, loc_start) ) 8 | import Data.ByteString.Char8 (hPutStrLn) 9 | import System.Log.FastLogger (LogStr, ToLogStr(toLogStr), fromLogStr) 10 | 11 | -- |An alias for the long type that LoggingT requires to log messages 12 | type LogFunction = Loc -> LogSource -> LogLevel -> LogStr -> IO () 13 | 14 | -- |Create a logging context from a couple of logging settings 15 | withLogger :: (MonadMask m, MonadIO m) => LoggingT m a -> m a 16 | withLogger action = runLoggingT action logMsg 17 | 18 | -- |Create a logging context with an existing `LogFunction` 19 | withLoggingFunc :: LogFunction -> LoggingT m a -> m a 20 | withLoggingFunc = flip runLoggingT 21 | 22 | logMsg :: LogFunction 23 | logMsg loc _ level msg = do 24 | dateLogStr <- nowLogString 25 | hPutStrLn stderr . fromLogStr $ dateLogStr <> " [" <> (toLogStr . show) level <> "] " <> msg <> " @(" <> locLogString loc <> ")" 26 | 27 | locLogString :: Loc -> LogStr 28 | locLogString loc = p <> ":" <> m <> " " <> f <> ":" <> l <> ":" <> c 29 | where p = toLogStr . loc_package $ loc 30 | m = toLogStr . loc_module $ loc 31 | f = toLogStr . loc_filename $ loc 32 | l = toLogStr . show . fst . loc_start $ loc 33 | c = toLogStr . show . snd . loc_start $ loc 34 | 35 | nowLogString :: IO LogStr 36 | nowLogString = do 37 | now <- getCurrentTime 38 | pure . toLogStr $ formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now 39 | -------------------------------------------------------------------------------- /example/src/Metrics.hs: -------------------------------------------------------------------------------- 1 | module Metrics where 2 | 3 | import ClassyPrelude 4 | import Composite.Ekg (ekgMetric) 5 | import Composite.Record ((:->), Record) 6 | import Composite.TH (withLensesAndProxies) 7 | import qualified System.Metrics as EKG 8 | import System.Metrics.Counter (Counter) 9 | import System.Metrics.Gauge (Gauge) 10 | import System.Metrics.Distribution (Distribution) 11 | import qualified System.Remote.Monitoring as EKG 12 | 13 | withLensesAndProxies [d| 14 | type FActiveUsers = "activeUsers" :-> Gauge 15 | type FResponseTimes = "endpointResponseTimes" :-> Distribution 16 | type FUserCreateRequests = "userCreates" :-> Counter 17 | type FUserRetrieveRequests = "userRetrieves" :-> Counter 18 | type FUserUpdateRequests = "userUpdates" :-> Counter 19 | type FUserDeleteRequests = "userDeletes" :-> Counter 20 | type FUserEnumerateRequests = "userEnumerates" :-> Counter 21 | |] 22 | type EkgMetrics = '[ FActiveUsers, FResponseTimes 23 | , FUserCreateRequests, FUserRetrieveRequests, FUserUpdateRequests 24 | , FUserDeleteRequests, FUserEnumerateRequests ] 25 | 26 | -- |Create a new ekg store and metrics record, register the relevant metrics, and start the ekg server 27 | configureMetrics :: IO (Record EkgMetrics) 28 | configureMetrics = do 29 | store <- EKG.newStore 30 | EKG.registerGcMetrics store 31 | metrics <- ekgMetric "myawesomeapp" store 32 | _ <- EKG.forkServerWith store "localhost" 8090 33 | pure metrics 34 | -------------------------------------------------------------------------------- /example/src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import ApiOrphans () 4 | import ClassyPrelude 5 | import Control.Lens (ix, over) 6 | import Control.Lens.TH (makeWrapped) 7 | import Composite ((:->), Record) 8 | import Composite.Aeson (DefaultJsonFormat(defaultJsonFormat), enumJsonFormat) 9 | import Composite.Aeson.TH (makeRecordJsonWrapper) 10 | import Composite.Opaleye (defaultRecTable) 11 | import Composite.Opaleye.TH (deriveOpaleyeEnum) 12 | import Composite.Swagger.TH (makeToSchema) 13 | import Composite.TH (withLensesAndProxies) 14 | import Data.Swagger 15 | ( ToParamSchema, ToSchema 16 | , declareNamedSchema, defaultSchemaOptions, constructorTagModifier 17 | , genericToParamSchema, paramSchemaToNamedSchema, toParamSchema ) 18 | import Data.Text (replace) 19 | import Opaleye (Column, PGInt8, PGText, Table(Table)) 20 | import Web.HttpApiData (ToHttpApiData, FromHttpApiData, toUrlPiece, parseUrlPiece) 21 | 22 | data UserType 23 | = UserTypeOwner 24 | | UserTypeManager 25 | | UserTypeRegular 26 | deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) 27 | 28 | instance DefaultJsonFormat UserType where 29 | defaultJsonFormat = enumJsonFormat "UserType" 30 | 31 | deriveOpaleyeEnum ''UserType "usertype" (stripPrefix "UserType") 32 | 33 | -- Manual swagger instances for sum type 34 | instance ToParamSchema UserType where 35 | toParamSchema = genericToParamSchema $ unprefix "UserType" 36 | where 37 | unprefix prefix = defaultSchemaOptions 38 | { constructorTagModifier = unpack . over (ix 1) charToLower . replace prefix "" . pack } 39 | instance ToSchema UserType where 40 | declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions 41 | 42 | -- Dumb instances here - they don't map to opaleye enums or json formats 43 | instance ToHttpApiData UserType where 44 | toUrlPiece typ = let x = tshow typ in fromMaybe x (stripPrefix "UserType" x) 45 | instance FromHttpApiData UserType where 46 | parseUrlPiece = maybe (Left "could not parse") Right . readMay . ("UserType" <>) 47 | 48 | withLensesAndProxies [d| 49 | type FId = "id" :-> Int64 50 | type CId = "id" :-> Column PGInt8 51 | type FIdMay = "id" :-> Maybe Int64 52 | type CIdMay = "id" :-> Maybe (Column PGInt8) 53 | type FLogin = "login" :-> Text 54 | type CLogin = "login" :-> Column PGText 55 | type FUserType = "usertype" :-> UserType 56 | type CUserType = "usertype" :-> Column PGUserType 57 | |] 58 | 59 | type ApiUser = '[FLogin, FUserType] 60 | type DbUser = '[FId, FLogin, FUserType] 61 | type DbUserInsCols = '[CIdMay, CLogin, CUserType] 62 | type DbUserCols = '[CId, CLogin, CUserType] 63 | 64 | userTable :: Table (Record DbUserInsCols) (Record DbUserCols) 65 | userTable = Table "users" defaultRecTable 66 | 67 | makeRecordJsonWrapper "ApiUserJson" ''ApiUser 68 | makeWrapped ''ApiUserJson 69 | makeToSchema "ApiUserJson" ''ApiUserJson 70 | -------------------------------------------------------------------------------- /stack-8.10.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-10-09 2 | packages: 3 | - composite-aeson 4 | - composite-aeson-path 5 | - composite-aeson-refined 6 | - composite-base 7 | - composite-binary 8 | - composite-ekg 9 | - composite-hashable 10 | - composite-opaleye 11 | - composite-swagger 12 | - example 13 | flags: {} 14 | extra-deps: 15 | - servant-blaze-0.9 16 | - servant-server-0.18 17 | - servant-swagger-1.1.8 18 | - servant-swagger-ui-0.3.4.3.23.11 19 | - servant-swagger-ui-core-0.3.3 20 | - opaleye-0.6.7006.1 21 | allow-newer: true 22 | nix: 23 | packages: 24 | - lzma 25 | - postgresql 26 | - zlib 27 | -------------------------------------------------------------------------------- /stack-8.6.5.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - composite-aeson 4 | - composite-aeson-path 5 | - composite-aeson-refined 6 | - composite-base 7 | - composite-binary 8 | - composite-ekg 9 | - composite-hashable 10 | - composite-opaleye 11 | - composite-swagger 12 | - example 13 | flags: {} 14 | extra-deps: 15 | - refined-0.4.4 16 | allow-newer: true 17 | nix: 18 | packages: 19 | - lzma 20 | - postgresql 21 | - zlib 22 | -------------------------------------------------------------------------------- /stack-8.6.5.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: refined-0.4.4@sha256:7dbbb741e397c61dc68a9c1d891b711344f8f1543f099bf012b54360a44a9ca0,2916 9 | pantry-tree: 10 | size: 788 11 | sha256: c103d3ae1233194c92c2843a08636e83ff025d02606345caf28b2324d65850a8 12 | original: 13 | hackage: refined-0.4.4 14 | snapshots: 15 | - completed: 16 | size: 524154 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/20.yaml 18 | sha256: 2f5099f69ddb6abfe64400fe1e6a604e8e628f55e6837211cd70a81eb0a8fa4d 19 | original: lts-14.20 20 | -------------------------------------------------------------------------------- /stack-8.8.3.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.5 2 | packages: 3 | - composite-aeson 4 | - composite-aeson-path 5 | - composite-aeson-refined 6 | - composite-base 7 | - composite-binary 8 | - composite-ekg 9 | - composite-hashable 10 | - composite-opaleye 11 | - composite-swagger 12 | - example 13 | flags: {} 14 | extra-deps: 15 | - refined-0.5.1 16 | - these-skinny-0.7.4 17 | - vinyl-0.13.0 18 | nix: 19 | packages: 20 | - lzma 21 | - postgresql 22 | - zlib 23 | -------------------------------------------------------------------------------- /stack-8.8.3.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: refined-0.5.1@sha256:acc9e941f7d83f9377a041c42dcdd32eabc8ecef920d0807659df00ecee3bada,2809 9 | pantry-tree: 10 | size: 622 11 | sha256: 40ed50ff95e24c2e64bc636ec68348942596051b5b422751c16365510bb5be94 12 | original: 13 | hackage: refined-0.5.1 14 | - completed: 15 | hackage: these-skinny-0.7.4@sha256:e29336a1a70a497e09d8266f8438efb30a807bafaa6b00f5a136f7493efb3160,1239 16 | pantry-tree: 17 | size: 262 18 | sha256: 77f01554e40d8e910d00f95c35dde86df4f691e2955d9afdc16508114c4d1af2 19 | original: 20 | hackage: these-skinny-0.7.4 21 | - completed: 22 | hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724 23 | pantry-tree: 24 | size: 1857 25 | sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01 26 | original: 27 | hackage: vinyl-0.13.0 28 | snapshots: 29 | - completed: 30 | size: 531707 31 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/5.yaml 32 | sha256: 9751e25e0af5713a53ddcfcc79564b082c71b1b357fadef0d85672a5b5ba3703 33 | original: lts-16.5 34 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2021-04-06 2 | packages: 3 | - composite-aeson 4 | - composite-aeson-path 5 | - composite-aeson-refined 6 | - composite-base 7 | - composite-binary 8 | - composite-ekg 9 | - composite-hashable 10 | - composite-opaleye 11 | - composite-swagger 12 | - example 13 | flags: {} 14 | extra-deps: 15 | - lens-5.0.1 16 | - opaleye-0.6.7006.1 17 | allow-newer: true 18 | nix: 19 | packages: 20 | - lzma 21 | - postgresql 22 | - zlib 23 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: lens-5.0.1@sha256:d44156c542b1630337a07cac5824f1846badeb59043adbe8c4e9ed1da89cc13d,15026 9 | pantry-tree: 10 | size: 8291 11 | sha256: 017fcde6fd1f792bc7509375c8aacbbd09b62f16b215e1ae3a261aa642b564b0 12 | original: 13 | hackage: lens-5.0.1 14 | - completed: 15 | hackage: opaleye-0.6.7006.1@sha256:06c8d8808aedabb065ce26387285b5f2d3320b801f818899cced186dc645dc34,5725 16 | pantry-tree: 17 | size: 5535 18 | sha256: 6a2d72804e9d87e1a9afe280a2a49838ee7771e640a4ef429c3b52e41f9c44c4 19 | original: 20 | hackage: opaleye-0.6.7006.1 21 | snapshots: 22 | - completed: 23 | size: 576531 24 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/4/6.yaml 25 | sha256: 6ce168aed6ba23cfe148061587ba1c0f24a09d4cad8b1a5a29b21878e33d6ef4 26 | original: nightly-2021-04-06 27 | -------------------------------------------------------------------------------- /update-build-shell.nix: -------------------------------------------------------------------------------- 1 | with import {}; 2 | 3 | stdenv.mkDerivation { 4 | name = "update-build"; 5 | buildInputs = [ (haskellPackages.ghcWithPackages (p: with p; [hpack cabal2nix])) ]; 6 | buildCommand = ""; 7 | } 8 | -------------------------------------------------------------------------------- /update-build.sh: -------------------------------------------------------------------------------- 1 | for target in {composite-{aeson{,-path,-refined},base,binary,ekg,hashable,opaleye,reflex,swagger},example}; do 2 | ( cd $target && hpack --force && cabal2nix . > package.nix ) 3 | done 4 | --------------------------------------------------------------------------------