├── .codeclimate.yml ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── circle.yml ├── example ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── example.cabal ├── src │ ├── Emails.hs │ ├── Lib.hs │ ├── Users.hs │ └── Users │ │ ├── Actions │ │ ├── Index.hs │ │ └── Show.hs │ │ └── Controller.hs ├── stack.yaml └── test │ └── Spec.hs ├── json-api.cabal ├── package.yaml ├── pbcopy ├── src └── Network │ ├── JSONApi.hs │ └── JSONApi │ ├── Document.hs │ ├── Error.hs │ ├── Identifier.hs │ ├── Link.hs │ ├── Meta.hs │ ├── Pagination.hs │ ├── Resource.hs │ └── Source.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Network └── JSONApi │ ├── DocumentSpec.hs │ ├── ErrorSpec.hs │ ├── IdentifierSpec.hs │ ├── MetaSpec.hs │ ├── PaginationSpec.hs │ ├── ResourceSpec.hs │ └── SourceSpec.hs ├── Spec.hs └── TestHelpers.hs /.codeclimate.yml: -------------------------------------------------------------------------------- 1 | --- 2 | engines: 3 | hlint: 4 | enabled: true 5 | ratings: 6 | paths: 7 | - src 8 | - "**.hs" 9 | exclude_paths: 10 | - test/ 11 | - example/ 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .stack-work/ 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Todd Mohney 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Circle CI](https://circleci.com/gh/toddmohney/json-api.svg?style=svg)](https://circleci.com/gh/toddmohney/json-api) 2 | 3 | ## Haskell Implementation of the JSON-API specification 4 | 5 | 6 | 7 | #### Motivation 8 | 9 | From the specification itself: 10 | 11 | > If you’ve ever argued with your team about the way your JSON responses should 12 | > be formatted, JSON API can be your anti-bikeshedding tool. 13 | > 14 | > By following shared conventions, you can increase productivity, take advantage 15 | > of generalized tooling, and focus on what matters: your application. 16 | > 17 | > Clients built around JSON API are able to take advantage of its features around 18 | > efficiently caching responses, sometimes eliminating network requests entirely. 19 | 20 | All in all, API discoverability and other [HATEOAS](https://spring.io/understanding/HATEOAS) 21 | principles make JSON-API an attractive resource serialization option. 22 | 23 | 24 | 25 | #### The specification 26 | 27 | Find the specification [here](http://jsonapi.org/) 28 | 29 | 30 | 31 | #### Example usage 32 | 33 | Let's start with an example User record: 34 | 35 | ```Haskell 36 | data User = User 37 | { userId :: Int 38 | , userFirstName :: String 39 | , userLastName :: String 40 | } deriving (Eq, Show) 41 | 42 | $(deriveJSON defaultOptions ''User) 43 | ``` 44 | 45 | From this, we can use the `json-api` package to produce a payload conformant 46 | to the [JSON-API specification](http://jsonapi.org/) like so: 47 | 48 | ```Haskell 49 | -- Builds the Document which will be serialized as our 50 | -- web server's response payload 51 | mkDocument :: User -> Links -> Document User Text Int 52 | mkDocument usr links = 53 | Document 54 | (Singleton $ toResource usr) 55 | (Just links) 56 | Nothing 57 | 58 | -- Helper function to convert a User into a resource object 59 | -- This could be our canonical serialization function for a User in any 60 | -- response payload 61 | toResource :: User -> Resource User Text 62 | toResource user = 63 | Resource resourceId resourceType user resourceLinks resourceMetaData 64 | where 65 | resourceId = ResourceId . pack . show . userId $ user 66 | resourceType = ResourceType "User" 67 | resourceLinks = Just $ userLinks user 68 | resourceMetaData = Nothing 69 | 70 | -- helper function to build links for a User resource 71 | userLinks :: User -> Links 72 | userLinks user = toLinks [ ("self", selfLink) ] 73 | where 74 | selfLink = toURL selfPath 75 | selfPath = "/users/" <> (show $ userId user) 76 | ``` 77 | 78 | When delivered as a response from a web server, for example, we get a payload 79 | that looks like this: 80 | 81 | ```JSON 82 | { 83 | "data":{ 84 | "attributes":{ 85 | "userFirstName":"Isaac", 86 | "userLastName":"Newton", 87 | "userId":1 88 | }, 89 | "id":"1", 90 | "meta":null, 91 | "type":"User", 92 | "links":{ 93 | "self":"/users/1" 94 | } 95 | }, 96 | "meta":null, 97 | "links":{ 98 | "self":"/users/1" 99 | } 100 | } 101 | ``` 102 | 103 | Neat! We can see that if we would like the full User data for the User with 104 | ID=1, we can query `/users/1`. Discoverability! 105 | 106 | We can also see from the top-level `links` data that this particular payload originated 107 | from `/users/1`. 108 | 109 | This is a very simple example to provide an introduction to the basic idea 110 | behind JSON-API and how to use this library. Check out [these examples](http://jsonapi.org/examples/) 111 | for more robust representations of resourceful payloads. Here, you'll start to 112 | see the more comprehensive benefits of a discoverable API. 113 | 114 | ##### Pagination Example 115 | 116 | Let's use the same example User record: 117 | 118 | ```Haskell 119 | data User = User 120 | { userId :: Int 121 | , userFirstName :: String 122 | , userLastName :: String 123 | } deriving (Eq, Show) 124 | 125 | $(deriveJSON defaultOptions ''User) 126 | ``` 127 | 128 | Suppose we now have a list of 2 users; 129 | 130 | ```Haskell 131 | let usrs = 132 | [ User 1 "Isaac" "Newton" 133 | , User 2 "Albert" "Einstein" 134 | ] 135 | ``` 136 | 137 | From this, we can use the `json-api` package to produce a payload for a collection with pagination links conformant 138 | to the [JSON-API pagination specification](https://jsonapi.org/format/#fetching-pagination) like so: 139 | 140 | ```Haskell 141 | let paginate = Pagination (PageIndex 1) (PageSize 1) (ResourceCount $ toEnum (length usrs)) 142 | let resourceLink = (fromJust . importURL) "/users" 143 | let paginationLinks = mkPaginationLinks PageStrategy resourceLink paginate 144 | let doc = mkDocuments [head usrs] (Just paginationLinks) Nothing 145 | ``` 146 | 147 | When delivered as a response from a web server, for example, we get a payload 148 | that looks like this: 149 | 150 | ```JSON 151 | { 152 | "data": [ 153 | { 154 | "attributes": { 155 | "userFirstName": "Isaac", 156 | "userLastName": "Newton", 157 | "userId": 1 158 | }, 159 | "relationships": null, 160 | "id": "1", 161 | "meta": null, 162 | "type": "users", 163 | "links": null 164 | } 165 | ], 166 | "meta": null, 167 | "included": [ 168 | ], 169 | "links": { 170 | "next": "/users?page%5bsize%5d=1&page%5bnumber%5d=2", 171 | "first": "/users?page%5bsize%5d=1&page%5bnumber%5d=1", 172 | "last": "/users?page%5bsize%5d=1&page%5bnumber%5d=2" 173 | } 174 | } 175 | ``` 176 | 177 | The key function in the code example is `mkPaginationLinks` which has the following signature; 178 | 179 | ```Haskell 180 | mkPaginationLinks :: Strategy -> URL -> Pagination -> Links 181 | ``` 182 | 183 | `Strategy` is a sum type that represents the different paging strategies as laid out in the [JSON-API pagination specification](https://jsonapi.org/format/#fetching-pagination). At the time of writing this README, the library only supports 2 paging strategies Offset and Page. Offset is a 0 index based approach unlike Page, i.e. `page[offset]` 0 is the same as `page[number]` 1. 184 | 185 | The `URL` type is used to build the links that appear in the JSON payload. The `Pagination` type contains the requisite information for the `mkPaginationLinks` function to generate the paging links. 186 | 187 | So let's break this example down. To get started we need to create a `Pagination` record. The first attribute of the record is `PageIndex`. This attribute informs the caller that the page we are looking at is the first in the entire collection (`PageIndex` is either a 0 based index or 1 based index depending on the `Strategy`). So in our example as we are using `PageStrategy`, `PageIndex 1` implies we are after the first page. The second attribute of the record is `PageSize`. This atrribute tells the caller how many items can appear in the list at most. So in our example seeing there are only 2 users, a `PageSize` of 1 would mean that in total we have 2 pages. The third attribute is `ResourceCount`. This attribute is required by the function `mkPaginationLinks` to figure out which links to generate. 188 | 189 | The links object in the JSON payload can have 4 attributes `next`, `prev`, `first` and `last`. This library only generates valid links. For example if the request is for the first page of a list, then the `prev` link is not present. 190 | 191 | #### Example Project 192 | 193 | There is an [example project](https://github.com/toddmohney/json-api/tree/master/example) illustrating how the library can be used in the context of a web server. 194 | 195 | #### Hackage 196 | 197 | Module documentation can be found on [Hackage](http://hackage.haskell.org/package/json-api) 198 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | dependencies: 2 | cache_directories: 3 | - "~/.stack" 4 | - ".stack-work" 5 | pre: 6 | - sudo apt-key adv --keyserver keyserver.ubuntu.com --recv-keys 575159689BEFB442 7 | - echo 'deb http://download.fpcomplete.com/ubuntu trusty main'|sudo tee /etc/apt/sources.list.d/fpco.list 8 | - sudo apt-get update && sudo apt-get install stack -y 9 | override: 10 | - stack setup 11 | - stack build 12 | test: 13 | override: 14 | - stack test 15 | 16 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | tmp/* 2 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Todd Mohney (c) 2016 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 Todd Mohney 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. -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | 2 | #### Running the example 3 | 4 | There's a `stack.yaml` file in this directory, so you can run and build this 5 | example project in a familiar manner. 6 | 7 | ```bash 8 | # pull your GHC deps 9 | stack setup 10 | 11 | # build the project 12 | stack build 13 | 14 | # run the webserver 15 | stack exec example-exe 16 | ``` 17 | 18 | At this point you should have a webserver running at `http://localhost:8080` 19 | You'll find available endpoints at the following urls: 20 | - [http://localhost:8080/users](http://localhost:8080/users) - responds with a list of User resources 21 | - [http://localhost:8080/users/1](http://localhost:8080/users/1) - responds with a singleton resource 22 | - [http://localhost:8080/users/2](http://localhost:8080/users/2) - responds with a singleton resource 23 | - [http://localhost:8080/users/3](http://localhost:8080/users/3) - responds with a 404 and error payload 24 | 25 | 26 | 27 | 28 | ## List Resource Example 29 | 30 | ```JSON 31 | GET /users 32 | 33 | { 34 | "data" : [ 35 | { 36 | "type" : "User", 37 | "relationships" : { 38 | "email" : { 39 | "links" : { 40 | "self" : "/emails/42" 41 | }, 42 | "data" : { 43 | "type" : "Email", 44 | "id" : "42" 45 | } 46 | } 47 | }, 48 | "links" : { 49 | "self" : "/users/1" 50 | }, 51 | "meta" : null, 52 | "id" : "1", 53 | "attributes" : { 54 | "userFirstName" : "Isaac", 55 | "userLastName" : "Newton", 56 | "userId" : 1 57 | } 58 | }, 59 | { 60 | "relationships" : { 61 | "email" : { 62 | "links" : { 63 | "self" : "/emails/88" 64 | }, 65 | "data" : { 66 | "id" : "88", 67 | "type" : "Email" 68 | } 69 | } 70 | }, 71 | "type" : "User", 72 | "attributes" : { 73 | "userFirstName" : "Albert", 74 | "userLastName" : "Einstein", 75 | "userId" : 2 76 | }, 77 | "meta" : null, 78 | "links" : { 79 | "self" : "/users/2" 80 | }, 81 | "id" : "2" 82 | } 83 | ], 84 | "meta" : { 85 | "user-count" : 2 86 | }, 87 | "links" : { 88 | "self" : "/users" 89 | } 90 | } 91 | ``` 92 | 93 | 94 | ## Singleton Resource Example 95 | 96 | ```JSON 97 | GET /users/1 98 | 99 | { 100 | "meta" : null, 101 | "data" : { 102 | "id" : "1", 103 | "attributes" : { 104 | "userFirstName" : "Isaac", 105 | "userId" : 1, 106 | "userLastName" : "Newton" 107 | }, 108 | "meta" : null, 109 | "links" : { 110 | "self" : "/users/1" 111 | }, 112 | "type" : "User", 113 | "relationships" : { 114 | "email" : { 115 | "links" : { 116 | "self" : "/emails/42" 117 | }, 118 | "data" : { 119 | "id" : "42", 120 | "type" : "Email" 121 | } 122 | } 123 | } 124 | }, 125 | "links" : { 126 | "self" : "/users/1" 127 | } 128 | } 129 | ``` 130 | 131 | 132 | ## Error Example 133 | 134 | ```JSON 135 | GET /users/3 136 | 137 | { 138 | "error":{ 139 | "status":"404", 140 | "code":null, 141 | "id":null, 142 | "meta":null, 143 | "title":"Resource Not Found", 144 | "links":null, 145 | "detail":"There is no User with id: 3" 146 | }, 147 | "meta":null, 148 | "links":{ 149 | "self":"/users/3" 150 | } 151 | } 152 | ``` 153 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = startApp 7 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1.0.4 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/toddmohney/example#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Todd Mohney 9 | maintainer: toddmohney@gmail.com 10 | copyright: 2016 Todd Mohney 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: 18 | src 19 | 20 | exposed-modules: 21 | Lib 22 | Emails 23 | Users 24 | Users.Controller 25 | 26 | other-modules: 27 | Users.Actions.Index 28 | Users.Actions.Show 29 | 30 | build-depends: base >= 4.7 && < 5 31 | , aeson 32 | , containers 33 | , data-default 34 | , json-api 35 | , servant-server 36 | , text 37 | , url 38 | , unordered-containers 39 | , wai 40 | , warp 41 | 42 | default-language: Haskell2010 43 | 44 | default-extensions: 45 | OverloadedStrings 46 | RecordWildCards 47 | TemplateHaskell 48 | 49 | ghc-options: 50 | -Wall 51 | -fwarn-unused-matches 52 | -fwarn-unused-binds 53 | -fwarn-unused-imports 54 | 55 | executable example-exe 56 | hs-source-dirs: app 57 | main-is: Main.hs 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | build-depends: base 60 | , example 61 | default-language: Haskell2010 62 | -------------------------------------------------------------------------------- /example/src/Emails.hs: -------------------------------------------------------------------------------- 1 | module Emails 2 | ( Email (..) 3 | , mkResourceIdentifer 4 | , mkLinks 5 | ) where 6 | 7 | import Data.Aeson.TH 8 | import Data.Maybe (fromJust) 9 | import Data.Monoid ((<>)) 10 | import Data.Text (Text, pack) 11 | import Network.URL 12 | import Network.JSONApi 13 | ( Identifier (..) 14 | , Links 15 | ) 16 | import qualified Network.JSONApi as JSONApi 17 | 18 | -- A resource associated to a User 19 | data Email = Email 20 | { emailId :: Int 21 | , userId :: Int 22 | , address :: Text 23 | } deriving (Eq, Show) 24 | 25 | $(deriveJSON defaultOptions ''Email) 26 | 27 | -- helper function to build an Identifier for an Email resource 28 | mkResourceIdentifer :: Email -> Identifier 29 | mkResourceIdentifer email = Identifier (pack . show . emailId $ email) "Email" Nothing 30 | 31 | -- helper function to build links for an Email resource 32 | mkLinks :: Email -> Links 33 | mkLinks email = JSONApi.mkLinks [ ("self", selfLink) ] 34 | where 35 | selfLink = toURL selfPath 36 | selfPath = "/emails/" <> (show $ emailId email) 37 | 38 | toURL :: String -> URL 39 | toURL = fromJust . importURL 40 | -------------------------------------------------------------------------------- /example/src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Lib 7 | ( startApp 8 | ) where 9 | 10 | import Network.Wai 11 | import Network.Wai.Handler.Warp 12 | import Network.JSONApi.Document (Document) 13 | import Servant 14 | import Users 15 | import qualified Users.Controller as Controller 16 | 17 | type API = "users" :> Get '[JSON] (Document User) 18 | :<|> "users" :> Capture "id" Int :> "simple" :> Get '[JSON] (Document User) 19 | :<|> "users" :> Capture "id" Int :> "full" :> Get '[JSON] (Document User) 20 | 21 | startApp :: IO () 22 | startApp = run 8080 app 23 | 24 | app :: Application 25 | app = serve api server 26 | 27 | api :: Proxy API 28 | api = Proxy 29 | 30 | server :: Server API 31 | server = Controller.usersIndex 32 | :<|> Controller.userShowSimple 33 | :<|> Controller.userShowFull 34 | -------------------------------------------------------------------------------- /example/src/Users.hs: -------------------------------------------------------------------------------- 1 | module Users 2 | ( User (..) 3 | , UserMetaData (..) 4 | , toResource 5 | , getUsers 6 | , getUser 7 | ) where 8 | 9 | import Data.Aeson.TH 10 | import Data.Maybe (fromJust) 11 | import Data.Monoid ((<>)) 12 | import Data.Text (pack) 13 | import Network.URL 14 | import Network.JSONApi 15 | ( Links 16 | , Meta 17 | , MetaObject (..) 18 | , ResourcefulEntity (..) 19 | , mkMeta 20 | ) 21 | import qualified Network.JSONApi as JSONApi 22 | 23 | data User = User 24 | { userId :: Int 25 | , userFirstName :: String 26 | , userLastName :: String 27 | } deriving (Eq, Show) 28 | 29 | $(deriveJSON defaultOptions ''User) 30 | 31 | data UserMetaData = UserMetaData 32 | { count :: Int 33 | } deriving (Eq, Show) 34 | 35 | $(deriveJSON defaultOptions ''UserMetaData) 36 | 37 | instance MetaObject UserMetaData where 38 | typeName _ = "userCount" 39 | 40 | instance ResourcefulEntity User where 41 | resourceIdentifier = pack . show . userId 42 | resourceType _ = "User" 43 | resourceLinks = Just . userLinks 44 | resourceMetaData _ = Just userMetaData 45 | resourceRelationships _ = Nothing 46 | 47 | -- helper function to build links for a User resource 48 | userLinks :: User -> Links 49 | userLinks user = JSONApi.mkLinks [ ("self", selfLink) ] 50 | where 51 | selfLink = toURL selfPath 52 | selfPath = "/users/" <> (show $ userId user) 53 | 54 | userMetaData :: Meta 55 | userMetaData = mkMeta (UserMetaData $ length getUsers) 56 | 57 | toURL :: String -> URL 58 | toURL = fromJust . importURL 59 | 60 | getUser :: Int -> Maybe User 61 | getUser 1 = Just isacc 62 | getUser 2 = Just albert 63 | getUser _ = Nothing 64 | 65 | getUsers :: [User] 66 | getUsers = [isacc, albert] 67 | 68 | isacc :: User 69 | isacc = User 1 "Isaac" "Newton" 70 | 71 | albert :: User 72 | albert = User 2 "Albert" "Einstein" 73 | -------------------------------------------------------------------------------- /example/src/Users/Actions/Index.hs: -------------------------------------------------------------------------------- 1 | module Users.Actions.Index 2 | ( usersIndex 3 | ) where 4 | 5 | import Data.Maybe (fromJust) 6 | import Servant (Handler) 7 | import Network.JSONApi 8 | ( Document 9 | , Links 10 | , Meta 11 | , mkMeta 12 | ) 13 | import qualified Network.JSONApi as JSONApi 14 | import Network.URL 15 | import Users 16 | 17 | -- A 'controller' action handler 18 | usersIndex :: Handler (Document User) 19 | usersIndex = 20 | return $ indexDocument users indexLinks (indexMetaData users) 21 | where 22 | users = 23 | [ User 1 "Isaac" "Newton" 24 | , User 2 "Albert" "Einstein" 25 | ] 26 | 27 | -- Builds the Links data for the 'index' action 28 | indexLinks :: Links 29 | indexLinks = JSONApi.mkLinks [ ("self", selfLink) ] 30 | where 31 | selfLink = toURL "/users" 32 | 33 | -- Builds the Meta data for the 'index' action 34 | indexMetaData :: [a] -> Meta 35 | indexMetaData usrs = mkMeta (UserMetaData $ length usrs) 36 | 37 | -- Builds the repsonse Document for the 'index' action 38 | indexDocument :: [User] -> Links -> Meta -> Document User 39 | indexDocument users links meta = 40 | JSONApi.mkDocument 41 | users 42 | (Just links) 43 | (Just meta) 44 | 45 | toURL :: String -> URL 46 | toURL = fromJust . importURL 47 | -------------------------------------------------------------------------------- /example/src/Users/Actions/Show.hs: -------------------------------------------------------------------------------- 1 | module Users.Actions.Show 2 | ( userShowSimple 3 | , userShowFull 4 | ) where 5 | 6 | import Data.Aeson.TH 7 | import qualified Data.Aeson as AE 8 | import Data.Default (def) 9 | import Data.Maybe (fromJust) 10 | import Data.Monoid ((<>)) 11 | import Data.Text (pack) 12 | import Servant (Handler, ServantErr (..), throwError, err404) 13 | import Network.JSONApi 14 | ( Document 15 | , ErrorDocument (..) 16 | , Error (..) 17 | , Links 18 | , Meta 19 | , MetaObject (..) 20 | , mkMeta 21 | ) 22 | import qualified Network.JSONApi as JSONApi 23 | import Network.URL 24 | import Users as U 25 | 26 | data DocumentMetaData = Pagination 27 | { currentPage :: Int 28 | , totalPages :: Int 29 | } deriving (Eq, Show) 30 | 31 | $(deriveJSON defaultOptions ''DocumentMetaData) 32 | 33 | instance MetaObject DocumentMetaData where 34 | typeName _ = "pagination" 35 | 36 | 37 | 38 | 39 | -- A 'controller' action handler 40 | userShowSimple :: Int -> Handler (Document User) 41 | userShowSimple userId = case U.getUser userId of 42 | Nothing -> throwError (resourceNotFound userId) 43 | (Just user) -> return $ showSimpleResourceDocument user 44 | 45 | 46 | -- A 'controller' action handler 47 | userShowFull :: Int -> Handler (Document User) 48 | userShowFull userId = case getUser userId of 49 | Nothing -> throwError (resourceNotFound userId) 50 | (Just user) -> return $ showFullResourceDocument user (showLinks userId) documentMetaData 51 | 52 | 53 | -- Builds the Links data for the 'show' action 54 | showLinks :: Int -> Links 55 | showLinks userId = JSONApi.mkLinks [ ("self", selfLink) ] 56 | where 57 | selfLink = toURL ("/users/" <> (show userId)) 58 | 59 | 60 | documentMetaData :: Meta 61 | documentMetaData = mkMeta (Pagination { currentPage = 1, totalPages = 40}) 62 | 63 | 64 | -- Builds a simple repsonse Document for our User resource 65 | showSimpleResourceDocument :: User -> Document User 66 | showSimpleResourceDocument user = 67 | JSONApi.mkDocument 68 | [user] 69 | Nothing 70 | Nothing 71 | 72 | 73 | -- Builds a full repsonse Document for our User resource 74 | showFullResourceDocument :: User -> Links -> Meta -> Document User 75 | showFullResourceDocument user links metaData = 76 | JSONApi.mkDocument 77 | [user] 78 | (Just links) 79 | (Just metaData) 80 | 81 | 82 | toURL :: String -> URL 83 | toURL = fromJust . importURL 84 | 85 | 86 | -- Provides 404 response 87 | resourceNotFound :: Int -> ServantErr 88 | resourceNotFound resourceId = err404 { errBody = AE.encode errorDocument } 89 | where 90 | errorDocument :: ErrorDocument Int 91 | errorDocument = ErrorDocument errorObj (Just (showLinks resourceId)) Nothing 92 | 93 | errorObj :: Error Int 94 | errorObj = 95 | def { status = Just "404" 96 | , title = Just "Resource Not Found" 97 | , detail = Just $ "There is no User with id: " <> (pack . show $ resourceId) 98 | } 99 | -------------------------------------------------------------------------------- /example/src/Users/Controller.hs: -------------------------------------------------------------------------------- 1 | module Users.Controller 2 | ( module Users.Actions.Index 3 | , module Users.Actions.Show 4 | ) where 5 | 6 | import Users.Actions.Index 7 | import Users.Actions.Show 8 | 9 | -------------------------------------------------------------------------------- /example/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: nightly-2016-07-03 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - location: . 10 | 11 | - location: ../ 12 | extra-dep: true 13 | 14 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 15 | extra-deps: [] 16 | 17 | # Override default flag values for local packages and extra-deps 18 | flags: {} 19 | 20 | # Extra package databases containing global packages 21 | extra-package-dbs: [] 22 | 23 | # Control whether we use the GHC we find on the path 24 | # system-ghc: true 25 | 26 | # Require a specific version of stack, using version ranges 27 | # require-stack-version: -any # Default 28 | # require-stack-version: >= 1.0.0 29 | 30 | # Override the architecture used by stack, especially useful on Windows 31 | # arch: i386 32 | # arch: x86_64 33 | 34 | # Extra directories used by stack for building 35 | # extra-include-dirs: [/path/to/dir] 36 | # extra-lib-dirs: [/path/to/dir] 37 | 38 | # Allow a newer minor version of GHC than the snapshot specifies 39 | # compiler-check: newer-minor 40 | -------------------------------------------------------------------------------- /example/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /json-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.3. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 6aa624502a73291732e0bbd403b6d9691e79387c2c37978d21327402feb9da01 8 | 9 | name: json-api 10 | version: 0.1.4.0 11 | synopsis: Utilities for generating JSON-API payloads 12 | description: Provides utilities for deriving JSON payloads conformant to the json-api specification 13 | category: Network 14 | stability: experimental 15 | homepage: https://github.com/toddmohney/json-api.git#readme 16 | bug-reports: https://github.com/toddmohney/json-api.git/issues 17 | author: Todd Mohney 18 | maintainer: Todd Mohney 19 | copyright: 2016 Todd Mohney 20 | license: MIT 21 | license-file: LICENSE 22 | tested-with: 23 | ghc ==7.10.3 24 | build-type: Simple 25 | extra-source-files: 26 | README.md 27 | LICENSE 28 | circle.yml 29 | stack.yaml 30 | example/LICENSE 31 | example/README.md 32 | example/example.cabal 33 | example/Setup.hs 34 | example/stack.yaml 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/toddmohney/json-api.git 39 | 40 | library 41 | exposed-modules: 42 | Network.JSONApi 43 | Network.JSONApi.Error 44 | Network.JSONApi.Document 45 | Network.JSONApi.Identifier 46 | Network.JSONApi.Meta 47 | Network.JSONApi.Link 48 | Network.JSONApi.Resource 49 | Network.JSONApi.Pagination 50 | Network.JSONApi.Source 51 | other-modules: 52 | Paths_json_api 53 | hs-source-dirs: 54 | src 55 | default-extensions: DeriveGeneric GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards TemplateHaskell 56 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fhide-source-paths -fno-warn-warnings-deprecations -freverse-errors -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -fwarn-unused-imports 57 | build-depends: 58 | aeson 59 | , base >=4.7 && <5.0 60 | , containers 61 | , data-default 62 | , deepseq 63 | , lens 64 | , lens-aeson 65 | , text 66 | , unordered-containers 67 | , url 68 | default-language: Haskell2010 69 | 70 | test-suite json-api-test 71 | type: exitcode-stdio-1.0 72 | main-is: Spec.hs 73 | other-modules: 74 | Network.JSONApi.DocumentSpec 75 | Network.JSONApi.ErrorSpec 76 | Network.JSONApi.IdentifierSpec 77 | Network.JSONApi.MetaSpec 78 | Network.JSONApi.PaginationSpec 79 | Network.JSONApi.ResourceSpec 80 | Network.JSONApi.SourceSpec 81 | TestHelpers 82 | Paths_json_api 83 | hs-source-dirs: 84 | test 85 | default-extensions: DeriveGeneric GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards 86 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fhide-source-paths -fno-warn-warnings-deprecations -freverse-errors -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches 87 | build-depends: 88 | aeson 89 | , aeson-pretty 90 | , base >=4.7 && <5.0 91 | , bytestring 92 | , containers 93 | , data-default 94 | , deepseq 95 | , hspec 96 | , json-api 97 | , lens 98 | , lens-aeson 99 | , text 100 | , unordered-containers 101 | , url 102 | default-language: Haskell2010 103 | build-tool-depends: hspec-discover:hspec-discover 104 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: json-api 2 | version: '0.1.4.0' 3 | synopsis: Utilities for generating JSON-API payloads 4 | description: ! 'Provides utilities for deriving JSON payloads conformant to the json-api specification' 5 | category: Network 6 | author: Todd Mohney 7 | maintainer: Todd Mohney 8 | copyright: 2016 Todd Mohney 9 | license: MIT 10 | github: toddmohney/json-api.git 11 | 12 | extra-source-files: 13 | - README.md 14 | - LICENSE 15 | - circle.yml 16 | - stack.yaml 17 | - example/LICENSE 18 | - example/README.md 19 | - example/example.cabal 20 | - example/*.hs 21 | - example/stack.yaml 22 | 23 | default-extensions: 24 | - DeriveGeneric 25 | - GeneralizedNewtypeDeriving 26 | - OverloadedStrings 27 | - RecordWildCards 28 | 29 | ghc-options: 30 | - -Wall 31 | - -Wcompat 32 | # - -Werror 33 | - -Widentities 34 | - -Wincomplete-record-updates 35 | - -Wincomplete-uni-patterns 36 | - -Wredundant-constraints 37 | - -fhide-source-paths 38 | - -fno-warn-warnings-deprecations 39 | - -freverse-errors 40 | - -fwarn-unused-binds 41 | - -fwarn-unused-imports 42 | - -fwarn-unused-matches 43 | 44 | dependencies: 45 | - aeson 46 | - base >=4.7 && <5.0 47 | - containers 48 | - data-default 49 | - deepseq 50 | - lens 51 | - lens-aeson 52 | - text 53 | - unordered-containers 54 | - url 55 | 56 | library: 57 | source-dirs: src 58 | default-extensions: 59 | - TemplateHaskell 60 | ghc-options: 61 | - -fwarn-unused-imports 62 | exposed-modules: 63 | - Network.JSONApi 64 | - Network.JSONApi.Error 65 | - Network.JSONApi.Document 66 | - Network.JSONApi.Identifier 67 | - Network.JSONApi.Meta 68 | - Network.JSONApi.Link 69 | - Network.JSONApi.Resource 70 | - Network.JSONApi.Pagination 71 | - Network.JSONApi.Source 72 | 73 | tests: 74 | json-api-test: 75 | main: Spec.hs 76 | source-dirs: test 77 | dependencies: 78 | - aeson-pretty 79 | - bytestring 80 | - hspec 81 | - json-api 82 | verbatim: 83 | build-tool-depends: 84 | hspec-discover:hspec-discover 85 | stability: experimental 86 | tested-with: ghc ==7.10.3 87 | -------------------------------------------------------------------------------- /pbcopy: -------------------------------------------------------------------------------- 1 | { 2 | "links" : { 3 | "self" : "/users" 4 | }, 5 | "meta" : { 6 | "user-count" : 2 7 | }, 8 | "data" : [ 9 | { 10 | "links" : { 11 | "self" : "/users/1" 12 | }, 13 | "meta" : null, 14 | "id" : "1", 15 | "attributes" : { 16 | "userLastName" : "Newton", 17 | "userId" : 1, 18 | "userFirstName" : "Isaac" 19 | }, 20 | "type" : "User", 21 | "relationships" : { 22 | "email" : { 23 | "links" : { 24 | "self" : "/emails/42" 25 | }, 26 | "data" : { 27 | "id" : "42", 28 | "type" : "Email" 29 | } 30 | } 31 | } 32 | }, 33 | { 34 | "links" : { 35 | "self" : "/users/2" 36 | }, 37 | "meta" : null, 38 | "id" : "2", 39 | "attributes" : { 40 | "userLastName" : "Einstein", 41 | "userId" : 2, 42 | "userFirstName" : "Albert" 43 | }, 44 | "relationships" : { 45 | "email" : { 46 | "links" : { 47 | "self" : "/emails/88" 48 | }, 49 | "data" : { 50 | "type" : "Email", 51 | "id" : "88" 52 | } 53 | } 54 | }, 55 | "type" : "User" 56 | } 57 | ] 58 | } 59 | { 60 | "links" : { 61 | "self" : "/users/1" 62 | }, 63 | "meta" : null, 64 | "data" : { 65 | "id" : "1", 66 | "attributes" : { 67 | "userFirstName" : "Isaac", 68 | "userId" : 1, 69 | "userLastName" : "Newton" 70 | }, 71 | "meta" : null, 72 | "type" : "User", 73 | "relationships" : { 74 | "email" : { 75 | "data" : { 76 | "id" : "42", 77 | "type" : "Email" 78 | }, 79 | "links" : { 80 | "self" : "/emails/42" 81 | } 82 | } 83 | }, 84 | "links" : { 85 | "self" : "/users/1" 86 | } 87 | } 88 | } 89 | -------------------------------------------------------------------------------- /src/Network/JSONApi.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Entry-point module for this package. 3 | -} 4 | module Network.JSONApi 5 | ( D.Document (..) 6 | , D.ResourceData (..) 7 | , D.ErrorDocument (..) 8 | , D.Included 9 | , E.Error (..) 10 | , R.Relationship 11 | , R.Resource (..) 12 | , R.Relationships 13 | , R.ResourcefulEntity (..) 14 | , I.HasIdentifier (..) 15 | , I.Identifier (..) 16 | , L.Links (..) 17 | , M.Meta 18 | , M.MetaObject (..) 19 | , L.mkLinks 20 | , P.Pagination (..) 21 | , P.PageIndex (..) 22 | , P.PageSize (..) 23 | , P.ResourceCount (..) 24 | , P.Strategy (..) 25 | , S.Source (..) 26 | , P.mkPaginationLinks 27 | , R.mkRelationship 28 | , R.mkRelationships 29 | , D.mkDocument 30 | , D.mkDocuments 31 | , D.mkDocument' 32 | , D.mkSimpleDocument 33 | , D.mkSimpleDocuments 34 | , D.mkSimpleDocument' 35 | , D.singleton 36 | , D.list 37 | , D.mkCompoundDocument 38 | , D.mkCompoundDocument' 39 | , D.mkIncludedResource 40 | , M.mkMeta 41 | ) where 42 | 43 | import qualified Network.JSONApi.Error as E 44 | import qualified Network.JSONApi.Document as D 45 | import qualified Network.JSONApi.Identifier as I 46 | import qualified Network.JSONApi.Link as L 47 | import qualified Network.JSONApi.Meta as M 48 | import qualified Network.JSONApi.Pagination as P 49 | import qualified Network.JSONApi.Resource as R 50 | import qualified Network.JSONApi.Source as S 51 | 52 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Document.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Contains representations of the top-level JSON-API document structure. 3 | -} 4 | module Network.JSONApi.Document 5 | ( Document (..) 6 | , ResourceData (..) 7 | , ErrorDocument (..) 8 | , Included 9 | , mkDocument 10 | , mkDocuments 11 | , mkDocument' 12 | , singleton 13 | , list 14 | , mkCompoundDocument 15 | , mkCompoundDocuments 16 | , mkCompoundDocument' 17 | , mkIncludedResource 18 | , mkSimpleDocument 19 | , mkSimpleDocuments 20 | , mkSimpleDocument' 21 | ) where 22 | 23 | import Control.DeepSeq (NFData) 24 | import Control.Monad (mzero) 25 | import Data.Aeson 26 | ( ToJSON 27 | , FromJSON 28 | , Value 29 | , (.=) 30 | , (.:) 31 | , (.:?) 32 | ) 33 | import qualified Data.Aeson as AE 34 | import qualified GHC.Generics as G 35 | import qualified Network.JSONApi.Error as E 36 | import Network.JSONApi.Link as L 37 | import Network.JSONApi.Meta as M 38 | import Network.JSONApi.Resource (Resource, ResourcefulEntity) 39 | import qualified Network.JSONApi.Resource as R 40 | 41 | {- | 42 | The 'Document' type represents the top-level JSON-API requirement. 43 | 44 | @data@ attribute - the resulting JSON may be either a singleton resource 45 | or a list of resources. See 'Resource' for the construction. 46 | 47 | For more information see: 48 | -} 49 | data Document a = Document 50 | { _data :: ResourceData a 51 | , _links :: Maybe Links 52 | , _meta :: Maybe Meta 53 | , _included :: [Value] 54 | } deriving (Show, Eq, G.Generic) 55 | 56 | instance NFData a => NFData (Document a) 57 | 58 | instance (ToJSON a) 59 | => ToJSON (Document a) where 60 | toJSON (Document (List res) links meta included) = 61 | AE.object [ "data" .= res 62 | , "links" .= links 63 | , "meta" .= meta 64 | , "included" .= included 65 | ] 66 | toJSON (Document (Singleton res) links meta included) = 67 | AE.object [ "data" .= res 68 | , "links" .= links 69 | , "meta" .= meta 70 | , "included" .= included 71 | ] 72 | 73 | instance (FromJSON a) => FromJSON (Document a) where 74 | parseJSON = AE.withObject "document" $ \v -> do 75 | d <- v .: "data" 76 | l <- v .:? "links" 77 | m <- v .:? "meta" 78 | i <- v .: "included" 79 | return (Document d l m i) 80 | 81 | {- | 82 | The 'Included' type is an abstraction used to constrain the @included@ 83 | section of the Document to JSON serializable Resource objects while 84 | enabling a heterogeneous list of Resource types. 85 | 86 | No data constructors for this type are exported as we need to 87 | constrain the 'Value' to a heterogeneous list of Resource types. 88 | See 'mkIncludedResource' for creating 'Included' types. 89 | -} 90 | data Included = Included [Value] 91 | deriving (G.Generic, Show) 92 | 93 | instance NFData Included 94 | 95 | instance Semigroup Included where 96 | (<>) (Included as) (Included bs) = Included (as <> bs) 97 | 98 | instance Monoid Included where 99 | mempty = Included [] 100 | 101 | {- | 102 | Constructor function for the Document data type. 103 | 104 | See 'mkCompoundDocument' for constructing compound Document 105 | including 'side-loaded' resources 106 | -} 107 | mkDocument :: ResourcefulEntity a => 108 | a 109 | -> Maybe Links 110 | -> Maybe Meta 111 | -> Document a 112 | mkDocument res = mkDocument' (toResourceData res) 113 | 114 | mkDocuments :: ResourcefulEntity a => 115 | [a] 116 | -> Maybe Links 117 | -> Maybe Meta 118 | -> Document a 119 | mkDocuments res = mkDocument' (toResourceDataMany res) 120 | 121 | mkDocument' :: ResourceData a 122 | -> Maybe Links 123 | -> Maybe Meta 124 | -> Document a 125 | mkDocument' res links meta = 126 | Document 127 | { _data = res 128 | , _links = links 129 | , _meta = meta 130 | , _included = [] 131 | } 132 | 133 | {- | 134 | A function for a single resourceful entity and document which do not 135 | require links or Meta data. 136 | -} 137 | mkSimpleDocument :: ResourcefulEntity a => a -> Document a 138 | mkSimpleDocument res = mkDocument res Nothing Nothing 139 | 140 | {- | 141 | A function for a multiple resourceful entities and document which do not 142 | require links or Meta data. 143 | -} 144 | mkSimpleDocuments :: ResourcefulEntity a => [a] -> Document a 145 | mkSimpleDocuments res = mkDocuments res Nothing Nothing 146 | 147 | {- | 148 | A function for document which do not require links or Meta data. 149 | -} 150 | mkSimpleDocument' :: ResourceData a -> Document a 151 | mkSimpleDocument' res = mkDocument' res Nothing Nothing 152 | 153 | {- | 154 | Constructor function for the Document data type. 155 | See 'mkIncludedResource' for constructing the 'Included' type. 156 | 157 | Supports building compound documents 158 | 159 | -} 160 | mkCompoundDocument :: ResourcefulEntity a => 161 | a 162 | -> Maybe Links 163 | -> Maybe Meta 164 | -> Included 165 | -> Document a 166 | mkCompoundDocument res = mkCompoundDocument' (toResourceData res) 167 | 168 | {- | 169 | Constructor function for the Document data type. 170 | See 'mkIncludedResource' for constructing the 'Included' type. 171 | Supports building compound documents 172 | 173 | -} 174 | mkCompoundDocuments :: ResourcefulEntity a => 175 | [a] 176 | -> Maybe Links 177 | -> Maybe Meta 178 | -> Included 179 | -> Document a 180 | mkCompoundDocuments res = mkCompoundDocument' (toResourceDataMany res) 181 | 182 | mkCompoundDocument' :: ResourceData a 183 | -> Maybe Links 184 | -> Maybe Meta 185 | -> Included 186 | -> Document a 187 | mkCompoundDocument' res links meta (Included included) = 188 | Document 189 | { _data = res 190 | , _links = links 191 | , _meta = meta 192 | , _included = included 193 | } 194 | 195 | {- | 196 | Constructor function for the Document data type. 197 | 198 | Supports building compound documents 199 | 200 | -} 201 | mkIncludedResource :: (ResourcefulEntity a, ToJSON a) => a -> Included 202 | mkIncludedResource res = Included [AE.toJSON . R.toResource $ res] 203 | 204 | toResourceData :: ResourcefulEntity a => a -> ResourceData a 205 | toResourceData r = Singleton (R.toResource r) 206 | 207 | toResourceDataMany :: ResourcefulEntity a => [a] -> ResourceData a 208 | toResourceDataMany rs = List (map R.toResource rs) 209 | 210 | {- | 211 | The 'Resource' type encapsulates the underlying 'Resource' 212 | 213 | Included in the top-level 'Document', the 'Resource' may be either 214 | a singleton resource or a list. 215 | 216 | For more information see: 217 | -} 218 | data ResourceData a = Singleton (Resource a) 219 | | List [ Resource a ] 220 | deriving (Show, Eq, G.Generic) 221 | 222 | singleton :: ResourcefulEntity a => a -> ResourceData a 223 | singleton = Singleton . R.toResource 224 | 225 | list :: ResourcefulEntity a => [a] -> ResourceData a 226 | list = List . map R.toResource 227 | 228 | instance NFData a => NFData (ResourceData a) 229 | 230 | instance (ToJSON a) => ToJSON (ResourceData a) where 231 | toJSON (Singleton res) = AE.toJSON res 232 | toJSON (List res) = AE.toJSON res 233 | 234 | instance (FromJSON a) => FromJSON (ResourceData a) where 235 | parseJSON (AE.Object v) = Singleton <$> (AE.parseJSON (AE.Object v)) 236 | parseJSON (AE.Array v) = List <$> (AE.parseJSON (AE.Array v)) 237 | parseJSON _ = mzero 238 | 239 | {- | 240 | The 'ErrorDocument' type represents the alternative form of the top-level 241 | JSON-API requirement. 242 | 243 | @error@ attribute - a descriptive object encapsulating application-specific 244 | error detail. 245 | 246 | For more information see: 247 | -} 248 | data ErrorDocument a = ErrorDocument 249 | { _error :: E.Error a 250 | , _errorLinks :: Maybe Links 251 | , _errorMeta :: Maybe Meta 252 | } deriving (Show, Eq, G.Generic) 253 | 254 | instance NFData a => NFData (ErrorDocument a) 255 | 256 | instance (ToJSON a) => ToJSON (ErrorDocument a) where 257 | toJSON (ErrorDocument err links meta) = 258 | AE.object [ "error" .= err 259 | , "links" .= links 260 | , "meta" .= meta 261 | ] 262 | 263 | instance (FromJSON a) => FromJSON (ErrorDocument a) where 264 | parseJSON = AE.withObject "error" $ \v -> 265 | ErrorDocument 266 | <$> v .: "error" 267 | <*> v .:? "links" 268 | <*> v .:? "meta" 269 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Error.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module representing a JSON-API error object. 3 | 4 | Error objects are used for providing application-specific detail 5 | to unsuccessful API responses. 6 | 7 | Specification: 8 | -} 9 | module Network.JSONApi.Error 10 | ( Error (..) 11 | ) where 12 | 13 | import Data.Aeson (ToJSON, FromJSON) 14 | import Data.Default 15 | import Data.Text 16 | import qualified GHC.Generics as G 17 | import Network.JSONApi.Link (Links) 18 | import Network.JSONApi.Meta 19 | import Network.JSONApi.Source (Source) 20 | import Prelude hiding (id) 21 | import Control.DeepSeq (NFData) 22 | 23 | {- | 24 | Type for providing application-specific detail to unsuccessful API 25 | responses. 26 | 27 | Specification: 28 | -} 29 | data Error a = 30 | Error { id :: Maybe Text 31 | , links :: Maybe Links 32 | , status :: Maybe Text 33 | , code :: Maybe Text 34 | , title :: Maybe Text 35 | , detail :: Maybe Text 36 | , source :: Maybe Source 37 | , meta :: Maybe Meta 38 | } 39 | deriving (Show, Eq, G.Generic) 40 | 41 | instance NFData a => NFData (Error a) 42 | instance ToJSON a => ToJSON (Error a) 43 | instance FromJSON a => FromJSON (Error a) 44 | 45 | instance Default (Error a) where 46 | def = Error 47 | { id = Nothing 48 | , links = Nothing 49 | , status = Nothing 50 | , code = Nothing 51 | , title = Nothing 52 | , detail = Nothing 53 | , source = Nothing 54 | , meta = Nothing 55 | } 56 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Identifier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | {- | 4 | Module representing a JSON-API resource object. 5 | 6 | Specification: 7 | -} 8 | module Network.JSONApi.Identifier 9 | ( HasIdentifier (..) 10 | , Identifier (..) 11 | , datatype 12 | , ident 13 | , metadata 14 | ) where 15 | 16 | import Control.Lens.TH 17 | import Data.Aeson (ToJSON, FromJSON, (.=), (.:), (.:?)) 18 | import qualified Data.Aeson as AE 19 | import Data.Text (Text) 20 | import Network.JSONApi.Meta (Meta) 21 | import Prelude hiding (id) 22 | import Control.DeepSeq (NFData) 23 | import qualified GHC.Generics as G 24 | 25 | {- | 26 | Identifiers are used to encapsulate the minimum amount of information 27 | to uniquely identify a resource. 28 | 29 | This object will be found at multiple levels of the JSON-API structure 30 | 31 | Specification: 32 | -} 33 | data Identifier = Identifier 34 | { _ident :: Text 35 | , _datatype :: Text 36 | , _metadata :: Maybe Meta 37 | } deriving (Show, Eq, G.Generic) 38 | 39 | instance ToJSON Identifier where 40 | toJSON (Identifier resId resType resMetaData) = 41 | AE.object [ "id" .= resId 42 | , "type" .= resType 43 | , "meta" .= resMetaData 44 | ] 45 | 46 | instance FromJSON Identifier where 47 | parseJSON = AE.withObject "resourceIdentifier" $ \v -> do 48 | id <- v .: "id" 49 | typ <- v .: "type" 50 | meta <- v .:? "meta" 51 | return $ Identifier id typ meta 52 | 53 | instance NFData Identifier 54 | 55 | 56 | {- | 57 | Typeclass indicating how to access an 'Identifier' for 58 | a given datatype 59 | -} 60 | class HasIdentifier a where 61 | identifier :: a -> Identifier 62 | 63 | makeLenses ''Identifier 64 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Link.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module representing a JSON-API link object. 3 | 4 | Specification: 5 | -} 6 | module Network.JSONApi.Link 7 | ( Links (..) 8 | , Rel 9 | , Href 10 | , mkLinks 11 | ) where 12 | 13 | import Data.Aeson (ToJSON, FromJSON) 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Text (Text, pack) 17 | import qualified GHC.Generics as G 18 | import Network.URL (URL, exportURL) 19 | import Control.DeepSeq (NFData) 20 | 21 | {- | 22 | Type representing a JSON-API link object. 23 | 24 | Links are an abstraction around an underlying Map consisting of 25 | relevance identifiers as keys and URIs as values. 26 | 27 | Example JSON: 28 | @ 29 | "links": { 30 | "self": "http://example.com/posts/1" 31 | } 32 | @ 33 | 34 | Specification: 35 | -} 36 | newtype Links = Links (Map Rel Href) 37 | deriving (Show, Eq, Ord, ToJSON, FromJSON, G.Generic) 38 | 39 | instance NFData Links 40 | 41 | type Rel = Text 42 | type Href = Text 43 | 44 | {- | 45 | Constructor function for building Links 46 | -} 47 | mkLinks :: [(Rel, URL)] -> Links 48 | mkLinks = Links . Map.fromList . map buildLink 49 | 50 | buildLink :: (Rel, URL) -> (Rel, Href) 51 | buildLink (key, url) = (key, pack (exportURL url)) 52 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Meta.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module representing a JSON-API meta object. 3 | 4 | Specification: 5 | -} 6 | module Network.JSONApi.Meta 7 | ( Meta 8 | , MetaObject (..) 9 | , mkMeta 10 | )where 11 | 12 | import Data.Aeson (ToJSON, FromJSON, Object, toJSON) 13 | import Data.HashMap.Strict as HM 14 | import Data.Text (Text) 15 | import qualified GHC.Generics as G 16 | import Control.DeepSeq (NFData) 17 | 18 | {- | 19 | Type representing a JSON-API meta object. 20 | 21 | Meta is an abstraction around an underlying Map consisting of 22 | resource-specific metadata. 23 | 24 | Example JSON: 25 | @ 26 | "meta": { 27 | "copyright": "Copyright 2015 Example Corp.", 28 | "authors": [ 29 | "Andre Dawson", 30 | "Kirby Puckett", 31 | "Don Mattingly", 32 | "Ozzie Guillen" 33 | ] 34 | } 35 | @ 36 | 37 | Specification: 38 | -} 39 | data Meta = Meta Object 40 | deriving (Show, Eq, G.Generic) 41 | 42 | instance NFData Meta 43 | instance ToJSON Meta 44 | instance FromJSON Meta 45 | 46 | instance Semigroup Meta where 47 | (<>) (Meta a) (Meta b) = Meta $ HM.union a b 48 | 49 | instance Monoid Meta where 50 | mempty = Meta $ HM.empty 51 | 52 | {- | 53 | Convienience class for constructing a Meta type 54 | 55 | Example usage: 56 | @ 57 | data Pagination = Pagination 58 | { currentPage :: Int 59 | , totalPages :: Int 60 | } deriving (Show, Generic) 61 | 62 | instance ToJSON Pagination 63 | instance MetaObject Pagination where 64 | typeName _ = "pagination" 65 | @ 66 | -} 67 | class (ToJSON a) => MetaObject a where 68 | typeName :: a -> Text 69 | 70 | {- | 71 | Convienience constructor function for the Meta type 72 | 73 | Useful on its own or in combination with Meta's monoid instance 74 | 75 | Example usage: 76 | See MetaSpec.hs for an example 77 | -} 78 | mkMeta :: (MetaObject a) => a -> Meta 79 | mkMeta obj = Meta $ HM.singleton (typeName obj) (toJSON obj) 80 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Pagination.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.JSONApi.Pagination ( 4 | Pagination (..) 5 | , PageIndex (..) 6 | , PageSize (..) 7 | , ResourceCount (..) 8 | , Strategy (..) 9 | , mkPaginationLinks 10 | ) where 11 | 12 | import Data.Aeson (ToJSON (toJSON), (.=), object) 13 | import Network.JSONApi.Link (Links, Rel, mkLinks) 14 | import Network.JSONApi.Meta (MetaObject (typeName)) 15 | import Network.URL (URL, add_param) 16 | import qualified GHC.Generics as G 17 | import Control.DeepSeq (NFData) 18 | 19 | {- | 20 | Wrapper type for the various components of pagination being page size, page index 21 | and the number of resources in total. 22 | -} 23 | data Pagination = Pagination { 24 | getPaginationPageIndex :: PageIndex 25 | , getPaginationPageSize :: PageSize 26 | , getPaginationResourceCount :: ResourceCount 27 | } deriving G.Generic 28 | 29 | instance NFData Pagination 30 | 31 | 32 | instance ToJSON Pagination where 33 | toJSON (Pagination (PageIndex num) (PageSize size) (ResourceCount count)) = 34 | object [ 35 | "pageSize" .= size 36 | , "currentPage" .= num 37 | , "totalDocuments" .= count 38 | ] 39 | 40 | {- | 41 | Pagination can be used as a meta object if required in addition to the links generated 42 | for paging. 43 | -} 44 | instance MetaObject Pagination where 45 | typeName _ = "pagination" 46 | 47 | {- | 48 | We can specify limits on the number of rows we would like back from the database 49 | -} 50 | newtype PageSize = PageSize { 51 | getPageSize :: Int 52 | } deriving (Show, NFData) 53 | 54 | newtype PageIndex = PageIndex { 55 | getPageIndex :: Int 56 | } deriving (Show, NFData) 57 | 58 | newtype ResourceCount = ResourceCount { 59 | getResourceCount :: Int 60 | } deriving (Show, NFData) 61 | 62 | {- | 63 | Pagination strategies are commonly implemented by the server of which Page and Offset 64 | are commonly used. 65 | -} 66 | data Strategy = PageStrategy | OffsetStrategy 67 | 68 | {- | 69 | Helper function to build relative links for a collection of resources of type ResourceEntity. 70 | 71 | This helper function assumes that the first page is always page 0. 72 | -} 73 | mkPaginationLinks :: Strategy -> URL -> Pagination -> Links 74 | mkPaginationLinks strategy baseUrl page = 75 | mkLinks (baseLinks ++ nextLinks ++ prevLinks) 76 | where 77 | pgIndex = getPageIndex $ getPaginationPageIndex page 78 | pgSize = getPageSize $ getPaginationPageSize page 79 | baseLinks = [mkPaginationLink strategy "first" baseUrl (firstPageIndex strategy) pgSize 80 | , mkPaginationLink strategy "last" baseUrl (lastPageIndex strategy page) pgSize] 81 | nextLinks = [mkPaginationLink strategy "next" baseUrl (pgIndex + 1) pgSize | shouldGenNextLink strategy page] 82 | prevLinks = [mkPaginationLink strategy "prev" baseUrl (pgIndex - 1) pgSize | shouldGenPrevLink strategy page] 83 | 84 | {- | 85 | If we are at the last page then we do not generate a next link. This function tells us whether to 86 | generate a next link based on the page strategy. 87 | -} 88 | shouldGenNextLink :: Strategy -> Pagination -> Bool 89 | shouldGenNextLink PageStrategy pagination = 90 | (getPageIndex . getPaginationPageIndex) pagination < numberOfPagesInPageList pagination 91 | shouldGenNextLink OffsetStrategy pagination = 92 | (getPageIndex . getPaginationPageIndex) pagination < numberOfPagesInPageList pagination - 1 93 | 94 | {- | 95 | If we on the first page then we do not generate a prev link. This function tells us whether we can generate 96 | a prev link. 97 | -} 98 | shouldGenPrevLink :: Strategy -> Pagination -> Bool 99 | shouldGenPrevLink strategy pagination = 100 | (getPageIndex . getPaginationPageIndex) pagination > firstPageIndex strategy 101 | 102 | {- | 103 | This function calculates the number of pages in the list. 104 | -} 105 | numberOfPagesInPageList :: Pagination -> Int 106 | numberOfPagesInPageList (Pagination _ pageSize resourceCount) = 107 | if resCount `mod` pgSize == 0 108 | then resCount `quot` pgSize 109 | else (resCount `quot` pgSize) + 1 110 | where 111 | pgSize = getPageSize pageSize 112 | resCount = getResourceCount resourceCount 113 | 114 | {- | 115 | Helper function used to generate a single pagination link. 116 | -} 117 | mkPaginationLink :: Strategy -> Rel -> URL -> Int -> Int -> (Rel, URL) 118 | mkPaginationLink strategy key baseUrl pageNo pageSize = 119 | (key, link) 120 | where 121 | pageNoUrl = add_param baseUrl (strategyToQueryStringNumberKey strategy, show pageNo) 122 | link = add_param pageNoUrl (strategyToQueryStringSizeKey strategy, show pageSize) 123 | 124 | {- | 125 | In the page strategy page numbering starts at 1, where as in the case of offset the numbering 126 | starts at 0. 127 | -} 128 | firstPageIndex :: Strategy -> Int 129 | firstPageIndex PageStrategy = 1 130 | firstPageIndex OffsetStrategy = 0 131 | 132 | lastPageIndex :: Strategy -> Pagination -> Int 133 | lastPageIndex PageStrategy page = numberOfPagesInPageList page 134 | lastPageIndex OffsetStrategy page = numberOfPagesInPageList page - 1 135 | 136 | {- | 137 | Simple pattern matcher than translates a Strategy to a query string element name. 138 | -} 139 | strategyToQueryStringNumberKey :: Strategy -> String 140 | strategyToQueryStringNumberKey PageStrategy = "page[number]" 141 | strategyToQueryStringNumberKey OffsetStrategy = "page[offset]" 142 | 143 | strategyToQueryStringSizeKey :: Strategy -> String 144 | strategyToQueryStringSizeKey PageStrategy = "page[size]" 145 | strategyToQueryStringSizeKey OffsetStrategy = "page[limit]" 146 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Resource.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module representing a JSON-API resource object. 3 | 4 | Specification: 5 | -} 6 | module Network.JSONApi.Resource 7 | ( Resource (..) 8 | , Relationships 9 | , ResourcefulEntity (..) 10 | , Relationship 11 | , mkRelationship 12 | , mkRelationships 13 | ) where 14 | 15 | import Control.Lens.TH 16 | import Data.Aeson (ToJSON, FromJSON, (.=), (.:), (.:?)) 17 | import qualified Data.Aeson as AE 18 | import Data.Map (Map) 19 | import qualified Data.Map as Map 20 | import Data.Monoid 21 | import Data.Text (Text) 22 | import GHC.Generics hiding (Meta) 23 | import Network.JSONApi.Identifier (HasIdentifier (..), Identifier (..)) 24 | import Network.JSONApi.Link (Links) 25 | import Network.JSONApi.Meta (Meta) 26 | import Prelude hiding (id) 27 | import Control.DeepSeq (NFData) 28 | 29 | {- | 30 | Type representing a JSON-API resource object. 31 | 32 | A Resource supplies standardized data and metadata about a resource. 33 | 34 | Specification: 35 | -} 36 | data Resource a = Resource 37 | { getIdentifier :: Identifier 38 | , getResource :: a 39 | , getLinks :: Maybe Links 40 | , getRelationships :: Maybe Relationships 41 | } deriving (Show, Eq, Generic) 42 | 43 | instance NFData a => NFData (Resource a) 44 | 45 | instance (ToJSON a) => ToJSON (Resource a) where 46 | toJSON (Resource (Identifier resId resType metaObj) resObj linksObj rels) = 47 | AE.object [ "id" .= resId 48 | , "type" .= resType 49 | , "attributes" .= resObj 50 | , "links" .= linksObj 51 | , "meta" .= metaObj 52 | , "relationships" .= rels 53 | ] 54 | 55 | instance (FromJSON a) => FromJSON (Resource a) where 56 | parseJSON = AE.withObject "resourceObject" $ \v -> do 57 | id <- v .: "id" 58 | typ <- v .: "type" 59 | attrs <- v .: "attributes" 60 | links <- v .:? "links" 61 | meta <- v .:? "meta" 62 | rels <- v .:? "relationships" 63 | return $ Resource (Identifier id typ meta) attrs links rels 64 | 65 | instance HasIdentifier (Resource a) where 66 | identifier = getIdentifier 67 | 68 | {- | 69 | A typeclass for decorating an entity with JSON API properties 70 | -} 71 | class ResourcefulEntity a where 72 | resourceIdentifier :: a -> Text 73 | resourceType :: a -> Text 74 | resourceLinks :: a -> Maybe Links 75 | resourceMetaData :: a -> Maybe Meta 76 | resourceRelationships :: a -> Maybe Relationships 77 | 78 | fromResource :: Resource a -> a 79 | fromResource = getResource 80 | 81 | toResource :: a -> Resource a 82 | toResource a = 83 | Resource 84 | (Identifier (resourceIdentifier a) (resourceType a) (resourceMetaData a)) 85 | a 86 | (resourceLinks a) 87 | (resourceRelationships a) 88 | 89 | {- | 90 | A type representing the Relationship between 2 entities 91 | 92 | A Relationship provides basic information for fetching further information 93 | about a related resource. 94 | 95 | Specification: 96 | -} 97 | data Relationship = Relationship 98 | { _data :: Maybe Identifier 99 | , _links :: Maybe Links 100 | } deriving (Show, Eq, Generic) 101 | 102 | instance NFData Relationship 103 | 104 | instance ToJSON Relationship where 105 | toJSON = AE.genericToJSON 106 | AE.defaultOptions { AE.fieldLabelModifier = drop 1 } 107 | 108 | instance FromJSON Relationship where 109 | parseJSON = AE.genericParseJSON 110 | AE.defaultOptions { AE.fieldLabelModifier = drop 1 } 111 | 112 | 113 | data Relationships = Relationships (Map Text Relationship) 114 | deriving (Show, Eq, Generic) 115 | 116 | instance NFData Relationships 117 | instance ToJSON Relationships 118 | instance FromJSON Relationships 119 | 120 | instance Semigroup Relationships where 121 | (<>) (Relationships a) (Relationships b) = Relationships (a <> b) 122 | 123 | instance Monoid Relationships where 124 | mempty = Relationships Map.empty 125 | 126 | mkRelationships :: Relationship -> Relationships 127 | mkRelationships rel = 128 | Relationships $ Map.singleton (relationshipType rel) rel 129 | 130 | 131 | relationshipType :: Relationship -> Text 132 | relationshipType relationship = case _data relationship of 133 | Nothing -> "unidentified" 134 | (Just (Identifier _ typ _)) -> typ 135 | 136 | 137 | {- | 138 | Constructor function for creating a Relationship record 139 | 140 | A relationship must contain either an Identifier or a Links record 141 | -} 142 | mkRelationship :: Maybe Identifier -> Maybe Links -> Maybe Relationship 143 | mkRelationship Nothing Nothing = Nothing 144 | mkRelationship resId links = Just $ Relationship resId links 145 | 146 | makeLenses ''Resource 147 | -------------------------------------------------------------------------------- /src/Network/JSONApi/Source.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module representing a JSON-API Source object. 3 | 4 | Specification: 5 | 6 | -} 7 | module Network.JSONApi.Source ( 8 | Source (..) 9 | ) where 10 | 11 | import Data.Aeson (ToJSON, FromJSON) 12 | import Data.Default (Default, def) 13 | import Data.Text (Text) 14 | import qualified GHC.Generics as G 15 | import Control.DeepSeq (NFData) 16 | 17 | data Source = 18 | Source { pointer :: Maybe Text 19 | , parameter :: Maybe Text 20 | } 21 | deriving (Show, Eq, G.Generic) 22 | 23 | instance NFData Source 24 | instance ToJSON Source 25 | instance FromJSON Source 26 | 27 | instance Default Source where 28 | def = Source 29 | { pointer = Nothing 30 | , parameter = Nothing 31 | } -------------------------------------------------------------------------------- /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 | # https://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 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.27 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - example 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | require-stack-version: ">=2.1" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | -------------------------------------------------------------------------------- /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 | snapshots: 8 | - completed: 9 | size: 500539 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/27.yaml 11 | sha256: 690db832392afe55733b4c7023fd29b1b1c660ee42f1fb505b86b07394ca994e 12 | original: lts-13.27 13 | -------------------------------------------------------------------------------- /test/Network/JSONApi/DocumentSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.JSONApi.DocumentSpec where 2 | 3 | import Control.Lens ((^?)) 4 | import Data.Aeson (ToJSON) 5 | import qualified Data.Aeson as AE 6 | import qualified Data.Aeson.Lens as Lens 7 | import Data.ByteString.Lazy.Char8 (ByteString) 8 | import qualified Data.ByteString.Lazy.Char8 as BS 9 | import Data.Either (isRight) 10 | import Data.Maybe 11 | import Network.JSONApi 12 | import TestHelpers 13 | import Test.Hspec 14 | 15 | main :: IO () 16 | main = hspec spec 17 | 18 | spec :: Spec 19 | spec = 20 | describe "JSON serialization" $ do 21 | it "JSON encodes/decodes a singleton resource" $ do 22 | let jsonApiObj = mkDocument testObject Nothing Nothing 23 | let encodedJson = encodeDocumentObject jsonApiObj 24 | let decodedJson = decodeDocumentObject encodedJson 25 | putStrLn (BS.unpack encodedJson) 26 | putStrLn (show decodedJson) 27 | isRight decodedJson `shouldBe` True 28 | 29 | it "JSON encodes/decodes a list of resources" $ do 30 | let jsonApiObj = mkDocuments [testObject, testObject2] Nothing Nothing 31 | let encodedJson = encodeDocumentObject jsonApiObj 32 | let decodedJson = decodeDocumentObject encodedJson 33 | {- putStrLn (BS.unpack encodedJson) -} 34 | {- putStrLn (show decodedJson) -} 35 | isRight decodedJson `shouldBe` True 36 | 37 | it "contains the allowable top-level keys" $ do 38 | let jsonApiObj = mkDocument testObject Nothing Nothing 39 | let encodedJson = encodeDocumentObject jsonApiObj 40 | let dataObject = encodedJson ^? Lens.key "data" 41 | let linksObject = encodedJson ^? Lens.key "links" 42 | let metaObject = encodedJson ^? Lens.key "meta" 43 | let includedObject = encodedJson ^? Lens.key "included" 44 | isJust dataObject `shouldBe` True 45 | isJust linksObject `shouldBe` True 46 | isJust metaObject `shouldBe` True 47 | isJust includedObject `shouldBe` True 48 | 49 | it "allows an optional top-level links object" $ do 50 | let jsonApiObj = mkDocument testObject (Just linksObj) Nothing 51 | let encodedJson = encodeDocumentObject jsonApiObj 52 | let decodedJson = decodeDocumentObject encodedJson 53 | -- putStrLn (BS.unpack encodedJson) 54 | -- putStrLn $ show decodedJson 55 | isRight decodedJson `shouldBe` True 56 | 57 | it "allows an optional top-level meta object" $ do 58 | let jsonApiObj = mkDocument testObject Nothing (Just testMetaObj) 59 | let encodedJson = encodeDocumentObject jsonApiObj 60 | let decodedJson = decodeDocumentObject encodedJson 61 | -- putStrLn (BS.unpack encodedJson) 62 | -- putStrLn $ show decodedJson 63 | isRight decodedJson `shouldBe` True 64 | 65 | it "allows a heterogeneous list of related resources" $ do 66 | let includedResources = (mkIncludedResource testObject) <> (mkIncludedResource testObject2) 67 | let jsonApiObj = mkCompoundDocument testObject Nothing Nothing includedResources 68 | let encodedJson = encodeDocumentObject jsonApiObj 69 | let decodedJson = decodeDocumentObject encodedJson 70 | {- putStrLn (BS.unpack encodedJson) -} 71 | {- putStrLn $ show decodedJson -} 72 | isRight decodedJson `shouldBe` True 73 | 74 | decodeDocumentObject :: ByteString 75 | -> Either String (Document TestResource) 76 | decodeDocumentObject = AE.eitherDecode 77 | 78 | encodeDocumentObject :: (ToJSON a) => Document a -> ByteString 79 | encodeDocumentObject = prettyEncode 80 | -------------------------------------------------------------------------------- /test/Network/JSONApi/ErrorSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.JSONApi.ErrorSpec where 2 | 3 | import qualified Data.Aeson as AE 4 | import qualified Data.ByteString.Lazy.Char8 as BS 5 | import Data.Default (def) 6 | import Data.Maybe 7 | import Network.JSONApi 8 | import Prelude hiding (id) 9 | import TestHelpers (prettyEncode) 10 | import Test.Hspec 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "Defaults" $ do 18 | it "provides defaults" $ 19 | let expectedDefault = Error 20 | { id = Nothing 21 | , links = Nothing 22 | , status = Nothing 23 | , code = Nothing 24 | , title = Nothing 25 | , detail = Nothing 26 | , source = Nothing 27 | , meta = Nothing 28 | } 29 | in (def::Error Int) `shouldBe` expectedDefault 30 | 31 | describe "JSON serialization" $ 32 | it "provides ToJSON/FromJSON instances" $ do 33 | let testError = (def::Error Int) 34 | let encJson = BS.unpack . prettyEncode $ testError 35 | let decJson = AE.decode (BS.pack encJson) :: Maybe (Error Int) 36 | isJust decJson `shouldBe` True 37 | {- putStrLn encJson -} 38 | {- putStrLn $ show . fromJust $ decJson -} 39 | -------------------------------------------------------------------------------- /test/Network/JSONApi/IdentifierSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.JSONApi.IdentifierSpec where 2 | 3 | import Control.Lens ((^.)) 4 | import Network.JSONApi.Identifier 5 | import Test.Hspec 6 | import TestHelpers (testMetaObj) 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "Lenses" $ do 14 | it "provides property access via lens" $ do 15 | testIdentifier ^. ident `shouldBe` "3" 16 | testIdentifier ^. datatype `shouldBe` "SomeIdentifier" 17 | testIdentifier ^. metadata `shouldBe` Just testMetaObj 18 | 19 | testIdentifier :: Identifier 20 | testIdentifier = Identifier "3" "SomeIdentifier" (Just testMetaObj) 21 | -------------------------------------------------------------------------------- /test/Network/JSONApi/MetaSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.JSONApi.MetaSpec where 2 | 3 | import Data.Aeson (ToJSON) 4 | import qualified Data.Aeson as AE 5 | import qualified Data.ByteString.Lazy.Char8 as BS 6 | import Data.Maybe (isJust) 7 | import Data.Monoid ((<>)) 8 | import Data.Text (Text) 9 | import GHC.Generics (Generic) 10 | import Network.JSONApi 11 | import TestHelpers (prettyEncode) 12 | import Test.Hspec 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "JSON serialization" $ do 20 | it "serializes/deserializes heterogeneous maps of ToJSON types" $ do 21 | let boolTestData = mkMeta testObject <> mkMeta otherTestObject 22 | let encBoolJson = BS.unpack . prettyEncode $ boolTestData 23 | let decBoolJson = AE.decode (BS.pack encBoolJson) :: Maybe Meta 24 | isJust decBoolJson `shouldBe` True 25 | 26 | testObject :: TestObject 27 | testObject = TestObject 99 102 "Zapp Brannigan" 28 | 29 | otherTestObject :: OtherTestObject 30 | otherTestObject = OtherTestObject "Olive Garden" "Woofers" 29 "TGIFriday's" 31 | 32 | data TestObject = TestObject 33 | { myID :: Int 34 | , myAge :: Int 35 | , myName :: Text 36 | } deriving (Show, Generic) 37 | 38 | instance ToJSON TestObject 39 | instance MetaObject TestObject where 40 | typeName _ = "testObject" 41 | 42 | data OtherTestObject = OtherTestObject 43 | { myFavoriteRestaurant :: Text 44 | , myDogsName :: Text 45 | , myDogsAge :: Int 46 | , myDogsFavoriteRestarant :: Text 47 | } deriving (Show, Generic) 48 | 49 | instance ToJSON OtherTestObject 50 | instance MetaObject OtherTestObject where 51 | typeName _ = "otherTestObject" 52 | -------------------------------------------------------------------------------- /test/Network/JSONApi/PaginationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.JSONApi.PaginationSpec where 4 | 5 | import Data.Map (toList) 6 | import Data.Maybe (fromJust) 7 | import Network.JSONApi 8 | import Network.URL (importURL) 9 | import Test.Hspec 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | spec :: Spec 15 | spec = 16 | describe "Pagination" $ do 17 | it "should return mandatory keys" $ do 18 | let p = Pagination (PageIndex 2) (PageSize 10) (ResourceCount 30) 19 | let results = mkPaginationLinks PageStrategy (fromJust $ importURL "/users") p 20 | case results of 21 | Links lm -> do 22 | let links = toList lm 23 | map fst links `shouldBe` ["first", "last", "next", "prev"] 24 | 25 | it "should return proper hrefs for paging strategy" $ do 26 | let p = Pagination (PageIndex 2) (PageSize 10) (ResourceCount 30) 27 | let results = mkPaginationLinks PageStrategy (fromJust $ importURL "/users") p 28 | case results of 29 | Links lm -> do 30 | let links = toList lm 31 | links `shouldBe` [("first", "/users?page%5bsize%5d=10&page%5bnumber%5d=1"), 32 | ("last", "/users?page%5bsize%5d=10&page%5bnumber%5d=3"), 33 | ("next", "/users?page%5bsize%5d=10&page%5bnumber%5d=3"), 34 | ("prev", "/users?page%5bsize%5d=10&page%5bnumber%5d=1")] 35 | 36 | it "should return proper hrefs for offset strategy" $ do 37 | let p = Pagination (PageIndex 1) (PageSize 10) (ResourceCount 30) 38 | let results = mkPaginationLinks OffsetStrategy (fromJust $ importURL "/users") p 39 | case results of 40 | Links lm -> do 41 | let links = toList lm 42 | links `shouldBe` [("first", "/users?page%5blimit%5d=10&page%5boffset%5d=0"), 43 | ("last", "/users?page%5blimit%5d=10&page%5boffset%5d=2"), 44 | ("next", "/users?page%5blimit%5d=10&page%5boffset%5d=2"), 45 | ("prev", "/users?page%5blimit%5d=10&page%5boffset%5d=0")] 46 | 47 | it "should support the page strategy" $ do 48 | let p = Pagination (PageIndex 0) (PageSize 10) (ResourceCount 20) 49 | let results = mkPaginationLinks PageStrategy (fromJust $ importURL "/users") p 50 | case results of 51 | Links lm -> do 52 | let links = toList lm 53 | (snd . head) links `shouldBe` "/users?page%5bsize%5d=10&page%5bnumber%5d=1" 54 | 55 | it "should support the offset strategy" $ do 56 | let p = Pagination (PageIndex 0) (PageSize 10) (ResourceCount 20) 57 | let results = mkPaginationLinks OffsetStrategy (fromJust $ importURL "/users") p 58 | case results of 59 | Links lm -> do 60 | let links = toList lm 61 | (snd . head) links `shouldBe` "/users?page%5blimit%5d=10&page%5boffset%5d=0" 62 | 63 | it "should omit prev when we are on the first page of a PageStrategy" $ do 64 | let p = Pagination (PageIndex 1) (PageSize 10) (ResourceCount 20) 65 | let results = mkPaginationLinks PageStrategy (fromJust $ importURL "/users") p 66 | case results of 67 | Links lm -> do 68 | let links = toList lm 69 | map fst links `shouldBe` ["first", "last", "next"] 70 | 71 | it "should omit next when we are on the last page of a PageStrategy" $ do 72 | let p = Pagination (PageIndex 2) (PageSize 10) (ResourceCount 20) 73 | let results = mkPaginationLinks PageStrategy (fromJust $ importURL "/users") p 74 | case results of 75 | Links lm -> do 76 | let links = toList lm 77 | map fst links `shouldBe` ["first", "last", "prev"] 78 | 79 | it "should omit prev when we are on the first page of a OffsetStrategy" $ do 80 | let p = Pagination (PageIndex 0) (PageSize 10) (ResourceCount 20) 81 | let results = mkPaginationLinks OffsetStrategy (fromJust $ importURL "/users") p 82 | case results of 83 | Links lm -> do 84 | let links = toList lm 85 | map fst links `shouldBe` ["first", "last", "next"] 86 | 87 | it "should omit next when we are on the last page of a OffsetStrategy" $ do 88 | let p = Pagination (PageIndex 1) (PageSize 10) (ResourceCount 20) 89 | let results = mkPaginationLinks OffsetStrategy (fromJust $ importURL "/users") p 90 | case results of 91 | Links lm -> do 92 | let links = toList lm 93 | map fst links `shouldBe` ["first", "last", "prev"] -------------------------------------------------------------------------------- /test/Network/JSONApi/ResourceSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.JSONApi.ResourceSpec where 2 | 3 | import qualified Data.Aeson as AE 4 | import qualified Data.ByteString.Lazy.Char8 as BS 5 | import Data.Maybe (isJust, fromJust) 6 | import Data.Text (Text, pack) 7 | import GHC.Generics (Generic) 8 | import Network.JSONApi 9 | import Network.URL (URL, importURL) 10 | import TestHelpers (prettyEncode) 11 | import Test.Hspec 12 | 13 | main :: IO () 14 | main = hspec spec 15 | 16 | spec :: Spec 17 | spec = 18 | describe "JSON serialization" $ 19 | it "can be encoded and decoded from JSON" $ do 20 | let encodedJson = BS.unpack . prettyEncode $ toResource testObject 21 | let decodedJson = AE.decode (BS.pack encodedJson) :: Maybe (Resource TestObject) 22 | isJust decodedJson `shouldBe` True 23 | {- putStrLn encodedJson -} 24 | {- putStrLn $ show . fromJust $ decodedJson -} 25 | 26 | data TestObject = TestObject 27 | { myId :: Int 28 | , myName :: Text 29 | , myAge :: Int 30 | , myFavoriteFood :: Text 31 | } deriving (Show, Generic) 32 | 33 | instance AE.ToJSON TestObject 34 | instance AE.FromJSON TestObject 35 | 36 | instance ResourcefulEntity TestObject where 37 | resourceIdentifier = pack . show . myId 38 | resourceType _ = "TestObject" 39 | resourceLinks _ = Just myResourceLinks 40 | resourceMetaData _ = Just myResourceMetaData 41 | resourceRelationships _ = Just myRelationshipss 42 | 43 | data PaginationMetaObject = PaginationMetaObject 44 | { currentPage :: Int 45 | , totalPages :: Int 46 | } deriving (Show, Generic) 47 | 48 | instance AE.ToJSON PaginationMetaObject 49 | instance AE.FromJSON PaginationMetaObject 50 | instance MetaObject PaginationMetaObject where 51 | typeName _ = "pagination" 52 | 53 | myRelationshipss :: Relationships 54 | myRelationshipss = 55 | mkRelationships relationship <> mkRelationships otherRelationship 56 | 57 | relationship :: Relationship 58 | relationship = 59 | fromJust $ mkRelationship 60 | (Just $ Identifier "42" "FriendOfTestObject" Nothing) 61 | (Just myResourceLinks) 62 | 63 | otherRelationship :: Relationship 64 | otherRelationship = 65 | fromJust $ mkRelationship 66 | (Just $ Identifier "49" "CousinOfTestObject" Nothing) 67 | (Just myResourceLinks) 68 | 69 | myResourceLinks :: Links 70 | myResourceLinks = 71 | mkLinks [ ("self", toURL "/me") 72 | , ("related", toURL "/tacos/4") 73 | ] 74 | 75 | myResourceMetaData :: Meta 76 | myResourceMetaData = mkMeta (PaginationMetaObject 1 14) 77 | 78 | toURL :: String -> URL 79 | toURL = fromJust . importURL 80 | 81 | testObject :: TestObject 82 | testObject = TestObject 1 "Fred Armisen" 49 "Pizza" 83 | -------------------------------------------------------------------------------- /test/Network/JSONApi/SourceSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.JSONApi.SourceSpec where 2 | 3 | import qualified Data.Aeson as AE 4 | import qualified Data.ByteString.Lazy.Char8 as BS 5 | import Data.Default (def) 6 | import Data.Maybe 7 | import Network.JSONApi 8 | import Prelude hiding (id) 9 | import TestHelpers (prettyEncode) 10 | import Test.Hspec 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "Defaults" $ 18 | it "provides defaults" $ 19 | let expectedDefault = Source 20 | { pointer = Nothing 21 | , parameter = Nothing 22 | } 23 | in (def::Source) `shouldBe` expectedDefault 24 | 25 | describe "JSON serialization" $ 26 | it "provides ToJSON/FromJSON instances" $ do 27 | let testSource = def::Source 28 | let encJson = BS.unpack . prettyEncode $ testSource 29 | let decJson = AE.decode (BS.pack encJson) :: Maybe Source 30 | 31 | isJust decJson `shouldBe` True 32 | 33 | -- putStrLn encJson 34 | -- print (fromJust decJson) 35 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -------------------------------------------------------------------------------- /test/TestHelpers.hs: -------------------------------------------------------------------------------- 1 | module TestHelpers where 2 | 3 | import qualified Data.Aeson as AE 4 | import qualified Data.Aeson.Encode.Pretty as AE 5 | import qualified Data.ByteString.Lazy.Char8 as BS 6 | import Data.Maybe (fromJust) 7 | import Data.Text (Text, pack) 8 | import GHC.Generics (Generic) 9 | import Network.JSONApi 10 | import Network.URL (URL, importURL) 11 | 12 | prettyEncode :: AE.ToJSON a => a -> BS.ByteString 13 | prettyEncode = AE.encodePretty' prettyConfig 14 | 15 | prettyConfig :: AE.Config 16 | prettyConfig = AE.defConfig 17 | { AE.confIndent = AE.Spaces 2 18 | , AE.confCompare = mempty 19 | } 20 | 21 | class HasIdentifiers a where 22 | uniqueId :: a -> Int 23 | typeDescriptor :: a -> Text 24 | 25 | data TestResource = TestResource 26 | { myId :: Int 27 | , myName :: Text 28 | , myAge :: Int 29 | , myFavoriteFood :: Text 30 | } deriving (Show, Generic) 31 | 32 | instance AE.ToJSON TestResource 33 | instance AE.FromJSON TestResource 34 | instance ResourcefulEntity TestResource where 35 | resourceIdentifier = pack . show . myId 36 | resourceType _ = "testResource" 37 | resourceLinks _ = Nothing 38 | resourceMetaData _ = Nothing 39 | resourceRelationships _ = Nothing 40 | instance HasIdentifiers TestResource where 41 | uniqueId = myId 42 | typeDescriptor _ = "TestResource" 43 | 44 | data OtherTestResource = OtherTestResource 45 | { myFavoriteNumber :: Int 46 | , myJob :: Text 47 | , myPay :: Int 48 | , myEmployer :: Text 49 | } deriving (Show, Generic) 50 | 51 | instance AE.ToJSON OtherTestResource 52 | instance AE.FromJSON OtherTestResource 53 | instance ResourcefulEntity OtherTestResource where 54 | resourceIdentifier = pack . show . myFavoriteNumber 55 | resourceType _ = "otherTestResource" 56 | resourceLinks _ = Nothing 57 | resourceMetaData _ = Nothing 58 | resourceRelationships _ = Nothing 59 | instance HasIdentifiers OtherTestResource where 60 | uniqueId = myFavoriteNumber 61 | typeDescriptor _ = "OtherTestResource" 62 | 63 | data TestMetaObject = TestMetaObject 64 | { totalPages :: Int 65 | , isSuperFun :: Bool 66 | } deriving (Show, Generic) 67 | 68 | instance AE.ToJSON TestMetaObject 69 | instance AE.FromJSON TestMetaObject 70 | instance MetaObject TestMetaObject where 71 | typeName _ = "importantData" 72 | 73 | toResource' :: (HasIdentifiers a) => a 74 | -> Maybe Links 75 | -> Maybe Meta 76 | -> Resource a 77 | toResource' obj links meta = 78 | Resource 79 | (Identifier (pack . show . uniqueId $ obj) (typeDescriptor obj) meta) 80 | obj 81 | links 82 | Nothing 83 | 84 | linksObj :: Links 85 | linksObj = mkLinks [ ("self", toURL "/things/1") 86 | , ("related", toURL "http://some.domain.com/other/things/1") 87 | ] 88 | 89 | testObject :: TestResource 90 | testObject = TestResource 1 "Fred Armisen" 51 "Pizza" 91 | 92 | testObject2 :: TestResource 93 | testObject2 = TestResource 2 "Carrie Brownstein" 35 "Lunch" 94 | 95 | otherTestObject :: OtherTestResource 96 | otherTestObject = OtherTestResource 999 "Atom Smasher" 100 "Atom Smashers, Inc" 97 | 98 | testMetaObj :: Meta 99 | testMetaObj = mkMeta (TestMetaObject 3 True) 100 | 101 | emptyMeta :: Maybe Meta 102 | emptyMeta = Nothing 103 | 104 | toURL :: String -> URL 105 | toURL = fromJust . importURL 106 | 107 | emptyLinks :: Maybe Links 108 | emptyLinks = Nothing 109 | --------------------------------------------------------------------------------