├── .github └── workflows │ └── ci.yml ├── .gitignore ├── README.md ├── cabal-ghcjs.project ├── cabal.8.10.5.project ├── cabal.8.6.5.project ├── cabal.8.8.3.project ├── cabal.9.2.4.project ├── cabal.project ├── cabal.project.local ├── default.nix ├── docs ├── conf.py ├── content-serialization.rst ├── error-handling.rst ├── haskell-client.rst ├── implementation.rst ├── index.lhs ├── index.rst ├── installation.rst ├── mock.rst ├── routing.rst ├── start.rst └── webapi.png ├── reflex-platform.nix ├── stack-ghc-8.0.yaml ├── stack-ghc-8.2.yaml ├── stack-ghc-8.4.yaml ├── stack-ghc-8.6.5.yaml ├── stack-ghc-8.8.3.yaml ├── stack.yaml ├── webapi-client-reflex-dom ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── src │ └── WebApi │ │ └── Client │ │ └── Reflex.hs └── webapi-client-reflex-dom.cabal ├── webapi-contract ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── src │ └── WebApi │ │ ├── AnonClient.hs │ │ ├── ContentTypes.hs │ │ ├── Contract.hs │ │ ├── Method.hs │ │ ├── Param.hs │ │ ├── Security.hs │ │ └── Util.hs ├── tests │ ├── Param.hs │ └── Spec.hs └── webapi-contract.cabal ├── webapi-docs ├── LICENSE ├── Setup.hs ├── src │ └── WebApi │ │ ├── Docs.hs │ │ └── Schema.hs ├── stack.yaml ├── test │ └── Spec.hs └── webapi-docs.cabal ├── webapi-openapi ├── CHANGELOG.md ├── Main.hs ├── Setup.hs ├── openapi-model-generator │ └── Main.hs ├── src │ └── WebApi │ │ └── OpenAPI.hs └── webapi-openapi.cabal ├── webapi-reflex-dom ├── CHANGELOG.md ├── README.md ├── src │ ├── Reflex │ │ └── Dom │ │ │ └── Contrib │ │ │ ├── MonadRouted.hs │ │ │ ├── Router.hs │ │ │ └── Utils.hs │ └── WebApi │ │ └── Reflex │ │ ├── Dom.hs │ │ └── Dom │ │ └── Router.hs ├── test │ ├── Devel.hs │ └── Main.hs └── webapi-reflex-dom.cabal ├── webapi-swagger ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── src │ ├── Constants.hs │ ├── ContractGen.hs │ ├── ContractGenTypes.hs │ ├── GenerationCore.hs │ ├── HaskellValidation.hs │ ├── Lib.hs │ ├── SwaggerGen.hs │ └── SwaggerJSONGen.hs ├── test │ └── Main.hs └── webapi-swagger.cabal ├── webapi-xml ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── src │ ├── Lib.hs │ └── WebApi │ │ └── XML.hs ├── test │ └── Spec.hs └── webapi-xml.cabal └── webapi ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── src ├── WebApi.hs └── WebApi │ ├── Client.hs │ ├── Internal.hs │ ├── Mock.hs │ ├── Router.hs │ ├── Server.hs │ └── ServerCompact.hs ├── tests ├── Spec.hs ├── WebApi │ ├── ClientSpec.hs │ ├── MockSpec.hs │ ├── ParamSpec.hs │ ├── RequestSpec.hs │ ├── ResponseSpec.hs │ └── RouteSpec.hs └── main.hs └── webapi.cabal /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | cabal: 11 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | os: [ubuntu-latest, macOS-latest, windows-latest] 17 | cabal: ["3.2"] 18 | ghc: 19 | - "8.6.5" 20 | - "8.8.3" 21 | - "8.10.5" 22 | exclude: 23 | - os: macOS-latest 24 | ghc: 8.8.3 25 | - os: macOS-latest 26 | ghc: 8.6.5 27 | - os: windows-latest 28 | ghc: 8.8.3 29 | - os: windows-latest 30 | ghc: 8.6.5 31 | 32 | steps: 33 | - uses: actions/checkout@v2 34 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 35 | 36 | - uses: haskell/actions/setup@v1 37 | id: setup-haskell-cabal 38 | name: Setup Haskell 39 | with: 40 | ghc-version: ${{ matrix.ghc }} 41 | cabal-version: ${{ matrix.cabal }} 42 | 43 | - uses: actions/cache@v1 44 | name: Cache cabal-store 45 | with: 46 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 47 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal 48 | 49 | - name: Install Dependencies 50 | run: | 51 | cabal update 52 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=always --project-file cabal.${{ matrix.ghc }}.project --only-dependencies 53 | 54 | - name: Build 55 | run: | 56 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=always --project-file cabal.${{ matrix.ghc }}.project 57 | 58 | - name: Test 59 | run: | 60 | cabal test all --enable-tests --project-file cabal.${{ matrix.ghc }}.project 61 | 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 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 | *~ 19 | _build_html/ 20 | .ghc.environment.* 21 | *.lock 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | webapi 2 | ======== 3 | 4 | Introduction to **WebApi** 5 | -------------------------- 6 | ![CI](https://github.com/byteally/webapi/workflows/CI/badge.svg) 7 | 8 | [`Webapi`](https://hackage.haskell.org/package/webapi) is a Haskell library that lets you 9 | 10 | * Write web API services 11 | * Quickly build Haskell client for existing API services 12 | * Generate API console interface for your web API ([coming soon](https://github.com/byteally/webapi-console)) 13 | * Generate a mock server that can mock your responses and requests too. 14 | 15 | Contributions and feedback are most welcome! 16 | 17 | You can find the full documentation and examples [here](http://byteally.github.io/webapi/) 18 | -------------------------------------------------------------------------------- /cabal-ghcjs.project: -------------------------------------------------------------------------------- 1 | compiler: ghcjs 2 | packages: 3 | webapi-contract 4 | webapi-client-reflex-dom 5 | webapi-reflex-dom -------------------------------------------------------------------------------- /cabal.8.10.5.project: -------------------------------------------------------------------------------- 1 | compiler: ghc 2 | packages: 3 | webapi-contract 4 | webapi 5 | webapi-client-reflex-dom 6 | webapi-docs 7 | webapi-xml 8 | webapi-openapi 9 | 10 | with-compiler: ghc-8.10.5 11 | index-state: 2021-06-21T10:46:43Z 12 | allow-newer: bytestring-trie:binary -------------------------------------------------------------------------------- /cabal.8.6.5.project: -------------------------------------------------------------------------------- 1 | compiler: ghc 2 | packages: 3 | webapi-contract 4 | webapi 5 | webapi-client-reflex-dom 6 | -- webapi-swagger 7 | webapi-docs 8 | webapi-xml 9 | -- webapi-hedgehog 10 | -- ../hedgehog-gen 11 | 12 | -- /tmp/bytestring-trie 13 | -------------------------------------------------------------------------------- /cabal.8.8.3.project: -------------------------------------------------------------------------------- 1 | compiler: ghc 2 | packages: 3 | webapi-contract 4 | webapi 5 | webapi-client-reflex-dom 6 | -- webapi-swagger 7 | webapi-docs 8 | webapi-xml 9 | -- webapi-hedgehog 10 | -- ../hedgehog-gen 11 | 12 | -- /tmp/bytestring-trie 13 | 14 | allow-newer: reflex-dom-core:base, reflex-dom-core:primitive 15 | constraints: primitive >= 0.7.0.1 16 | 17 | 18 | with-compiler: ghc-8.8.3 19 | index-state: 2021-06-21T10:46:43Z 20 | -------------------------------------------------------------------------------- /cabal.9.2.4.project: -------------------------------------------------------------------------------- 1 | compiler: ghc 2 | packages: 3 | webapi-contract 4 | webapi 5 | -- webapi-client-reflex-dom 6 | webapi-docs 7 | webapi-xml 8 | webapi-openapi 9 | 10 | with-compiler: ghc-9.2.4 11 | index-state: 2022-08-09T04:58:03Z 12 | allow-newer: bytestring-trie:binary -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | compiler: ghc 2 | packages: 3 | webapi-contract 4 | webapi 5 | webapi-client-reflex-dom 6 | webapi-swagger 7 | webapi-docs 8 | webapi-xml 9 | webapi-openapi 10 | webapi-reflex-dom 11 | -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/byteally/webapi/68166dc75652d30e0891219ece2dfbbb486fd808/cabal.project.local -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ./reflex-platform.nix).project ({ pkgs, ... }: { 2 | packages = { 3 | webapi = ./webapi; 4 | webapi-contract = ./webapi-contract; 5 | webapi-client-reflex-dom = ./webapi-client-reflex-dom; 6 | webapi-swagger = ./webapi-swagger; 7 | webapi-docs = ./webapi-docs; 8 | bytestring-trie = ((pkgs.fetchFromGitHub { 9 | owner = "capital-match"; 10 | repo = "bytestring-trie"; 11 | rev = "47526b2ec810239fe824c03c13cf1d81f0741b5c"; 12 | sha256 = "1m4ywdh2wh0l8f7w7q7k4p0icsx5slcpjgnv3biylz1yvzb1y42q"; 13 | })); 14 | 15 | }; 16 | 17 | overrides = self : super : { 18 | bytestring-lexing = pkgs.haskell.lib.dontCheck super.bytestring-lexing; 19 | http-media = pkgs.haskell.lib.dontCheck super.http-media; 20 | Glob = pkgs.haskell.lib.dontCheck super.Glob; 21 | multiset = pkgs.haskell.lib.dontCheck super.multiset; 22 | }; 23 | 24 | shells = { 25 | ghc = ["webapi" 26 | "webapi-contract" 27 | "webapi-client-reflex-dom" 28 | "webapi-swagger" 29 | "webapi-docs" 30 | ]; 31 | ghcjs = ["webapi-contract" 32 | "webapi-client-reflex-dom" 33 | ]; 34 | }; 35 | 36 | }) 37 | -------------------------------------------------------------------------------- /docs/content-serialization.rst: -------------------------------------------------------------------------------- 1 | Content Serialization / Deserialization 2 | ======================================= 3 | 4 | In WebApi_, :code:`ToParam` and :code:`FromParam` are the typeclasses responsible for serializing and deserializing data. Serialization and deserialization for your data types are automatically take care of if they have generic instances without you having to write anything. You still have to derive them though. 5 | 6 | Lets look at an example :: 7 | 8 | data LatLng = LatLng 9 | { lat :: Double 10 | , lng :: Double 11 | } deriving Generic 12 | 13 | To let WebApi_ automatically deserialize this type, we just need to give 14 | an empty instance declaration :: 15 | 16 | instance FromParam 'QueryParam LatLng 17 | 18 | And to serialize a type (in case you are writing a client), you can give 19 | a similar :code:`ToParam` instance. :: 20 | 21 | instance ToParam 'QueryParam LatLng 22 | 23 | Nested Types 24 | ------------ 25 | 26 | If you use :code:`Generic` instance for nested types, they will be serialized with a dot notation. :: 27 | 28 | data UserData = UserData 29 | { age :: Int 30 | , address :: Text 31 | , name :: Text 32 | , location :: LatLng 33 | } deriving (Show, Eq, Generic) 34 | 35 | Here the location field would be serialized as 36 | :code:`location.lat` and :code:`location.lng` 37 | 38 | Writing Custom instances 39 | ------------------------ 40 | 41 | Sometimes you may want to serialize/deserialize the data to a custom format. 42 | You can easily do this by writing a custom instance of :code:`ToParam` and 43 | :code:`FromParam`. Lets declare a datatype and try to write :code:`ToParam` and 44 | :code:`FromParam` instances for those. :: 45 | 46 | data Location = Location { loc :: LatLng } deriving Generic 47 | 48 | data LatLng = LatLng 49 | { lat :: Double 50 | , lng :: Double 51 | } deriving Generic 52 | 53 | Lets say we want to deserialize query parameter :code:`loc=10,20` to 54 | :code:`Location` where :code:`10` and :code:`20` are values of :code:`lat` and 55 | :code:`lng` respectively. We can write a :code:`FromParam` instance for this as 56 | follows: :: 57 | 58 | instance FromParam 'QueryParam Location where 59 | fromParam pt key trie = case lookupParam pt key trie of 60 | Just (Just par) -> case splitOnComma par of 61 | Just (lt, lg) -> case (LatLng <$> decodeParam lt <*> decodeParam lg) of 62 | Just ll -> Validation $ Right (Location ll) 63 | _ -> Validation $ Left [ParseErr key "Unable to cast to LatLng"] 64 | Nothing -> Validation $ Left [ParseErr key "Unable to cast to LatLng"] 65 | Just Nothing -> Validation $ Left [ParseErr key "Value not found"] 66 | _ -> Validation $ Left [NotFound key] 67 | where 68 | splitOnComma :: ByteString -> Maybe (ByteString, ByteString) 69 | splitOnComma x = 70 | let (a, b) = C.break (== ',') x -- Data.ByteString.Char8 imported as C 71 | in if (BS.null a) || (BS.null b) -- Data.ByteString imported as BS 72 | then Nothing 73 | else Just (a, b) 74 | 75 | :code:`fromParam` takes a :code:`Proxy` of our type (here, :code:`Location`), 76 | a key (:code:`ByteString`) and a :code:`Trie`. 77 | :code:`WebApi` uses :code:`Trie` to store the parsed data while deserialization. 78 | :code:`fromParam` returns a value of type :code:`Validation` which is a wrapper 79 | over :code:`Either` type carrying the parsed result. 80 | 81 | We use :code:`lookupParam` function for looking up the key (:code:`loc`). 82 | If the key matches, it'll return :code:`Just` with the value of the key (in our case :code:`10,20`). 83 | Now we split this value into a tuple using :code:`splitOnComma` and make a value 84 | of type :code:`LatLng` using these. 85 | 86 | Similarly, a :code:`ToParam` instance for :code:`Location` can be written as: :: 87 | 88 | instance ToParam 'QueryParam Location where 89 | toParam pt pfx (Location (LatLng lt lg)) = [("loc", Just $ encodeParam lt <> "," <> encodeParam lg)] 90 | 91 | Here we take a value of type :code:`Location` and convert it into a key-value pair. 92 | :code:`WebApi` uses this key-value pair to form the query string. 93 | 94 | This example only included :code:`QueryParam` but this can be easily extended to 95 | other param types. 96 | 97 | Content Types 98 | ------------- 99 | 100 | You can tell WebApi_ about the content-type of :code:`ApiOut/ApiErr` using 101 | :code:`ContentTypes`. :: 102 | 103 | instance ApiContract MyApiService POST User where 104 | type FormParam POST User = UserData 105 | type ApiOut POST User = UserToken 106 | type ContentTypes POST User = '[JSON] 107 | 108 | By default :code:`ContentTypes` is set to :code:`JSON`. That means you need to 109 | give :code:`ToJSON` instances for the types associated with :code:`ApiOut/ApiErr` 110 | while writing server side component and :code:`FromJSON` instances while writing 111 | client side version. 112 | 113 | Apart from :code:`JSON` you can give other types such as :code:`HTML`, :code:`PlainText` 114 | etc. You can see a complete list :wahackage:`here` 115 | 116 | .. _WebApi: https://hackage.haskell.org/package/webapi 117 | -------------------------------------------------------------------------------- /docs/error-handling.rst: -------------------------------------------------------------------------------- 1 | Error Handling 2 | ============== 3 | 4 | WebApi_ gives you a way to raise errors in your handler using :code:`raise`. 5 | The following handler is an example that raises a 404 error 6 | 7 | :: 8 | 9 | instance ApiHandler MyApiImpl GET User where 10 | handler _ req = do 11 | hasUser <- isUserInDB 12 | if (hasUser) 13 | then respond (UserToken "Foo" "Bar") 14 | else raise status404 () 15 | 16 | :code:`raise` takes two arguments. First one is the status code which we need to 17 | send with the :code:`Response`. Second argument is of type :code:`ApiErr m r` 18 | which defaults to Unit :code:`()`. 19 | 20 | If you want to send some additional information with your error response, you can write a data type for error and specify that as :code:`ApiErr` in your contract. 21 | 22 | An example, :: 23 | 24 | data Error = Error { error :: Text } deriving (Show, Generic) 25 | instance ToJSON Error 26 | instance ParamErrToApiErr Error where 27 | toApiErr errs = Error (toApiErr errs) 28 | 29 | instance ApiContract MyApiService POST User where 30 | type FormParam POST User = UserData 31 | type ApiOut POST User = UserToken 32 | type ApiErr POST User = Error 33 | 34 | 35 | Any type which you associate with :code:`ApiErr`, should have a :code:`ParamErrToApiErr` 36 | instance. This is needed for :code:`WebApi` to map all the failures to this type. 37 | Also based on :code:`ContentType` set in the contract (which defaults to :code:`JSON`), 38 | we need to give the required instance. In this case it is :code:`ToJSON`. 39 | 40 | .. _WebApi: https://hackage.haskell.org/package/webapi 41 | -------------------------------------------------------------------------------- /docs/haskell-client.rst: -------------------------------------------------------------------------------- 1 | Building haskell client for third-party API 2 | =================================== 3 | 4 | 5 | WebApi_ framework could be used to build haskell clients for existing API services. All you have to do is 6 | 7 | * Define the routes (as types) 8 | * Write the **contract** for the API service. 9 | 10 | 11 | To demonstrate, we've chosen `Uber API `_ as the third party API service and picked the two most commonly used endpoints in Uber API 12 | 13 | * `get time estimate `_ - Gets the time estimate for nearby rides 14 | 15 | * `request a ride `_ - Lets us request a ride. 16 | 17 | Since we have already discussed what a **contract** is under the :doc:`start` section in detail we can jump straight to our example. 18 | 19 | 20 | 21 | Lets first define the type for the API service, call it :code:`UberApi` and types for our routes. (`get time estimate `_ and `request a ride `_ ). 22 | 23 | :: 24 | 25 | data UberApi 26 | 27 | -- pieces of a route are seperated using ':/' 28 | type TimeEstimateR = "estimates" :/ "time" 29 | -- If the route has only one piece, we use 'Static' constructor to build it. 30 | type RequestRideR = Static "requests" 31 | 32 | 33 | 34 | Now lets define what methods (GET, POST etc.) can be used on these routes. For this we need to define :wahackage:`WebApi ` instance for our service :code:`UberApi` . 35 | 36 | :: 37 | 38 | instance WebApi UberApi where 39 | type Apis UberApi = 40 | '[ Route '[GET] TimeEstimateR 41 | , Route '[POST] RequestRideR 42 | ] 43 | 44 | 45 | So far, we have defined the routes and the methods associated with them. We are yet to define how the requests and responses will look for these two end-points (**contract**). 46 | 47 | We'll start with the :code:`TimeEstimateR` route. As defined in the Uber API `doc `_ , :code:`GET` request for :code:`TimeEstimateR` takes the user's current latitude, longitude, product_id (if any) as query parameters and return back a result containig a list of :code:`TimeEstimate` (rides nearby along with time estimates). And this is how we represent the query and the response as data types. 48 | 49 | :: 50 | 51 | -- query data type 52 | data TimeParams = TimeParams 53 | { start_latitude :: Double 54 | , start_longitude :: Double 55 | , product_id :: Maybe Text 56 | } deriving (Generic) 57 | 58 | -- response data type 59 | newtype Times = Times { times :: [TimeEstimate] } 60 | deriving (Show, Generic) 61 | 62 | -- We prefix each field with 't_' to prevent name clashes. 63 | -- It will be removed during deserialization 64 | data TimeEstimate = TimeEstimate 65 | { t_product_id :: Text 66 | , t_display_name :: Text 67 | , t_estimate :: Int 68 | } deriving (Show, Generic) 69 | 70 | 71 | instance ApiContract UberApi GET TimeEstimateR where 72 | type HeaderIn GET TimeEstimateR = Token 73 | type QueryParam GET TimeEstimateR = TimeParams 74 | type ApiOut GET TimeEstimateR = Times 75 | 76 | 77 | As request to Uber API requires an Authorization header, we include that in our contract for each route. The data type `Token `_ used in the header is defined `here `_ 78 | 79 | There is still one piece missing though. Serialization/ de-serialization of request/response data types. To do that, we need to give `FromJSON `_ instance for our response and :wahackage:`ToParam ` instance for the query param datatype. 80 | 81 | :: 82 | 83 | instance ToParam 'QueryParam TimeParams 84 | instance FromJSON Times 85 | instance FromJSON TimeEstimate where 86 | parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } 87 | 88 | 89 | Similarly we can write contract for the other routes too. You can find the full contract `here `_ . 90 | 91 | And that's it! By simply defining a contract we have built a Haskell client for Uber API. The code below shows how to make the API calls. 92 | 93 | :: 94 | 95 | -- To get the time estimates, we can write our main function as: 96 | main :: IO () 97 | main = do 98 | manager <- newManager tlsManagerSettings 99 | let timeQuery = TimeParams 12.9760 80.2212 Nothing 100 | cSettings = ClientSettings "https://sandbox-api.uber.com/v1" manager 101 | auth' = OAuthToken "" 102 | auth = OAuth auth' 103 | 104 | times' <- client cSettings (Request () timeQuery () () auth () () :: WebApi.Request GET TimeEstimateR) 105 | -- remaining main code 106 | 107 | 108 | We use :wahackage:`client` function to send the request. It takes :wahackage:`ClientSettings ` and :wahackage:`Request ` as input and gives us the :wahackage:`Response ` . If you see the :wahackage:`Request ` pattern synonym, we need to give it all the params, headers etc. to construct a :wahackage:`Request ` . So for a particular route, the params which we declare in the contract are filled with the declared datatypes and the rest defaults to :code:`()` **unit** 109 | 110 | When the endpoint gives a response back, WebApi_ deserializes it into :wahackage:`Response ` . Lets write a function to handle the response. 111 | 112 | :: 113 | 114 | let responseHandler res fn = case res of 115 | Success _ res' _ _ -> fn res' 116 | Failure err -> print "Request failed :(" 117 | 118 | We have successfully made a request and now can handle the response with :code:`responseHandler`. If the previous request (to get time estimate) was succesful, lets book the nearest ride with our second route. 119 | 120 | :: 121 | 122 | responseHandler times' $ \times -> do 123 | let rideId = getNearestRideId times 124 | reqQuery = defRideReqParams { product_id = Just rideId, start_place_id = Just "work", end_place_d = Just "home" } 125 | ridereq = client cSettings (Request () () () () auth' () reqQuery :: WebApi.Request POST RequestRideR) 126 | rideInfo' <- ridereq 127 | responseHandler rideInfo' $ \rideInfo -> do 128 | putStrLn "You have successfully booked a ride. Yay!" 129 | putStrLn $ "Ride Status: " ++ unpack (status rideInfo) 130 | return () 131 | where 132 | getNearestRideId (Times xs) = t_product_id . head . sortBy (comparing t_estimate) $ xs 133 | 134 | 135 | And that's it! We now have our haskell client. Using the same contract you can also generate a mock server 136 | 137 | You can find the full uber client library for haskell `here `_ . 138 | 139 | .. _UberApi : https://developer.uber.com/docs/api-overview 140 | .. _WebApi : https://hackage.haskell.org/package/webapi 141 | -------------------------------------------------------------------------------- /docs/implementation.rst: -------------------------------------------------------------------------------- 1 | 2 | Server implementation 3 | ============== 4 | 5 | An :wahackage:`ApiContract ` is just a schematic representation of your API service. We still need to implement our handlers that actually does the work. You would have already read about this in the :doc:`start` section. 6 | 7 | Implementation of a contract consists of 8 | 9 | * Writing a :wahackage:`WebApiServer ` instance. 10 | * Writing :wahackage:`ApiHandler ` instances for all your end-points. 11 | 12 | Writing WebApiServer instance 13 | ------------------------------------- 14 | The :code:`WebApiServer` typeclass has 15 | 16 | - Two associated types 17 | - **HandlerM** - It is the type of monad in which our handler should run (defaults to :code:`IO`). 18 | This monad should implement :code:`MonadCatch` and :code:`MonadIO` classes. 19 | 20 | - **ApiInterface** - :code:`ApiInterface` links the implementation with the contract. This lets us have 21 | multiple implementations for the same contract 22 | 23 | - One method 24 | - **toIO** - It is a method which is used to convert our handler monad's action to :code:`IO`. 25 | (defaults to :code:`id`) 26 | 27 | Let's define a type for our implementation and write a :code:`WebApiServer` instance for the same. 28 | 29 | :: 30 | 31 | data MyApiServiceImpl = MyApiServiceImpl 32 | 33 | instance WebApiServer MyApiServiceImpl where 34 | type HandlerM MyApiServiceImpl = IO 35 | type ApiInterface MyApiServiceImpl = MyApiService 36 | toIO _ = id 37 | 38 | 39 | 40 | .. note:: You can skip writing :code:`HandlerM`'s and :code:`toIO`'s definitions if 41 | you want your :code:`HandlerM` to be :code:`IO`. 42 | 43 | Writing instances for your handlers 44 | ------------------------------------ 45 | 46 | Now we can write handler for our :code:`User` route as :: 47 | 48 | instance ApiHandler MyApiServiceImpl POST User where 49 | handler _ req = do 50 | let _userInfo = formParam req 51 | respond (UserToken "Foo" "Bar") 52 | 53 | :code:`handler` returns a :code:`Response`. Here we used :code:`respond` to 54 | build a :code:`Success` :wahackage:`Response`. 55 | You can use its counter-part :code:`raise` as discussed in :doc:`error-handling` 56 | to send :code:`Failure` :wahackage:`Response` 57 | 58 | Doing more with your handler monad 59 | ---------------------------------- 60 | 61 | Though the above implementation can get you started, it falls short for many 62 | practical scenarios. We'll discuss some of them in the following sections. 63 | 64 | Adding a config Reader 65 | ~~~~~~~~~~~~~~~~~~~~~~ 66 | 67 | Most of the times our app would need some kind of initial setting which could 68 | come from a config file or some environment variables. To accomodate for that, we 69 | can change :code:`MyApiServiceImpl` to :: 70 | 71 | data AppSettings = AppSettings 72 | 73 | data MyApiServiceImpl = MyApiServiceImpl AppSettings 74 | 75 | Just adding :code:`AppSettings` to our :code:`MyApiServiceImpl` is useless unless our 76 | monad gives a way to access those settings. So we need a monad in which we can 77 | read these settings, anytime we require. A :code:`ReaderT` transformer would fit 78 | perfectly for this scenario. 79 | 80 | For those who are not familiar with :code:`Reader` monad, it is a monad 81 | which gives you read only access to some data(say, settings) throughout a computation. 82 | You can access that data in your monad using :code:`ask`. :code:`ReaderT` is a 83 | monad transformer which adds capabilities of :code:`Reader` monad on top of 84 | another monad. In our case, we'll add reading capabilities to :code:`IO`. So the 85 | monad for our handler would look something like :: 86 | 87 | newtype MyApiMonad a = MyApiMonad (ReaderT AppSettings IO a) 88 | deriving (Monad, MonadIO, MonadCatch) 89 | 90 | Note: :code:`HandlerM` is required to have :code:`MonadIO` and :code:`MonadCatch` 91 | instances. Thats why you see them in the :code:`deriving` clause. 92 | 93 | There is still one more piece left, before we can use this. We need to define 94 | :code:`toIO` function to convert :code:`MyApiMonad`'s actions to :code:`IO`. 95 | We can use `runReaderT `_ to pass the initial :code:`Reader`'s environment settings 96 | and execute the computation in the underlying monad(IO in this case). :: 97 | 98 | toIO (MyApiServiceImpl settings) (MyApiMonad r) = runReaderT r settings 99 | 100 | So the :code:`WebApiServer` instance for our modified :code:`MyApiServiceImpl` 101 | would look like: :: 102 | 103 | instance WebApiServer MyApiServiceImpl where 104 | type HandlerM MyApiServiceImpl = MyApiMonad 105 | type ApiInterface MyApiServiceImpl = MyAppService 106 | toIO (MyApiServiceImpl settings) (MyApiMonad r) = runReaderT r settings 107 | 108 | A sample :code:`ApiHandler` for this would be something like: :: 109 | 110 | instance ApiHandler MyApiServiceImpl POST User where 111 | handler _ req = do 112 | settings <- ask 113 | -- do something with settings 114 | respond (UserToken "Foo" "Bar") 115 | 116 | .. _implementation: 117 | 118 | Adding a logger 119 | ~~~~~~~~~~~~~~~ 120 | 121 | Adding a logging system to our implementation is similar to adding a :code:`Reader`. 122 | We use :code:`LoggingT` transformer to achieve that. :: 123 | 124 | newtype MyApiMonad a = MyApiMonad (LoggingT (ReaderT AppSettings IO) a) 125 | deriving (Monad, MonadIO, MonadCatch, MonadLogger) 126 | 127 | instance WebApiServer MyApiServiceImpl where 128 | type HandlerM MyApiServiceImpl = MyApiMonad 129 | type ApiInterface MyApiServiceImpl = MyAppService 130 | toIO (MyApiServiceImpl settings) (MyApiMonad r) = runReaderT (runStdoutLoggingT r) settings 131 | -------------------------------------------------------------------------------- /docs/index.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE DataKinds, TypeFamilies, MultiParamTypeClasses, TypeOperators, 2 | > TypeSynonymInstances, FlexibleInstances, OverloadedStrings, DeriveGeneric #-} 3 | > import WebApi 4 | > import Data.Aeson 5 | > import Data.Text 6 | > import GHC.Generics 7 | > import Network.Wai.Handler.Warp (run) 8 | > import qualified Network.Wai as Wai 9 | 10 | 11 | Introduction to **WebApi** 12 | ========================== 13 | 14 | [`Webapi`](https://hackage.haskell.org/package/webapi) is a Haskell library that lets you 15 | 16 | * Write web API services 17 | * Quickly build Haskell client for existing API services 18 | * Generate API console interface for your web API ([coming soon](https://github.com/byteally/webapi-console)) 19 | * Generate a mock server that can mock your responses and requests too. 20 | 21 | [`Webapi`](https://hackage.haskell.org/package/webapi) is built with [`WAI`](https://hackage.haskell.org/package/wai/docs/Network-Wai.html). It makes use of the strong type system of haskell which lets to 22 | 23 | * Create a type safe routing system. 24 | * Enable type safe generation of links. 25 | * Specify a contract for the APIs. 26 | * Auto serialization and deserialization of the request and response based on api contract. 27 | * Write handlers which respect the contract. 28 | 29 | Installation 30 | ------------ 31 | 32 | We recommend using [stack](https://github.com/commercialhaskell/stack#readme) build tool for installation and building. If you don't have [stack](https://github.com/commercialhaskell/stack#readme) already, follow [these](http://docs.haskellstack.org/en/stable/install_and_upgrade/) instructions to install it. To setup your own project: 33 | 34 | * Create a project: `stack new ` 35 | 36 | * Add *webapi* to the *extra-deps* section in `stack.yaml` file: 37 | 38 | ``` 39 | 40 | extra-deps: 41 | - webapi-0.2.2.0 42 | 43 | ``` 44 | Also add *webapi* to the `build-depends` section of your *cabal* file. 45 | 46 | ``` 47 | 48 | build-depends: webapi 49 | 50 | ``` 51 | 52 | You can find the whole source code for this post in literate haskell [here](https://github.com/byteally/webapi/blob/master/docs/index.lhs). You can fire up `ghci` by running `stack exec ghci` and load this file with: `:l index.lhs` command. 53 | 54 | A First taste of WebApi 55 | ----------------------- 56 | 57 | Writing your web API service comprises of two steps 58 | 59 | * Writing a contract (definition below) 60 | * Providing an implementation 61 | 62 | Contract 63 | -------- 64 | A contract is the list of end-points in your API service and the definition of each API endpoint. 65 | We define what goes in (Eg Query params, form params) and what comes out (the response) of each API endpoint. 66 | 67 | As an example, consider a web API service that lets you do create, update, delete and fetch users. First step is to create a datatype for our service. Lets call it `MyApiService` 68 | 69 | To define your contract using the framework, you need to 70 | 71 | * Declare a data type for your API service. 72 | 73 | ```haskell 74 | 75 | > data MyApiService 76 | 77 | ``` 78 | 79 | * List down the routes of your API service. 80 | 81 | ```haskell 82 | 83 | > type User = Static "user" 84 | > type UserId = "user":/Int 85 | 86 | ``` 87 | 88 | * Write a [`WebApi`]($webapi-url$/docs/WebApi-Contract.html#t:WebApi) instance which declares the endpoints. 89 | 90 | ```haskell 91 | 92 | > instance WebApi MyApiService where 93 | > -- Route 94 | > type Apis MyApiService = '[ Route '[GET, POST] User 95 | > , Route '[GET, PUT, DELETE] UserId 96 | > ] 97 | 98 | ``` 99 | 100 | * Write [`ApiContract`]($webapi-url$/docs/WebApi-Contract.html#t:ApiContract) instances describing what goes in and what comes out from each API endpoint. 101 | 102 | In the following code snippet, the first instance declares that the `POST` method on route `/user` takes `UserData` as form parameters and responds with nothing (`()`). 103 | 104 | An equivalent curl syntax would be: `curl -H "Content-Type: application/x-www-form-urlencoded" -d 'age=12&address=Velachery&name=Bhishag' ` 105 | 106 | ```haskell 107 | 108 | > -- Takes a User type in form params and returns unit. 109 | > instance ApiContract MyApiService POST User where 110 | > type FormParam POST User = UserData 111 | > type ApiOut POST User = () 112 | > 113 | > -- Takes a User type in form params and returns updated users. 114 | > instance ApiContract MyApiService PUT UserId where 115 | > type FormParam PUT UserId = UserData 116 | > type ApiOut PUT UserId = [UserData] 117 | > 118 | > -- Removes the specified user and returns unit. 119 | > instance ApiContract MyApiService DELETE UserId where 120 | > type ApiOut DELETE UserId = () 121 | > 122 | > -- Gets a specific user 123 | > instance ApiContract MyApiService GET UserId where 124 | > type ApiOut GET UserId = UserData 125 | > 126 | > -- Gets all users 127 | > instance ApiContract MyApiService GET User where 128 | > type ApiOut GET User = [UserData] 129 | > 130 | > -- Our user type 131 | > data UserData = UserData { age :: Int 132 | > , address :: Text 133 | > , name :: Text 134 | > , userId :: Maybe Int 135 | > } deriving (Show, Eq, Generic) 136 | 137 | ``` 138 | 139 | We also have to define instances for json and param serialization & deserialization for `UserData` type. A definition needn't be provided since [`GHC.Generics`](https://hackage.haskell.org/package/base/docs/GHC-Generics.html) provides a generic implementation. 140 | 141 | ```haskell 142 | 143 | > 144 | > instance FromJSON UserData 145 | > instance ToJSON UserData 146 | > 147 | > instance FromParam UserData 'FormParam 148 | 149 | ``` 150 | 151 | This completes the contract part of the API. 152 | 153 | Implementation 154 | -------------- 155 | 156 | First step is to create a type for the implementation and define [`WebApiImplementation`]($webapi-url$/docs/WebApi-Server.html#t:WebApiImplementation) instance for it. 157 | 158 | ```haskell 159 | 160 | > data MyApiServiceImpl = MyApiServiceImpl 161 | > 162 | > instance WebApiImplementation MyApiServiceImpl where 163 | > type HandlerM MyApiServiceImpl = IO 164 | > type ApiInterface MyApiServiceImpl = MyApiService 165 | 166 | ``` 167 | 168 | [`HandlerM`](http://hackage.haskell.org/package/webapi-0.1.0.0/candidate/docs/WebApi-Server.html#t:HandlerM) is the base monad in which the [`handler`]($webapi-url$/docs/WebApi-Server.html#v:handler) will run. We also state that `MyApiServiceImpl` is an implementation of the [`ApiInterface`]($webapi-url$/docs/WebApi-Server.html#t:ApiInterface) provided by `MyApiServiceApi`. 169 | 170 | Now let's create the [`ApiHandler`]($webapi-url$/docs/WebApi-Server.html#t:ApiHandler)s 171 | 172 | ```haskell 173 | 174 | > instance ApiHandler MyApiServiceImpl POST User where 175 | > handler _ req = do 176 | > let _userInfo = formParam req 177 | > respond () 178 | > 179 | > instance ApiHandler MyApiServiceImpl GET User where 180 | > handler _ _ = do 181 | > let users = [] 182 | > respond users 183 | > 184 | > instance ApiHandler MyApiServiceImpl PUT UserId where 185 | > handler _ req = do 186 | > let userInfo = formParam req 187 | > respond [userInfo] 188 | > 189 | > instance ApiHandler MyApiServiceImpl DELETE UserId where 190 | > handler _ req = do 191 | > let _userID = pathParam req 192 | > respond () 193 | > 194 | > instance ApiHandler MyApiServiceImpl GET UserId where 195 | > handler _ req = do 196 | > let userID = pathParam req 197 | > userInfo = UserData 10 "Address" "Name" (Just userID) 198 | > respond userInfo 199 | 200 | ``` 201 | By keeping the implementation separate from the contract, it is possible for a contract to have multiple implementations. 202 | Hypothetically, there could be a websocket implementation as well as a ReST implementation for a single contract. 203 | 204 | The last thing that is left is to create a [`WAI`](https://hackage.haskell.org/package/wai/docs/Network-Wai.html) application from all the aforementioned information. For that we use [`serverApp`]($webapi-url$/docs/WebApi-Server.html#v:serverApp). 205 | 206 | ```haskell 207 | 208 | > myApiApp :: Wai.Application 209 | > myApiApp = serverApp serverSettings MyApiServiceImpl 210 | > 211 | > main :: IO () 212 | > main = run 8000 myApiApp 213 | > 214 | 215 | ``` 216 | 217 | That's it - now `myApiApp` could be run like any other [`WAI`](https://hackage.haskell.org/package/wai/docs/Network-Wai.html) application. 218 | -------------------------------------------------------------------------------- /docs/index.rst: -------------------------------------------------------------------------------- 1 | **Introduction** 2 | ================ 3 | 4 | .. image:: webapi.png 5 | :width: 170px 6 | :height: 48px 7 | :scale: 100 % 8 | :alt: webapi 9 | 10 | .. |webapi-uri| replace:: https://hackage.haskell.org/package/webapi-0.2.2.0/docs/ 11 | 12 | 13 | 14 | `WebApi `_ is a Haskell library that lets you 15 | 16 | * Write web API services 17 | * Quickly build Haskell client for existing API services 18 | * Generate API console interface for your web API (`coming soon `_) 19 | * Generate a mock server that can mock your responses and requests 20 | 21 | `WebApi `_ is built with `WAI `_. It makes use of the strong type system of haskell which lets to 22 | 23 | * Create a type safe routing system. 24 | * Enable type safe generation of links. 25 | * Specify a contract for the APIs. 26 | * Auto serialization and deserialization of the request and response based on api contract. 27 | * Write handlers which respect the contract. 28 | 29 | 30 | .. toctree:: 31 | :caption: Contents: 32 | :maxdepth: 2 33 | :numbered: 34 | 35 | self 36 | installation 37 | start 38 | routing 39 | implementation 40 | content-serialization 41 | error-handling 42 | haskell-client 43 | mock 44 | 45 | 46 | -------------------------------------------------------------------------------- /docs/installation.rst: -------------------------------------------------------------------------------- 1 | **Installation** 2 | ================ 3 | We recommend using `stack `_ build tool for installation and building. If you don't have `stack `_ already, follow `these `_ instructions to install it. To setup your own project: 4 | 5 | 1) Create a project using stack: 6 | :: 7 | 8 | stack new 9 | 10 | 2) Then add :code:`webapi` to the :code:`extra-deps` section in **stack.yaml** file: 11 | :: 12 | 13 | extra-deps: 14 | - webapi-0.3 15 | 16 | 3) Finally add :code:`webapi` to the :code:`build-depends` section of your **cabal** file. 17 | :: 18 | 19 | build-depends: webapi 20 | -------------------------------------------------------------------------------- /docs/mock.rst: -------------------------------------------------------------------------------- 1 | Mocking Data 2 | ============ 3 | 4 | Writing a contract enables you to create a mock server or a client by just 5 | writing the :code:`Arbitrary` instances for datatypes used in the contract. 6 | 7 | Lets create a mock server for the contract mentioned in :doc:`start` by writing arbitrary instances for our datatypes. :: 8 | 9 | instance Arbitrary UserData where 10 | arbitrary = UserData <$> arbitrary 11 | <*> arbitrary 12 | <*> arbitrary 13 | 14 | instance Arbitrary UserToken where 15 | arbitrary = UserToken <$> arbitrary 16 | <*> arbitrary 17 | instance Arbitrary Text where 18 | arbitrary = elements ["Foo", "Bar", "Baz"] 19 | 20 | Now we can create a :code:`Wai.Application` for our mock server as :: 21 | 22 | mockApp :: Wai.Application 23 | mockApp = mockServer serverSettings (MockServer mockServerSettings :: MockServer MyApiService) 24 | 25 | :code:`mockServer` takes :code:`ServerSettings` and :code:`MockServer` as arguments. 26 | :code:`MockServer` lets you decide what kind of mock data is to be returned 27 | (:code:`ApiOut`, :code:`ApiError` or :code:`OtherError`). It returns :code:`ApiOut` 28 | (:code:`SuccessData`) by default. 29 | 30 | Now you can run this :code:`Wai.Application` on some port to bring up your mock 31 | server. :: 32 | 33 | main :: IO () 34 | main = run 8000 mockApp 35 | 36 | You can even mock the requests. To create a mock :code:`Request` 37 | for route :code:`User` declared in :doc:`start`, we can write: :: 38 | 39 | req <- mockClient (Res :: Resource GET User) 40 | 41 | We can use this :code:`req` while calling :code:`client` function to make a 42 | :code:`Request`. 43 | -------------------------------------------------------------------------------- /docs/routing.rst: -------------------------------------------------------------------------------- 1 | **Routing** 2 | ================ 3 | 4 | WebApi_ supports the following HTTP verbs 5 | **GET**, **POST**, **PUT**, **DELETE**, **PATCH**, **HEAD** 6 | 7 | You can also use any :wahackage:`Custom ` method as per your needs. 8 | 9 | In WebApi_ we need to first write all the routes as types and then declare the valid HTTP verbs for each route type. 10 | 11 | Routes as types 12 | --------------- 13 | Each route is declared as a type. For demo purposes let's consider a API service that would allow you to create and get users. We need two URIs. One to create a user and another one to get the user by her ID. 14 | 15 | :code:`/user` **URI to create a user** 16 | :: 17 | 18 | type User = Static "user" 19 | 20 | 21 | :code:`/user/9` **URI to get a user** 22 | :: 23 | 24 | type UserId = "user" :/ Int 25 | 26 | 27 | * Note that :code:`/user` is declared as :code:`Static "user"` to wrap **user** in :code:`Static` to make all the types of the same **kind** **(*)** 28 | 29 | As you could see in the above examples, routes are defined as types. The next step is to write a :doc:`WebApi ` instance for the route types along with the HTTP verbs they support. 30 | 31 | :: 32 | 33 | instance WebApi MyApiService where 34 | -- Route 35 | type Apis MyApiService = '[ Route '[POST] User 36 | , Route '[GET, PUT, DELETE] UserId 37 | ] 38 | 39 | 40 | In the above code snippet, we are declaring that our route type 41 | 42 | * :code:`User` ie (:code:`/user`) accepts :code:`POST` 43 | * :code:`UserId` accepts :code:`GET`, :code:`PUT`, :code:`DELETE`. 44 | 45 | - Let's say the user Id is 9, then :code:`GET /user/9` could be used to get the user, :code:`PUT /user/9` to edit the user and :code:`DELETE user/9` to delete the user. 46 | 47 | More examples 48 | ------------- 49 | 50 | :code:`/post/tech/why-i-like-web-api` 51 | :: 52 | 53 | type Post = "post" :/ Text :/ Text 54 | 55 | :code:`/post/tech/why-i-like-web-api/edit` 56 | :: 57 | 58 | 59 | type EditPost = "post" :/ Text :/ Text :/ "edit" 60 | 61 | :code:`/why-i-like-web-api/comments` 62 | :: 63 | 64 | 65 | type Comments = Text :/ "comments" 66 | 67 | .. note:: Please note that when two route format overlaps, for example :code:`user/posts` and :code:`user/brian` WebApi's routing system would take the first route that is declared first in the :code:`WebApi` instance. 68 | 69 | .. _WebApi : https://hackage.haskell.org/package/webapi 70 | -------------------------------------------------------------------------------- /docs/start.rst: -------------------------------------------------------------------------------- 1 | Quick start 2 | ======================= 3 | 4 | Writing your API service comprises of two steps 5 | 6 | * Writing a contract (schematic representation of your API) 7 | * Providing a server implementation 8 | 9 | Contract 10 | -------- 11 | A contract is the list of end-points in your API service and the definition of each API endpoint. 12 | We define what goes in as **request** (Query params, form params, headers etc) and what comes out as the **response** of each API endpoint. 13 | 14 | As an example, consider a API service that lets you create, update, delete and fetch users. First step is to create a datatype for our API service. Lets call it :code:`MyApiService` 15 | 16 | To define your contract using the framework, you need to 17 | 18 | * Declare a data type for your API service. 19 | 20 | :: 21 | 22 | data MyApiService 23 | 24 | 25 | * Declare your routes as types. 26 | 27 | :: 28 | 29 | type User = Static "user" 30 | type UserId = "user" :/ Int 31 | 32 | 33 | * Write a :wahackage:`WebApi ` instance which declares the endpoints. 34 | 35 | :: 36 | 37 | instance WebApi MyApiService where 38 | -- Route 39 | type Apis MyApiService = '[ Route '[GET, POST] User 40 | , Route '[GET, PUT, DELETE] UserId 41 | ] 42 | 43 | 44 | * Write :wahackage:`ApiContract ` instances describing what goes in an **request** and what comes out as **response** from each API endpoint. Let's write our first :wahackage:`ApiContract ` instance for :code:`POST /user`. 45 | 46 | 47 | :: 48 | 49 | 50 | -- Our user type 51 | data UserData = UserData { age :: Int 52 | , address :: Text 53 | , name :: Text 54 | } deriving (Show, Eq, Generic) 55 | 56 | data UserToken = UserToken { userId :: Text 57 | , token :: Text 58 | } deriving (Show, Eq, Generic) 59 | 60 | 61 | -- Takes a User type in form params and returns UserToken. 62 | instance ApiContract MyApiService POST User where 63 | type FormParam POST User = UserData 64 | type ApiOut POST User = UserToken 65 | 66 | 67 | 68 | 69 | In our code snippet above, the end-point :code:`POST /user` takes user's information (**name, age** and **address**) as **post params** and gives out the user's **token** and **userId** 70 | 71 | An equivalent curl syntax would be: 72 | :: 73 | 74 | `curl -H "Content-Type: application/x-www-form-urlencoded" -d 'age=30&address=nazareth&name=Brian' http://api.peoplefrontofjudia.com/users ` 75 | 76 | 77 | 78 | 79 | * Finally to complete our contract, we have to write instances for json, param serialization & deserialization for :code:`UserData` and :code:`UserToken` types. A definition needn't be provided since `GHC.Generics `_ provides a generic implementation. 80 | 81 | :: 82 | 83 | instance FromJSON UserData 84 | instance ToJSON UserData 85 | instance FromParam 'FormParam UserData 86 | 87 | {--We dont need a FromParam instance since UserToken according 88 | to our example is not sent us form params or query params -} 89 | instance FromJSON UserToken 90 | instance ToJSON UserToken 91 | 92 | This completes the contract part of the API. 93 | 94 | 95 | Server implementation 96 | -------------- 97 | 98 | * First step is to create a type for the implementation and define :wahackage:`WebApiServer ` instance for it. 99 | 100 | :: 101 | 102 | data MyApiServiceImpl = MyApiServiceImpl 103 | 104 | instance WebApiServer MyApiServiceImpl where 105 | type HandlerM MyApiServiceImpl = IO 106 | type ApiInterface MyApiServiceImpl = MyApiService 107 | 108 | 109 | 110 | `HandlerM `_ is the base monad in which the :wahackage:`handler ` will run. We also state that :code:`MyApiServiceImpl` is the implementation for the contract :code:`MyApiServiceApi`. 111 | 112 | By keeping the implementation separate from the contract, it is possible for a contract to have multiple implementations. 113 | 114 | * Now let's create the :wahackage:`ApiHandler ` for one of our end-point :code:`POST /user` 115 | 116 | :: 117 | 118 | instance ApiHandler MyApiServiceImpl POST User where 119 | handler _ req = do 120 | let _userInfo = formParam req 121 | respond (UserToken "Foo" "Bar") 122 | 123 | 124 | The last thing that is left is to create a `WAI `_ application from all the aforementioned information. For that we use :wahackage:`serverApp ` . 125 | 126 | :: 127 | 128 | myApiApp :: Wai.Application 129 | myApiApp = serverApp serverSettings MyApiServiceImpl 130 | 131 | main :: IO () 132 | main = run 8000 myApiApp 133 | 134 | 135 | That's it - now :code:`myApiApp` could be run like any other `WAI `_ application. 136 | 137 | There's more you could do with **WebApi** apart from building API services. You can also :doc:`build haskell clients` for existing API services by defining just the contract, build full-stack webapps that serve html & javascript and :doc:`generate mock servers. ` 138 | -------------------------------------------------------------------------------- /docs/webapi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/byteally/webapi/68166dc75652d30e0891219ece2dfbbb486fd808/docs/webapi.png -------------------------------------------------------------------------------- /reflex-platform.nix: -------------------------------------------------------------------------------- 1 | let 2 | initialNixpkgs = import {}; 3 | 4 | sources = { 5 | reflex-platform = initialNixpkgs.pkgs.fetchFromGitHub { 6 | owner = "reflex-frp"; 7 | repo = "reflex-platform"; 8 | rev = "df0bdcca5eb2a3236ec0496e4430d91876b29cf5"; 9 | sha256 = "1ja3vkq9px8f9iyiazq44mamaahgiphi9l236pvzbl5jvhi5c4qr"; 10 | }; 11 | }; 12 | 13 | reflex-platform = import sources.reflex-platform {}; 14 | in 15 | reflex-platform 16 | -------------------------------------------------------------------------------- /stack-ghc-8.0.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - 'webapi' 3 | - 'webapi-docs' 4 | - 'webapi-contract' 5 | - 'webapi-swagger' 6 | resolver: lts-9.21 7 | -------------------------------------------------------------------------------- /stack-ghc-8.2.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - 'webapi' 3 | - 'webapi-docs' 4 | - 'webapi-contract' 5 | - 'webapi-swagger' 6 | resolver: lts-11.22 7 | -------------------------------------------------------------------------------- /stack-ghc-8.4.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - 'webapi' 3 | - 'webapi-docs' 4 | - 'webapi-contract' 5 | - 'webapi-swagger' 6 | - location: 7 | git: https://github.com/capital-match/bytestring-trie.git 8 | commit: 47526b2ec810239fe824c03c13cf1d81f0741b5c 9 | extra-dep: true 10 | resolver: lts-12.24 11 | 12 | extra-deps: 13 | - multiset-0.3.4.1 -------------------------------------------------------------------------------- /stack-ghc-8.6.5.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | 3 | packages: 4 | - webapi 5 | - webapi-docs 6 | - webapi-contract 7 | - webapi-swagger 8 | 9 | extra-deps: 10 | - bytestring-trie-0.2.5.0@sha256:96498959cf2af0e3f1f3dfb526b78502c9fa8f21255a3506938ee2a26e61d653,3331 11 | 12 | 13 | -------------------------------------------------------------------------------- /stack-ghc-8.8.3.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.12 2 | 3 | packages: 4 | - webapi 5 | - webapi-docs 6 | - webapi-contract 7 | # - webapi-swagger 8 | 9 | extra-deps: 10 | - bytestring-trie-0.2.5.0@sha256:96498959cf2af0e3f1f3dfb526b78502c9fa8f21255a3506938ee2a26e61d653,3331 11 | 12 | allow-newer: true 13 | 14 | 15 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.12 2 | 3 | packages: 4 | - webapi 5 | - webapi-docs 6 | - webapi-contract 7 | # - webapi-swagger 8 | 9 | extra-deps: 10 | - bytestring-trie-0.2.5.0@sha256:96498959cf2af0e3f1f3dfb526b78502c9fa8f21255a3506938ee2a26e61d653,3331 11 | 12 | allow-newer: true 13 | 14 | 15 | -------------------------------------------------------------------------------- /webapi-client-reflex-dom/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for webapi-client-reflex-dom 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /webapi-client-reflex-dom/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Magesh 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 Magesh 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 | -------------------------------------------------------------------------------- /webapi-client-reflex-dom/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi-client-reflex-dom/src/WebApi/Client/Reflex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | module WebApi.Client.Reflex where 11 | 12 | import Control.Exception 13 | import Control.Monad 14 | import Data.Bifunctor 15 | import Data.ByteString (ByteString) 16 | import Data.ByteString.Builder (toLazyByteString) 17 | import qualified Data.ByteString.Lazy as LBS (ByteString, fromStrict, toStrict) 18 | import qualified Data.CaseInsensitive as CI 19 | import Data.Either 20 | import Data.Kind 21 | import Data.List (find) 22 | import qualified Data.Map as Map 23 | import Data.Proxy 24 | import Data.Text (Text) 25 | import qualified Data.Text as T 26 | import qualified Data.Text.Encoding as T 27 | import GHCJS.DOM.File 28 | import GHCJS.DOM.FormData 29 | import Language.Javascript.JSaddle 30 | import Network.HTTP.Media (mapContentMedia, renderHeader) 31 | import Network.HTTP.Types as HT 32 | import Reflex.Dom.Core hiding (Request, Response) 33 | import WebApi.ContentTypes 34 | import WebApi.Contract as WebApi 35 | import WebApi.Param as WebApi 36 | import WebApi.Util 37 | --import Control.Monad.IO.Class 38 | 39 | 40 | type family NamespaceOf (r :: Type) where 41 | NamespaceOf (ns :// (r :: k)) = ns 42 | 43 | client :: forall meth r t m. 44 | ( DomBuilder t m 45 | , MonadJSM (Performable m) 46 | , MonadJSM m 47 | , PerformEvent t m 48 | , TriggerEvent t m 49 | , WebApi (NamespaceOf r) 50 | , SingMethod meth 51 | , MkPathFormatString r 52 | , ToParam 'PathParam (PathParam meth r) 53 | , ToParam 'QueryParam (QueryParam meth r) 54 | , ToParam 'FormParam (FormParam meth r) 55 | , ToHeader (HeaderIn meth r) 56 | , ToParam 'FileParam (FileParam meth r) 57 | , ToParam 'Cookie (CookieIn meth r) 58 | , FromHeader (HeaderOut meth r) 59 | , CookieOut meth r ~ () -- TODO: Http-Only cookie cannot be read from JS 60 | , PartEncodings (RequestBody meth r) 61 | , Decodings (ContentTypes meth r) (ApiOut meth r) 62 | , Decodings (ContentTypes meth r) (ApiErr meth r) 63 | , ToHListRecTuple (StripContents (RequestBody meth r)) 64 | ) => Event t (Request meth r) -> m (Event t (Response meth r)) 65 | client req = do 66 | host <- getLocationHost 67 | clientOrigin host req 68 | 69 | clientOrigin :: forall meth r t m. 70 | ( DomBuilder t m 71 | , MonadJSM (Performable m) 72 | , MonadJSM m 73 | , PerformEvent t m 74 | , TriggerEvent t m 75 | , WebApi (NamespaceOf r) 76 | , SingMethod meth 77 | , MkPathFormatString r 78 | , ToParam 'PathParam (PathParam meth r) 79 | , ToParam 'QueryParam (QueryParam meth r) 80 | , ToParam 'FormParam (FormParam meth r) 81 | , ToHeader (HeaderIn meth r) 82 | , ToParam 'FileParam (FileParam meth r) 83 | , ToParam 'Cookie (CookieIn meth r) 84 | , FromHeader (HeaderOut meth r) 85 | , CookieOut meth r ~ () -- TODO: Http-Only cookie cannot be read from JS 86 | , PartEncodings (RequestBody meth r) 87 | , Decodings (ContentTypes meth r) (ApiOut meth r) 88 | , Decodings (ContentTypes meth r) (ApiErr meth r) 89 | , ToHListRecTuple (StripContents (RequestBody meth r)) 90 | ) => Text -> Event t (Request meth r) -> m (Event t (Response meth r)) 91 | clientOrigin baseUrl reqEvt = do 92 | let 93 | mkXhrReq :: (MonadJSM jsm) => Request meth r -> jsm (XhrRequest Text) 94 | mkXhrReq req = do 95 | let 96 | meth = singMethod (Proxy :: Proxy meth) 97 | reqHeaders' = if T.null formPar 98 | then case partEncMay of 99 | Just (mt, _) -> (hContentType, renderHeader mt) : (toHeader $ headerIn req) 100 | Nothing -> toHeader $ headerIn req 101 | else (hContentType, "application/x-www-form-urlencoded") : (toHeader $ headerIn req) 102 | reqHeaders = Map.fromList $ fmap (\(k,v) -> ( T.decodeUtf8 $ CI.original k 103 | , T.decodeUtf8 v)) reqHeaders' 104 | formPar = T.decodeUtf8 $ renderSimpleQuery False $ toFormParam $ formParam req 105 | -- TODO: Should qpar be Maybe 106 | reqUrl = WebApi.link (Res :: Resource meth r) (Just (T.encodeUtf8 baseUrl)) (pathParam req) (Just $ queryParam req) 107 | cts = Proxy :: Proxy (RequestBody meth r) 108 | cts' = Proxy :: Proxy (StripContents (RequestBody meth r)) 109 | -- NOTE: Handles only single request body 110 | partEncMay = case partEncodings cts (toRecTuple cts' (requestBody req)) of 111 | [[partEnc']] -> Just partEnc' 112 | _ -> Nothing 113 | sendData = case partEncMay of 114 | Just (_, b) -> T.decodeUtf8 $ LBS.toStrict $ toLazyByteString b 115 | _ -> formPar 116 | 117 | -- TODO: Handle Files 118 | forM_ (toFileParam $ fileParam req) $ \(fname, _finfo) -> do 119 | formData <- newFormData Nothing 120 | appendBlob formData (T.decodeUtf8 fname) (undefined :: File) (Nothing :: Maybe Text) 121 | pure () 122 | 123 | pure XhrRequest 124 | { _xhrRequest_method = T.decodeUtf8 meth 125 | , _xhrRequest_url = T.decodeUtf8 reqUrl 126 | , _xhrRequest_config = XhrRequestConfig 127 | { _xhrRequestConfig_headers = reqHeaders 128 | , _xhrRequestConfig_responseHeaders = AllHeaders -- Parses all headers, can be more refined OnlyHeaders 129 | , _xhrRequestConfig_sendData = sendData 130 | , _xhrRequestConfig_responseType = Nothing 131 | , _xhrRequestConfig_user = Nothing 132 | , _xhrRequestConfig_password = Nothing 133 | , _xhrRequestConfig_withCredentials = False 134 | } 135 | } 136 | xhrReq <- performEvent $ mkXhrReq <$> reqEvt 137 | xhrRes <- performRequestAsyncWithError xhrReq 138 | let 139 | getContentType :: ResponseHeaders -> Maybe ByteString 140 | getContentType = fmap snd . find ((== hContentType) . fst) 141 | 142 | fromClientResponse :: ( FromHeader (HeaderOut meth r) 143 | , Decodings (ContentTypes meth r) (ApiOut meth r) 144 | ) => XhrResponse -> Response meth r 145 | fromClientResponse resp = 146 | let 147 | status = mkStatus (fromIntegral $ _xhrResponse_status resp) (T.encodeUtf8 $ _xhrResponse_statusText resp) 148 | 149 | respHdrRaw :: ResponseHeaders 150 | respHdrRaw = fmap (bimap (CI.map T.encodeUtf8) T.encodeUtf8) 151 | $ Map.toList $ _xhrResponse_headers resp 152 | respHdr = fromHeader $ respHdrRaw :: Validation [ParamErr] (HeaderOut meth r) 153 | 154 | toParamErr :: Either String a -> Either [ParamErr] a 155 | toParamErr (Left str) = Left [ParseErr "" (T.pack $ str)] 156 | toParamErr (Right r) = Right r 157 | 158 | decode' :: ( Decodings (ContentTypes meth r) a 159 | ) => apiRes meth r -> LBS.ByteString -> Either String a 160 | decode' r o = case getContentType (respHdrRaw) of 161 | Just ctype -> let decs = decodings (reproxy r) o 162 | in maybe (firstRight (map snd decs)) id (mapContentMedia decs ctype) 163 | Nothing -> firstRight (map snd (decodings (reproxy r) o)) 164 | 165 | reproxy :: apiRes meth r -> Proxy (ContentTypes meth r) 166 | reproxy = const Proxy 167 | 168 | firstRight :: [Either String b] -> Either String b 169 | firstRight = maybe (Left "Couldn't find matching Content-Type") id . find isRight 170 | 171 | -- TODO: Handle other xhr response case 172 | xhrResp = LBS.fromStrict $ T.encodeUtf8 $ maybe T.empty id $ _xhrResponse_responseText resp 173 | 174 | in case WebApi.Success <$> pure status 175 | <*> (Validation $ toParamErr $ decode' (Res :: Resource meth r) xhrResp) 176 | <*> respHdr 177 | <*> pure () of 178 | Validation (Right success) -> success 179 | Validation (Left errs1) -> 180 | case ApiError 181 | <$> pure status 182 | <*> (Validation $ toParamErr $ decode' (Res :: Resource meth r) xhrResp) 183 | <*> (Just <$> respHdr) 184 | <*> (Just <$> (pure ())) of 185 | Validation (Right failure) -> (WebApi.Failure . Left) failure 186 | Validation (Left errs2) -> 187 | let errs = case HT.statusCode status of 188 | 200 -> errs1 189 | _ -> errs2 190 | in WebApi.Failure $ Right (OtherError (toException $ ApiErrParseFailException status $ T.intercalate "\n" $ fmap (T.pack . show) errs)) 191 | 192 | pure $ ffor xhrRes $ \case 193 | Left e -> WebApi.Failure $ Right $ OtherError $ toException e 194 | Right r -> fromClientResponse r 195 | 196 | data ContentDecodeException 197 | = ContentDecodeException 198 | deriving (Show, Eq) 199 | 200 | instance Exception ContentDecodeException 201 | -------------------------------------------------------------------------------- /webapi-client-reflex-dom/webapi-client-reflex-dom.cabal: -------------------------------------------------------------------------------- 1 | -- Initial webapi-client-reflex-dom.cabal generated by cabal init. For 2 | -- further documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: webapi-client-reflex-dom 5 | version: 0.2.0.0 6 | synopsis: Type safe XHR client for webapi using reflex-dom 7 | -- description: 8 | homepage: https://github.com/byteally/webapi 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Magesh 12 | maintainer: magesh85@gmail.com 13 | -- copyright: 14 | category: Web 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md 17 | cabal-version: >=1.10 18 | 19 | library 20 | exposed-modules: WebApi.Client.Reflex 21 | -- other-modules: 22 | build-depends: base >= 4.9 && < 5 23 | , webapi-contract == 0.5.* 24 | , reflex >= 0.6.4 && < 0.10 25 | , reflex-dom-core >= 0.7 && < 0.9 26 | , ghcjs-dom 27 | , text 28 | , bytestring 29 | , jsaddle >= 0.9.0.0 && < 0.10 30 | , containers 31 | , case-insensitive >= 1.2 32 | , http-types >= 0.8 33 | , http-media >= 0.7 && < 0.9 34 | hs-source-dirs: src 35 | default-language: Haskell2010 36 | ghc-options: -Wall -Werror -O2 37 | -------------------------------------------------------------------------------- /webapi-contract/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | -------------------------------------------------------------------------------- /webapi-contract/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, byteally 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of webapi nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /webapi-contract/README.md: -------------------------------------------------------------------------------- 1 | webapi-contract 2 | =============== 3 | 4 | You can write contracts for [webapi](https://hackage.haskell.org/package/webapi) with this package. 5 | 6 | Please take a look at for more details. 7 | -------------------------------------------------------------------------------- /webapi-contract/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi-contract/src/WebApi/ContentTypes.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : WebApi.ContentTypes 3 | License : BSD3 4 | Stability : experimental 5 | -} 6 | 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE TupleSections #-} 18 | {-# LANGUAGE FlexibleContexts #-} 19 | 20 | module WebApi.ContentTypes 21 | ( 22 | -- * Predefined Content Types. 23 | JSON 24 | , PlainText 25 | , HTML 26 | , OctetStream 27 | , MultipartFormData 28 | , UrlEncoded 29 | 30 | -- * Creating custom Content Types. 31 | , Content 32 | , Accept (..) 33 | , Encode (..) 34 | , Decode (..) 35 | 36 | -- * Converting from and to 'Text' 37 | , FromText (..) 38 | , ToText (..) 39 | 40 | -- * Html 41 | , Html 42 | , html 43 | 44 | -- * Internal classes. 45 | , Encodings (..) 46 | , Decodings (..) 47 | , PartEncodings (..) 48 | , PartDecodings (..) 49 | , StripContents 50 | ) where 51 | 52 | import Data.Text.Lazy.Encoding (encodeUtf8Builder) 53 | import Data.Aeson (ToJSON (..), FromJSON (..), eitherDecode) 54 | #if MIN_VERSION_aeson(1,0,0) 55 | import Data.Aeson.Encoding (fromEncoding) 56 | #else 57 | import Data.Aeson.Encode (encodeToBuilder) 58 | #endif 59 | import qualified Data.ByteString as SB 60 | import qualified Data.ByteString.Lazy as LBS 61 | import Data.ByteString.Lazy (ByteString) 62 | import Data.Maybe (fromMaybe) 63 | import Data.Proxy 64 | import qualified Data.Text as T 65 | import qualified Data.Text.Lazy as LT 66 | import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) 67 | import Network.HTTP.Media.MediaType 68 | import Network.HTTP.Media (mapContentMedia) 69 | import WebApi.Util 70 | import Data.ByteString.Builder (lazyByteString, Builder) 71 | import Data.Kind ( Type ) 72 | 73 | 74 | -- | Type representing content type of @text/html@. 75 | data HTML 76 | 77 | -- | Type representing content type of @application/octetstream@. 78 | data OctetStream 79 | 80 | -- | Type representing content type of @multipart/form-data@. 81 | data MultipartFormData 82 | 83 | -- | Type representing content type of @application/x-www-form-urlencoded@. 84 | data UrlEncoded 85 | 86 | -- | Encodings of type for all content types `ctypes`. 87 | class Encodings (ctypes :: [Type]) a where 88 | encodings :: Proxy ctypes -> a -> [(MediaType, Builder)] 89 | 90 | instance ( Accept ctype 91 | , Encode ctype a 92 | , Encodings ctypes a 93 | ) => Encodings (ctype ': ctypes) a where 94 | encodings _ a = (contentType (Proxy :: Proxy ctype), encode (Proxy :: Proxy ctype) a) : encodings (Proxy :: Proxy ctypes) a 95 | 96 | instance Encodings '[] a where 97 | encodings _ _ = [] 98 | 99 | -- | Decodings of type for all content types `ctypes`. 100 | class Decodings (ctypes :: [Type]) a where 101 | decodings :: Proxy ctypes -> ByteString -> [(MediaType, Either String a)] 102 | 103 | instance ( Accept ctype 104 | , Decode ctype a 105 | , Decodings ctypes a 106 | ) => Decodings (ctype ': ctypes) a where 107 | decodings _ bs = (contentType (Proxy :: Proxy ctype), decode (Proxy :: Proxy ctype) bs) : decodings (Proxy :: Proxy ctypes) bs 108 | 109 | instance Decodings '[] a where 110 | decodings _ _ = [] 111 | 112 | -- | Singleton class for content type. 113 | class Accept ctype where 114 | contentType :: Proxy ctype -> MediaType 115 | 116 | instance Accept PlainText where 117 | contentType _ = "text" // "plain" /: ("charset", "utf-8") 118 | 119 | instance Accept JSON where 120 | contentType _ = "application" // "json" 121 | 122 | instance Accept HTML where 123 | contentType _ = "text" // "html" /: ("charset", "utf-8") 124 | 125 | instance Accept OctetStream where 126 | contentType _ = "application" // "octet-stream" 127 | 128 | instance Accept MultipartFormData where 129 | contentType _ = "multipart" // "form-data" 130 | 131 | instance Accept UrlEncoded where 132 | contentType _ = "application" // "x-www-form-urlencoded" 133 | 134 | -- | Encode a type into a specific content type. 135 | class (Accept a) => Encode a c where 136 | encode :: Proxy a -> c -> Builder 137 | 138 | instance (ToJSON c) => Encode JSON c where 139 | #if MIN_VERSION_aeson(1,0,0) 140 | encode _ = fromEncoding . toEncoding 141 | #else 142 | encode _ = encodeToBuilder . toJSON 143 | #endif 144 | 145 | instance (ToText a) => Encode PlainText a where 146 | encode _ = encodeUtf8Builder . toText 147 | 148 | -- | (Try to) Decode a type from a specific content type. 149 | class (Accept c) => Decode c a where 150 | decode :: Proxy c -> ByteString -> Either String a 151 | 152 | instance (FromJSON a) => Decode JSON a where 153 | decode _ = eitherDecode 154 | 155 | instance (FromText a) => Decode PlainText a where 156 | decode _ = maybe (Left "Couldn't parse: ") Right . fromText . decodeUtf8 157 | 158 | class ToText a where 159 | toText :: a -> LT.Text 160 | 161 | instance ToText T.Text where 162 | toText = LT.fromStrict 163 | 164 | instance ToText LT.Text where 165 | toText = id 166 | 167 | instance ToText ByteString where 168 | toText = decodeUtf8 169 | 170 | instance ToText SB.ByteString where 171 | toText = decodeUtf8 . LBS.fromStrict 172 | 173 | instance ToText () where 174 | toText _ = "" 175 | 176 | class FromText a where 177 | fromText :: LT.Text -> Maybe a 178 | 179 | instance FromText T.Text where 180 | fromText = Just . LT.toStrict 181 | 182 | instance FromText LT.Text where 183 | fromText = Just 184 | 185 | instance FromText () where 186 | fromText "" = Just () 187 | fromText _ = Nothing 188 | 189 | instance FromText ByteString where 190 | fromText = Just . encodeUtf8 191 | 192 | instance FromText SB.ByteString where 193 | fromText = Just . LBS.toStrict . encodeUtf8 194 | 195 | newtype Html = Html ByteString 196 | 197 | instance Encode HTML Html where 198 | encode _ (Html b) = lazyByteString b 199 | 200 | instance Decode HTML Html where 201 | decode _ = return . Html 202 | 203 | html :: ByteString -> Html 204 | html = Html 205 | 206 | class PartEncodings (xs :: [Type]) where 207 | partEncodings :: Proxy xs 208 | -> HListToRecTuple (StripContents xs) 209 | -> [[(MediaType, Builder)]] 210 | 211 | instance (PartEncodings ts, Encodings ctypes (StripContent t), MkContent t ~ Content ctypes a) => PartEncodings (t ': ts) where 212 | partEncodings _ (t, ts) = encodings (Proxy :: Proxy ctypes) t : partEncodings (Proxy :: Proxy ts) ts 213 | 214 | instance PartEncodings '[] where 215 | partEncodings _ () = [] 216 | 217 | class PartDecodings (xs :: [Type]) where 218 | partDecodings :: Proxy xs -> [(SB.ByteString, ByteString)] -> Either String (HListToRecTuple (StripContents xs)) 219 | 220 | instance (PartDecodings ts, Decodings ctypes (StripContent t), MkContent t ~ Content ctypes a) => PartDecodings (t ': ts) where 221 | partDecodings _ ((ctype, partBody) : xs) = do 222 | let decs = decodings (Proxy :: Proxy ctypes) partBody 223 | (decValE :: Maybe (Either String (StripContent t))) = mapContentMedia decs ctype 224 | decVal <- fromMaybe (Left "Error 415: No Matching Content Type") decValE 225 | (decVal, ) <$> partDecodings (Proxy :: Proxy ts) xs 226 | partDecodings _ [] = error "Panic: impossible case" 227 | 228 | instance PartDecodings '[] where 229 | partDecodings _ _ = Right () 230 | 231 | type family MkContent a where 232 | MkContent (Content ctypes a) = Content ctypes a 233 | MkContent a = Content '[JSON] a 234 | 235 | -- | Type representing content type of @application/json@. 236 | data JSON 237 | 238 | -- | Type representing content type of @text/plain@. 239 | data PlainText 240 | 241 | 242 | -------------------------------------------------------------------------------- /webapi-contract/src/WebApi/Method.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : WebApi.ContentTypes 3 | License : BSD3 4 | Stability : experimental 5 | 6 | Defines various types to represent the HTTP methods. 7 | 8 | -} 9 | 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | module WebApi.Method 14 | ( 15 | -- * Methods 16 | GET 17 | , POST 18 | , PUT 19 | , DELETE 20 | , HEAD 21 | , PATCH 22 | , TRACE 23 | , OPTIONS 24 | , CONNECT 25 | , CUSTOM 26 | 27 | -- * Internal 28 | , SingMethod (..) 29 | ) where 30 | 31 | import Data.ByteString.Char8 (pack) 32 | import Data.Proxy 33 | import GHC.TypeLits 34 | import Network.HTTP.Types 35 | import Data.Kind ( Type ) 36 | 37 | -- | Type representing a GET method. 38 | data GET 39 | -- | Type representing a POST method. 40 | data POST 41 | -- | Type representing a PUT method. 42 | data PUT 43 | -- | Type representing a DELETE method. 44 | data DELETE 45 | -- | Type representing a HEAD method. 46 | data HEAD 47 | -- | Type representing a PATCH method. 48 | data PATCH 49 | -- | Type representing a OPTIONS method. 50 | data OPTIONS 51 | -- | Type representing a TRACE method. 52 | data TRACE 53 | -- | Type representing a CONNECT method. 54 | data CONNECT 55 | -- | Type representing a Custom method. 56 | data CUSTOM (m :: Symbol) 57 | 58 | -- | Singleton class for method types. 59 | class SingMethod (meth :: Type) where 60 | singMethod :: Proxy meth -> Method 61 | 62 | instance SingMethod GET where 63 | singMethod = const methodGet 64 | 65 | instance SingMethod POST where 66 | singMethod = const methodPost 67 | 68 | instance SingMethod PUT where 69 | singMethod = const methodPut 70 | 71 | instance SingMethod DELETE where 72 | singMethod = const methodDelete 73 | 74 | instance SingMethod OPTIONS where 75 | singMethod = const methodOptions 76 | 77 | instance SingMethod HEAD where 78 | singMethod = const methodHead 79 | 80 | instance SingMethod TRACE where 81 | singMethod = const methodTrace 82 | 83 | instance SingMethod PATCH where 84 | singMethod = const methodPatch 85 | 86 | instance SingMethod CONNECT where 87 | singMethod = const methodConnect 88 | 89 | instance KnownSymbol m => SingMethod (CUSTOM m) where 90 | singMethod = const $ pack $ symbolVal (Proxy :: Proxy m) 91 | -------------------------------------------------------------------------------- /webapi-contract/src/WebApi/Security.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE DataKinds #-} 7 | module WebApi.Security where 8 | 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import GHC.Generics 12 | import Data.Aeson 13 | import GHC.TypeLits 14 | 15 | newtype URL = URL { getUrl :: Text } 16 | deriving (Eq, Ord, Show, ToJSON, FromJSON) 17 | 18 | -- | The location of the API key. 19 | data ApiKeyLocation 20 | = ApiKeyQuery 21 | | ApiKeyHeader 22 | | ApiKeyCookie 23 | deriving (Eq, Show, Generic) 24 | 25 | data ApiKeyParams str = ApiKeyParams 26 | { -- | The name of the header or query parameter to be used. 27 | apiKeyName :: str 28 | 29 | -- | The location of the API key. 30 | , apiKeyIn :: ApiKeyLocation 31 | } deriving (Eq, Show, Generic) 32 | 33 | -- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. 34 | type AuthorizationURL = Text 35 | 36 | -- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. 37 | type TokenURL = Text 38 | 39 | newtype OAuth2ImplicitFlow 40 | = OAuth2ImplicitFlow {oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL} 41 | deriving (Eq, Show, Generic) 42 | 43 | newtype OAuth2PasswordFlow 44 | = OAuth2PasswordFlow {oAuth2PasswordFlowTokenUrl :: TokenURL} 45 | deriving (Eq, Show, Generic) 46 | 47 | newtype OAuth2ClientCredentialsFlow 48 | = OAuth2ClientCredentialsFlow {oAuth2ClientCredentialsFlowTokenUrl :: TokenURL} 49 | deriving (Eq, Show, Generic) 50 | 51 | data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow 52 | { oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL 53 | , oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL 54 | } deriving (Eq, Show, Generic) 55 | 56 | data OAuth2Flow p = OAuth2Flow 57 | { oAuth2Params :: p 58 | 59 | -- | The URL to be used for obtaining refresh tokens. 60 | , oAath2RefreshUrl :: Maybe URL 61 | 62 | -- | The available scopes for the OAuth2 security scheme. 63 | -- A map between the scope name and a short description for it. 64 | -- The map MAY be empty. 65 | , oAuth2Scopes :: [(Text, Text)] 66 | } deriving (Eq, Show, Generic) 67 | 68 | data OAuth2Flows = OAuth2Flows 69 | { -- | Configuration for the OAuth Implicit flow 70 | oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow) 71 | 72 | -- | Configuration for the OAuth Resource Owner Password flow 73 | , oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow) 74 | 75 | -- | Configuration for the OAuth Client Credentials flow 76 | , oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow) 77 | 78 | -- | Configuration for the OAuth Authorization Code flow 79 | , oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow) 80 | } deriving (Eq, Show, Generic) 81 | 82 | type BearerFormat = Text 83 | 84 | data HttpSchemeType 85 | = HttpSchemeBearer (Maybe BearerFormat) 86 | | HttpSchemeBasic 87 | | HttpSchemeCustom Text 88 | deriving (Eq, Show, Generic) 89 | 90 | data SecuritySchemeType str 91 | = SecuritySchemeHttp HttpSchemeType 92 | | SecuritySchemeApiKey (ApiKeyParams str) 93 | | SecuritySchemeOAuth2 OAuth2Flows 94 | | SecuritySchemeOpenIdConnect URL 95 | deriving (Eq, Show, Generic) 96 | 97 | data SecurityScheme = SecurityScheme 98 | { -- | The type of the security scheme. 99 | securitySchemeType :: SecuritySchemeType Text 100 | 101 | -- | A short description for security scheme. 102 | , securitySchemeDescription :: Maybe Text 103 | } deriving (Eq, Show, Generic) 104 | 105 | newtype SecurityDefinitions 106 | = SecurityDefinitions [(Text, SecurityScheme)] 107 | deriving (Eq, Show, Generic) 108 | 109 | -- | Lists the required security schemes to execute this operation. 110 | -- The object can have multiple security schemes declared in it which are all required 111 | -- (that is, there is a logical AND between the schemes). 112 | newtype SecurityRequirement str = SecurityRequirement 113 | { getSecurityRequirement :: [(str, [str])] 114 | } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON) 115 | 116 | 117 | type ApiKeyInCookie (k :: Symbol) = 'SecuritySchemeApiKey ('ApiKeyParams k 'ApiKeyCookie) 118 | 119 | type ApiKeyInHeader (k :: Symbol) = 'SecuritySchemeApiKey ('ApiKeyParams k 'ApiKeyHeader) 120 | 121 | type EmptySecurityReq = '[ 'SecurityRequirement '[]] 122 | 123 | type family NeedCSRFCheck' (sec :: SecuritySchemeType Symbol) :: Bool where 124 | NeedCSRFCheck' ('SecuritySchemeApiKey ('ApiKeyParams _ 'ApiKeyCookie)) = 'True 125 | NeedCSRFCheck' _ = 'False 126 | 127 | type family NeedCSRFCheck (sreqs :: [SecurityRequirement Symbol]) (schs :: [(Symbol, SecuritySchemeType Symbol)]) :: Bool where 128 | NeedCSRFCheck '[] _ = 'False 129 | NeedCSRFCheck ( _ ': sreqs) schs = 'False 130 | 131 | 132 | needCSRFCheck :: [SecurityRequirement Text] -> [(Text, SecuritySchemeType Text)] -> Bool 133 | needCSRFCheck [] _ = False 134 | needCSRFCheck (sreq : sreqs) schs 135 | | any checkSch $ getSecurityRequirement sreq = True 136 | | otherwise = needCSRFCheck sreqs schs 137 | where checkSch (name, _) = case lookup name schs of 138 | Nothing -> error $ "Panic: Invalid security schema: " <> (T.unpack name) 139 | Just (SecuritySchemeApiKey (ApiKeyParams {apiKeyIn=ApiKeyCookie})) -> True 140 | Just _ -> False 141 | -------------------------------------------------------------------------------- /webapi-contract/src/WebApi/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | 11 | module WebApi.Util where 12 | 13 | import Data.Proxy (Proxy (..)) 14 | import Data.Text (Text, pack) 15 | import GHC.TypeLits 16 | import GHC.Exts 17 | import Data.Kind 18 | 19 | type family HListToTuple (xs :: [Type]) :: Type where 20 | HListToTuple '[] = () 21 | HListToTuple '[p1] = p1 22 | HListToTuple '[p1, p2] = (p1, p2) 23 | HListToTuple '[p1, p2, p3] = (p1, p2, p3) 24 | HListToTuple '[p1, p2, p3, p4] = (p1, p2, p3, p4) 25 | HListToTuple '[p1, p2, p3, p4, p5] = (p1, p2, p3, p4, p5) 26 | HListToTuple '[p1, p2, p3, p4, p5, p6] = (p1, p2, p3, p4, p5, p6) 27 | HListToTuple '[p1, p2, p3, p4, p5, p6, p7] = (p1, p2, p3, p4, p5, p6, p7) 28 | HListToTuple '[p1, p2, p3, p4, p5, p6, p7, p8] = (p1, p2, p3, p4, p5, p6, p7, p8) 29 | HListToTuple '[p1, p2, p3, p4, p5, p6, p7, p8, p9] = (p1, p2, p3, p4, p5, p6, p7, p8, p9) 30 | 31 | type family HListToRecTuple (xs :: [Type]) :: Type where 32 | HListToRecTuple (x ': xs) = (x, HListToRecTuple xs) 33 | HListToRecTuple '[] = () 34 | 35 | class ToHListRecTuple (xs :: [Type]) where 36 | toRecTuple :: Proxy xs -> HListToTuple xs -> HListToRecTuple xs 37 | fromRecTuple :: Proxy xs -> HListToRecTuple xs -> HListToTuple xs 38 | 39 | instance ToHListRecTuple '[] where 40 | toRecTuple _ () = () 41 | fromRecTuple _ () = () 42 | 43 | instance (HListToRecTuple '[p1] ~ (p1, ())) => ToHListRecTuple '[p1] where 44 | toRecTuple _ (p1) = (p1, ()) 45 | fromRecTuple _ (p1, ()) = (p1) 46 | 47 | instance ToHListRecTuple '[p1, p2] where 48 | toRecTuple _ (p1, p2) = (p1, (p2, ())) 49 | fromRecTuple _ (p1, (p2, ())) = (p1, p2) 50 | 51 | instance ToHListRecTuple '[p1, p2, p3] where 52 | toRecTuple _ (p1, p2, p3) = (p1, (p2, (p3, ()))) 53 | fromRecTuple _ (p1, (p2, (p3, ()))) = (p1, p2, p3) 54 | 55 | instance ToHListRecTuple '[p1, p2, p3, p4] where 56 | toRecTuple _ (p1, p2, p3, p4) = (p1, (p2, (p3, (p4, ())))) 57 | fromRecTuple _ (p1, (p2, (p3, (p4, ())))) = (p1, p2, p3, p4) 58 | 59 | instance ToHListRecTuple '[p1, p2, p3, p4, p5] where 60 | toRecTuple _ (p1, p2, p3, p4, p5) = (p1, (p2, (p3, (p4, (p5, ()))))) 61 | fromRecTuple _ (p1, (p2, (p3, (p4, (p5, ()))))) = (p1, p2, p3, p4, p5) 62 | 63 | instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6] where 64 | toRecTuple _ (p1, p2, p3, p4, p5, p6) = (p1, (p2, (p3, (p4, (p5, (p6, ())))))) 65 | fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, ())))))) = (p1, p2, p3, p4, p5, p6) 66 | 67 | instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6, p7] where 68 | toRecTuple _ (p1, p2, p3, p4, p5, p6, p7) = (p1, (p2, (p3, (p4, (p5, (p6, (p7, ()))))))) 69 | fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, (p7, ()))))))) = (p1, p2, p3, p4, p5, p6, p7) 70 | 71 | instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6, p7, p8] where 72 | toRecTuple _ (p1, p2, p3, p4, p5, p6, p7, p8) = (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, ())))))))) 73 | fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, ())))))))) = (p1, p2, p3, p4, p5, p6, p7, p8) 74 | 75 | instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6, p7, p8, p9] where 76 | toRecTuple _ (p1, p2, p3, p4, p5, p6, p7, p8, p9) = (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, (p9, ()))))))))) 77 | fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, (p9, ()))))))))) = (p1, p2, p3, p4, p5, p6, p7, p8, p9) 78 | 79 | infixr 5 :++ 80 | type family (:++) (as :: [k]) (bs :: [k]) :: [k] where 81 | '[] :++ bs = bs 82 | (a ': as) :++ bs = a ': (as :++ bs) 83 | 84 | type family StripContents (a :: [Type]) :: [Type] where 85 | StripContents (t ': ts) = StripContent t ': StripContents ts 86 | StripContents '[] = '[] 87 | 88 | type family StripContent a where 89 | StripContent (Content ctypes t) = t 90 | StripContent t = t 91 | 92 | data Content (ctypes :: [Type]) (a :: Type) 93 | 94 | 95 | -- | Datatype representing a endpoint. 96 | data Route (ms :: [Type]) (r :: Type) 97 | 98 | -- | Datatype associating a namespace with a route. 99 | data (://) (ns :: Type) (ps :: k) 100 | infixr 5 :// 101 | 102 | -- | Datatype representing a route. 103 | data (:/) (p1 :: k) (p2 :: k1) 104 | infixr 5 :/ 105 | 106 | -- | Datatype representing a static path piece. 107 | data Static (s :: Symbol) 108 | 109 | type Root = Static "" 110 | 111 | 112 | instance (MkFormatStr (ToPieces (a :/ b))) => MkPathFormatString (a :/ b) where 113 | mkPathFormatString _ = mkFormatStr (Proxy :: Proxy (ToPieces (a :/ b))) 114 | 115 | instance (MkPathFormatString b) => MkPathFormatString (a :// (b :: Type)) where 116 | mkPathFormatString _ = mkPathFormatString (Proxy :: Proxy b) 117 | 118 | instance (MkPathFormatString (Static b)) => MkPathFormatString (a :// (b :: Symbol)) where 119 | mkPathFormatString _ = mkPathFormatString (Proxy :: Proxy (Static b)) 120 | 121 | instance (KnownSymbol s) => MkPathFormatString (Static s) where 122 | mkPathFormatString _ = mkFormatStr (Proxy :: Proxy (ToPieces (Static s))) 123 | 124 | 125 | data Namespace (ns :: Type) 126 | 127 | -- | Convert the path into a flat hierarchy. 128 | type family ToPieces (r :: k) :: [Type] where 129 | ToPieces (ns :// (ps :: Type)) = Namespace ns ': ToPieces' ps 130 | ToPieces (ns :// (ps :: Symbol)) = Namespace ns ': ToPieces' (Static ps) 131 | ToPieces p = ToPieces' p 132 | 133 | type family ToPieces' (r :: k) :: [Type] where 134 | ToPieces' (Static s) = '[StaticPiece s] 135 | ToPieces' ((p1 :: Symbol) :/ (p2 :: Symbol)) = '[StaticPiece p1, StaticPiece p2] 136 | ToPieces' ((p1 :: Type) :/ (p2 :: Symbol)) = '[DynamicPiece p1, StaticPiece p2] 137 | ToPieces' ((p1 :: Symbol) :/ (p2 :/ p3)) = StaticPiece p1 ': ToPieces' (p2 :/ p3) 138 | ToPieces' ((p1 :: Type) :/ (p2 :/ p3)) = DynamicPiece p1 ': ToPieces' (p2 :/ p3) 139 | ToPieces' ((p1 :: Type) :/ (p2 :: Type)) = '[DynamicPiece p1, DynamicPiece p2] 140 | ToPieces' ((p1 :: Symbol) :/ (p2 :: Type)) = '[StaticPiece p1, DynamicPiece p2] 141 | 142 | type family FromPieces (pps :: [Type]) :: Type where 143 | FromPieces (Namespace ns ': ps) = ns :// FromPieces' ps 144 | FromPieces ps = FromPieces' ps 145 | 146 | type family FromPieces' (pps :: [Type]) :: Type where 147 | FromPieces' '[StaticPiece s] = Static s 148 | FromPieces' '[StaticPiece p1, StaticPiece p2] = p1 :/ p2 149 | FromPieces' '[DynamicPiece p1, DynamicPiece p2] = p1 :/ p2 150 | FromPieces' '[StaticPiece p1, DynamicPiece p2] = p1 :/ p2 151 | FromPieces' '[DynamicPiece p1, StaticPiece p2] = p1 :/ p2 152 | 153 | FromPieces' (DynamicPiece p ': ps) = p :/ FromPieces' ps 154 | FromPieces' (StaticPiece p ': ps) = p :/ FromPieces' ps 155 | -- | Type of segments of a Path. 156 | data PathSegment = StaticSegment Text -- ^ A static segment 157 | | Hole -- ^ A dynamic segment 158 | deriving (Show, Eq) 159 | 160 | -- | Describe representation of the route. 161 | class MkPathFormatString r where 162 | -- | Given a route, this function should produce the @[PathSegment]@ of that route. This gives the flexibility to hook in a different routing system into the application. 163 | mkPathFormatString :: Proxy r -> [PathSegment] 164 | 165 | class MkFormatStr (xs :: [Type]) where 166 | mkFormatStr :: Proxy xs -> [PathSegment] 167 | 168 | instance MkFormatStr '[] where 169 | mkFormatStr _ = [] 170 | 171 | 172 | data StaticPiece (s :: Symbol) 173 | 174 | instance (KnownSymbol s, MkFormatStr xs) => MkFormatStr (StaticPiece s ': xs) where 175 | mkFormatStr _ = StaticSegment (pack (symbolVal (Proxy :: Proxy s))) : mkFormatStr (Proxy :: Proxy xs) 176 | 177 | data DynamicPiece (t :: Type) 178 | 179 | instance (MkFormatStr xs) => MkFormatStr (DynamicPiece s ': xs) where 180 | mkFormatStr _ = Hole : mkFormatStr (Proxy :: Proxy xs) 181 | 182 | type family FilterDynP (ps :: [Type]) :: [Type] where 183 | FilterDynP (DynamicPiece p1 ': p2) = p1 ': FilterDynP p2 184 | FilterDynP (p1 ': p2) = FilterDynP p2 185 | FilterDynP '[] = '[] 186 | 187 | type family Elem t ts :: Constraint where 188 | Elem t ts = Elem' t ts ts 189 | 190 | type family Elem' t ts ots :: Constraint where 191 | Elem' t (t ': ts) _ = () 192 | Elem' t (_ ': ts) ots = Elem' t ts ots 193 | Elem' t '[] ots = TypeError ('Text "Type " ':<>: 194 | 'ShowType t ':<>: 195 | 'Text " is not a member of " ':<>: 196 | 'ShowType ots 197 | ) 198 | -------------------------------------------------------------------------------- /webapi-contract/tests/Param.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE DataKinds #-} 6 | 7 | module Param where 8 | 9 | import Hedgehog 10 | import qualified Hedgehog.Gen as Gen 11 | import qualified Hedgehog.Range as Range 12 | import Test.Tasty 13 | import Test.Tasty.Hedgehog 14 | import WebApi.Param 15 | 16 | test_ParamRoundTrip :: TestTree 17 | test_ParamRoundTrip = 18 | testGroup 19 | "http params round trip" 20 | [ testGroup 21 | "encode/decode param rountrip" 22 | [ testProperty "minBound @Int" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.int 23 | , testProperty "maxBound @Int" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.int 24 | , testProperty "minBound @Int8" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.int8 25 | , testProperty "maxBound @Int8" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.int8 26 | , testProperty "minBound @Int16" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.int16 27 | , testProperty "maxBound @Int16" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.int16 28 | , testProperty "minBound @Int32" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.int32 29 | , testProperty "maxBound @Int32" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.int32 30 | , testProperty "minBound @Int64" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.int64 31 | , testProperty "maxBound @Int64" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.int64 32 | , testProperty "minBound @Word" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.word 33 | , testProperty "maxBound @Word" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.word 34 | , testProperty "minBound @Word8" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.word8 35 | , testProperty "maxBound @Word8" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.word8 36 | , testProperty "minBound @Word16" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.word16 37 | , testProperty "maxBound @Word16" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.word16 38 | , testProperty "minBound @Word32" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.word32 39 | , testProperty "maxBound @Word32" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.word32 40 | , testProperty "minBound @Word64" $ withTests 1 $ tripper tripParam $ minBoundOf Gen.word64 41 | , testProperty "maxBound @Word64" $ withTests 1 $ tripper tripParam $ maxBoundOf Gen.word64 42 | ], 43 | testGroup 44 | "query param rountrip" 45 | [ testProperty "minBound @Int" $ withTests 1 $ tripper tripQuery $ minBoundOf Gen.int, 46 | testProperty "maxBound @Int" $ withTests 1 $ tripper tripQuery $ maxBoundOf Gen.int 47 | ] 48 | ] 49 | 50 | maxBoundOf :: forall a gen. (Bounded a, MonadGen gen) => (Range a -> gen a) -> gen a 51 | maxBoundOf gen = gen (Range.singleton $ maxBound @a) 52 | 53 | minBoundOf :: forall a gen. (Bounded a, MonadGen gen) => (Range a -> gen a) -> gen a 54 | minBoundOf gen = gen (Range.singleton $ minBound @a) 55 | 56 | tripParam :: 57 | ( MonadTest m, 58 | Show a, 59 | Eq a, 60 | EncodeParam a, 61 | DecodeParam a 62 | ) => 63 | a -> 64 | m () 65 | tripParam a = tripping a encodeParam decodeParam 66 | 67 | tripQuery :: 68 | ( MonadTest m, 69 | Show a, 70 | Eq a, 71 | ToParam 'QueryParam a, 72 | FromParam 'QueryParam a 73 | ) => 74 | a -> 75 | m () 76 | tripQuery a = tripping a toQueryParam fromQueryParam 77 | 78 | tripForm :: 79 | ( MonadTest m, 80 | Show a, 81 | Eq a, 82 | ToParam 'FormParam a, 83 | FromParam 'FormParam a 84 | ) => 85 | a -> 86 | m () 87 | tripForm a = tripping a toFormParam fromFormParam 88 | 89 | tripFile :: 90 | ( MonadTest m, 91 | Show a, 92 | Eq a, 93 | ToParam 'FileParam a, 94 | FromParam 'FileParam a 95 | ) => 96 | a -> 97 | m () 98 | tripFile a = tripping a toFileParam fromFileParam 99 | 100 | {- 101 | tripPath :: 102 | ( MonadTest m, 103 | Show a, 104 | Eq a, 105 | ToParam 'PathParam a, 106 | FromParam 'PathParam a 107 | ) => 108 | a -> 109 | m () 110 | tripPath a = tripping a toPathParam fromPathParam 111 | 112 | 113 | tripCookie :: 114 | ( MonadTest m, 115 | Show a, 116 | Eq a, 117 | ToParam 'Cookie a, 118 | FromParam 'Cookie a 119 | ) => 120 | a -> 121 | m () 122 | tripCookie a = tripping a toCookie fromCookie 123 | -} 124 | 125 | tripper :: (Show a) => (forall m. MonadTest m => a -> m ()) -> Gen a -> Property 126 | tripper trip gen = property $ do 127 | a <- forAll gen 128 | trip a 129 | -------------------------------------------------------------------------------- /webapi-contract/tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | -------------------------------------------------------------------------------- /webapi-contract/webapi-contract.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial webapi.cabal generated by cabal init. For further 3 | -- documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: webapi-contract 6 | version: 0.5 7 | synopsis: Contracts for webapi library 8 | description: Contracts for webapi library 9 | homepage: http://byteally.github.io/webapi/ 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Magesh B 13 | maintainer: magesh85@gmail.com 14 | -- copyright: 15 | -- extra-source-files: 16 | category: Web 17 | build-type: Simple 18 | extra-source-files: ChangeLog.md 19 | source-repository head 20 | type: git 21 | location: https://github.com/byteally/webapi 22 | 23 | common lib-common 24 | build-depends: base >= 4.7 && < 5 25 | , text >= 1.2 && < 2.2 26 | , bytestring >= 0.10.6.0 && < 0.12 27 | , http-types >= 0.8.6 && < 0.13 28 | , aeson >= 0.9 && < 2.4 29 | , http-media >= 0.6 && < 0.9 30 | , time >= 1.5 && < 1.13 31 | , bytestring-lexing == 0.5.* 32 | , bytestring-trie == 0.2.* 33 | , case-insensitive == 1.2.* 34 | , vector >= 0.10 && < 0.14 35 | , containers >= 0.5.0 && < 0.7 36 | , multiset >= 0.3.3 && < 0.4 37 | , unordered-containers >= 0.2.4 && < 0.3 38 | , choice >= 0.2.2 39 | , uuid-types == 1.0.* 40 | 41 | ghc-options: -Wall 42 | default-language: Haskell2010 43 | 44 | 45 | library 46 | import: lib-common 47 | exposed-modules: WebApi.Contract 48 | , WebApi.Method 49 | , WebApi.Util 50 | , WebApi.ContentTypes 51 | , WebApi.Param 52 | , WebApi.AnonClient 53 | , WebApi.Security 54 | 55 | hs-source-dirs: src 56 | 57 | test-suite webapi-contract-test 58 | import: lib-common 59 | type: exitcode-stdio-1.0 60 | 61 | main-is: Spec.hs 62 | other-modules: Param 63 | hs-source-dirs: tests 64 | cpp-options: -DTEST 65 | 66 | build-depends: tasty >= 0.11 && < 1.3 67 | , tasty-hunit >= 0.10 68 | , tasty-hedgehog >= 1.0 && < 1.1.0 69 | , hedgehog >= 1.0 && < 1.1 70 | , webapi-contract 71 | 72 | build-tool-depends: tasty-discover:tasty-discover >= 4.2.0 73 | -------------------------------------------------------------------------------- /webapi-docs/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Magesh B (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 Magesh B 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. -------------------------------------------------------------------------------- /webapi-docs/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi-docs/src/WebApi/Docs.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE ExistentialQuantification #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE DeriveGeneric #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE CPP #-} 17 | #if __GLASGOW_HASKELL__ >= 800 18 | {-# LANGUAGE UndecidableSuperClasses #-} 19 | {-# LANGUAGE FlexibleInstances #-} 20 | #endif 21 | 22 | 23 | 24 | module WebApi.Docs 25 | ( WebApiDocs (..) 26 | , ApiDocs (..) 27 | , Docs 28 | , FName 29 | , Rec(..), nil 30 | , ResourceDoc (..) 31 | , DocField 32 | , (:-) 33 | , bodyDocs 34 | , docs 35 | , field 36 | , nested 37 | , (-:) 38 | , docSummary 39 | , nestedSummary 40 | , nestedDocs 41 | , f 42 | ) where 43 | 44 | import WebApi.Contract 45 | import Data.Proxy 46 | import GHC.Generics 47 | import GHC.TypeLits 48 | import GHC.Exts 49 | #if __GLASGOW_HASKELL__ >= 800 50 | import GHC.OverloadedLabels 51 | #endif 52 | import Data.Text 53 | import Data.String 54 | import Language.Haskell.TH.Quote 55 | import Language.Haskell.TH 56 | 57 | class (WebApi p) => WebApiDocs (p :: *) where 58 | type DocumentedApis p :: [*] 59 | 60 | data ResourceDoc m r = ResourceDoc 61 | deriving (Generic) 62 | 63 | class ApiContract p m r => ApiDocs (p :: *) (m :: *) (r :: *) where 64 | apiDocs :: Proxy p -> Proxy (Request m r) -> Docs (ResourceDoc m r) 65 | 66 | default apiDocs :: Generic (ResourceDoc m r) => Proxy p -> Proxy (Request m r) -> Docs (ResourceDoc m r) 67 | apiDocs _ _ = docs "" nil 68 | 69 | queryParamDocs :: Generic (QueryParam m r) => Proxy p -> Proxy (Request m r) -> Docs (QueryParam m r) 70 | 71 | default queryParamDocs :: Generic (QueryParam m r) => Proxy p -> Proxy (Request m r) -> Docs (QueryParam m r) 72 | queryParamDocs _ _ = docs "" nil 73 | 74 | formParamDocs :: Generic (FormParam m r) => Proxy p -> Proxy (Request m r) -> Docs (FormParam m r) 75 | 76 | default formParamDocs :: Generic (FormParam m r) => Proxy p -> Proxy (Request m r) -> Docs (FormParam m r) 77 | formParamDocs _ _ = docs "" nil 78 | 79 | fileParamDocs :: Generic (FileParam m r) => Proxy p -> Proxy (Request m r) -> Docs (FileParam m r) 80 | 81 | default fileParamDocs :: Generic (FileParam m r) => Proxy p -> Proxy (Request m r) -> Docs (FileParam m r) 82 | fileParamDocs _ _ = docs "" nil 83 | 84 | headerInDocs :: Generic (HeaderIn m r) => Proxy p -> Proxy (Request m r) -> Docs (HeaderIn m r) 85 | 86 | default headerInDocs :: Generic (HeaderIn m r) => Proxy p -> Proxy (Request m r) -> Docs (HeaderIn m r) 87 | headerInDocs _ _ = docs "" nil 88 | 89 | cookieInDocs :: Generic (CookieIn m r) => Proxy p -> Proxy (Request m r) -> Docs (CookieIn m r) 90 | 91 | default cookieInDocs :: Generic (CookieIn m r) => Proxy p -> Proxy (Request m r) -> Docs (CookieIn m r) 92 | cookieInDocs _ _ = docs "" nil 93 | 94 | apiOutDocs :: Generic (ApiOut m r) => Proxy p -> Proxy (Request m r) -> Docs (ApiOut m r) 95 | 96 | default apiOutDocs :: Generic (ApiOut m r) => Proxy p -> Proxy (Request m r) -> Docs (ApiOut m r) 97 | apiOutDocs _ _ = docs "" nil 98 | 99 | apiErrDocs :: Generic (ApiErr m r) => Proxy p -> Proxy (Request m r) -> Docs (ApiErr m r) 100 | 101 | default apiErrDocs :: Generic (ApiErr m r) => Proxy p -> Proxy (Request m r) -> Docs (ApiErr m r) 102 | apiErrDocs _ _ = docs "" nil 103 | 104 | headerOutDocs :: Generic (HeaderOut m r) => Proxy p -> Proxy (Request m r) -> Docs (HeaderOut m r) 105 | 106 | default headerOutDocs :: Generic (HeaderOut m r) => Proxy p -> Proxy (Request m r) -> Docs (HeaderOut m r) 107 | headerOutDocs _ _ = docs "" nil 108 | 109 | cookieOutDocs :: Generic (CookieOut m r) => Proxy p -> Proxy (Request m r) -> Docs (CookieOut m r) 110 | 111 | default cookieOutDocs :: Generic (CookieOut m r) => Proxy p -> Proxy (Request m r) -> Docs (CookieOut m r) 112 | cookieOutDocs _ _ = docs "" nil 113 | 114 | reqBodyDocs :: All1 Generic (RequestBody m r) => Proxy p -> Proxy (Request m r) -> ReqBodyDoc (RequestBody m r) 115 | default reqBodyDocs :: ( EmptyReqBodyDoc (RequestBody m r) 116 | , All1 Generic (RequestBody m r) 117 | ) => Proxy p -> Proxy (Request m r) -> ReqBodyDoc (RequestBody m r) 118 | reqBodyDocs _ _ = emptyBodyDoc Proxy 119 | 120 | 121 | type family All1 (c :: * -> Constraint) (xs :: [*]) :: Constraint where 122 | All1 c (x ': xs) = (c x, All1 c xs) 123 | All1 c '[] = () 124 | 125 | data ReqBodyDoc (bodies :: [*]) = ReqBodyDoc (Rec Docs bodies) 126 | 127 | bodyDocs :: Rec (DocField body) xs -> ReqBodyDoc '[body] 128 | bodyDocs bdocs = ReqBodyDoc (docs "" bdocs :& nil) 129 | 130 | class EmptyReqBodyDoc (bodies :: [*]) where 131 | emptyBodyDoc :: Proxy bodies -> ReqBodyDoc bodies 132 | 133 | instance EmptyReqBodyDoc bodies => EmptyReqBodyDoc (bdy ': bodies) where 134 | emptyBodyDoc _ = case emptyBodyDoc Proxy of 135 | ReqBodyDoc docss -> ReqBodyDoc (docs "" nil :& docss) 136 | 137 | instance EmptyReqBodyDoc '[] where 138 | emptyBodyDoc _ = ReqBodyDoc nil 139 | 140 | 141 | data ((fn :: Symbol) :- (a :: *)) = Field 142 | 143 | data Docs t = forall xs.Docs Text (Rec (DocField t) xs) 144 | 145 | docSummary :: Docs t -> Text 146 | docSummary (Docs summ _) = summ 147 | 148 | data DocField s (fld :: *) where 149 | DocField :: FName fn -> Doc t -> DocField s (fn :- t) 150 | 151 | data Doc t = Doc Text 152 | | Nested (NestedDoc t) 153 | 154 | data NestedDoc t = NestedDoc 155 | { nsummary :: Text 156 | , ndocs :: Docs t 157 | } 158 | 159 | nestedDocs :: Doc t -> Maybe (Docs t) 160 | nestedDocs (Nested ndoc) = Just $ ndocs ndoc 161 | nestedDocs (Doc _) = Nothing 162 | 163 | nestedSummary :: Doc t -> Maybe Text 164 | nestedSummary (Nested ndoc) = Just $ nsummary ndoc 165 | nestedSummary _ = Nothing 166 | 167 | instance IsString (Doc t) where 168 | fromString = Doc . pack 169 | 170 | data Rec :: (k -> *) -> [k] -> * where 171 | Nil :: Rec f '[] 172 | (:&) :: f x -> Rec f xs -> Rec f (x ': xs) 173 | 174 | infixr 7 :& 175 | 176 | data FName (fn :: Symbol) = FN 177 | 178 | field :: forall fn.FName fn 179 | field = FN 180 | 181 | (-:) :: FName fn -> Doc t -> DocField s (fn :- t) 182 | (-:) fn doc = DocField fn doc 183 | 184 | docs :: Text -> Rec (DocField t) xs -> Docs t 185 | docs = Docs 186 | 187 | nested :: Text -> Docs t -> Doc t 188 | nested summary = Nested . NestedDoc summary 189 | 190 | nil :: Rec f '[] 191 | nil = Nil 192 | 193 | f :: QuasiQuoter 194 | f = QuasiQuoter 195 | { quoteExp = quoteFieldExp 196 | , quotePat = error "Field QuasiQuote cannot be used in pattern" 197 | , quoteDec = error "Field QuasiQuote cannot be used in declaration" 198 | , quoteType = error "Field QuasiQuote cannot be used in type" 199 | } 200 | 201 | quoteFieldExp :: String -> Q Exp 202 | quoteFieldExp fld = do 203 | let ty = litT $ strTyLit fld 204 | [|field :: FName $(ty) |] 205 | 206 | 207 | #if __GLASGOW_HASKELL__ >= 800 208 | instance fn ~ fn' => IsLabel (fn :: Symbol) (FName fn') where 209 | {-# INLINE fromLabel #-} 210 | #endif 211 | #if MIN_VERSION_base(4,10,1) 212 | fromLabel = FN 213 | #elif MIN_VERSION_base(4,9,1) 214 | fromLabel _ = FN 215 | #endif 216 | -------------------------------------------------------------------------------- /webapi-docs/src/WebApi/Schema.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | 8 | module WebApi.Schema where 9 | 10 | import Data.Proxy 11 | import WebApi.Docs 12 | import Language.Haskell.TH.Quote 13 | import Language.Haskell.TH 14 | import Data.Text (Text) 15 | 16 | discovery :: Proxy api -> () 17 | discovery = undefined 18 | -------------------------------------------------------------------------------- /webapi-docs/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-6.6 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.1" 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 -------------------------------------------------------------------------------- /webapi-docs/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /webapi-docs/webapi-docs.cabal: -------------------------------------------------------------------------------- 1 | name: webapi-docs 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/mageshb/webapi-docs#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Magesh B 9 | maintainer: magesh85@gmail.com 10 | copyright: © 2016 Magesh B 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: WebApi.Docs 19 | WebApi.Schema 20 | build-depends: base >= 4.7 && < 5 21 | , webapi >= 0.2 22 | , webapi-contract 23 | , text >= 1.2 24 | , template-haskell 25 | default-language: Haskell2010 26 | 27 | test-suite webapi-docs-test 28 | type: exitcode-stdio-1.0 29 | hs-source-dirs: test 30 | main-is: Spec.hs 31 | build-depends: base 32 | , webapi-docs 33 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 34 | default-language: Haskell2010 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/mageshb/webapi-docs 39 | -------------------------------------------------------------------------------- /webapi-openapi/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for webapi-openapi 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /webapi-openapi/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn "Hello, Haskell!" 5 | -------------------------------------------------------------------------------- /webapi-openapi/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi-openapi/openapi-model-generator/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Main where 4 | 5 | import Options.Applicative 6 | ( (<**>), 7 | fullDesc, 8 | header, 9 | info, 10 | long, 11 | progDesc, 12 | strOption, 13 | execParser, 14 | helper, 15 | Parser ) 16 | import WebApi.OpenAPI (generateModels) 17 | 18 | data CliArgs 19 | = CliArgs 20 | { inputJsonFP :: FilePath, 21 | outDirBaseFp :: FilePath, 22 | reqFilePathPrefix :: FilePath 23 | } 24 | 25 | cliParser :: Parser CliArgs 26 | cliParser = 27 | CliArgs 28 | <$> strOption (long "inputJsonFP") 29 | <*> strOption (long "outDirBaseFp") 30 | <*> strOption (long "reqFilePathPrefix") 31 | 32 | main :: IO () 33 | main = do 34 | CliArgs {..} <- execParser opts 35 | generateModels inputJsonFP outDirBaseFp reqFilePathPrefix 36 | where opts = 37 | info 38 | (cliParser <**> helper) 39 | (fullDesc 40 | <> progDesc "Print a greeting for TARGET" 41 | <> header "hello - a test for optparse-applicative" 42 | ) 43 | 44 | -------------------------------------------------------------------------------- /webapi-openapi/webapi-openapi.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | 3 | name: webapi-openapi 4 | version: 0.1.0.0 5 | synopsis: OpenAPI model generator for webapi 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Magesh B 9 | maintainer: magesh85@gmail.com 10 | copyright: 2021 Byteally 11 | build-type: Simple 12 | extra-source-files: CHANGELOG.md 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/byteally/webapi 17 | 18 | library 19 | exposed-modules: 20 | WebApi.OpenAPI 21 | hs-source-dirs: 22 | src 23 | build-depends: 24 | base >= 4.9 && < 5 25 | , text >= 1.2 && < 1.3 26 | , aeson 27 | , bytestring 28 | , openapi3 29 | , ghc-source-gen 30 | , ghc 31 | , ghc-paths 32 | , insert-ordered-containers 33 | , unordered-containers 34 | , mtl 35 | , containers 36 | , fourmolu 37 | , process 38 | , filepath 39 | , directory 40 | , template-haskell 41 | , fitspec 42 | , http-media 43 | default-language: Haskell2010 44 | ghc-options: -Wall -Werror -O2 45 | 46 | executable openapi-model-generator 47 | main-is: Main.hs 48 | hs-source-dirs: openapi-model-generator 49 | build-depends: base >= 4.9 && < 5 50 | , optparse-applicative 51 | , webapi-openapi 52 | 53 | default-language: Haskell2010 54 | ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N -------------------------------------------------------------------------------- /webapi-reflex-dom/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for webapi-reflex-dom 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /webapi-reflex-dom/README.md: -------------------------------------------------------------------------------- 1 | # WebApi style reflex app library 2 | -------------------------------------------------------------------------------- /webapi-reflex-dom/src/Reflex/Dom/Contrib/Router.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ForeignFunctionInterface #-} 5 | {-# LANGUAGE JavaScriptFFI #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE RecursiveDo #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | module Reflex.Dom.Contrib.Router ( 15 | -- == High-level routers 16 | route 17 | , route' 18 | , partialPathRoute 19 | 20 | -- = Low-level URL bar access 21 | , getLoc 22 | , getURI 23 | , getUrlText 24 | , uriOrigin 25 | , URI 26 | 27 | -- = History movement 28 | , goForward 29 | , goBack 30 | ) where 31 | 32 | ------------------------------------------------------------------------------ 33 | import Control.Monad.Fix (MonadFix) 34 | import Control.Lens ((&), (.~), (^.)) 35 | import qualified Data.ByteString.Char8 as BS 36 | import Data.Monoid ((<>)) 37 | import Data.Text (Text) 38 | import qualified Data.Text as T 39 | import qualified Data.Text.Encoding as T 40 | import GHCJS.Foreign (isFunction) 41 | import GHCJS.DOM.Types (Location(..), PopStateEvent(..)) 42 | import qualified GHCJS.DOM.Types as DOM 43 | import Reflex.Dom.Core hiding (EventName, Window) 44 | import qualified URI.ByteString as U 45 | import GHCJS.DOM.Types (uncheckedCastTo, MonadJSM) 46 | import GHCJS.DOM.History (History, back, forward, pushState) 47 | import GHCJS.DOM (currentWindowUnchecked, currentDocumentUnchecked) 48 | import GHCJS.DOM.Document (createEvent) 49 | import GHCJS.DOM.Event (initEvent) 50 | import GHCJS.DOM.EventM (on) 51 | import GHCJS.DOM.EventTarget (dispatchEvent_) 52 | import GHCJS.DOM.Location (getHref) 53 | import GHCJS.DOM.PopStateEvent 54 | import GHCJS.DOM.Window (getHistory, getLocation) 55 | import GHCJS.DOM.WindowEventHandlers (popState) 56 | import GHCJS.Marshal.Pure (pFromJSVal) 57 | import qualified Language.Javascript.JSaddle as JS 58 | import Language.Javascript.JSaddle (ghcjsPure, JSM, liftJSM, Object(..)) 59 | ------------------------------------------------------------------------------ 60 | 61 | 62 | ------------------------------------------------------------------------------- 63 | -- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic 64 | -- routing of a widget 65 | -- These sources of URL-bar change will be reflected in the output URI 66 | -- - Input events to 'route' 67 | -- - Browser Forward/Back button clicks 68 | -- - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls 69 | -- - Any URL changes followed by a popState event 70 | -- But external calls to pushState that don't manually fire a popState 71 | -- won't be detected 72 | route 73 | :: forall t m. 74 | ( MonadHold t m 75 | , PostBuild t m 76 | , TriggerEvent t m 77 | , PerformEvent t m 78 | , MonadJSM m 79 | , MonadJSM (Performable m)) 80 | => Event t T.Text 81 | -> m (Dynamic t (U.URIRef U.Absolute)) 82 | route pushTo = do 83 | loc0 <- getURI 84 | 85 | _ <- performEvent $ ffor pushTo $ \t -> do 86 | let newState = 87 | Just t 88 | withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text) 89 | liftJSM dispatchEvent' 90 | 91 | locUpdates <- getPopState 92 | holdDyn loc0 locUpdates 93 | 94 | route' 95 | :: forall t m a b. 96 | ( MonadHold t m 97 | , PostBuild t m 98 | , TriggerEvent t m 99 | , PerformEvent t m 100 | , MonadJSM m 101 | , MonadJSM (Performable m) 102 | , MonadFix m) 103 | => (URI -> a -> URI) 104 | -> (URI -> b) 105 | -> Event t a 106 | -> m (Dynamic t b) 107 | route' encode decode routeUpdate = do 108 | rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates) 109 | let urlUpdates = attachWith encode (current rUri) routeUpdate 110 | return $ decode <$> rUri 111 | 112 | 113 | ------------------------------------------------------------------------------- 114 | -- | Route a single page app according to the part of the path after 115 | -- pathBase 116 | partialPathRoute 117 | :: forall t m. 118 | ( MonadHold t m 119 | , PostBuild t m 120 | , DomBuilder t m 121 | , TriggerEvent t m 122 | , PerformEvent t m 123 | , MonadJSM m 124 | , MonadJSM (Performable m) 125 | , MonadFix m) 126 | => T.Text -- ^ The path segments not related to SPA routing 127 | -- (leading '/' will be added automaticaly) 128 | -> Event t T.Text -- ^ Updates to the path segments used for routing 129 | -- These values will be appended to the base path 130 | -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing 131 | partialPathRoute pathBase pathUpdates = do 132 | route' (flip updateUrl) parseParts pathUpdates 133 | where 134 | 135 | toPath :: T.Text -> BS.ByteString 136 | toPath dynpath = T.encodeUtf8 $ 137 | "/" <> cleanT pathBase <> 138 | "/" <> cleanT dynpath 139 | 140 | updateUrl :: T.Text -> URI -> URI 141 | updateUrl updateParts u = u & U.pathL .~ toPath updateParts 142 | 143 | parseParts :: URI -> [T.Text] 144 | parseParts u = 145 | maybe (error $ pfxErr u pathBase) 146 | (T.splitOn "/" . T.decodeUtf8 . cleanB) . 147 | BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $ 148 | cleanB (u ^. U.pathL) 149 | 150 | cleanT = T.dropWhile (=='/') 151 | cleanB = BS.dropWhile (== '/') 152 | 153 | 154 | ------------------------------------------------------------------------------- 155 | uriOrigin :: U.URIRef U.Absolute -> T.Text 156 | uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r' 157 | where 158 | r' = r { U.uriPath = mempty 159 | , U.uriQuery = mempty 160 | , U.uriFragment = mempty 161 | } 162 | 163 | 164 | ------------------------------------------------------------------------------- 165 | getPopState 166 | :: forall t m. 167 | ( MonadHold t m 168 | , TriggerEvent t m 169 | , MonadJSM m) => m (Event t URI) 170 | getPopState = do 171 | window <- currentWindowUnchecked 172 | wrapDomEventMaybe window (`on` popState) $ do 173 | loc 174 | <- getLocation window 175 | locStr <- getHref loc 176 | return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr) 177 | 178 | 179 | ------------------------------------------------------------------------------- 180 | goForward :: (MonadJSM m) => m () 181 | goForward = withHistory forward 182 | 183 | 184 | ------------------------------------------------------------------------------- 185 | goBack :: (MonadJSM m) => m () 186 | goBack = withHistory back 187 | 188 | 189 | ------------------------------------------------------------------------------- 190 | withHistory :: (MonadJSM m) => (History -> m a) -> m a 191 | withHistory act = do 192 | w <- currentWindowUnchecked 193 | h 194 | <- getHistory w 195 | act h 196 | 197 | 198 | ------------------------------------------------------------------------------- 199 | -- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window 200 | getLoc :: (MonadJSM m) => m Location 201 | getLoc = do 202 | win <- currentWindowUnchecked 203 | loc 204 | <- getLocation win 205 | return loc 206 | 207 | 208 | ------------------------------------------------------------------------------- 209 | -- | (Unsafely) get the URL text of a window 210 | getUrlText :: (MonadJSM m) => m T.Text 211 | getUrlText = getLoc >>= getHref 212 | 213 | 214 | ------------------------------------------------------------------------------- 215 | type URI = U.URIRef U.Absolute 216 | 217 | 218 | ------------------------------------------------------------------------------- 219 | getURI :: (MonadJSM m) => m URI 220 | getURI = do 221 | l <- getUrlText 222 | return $ either (error "No parse of window location") id . 223 | U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l 224 | 225 | 226 | dispatchEvent' :: JSM () 227 | dispatchEvent' = do 228 | window <- currentWindowUnchecked 229 | obj@(Object o) <- JS.create 230 | JS.objSetPropertyByName obj ("cancelable" :: Text) True 231 | JS.objSetPropertyByName obj ("bubbles" :: Text) True 232 | JS.objSetPropertyByName obj ("view" :: Text) window 233 | event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case 234 | True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o 235 | False -> do 236 | doc <- currentDocumentUnchecked 237 | event <- createEvent doc ("PopStateEvent" :: Text) 238 | initEvent event ("popstate" :: Text) True True 239 | JS.objSetPropertyByName obj ("view" :: Text) window 240 | return $ uncheckedCastTo PopStateEvent event 241 | 242 | dispatchEvent_ window event 243 | 244 | 245 | ------------------------------------------------------------------------------- 246 | hush :: Either e a -> Maybe a 247 | hush (Right a) = Just a 248 | hush _ = Nothing 249 | 250 | 251 | ------------------------------------------------------------------------------- 252 | pfxErr :: URI -> T.Text -> String 253 | pfxErr pn pathBase = 254 | T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn) 255 | <> ") without expected prefix (" <> pathBase <> ")" 256 | -------------------------------------------------------------------------------- /webapi-reflex-dom/src/Reflex/Dom/Contrib/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE JavaScriptFFI #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | {-| 10 | 11 | Misc reflex-dom helper functions. 12 | 13 | -} 14 | 15 | module Reflex.Dom.Contrib.Utils 16 | ( tshow 17 | , widgetHoldHelper 18 | , putDebugLn 19 | , putDebugLnE 20 | , listWithKeyAndSelection 21 | , waitUntilJust 22 | , alertEvent 23 | , alertEvents 24 | , confirmEvent 25 | , getWindowLocationPath 26 | , windowHistoryPushState 27 | , setWindowLoc 28 | ) where 29 | 30 | ------------------------------------------------------------------------------ 31 | import Control.Concurrent 32 | import Control.Monad 33 | import Control.Monad.Fail 34 | import Control.Monad.Reader 35 | import Data.Map (Map) 36 | import Data.Text (Text) 37 | import qualified Data.Text as T 38 | import GHCJS.DOM as DOM 39 | import GHCJS.DOM.History as DOM 40 | import GHCJS.DOM.Location as DOM 41 | import GHCJS.DOM.Types hiding (Text, Event) 42 | import qualified GHCJS.DOM.Window as DOM 43 | import qualified Language.Javascript.JSaddle as JS 44 | import Reflex 45 | import Reflex.Dom.Core hiding (Window, fromJSString) 46 | ------------------------------------------------------------------------------ 47 | 48 | 49 | ------------------------------------------------------------------------------ 50 | -- | Helper function for showing Text. 51 | tshow :: Show a => a -> Text 52 | tshow = T.pack . show 53 | 54 | ------------------------------------------------------------------------------ 55 | -- | Convenient function that pops up a javascript alert dialog box when an 56 | -- event fires with a message to display. 57 | alertEvent 58 | :: (PerformEvent t m, MonadJSM m, MonadJSM (Performable m), MonadFail m) 59 | => (a -> String) -> Event t a -> m () 60 | alertEvent str e = do 61 | Just window <- currentWindow 62 | performEvent_ (DOM.alert window . str <$> e) 63 | 64 | ------------------------------------------------------------------------------ 65 | -- | Convenient function that pops up multiple javascript alert dialog box 66 | -- sequentially when an event fires with messages to display. 67 | alertEvents 68 | :: (PerformEvent t m, MonadJSM m, MonadJSM (Performable m), MonadFail m) 69 | => (a -> [String]) -> Event t a -> m () 70 | alertEvents str e = do 71 | Just window <- currentWindow 72 | performEvent_ (mapM_ (DOM.alert window) <$> str <$> e) 73 | 74 | ------------------------------------------------------------------------------ 75 | -- | Convenient function that pops up a javascript confirmation dialog box 76 | -- when an event fires with a message to display. 77 | confirmEvent 78 | :: (MonadJSM (Performable m), MonadFail (Performable m), PerformEvent t m) 79 | => (a -> String) -> Event t a -> m (Event t a) 80 | confirmEvent str e = liftM (fmapMaybe id) $ performEvent (confirm <$> e) 81 | where 82 | confirm a = do 83 | Just window <- currentWindow 84 | ok <- DOM.confirm window $ Just $ str a 85 | return $ if ok then Just a else Nothing 86 | 87 | ------------------------------------------------------------------------------ 88 | -- | Gets the current path of the DOM Window (i.e., the contents of the 89 | -- address bar after the host, beginning with a "/"). 90 | -- https://developer.mozilla.org/en-US/docs/Web/API/Location 91 | getWindowLocationPath :: MonadJSM m => Window -> m String 92 | getWindowLocationPath = DOM.getPathname <=< DOM.getLocation 93 | 94 | ------------------------------------------------------------------------------ 95 | -- | Pushes a new URL to the window history. 96 | windowHistoryPushState :: MonadJSM m => String -> m () 97 | windowHistoryPushState url = do 98 | history <- DOM.getHistory =<< DOM.currentWindowUnchecked 99 | DOM.pushState history JS.create (mempty :: JSString) $ Just url 100 | 101 | setWindowLoc :: MonadJSM m => String -> m () 102 | setWindowLoc url = do 103 | location <- DOM.getLocation =<< currentWindowUnchecked 104 | DOM.setHref location url 105 | 106 | ------------------------------------------------------------------------------ 107 | -- | A common form for widgetHold calls that mirrors the pattern seen in hold 108 | -- and holdDyn. 109 | widgetHoldHelper 110 | :: MonadWidget t m 111 | => (a -> m b) 112 | -> a 113 | -> Event t a 114 | -> m (Dynamic t b) 115 | widgetHoldHelper f eDef e = widgetHold (f eDef) (f <$> e) 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | -- | Simple debug function that prints a message on postBuild. 120 | putDebugLn :: MonadWidget t m => String -> m () 121 | putDebugLn str = do 122 | pb <- getPostBuild 123 | putDebugLnE pb (const str) 124 | 125 | 126 | ------------------------------------------------------------------------------ 127 | -- | Prints a string when an event fires. This differs slightly from 128 | -- traceEvent because it will print even if the event is otherwise unused. 129 | putDebugLnE :: MonadWidget t m => Event t a -> (a -> String) -> m () 130 | putDebugLnE e mkStr = do 131 | performEvent_ (liftIO . putStrLn . mkStr <$> e) 132 | 133 | 134 | ------------------------------------------------------------------------------ 135 | -- | A generalized version of the one in reflex-dom. 136 | listWithKeyAndSelection 137 | :: forall t m k v a. (MonadWidget t m, Ord k) 138 | => Dynamic t k 139 | -> Dynamic t (Map k v) 140 | -> (k -> Dynamic t v -> Dynamic t Bool -> m a) 141 | -> m (Dynamic t (Map k a)) 142 | listWithKeyAndSelection selection vals mkChild = do 143 | let selectionDemux = demux selection 144 | listWithKey vals $ \k v -> do 145 | let selected = demuxed selectionDemux k 146 | mkChild k v selected 147 | 148 | 149 | ------------------------------------------------------------------------------ 150 | -- | Simple utility function to robustly get things like the current window, 151 | -- DOM document, document body, etc. 152 | waitUntilJust :: IO (Maybe a) -> IO a 153 | waitUntilJust a = do 154 | mx <- a 155 | case mx of 156 | Just x -> return x 157 | Nothing -> do 158 | threadDelay 10000 159 | waitUntilJust a 160 | 161 | -------------------------------------------------------------------------------- /webapi-reflex-dom/src/WebApi/Reflex/Dom.hs: -------------------------------------------------------------------------------- 1 | module WebApi.Reflex.Dom 2 | ( module WebApi.Reflex.Dom 3 | , module WebApi.Reflex.Dom.Router 4 | , module WebApi.Contract 5 | , module WebApi.Param 6 | , module Reflex.Dom.Contrib.MonadRouted 7 | , module Reflex.Dom.Contrib.Router 8 | ) where 9 | 10 | import WebApi.Contract 11 | import WebApi.Reflex.Dom.Router 12 | import WebApi.Param hiding ( link ) 13 | import Reflex.Dom.Contrib.MonadRouted 14 | import Reflex.Dom.Contrib.Router 15 | import Reflex hiding (Request, Response) 16 | import Reflex.Network 17 | import Control.Monad.Fix 18 | 19 | -- ^ `networkViewByParam` hold the view till param values selected from Request remains same 20 | networkViewByParam :: 21 | ( Eq par 22 | , NotReady t m 23 | , Adjustable t m 24 | , PostBuild t m 25 | , MonadHold t m 26 | , MonadFix m 27 | ) => (Request meth r -> par) -- ^ Param selector 28 | -> Dynamic t (Request meth r) -- ^ Request Dyn of the handler 29 | -> (par -> m a) -- ^ view to be rendered until param values changes 30 | -> m (Event t a) 31 | networkViewByParam sel reqDyn hand = networkView . (fmap hand) =<< (holdUniqDyn $ fmap sel reqDyn) 32 | -------------------------------------------------------------------------------- /webapi-reflex-dom/test/Devel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE DerivingStrategies #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE CPP #-} 16 | 17 | import Language.Javascript.JSaddle 18 | #ifndef ghcjs_HOST_OS 19 | import Language.Javascript.JSaddle.Warp 20 | #endif 21 | import Reflex.Dom.Core hiding (Request, Response) 22 | import WebApi.Reflex.Dom 23 | import GHC.Generics 24 | import qualified Data.Text as T 25 | 26 | main :: IO () 27 | main = do 28 | #ifndef ghcjs_HOST_OS 29 | run 3001 $ 30 | #endif 31 | mainWidget page 32 | 33 | page :: forall t m1 m. (Reflex t, MonadWidget t m) => m () 34 | page = do 35 | ev <- uiApp (defUIRequest @(Dom GET) @HomeR () ()) Nothing (text "404") (const $ text "400") (compactUIServer @SampleApp @m sampleAppApi) 36 | d <- holdDyn "" (T.pack . show <$> ev) 37 | dynText d 38 | pure () 39 | 40 | data QP = 41 | QP { f1 :: Int 42 | , f2 :: Double 43 | } deriving (Show, Eq, Generic) 44 | deriving anyclass (FromParam 'QueryParam, ToParam 'QueryParam) 45 | 46 | data SampleApp = SampleApp 47 | 48 | type instance MountPoint SampleApp = 'ApiMount SampleApp "" 49 | 50 | type HomeR = SampleApp :// "home" :/ "check" :/ "check" 51 | type Page1R = SampleApp :// "page1" 52 | type Page2R = SampleApp :// "page2" :/ Int 53 | type Page3R = SampleApp :// "page3" :/ Int 54 | 55 | instance WebApi SampleApp where 56 | type Apis SampleApp = 57 | '[ Route '[Dom GET] HomeR 58 | , Route '[Dom GET] Page1R 59 | , Route '[Dom GET] Page2R 60 | , Route '[Dom GET] Page3R 61 | ] 62 | 63 | instance ApiContract SampleApp (Dom GET) HomeR where 64 | type ApiOut (Dom GET) HomeR = () 65 | type OperationId (Dom GET) HomeR = 'OpId SampleApp "getHome" 66 | 67 | instance ApiContract SampleApp (Dom GET) Page1R where 68 | type ApiOut (Dom GET) Page1R = () 69 | type OperationId (Dom GET) Page1R = 'OpId SampleApp "getPage1" 70 | 71 | instance ApiContract SampleApp (Dom GET) Page2R where 72 | type ApiOut (Dom GET) Page2R = () 73 | type OperationId (Dom GET) Page2R = 'OpId SampleApp "getPage2" 74 | 75 | instance ApiContract SampleApp (Dom GET) Page3R where 76 | type ApiOut (Dom GET) Page3R = () 77 | type QueryParam (Dom GET) Page3R = QP 78 | type OperationId (Dom GET) Page3R = 'OpId SampleApp "getPage3" 79 | 80 | getHome' :: 81 | ( Applicative w 82 | , Reflex t 83 | , DomBuilder t w 84 | , MonadRouted t w 85 | ) => Dynamic t (Request (Dom GET) HomeR) -> (w (Response (Dom GET) HomeR)) 86 | getHome' _ = do 87 | el "div" $ text "Hello HomeR ............" 88 | el "div" $ do 89 | ev1 <- link "page1" 90 | navigate (defUIRequest @(Dom GET) @Page1R () () <$ _link_clicked ev1) 91 | el "div" $ do 92 | ev2 <- link "page2" 93 | navigate (defUIRequest @(Dom GET) @Page2R 10 () <$ _link_clicked ev2) 94 | el "div" $ do 95 | ev3 <- link "page3" 96 | navigate (defUIRequest @(Dom GET) @Page3R 15 (QP { f1 =10, f2= 15.5 }) <$ _link_clicked ev3) 97 | el "div" $ do 98 | ev4 <- link "404" 99 | redirectInternal ("/page4/zo" <$ _link_clicked ev4) 100 | el "div" $ do 101 | ev5 <- link "query-param-fail" 102 | redirectInternal ("/page3/15?f1=10" <$ _link_clicked ev5) 103 | respond () 104 | 105 | getPage1' :: 106 | ( Applicative w 107 | , Reflex t 108 | , DomBuilder t w 109 | , MonadRouted t w 110 | ) => Dynamic t (Request (Dom GET) Page1R) -> (w (Response (Dom GET) Page1R)) 111 | getPage1' _ = do 112 | text "Hello Page1" 113 | ev1 <- link "home" 114 | navigate (defUIRequest @(Dom GET) @HomeR () () <$ _link_clicked ev1) 115 | respond () 116 | 117 | getPage2' :: 118 | ( Applicative w 119 | , Reflex t 120 | , DomBuilder t w 121 | , MonadRouted t w 122 | , PostBuild t w 123 | ) => Dynamic t (Request (Dom GET) Page2R) -> (w (Response (Dom GET) Page2R)) 124 | getPage2' req = do 125 | text "Hello Page2" 126 | dynText (T.pack . show . pathParam <$> req) 127 | ev1 <- link "home" 128 | navigate (defUIRequest @(Dom GET) @HomeR () () <$ _link_clicked ev1) 129 | respond () 130 | 131 | getPage3' :: 132 | ( Applicative w 133 | , Reflex t 134 | , DomBuilder t w 135 | , MonadRouted t w 136 | ) => Dynamic t (Request (Dom GET) Page3R) -> (w (Response (Dom GET) Page3R)) 137 | getPage3' _ = do 138 | text "Hello Page3" 139 | ev1 <- link "home" 140 | navigate (defUIRequest @(Dom GET) @HomeR () () <$ _link_clicked ev1) 141 | respond () 142 | 143 | instance 144 | ( Applicative w 145 | , Reflex t 146 | , DomBuilder t w 147 | , MonadRouted t w 148 | ) => UIHandler w t SampleApp (Dom GET) HomeR where 149 | handler _ = getHome' 150 | 151 | 152 | instance 153 | ( Applicative w 154 | , Reflex t 155 | , DomBuilder t w 156 | , MonadRouted t w 157 | ) => UIHandler w t SampleApp (Dom GET) Page1R where 158 | handler _ = getPage1' 159 | 160 | instance 161 | ( Applicative w 162 | , Reflex t 163 | , DomBuilder t w 164 | , MonadRouted t w 165 | , PostBuild t w 166 | ) => UIHandler w t SampleApp (Dom GET) Page2R where 167 | handler _ = getPage2' 168 | 169 | instance 170 | ( Applicative w 171 | , Reflex t 172 | , DomBuilder t w 173 | , MonadRouted t w 174 | ) => UIHandler w t SampleApp (Dom GET) Page3R where 175 | handler _ = getPage3' 176 | 177 | data SampleAppApi t m = 178 | SampleAppApi { getHome :: Dynamic t (Request (Dom GET) HomeR) -> (m (Response (Dom GET) HomeR)) 179 | , getPage1 :: Dynamic t (Request (Dom GET) Page1R) -> (m (Response (Dom GET) Page1R)) 180 | , getPage2 :: Dynamic t (Request (Dom GET) Page2R) -> (m (Response (Dom GET) Page2R)) 181 | , getPage3 :: Dynamic t (Request (Dom GET) Page3R) -> (m (Response (Dom GET) Page3R)) 182 | } 183 | 184 | sampleAppApi :: 185 | forall t m. 186 | ( Reflex t 187 | , DomBuilder t m 188 | , Reflex t 189 | , DomBuilder t m 190 | , MonadRouted t m 191 | , PostBuild t m 192 | ) => SampleAppApi t m 193 | sampleAppApi = 194 | SampleAppApi { getHome = getHome' 195 | , getPage1 = getPage1' 196 | , getPage2 = getPage2' 197 | , getPage3 = getPage3' 198 | } 199 | 200 | instance WebUIServer SampleApp 201 | 202 | -------------------------------------------------------------------------------- /webapi-reflex-dom/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented." 5 | -------------------------------------------------------------------------------- /webapi-reflex-dom/webapi-reflex-dom.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webapi-reflex-dom 3 | version: 0.2.0.0 4 | 5 | -- A short (one-line) description of the package. 6 | -- synopsis: 7 | 8 | -- A longer description of the package. 9 | -- description: 10 | 11 | -- A URL where users can report bugs. 12 | -- bug-reports: 13 | 14 | -- The license under which the package is released. 15 | -- license: 16 | author: Magesh 17 | maintainer: magesh85@gmail.com 18 | 19 | -- A copyright notice. 20 | -- copyright: 21 | -- category: 22 | extra-source-files: 23 | CHANGELOG.md 24 | README.md 25 | 26 | library 27 | exposed-modules: WebApi.Reflex.Dom 28 | WebApi.Reflex.Dom.Router 29 | Reflex.Dom.Contrib.MonadRouted 30 | Reflex.Dom.Contrib.Router 31 | 32 | build-depends: base >=4.12.0.0 33 | , reflex-dom-core 34 | , reflex 35 | , webapi-contract 36 | , text 37 | , http-types 38 | , bytestring 39 | , jsaddle 40 | , jsaddle-dom 41 | , ghcjs-dom 42 | , lens 43 | , uri-bytestring 44 | , mtl 45 | , ref-tf 46 | , exception-transformers 47 | hs-source-dirs: src 48 | default-language: Haskell2010 49 | 50 | if impl(ghcjs) 51 | build-depends: ghcjs-base 52 | 53 | 54 | test-suite webapi-reflex-dom-test 55 | default-language: Haskell2010 56 | type: exitcode-stdio-1.0 57 | hs-source-dirs: test 58 | main-is: Devel.hs 59 | build-depends: base >=4.12.0.0 60 | , webapi-contract 61 | , jsaddle 62 | , reflex-dom-core 63 | , webapi-reflex-dom 64 | , reflex 65 | , text 66 | if !impl (ghcjs) 67 | build-depends: jsaddle-warp 68 | -- Modules included in this library but not exported. 69 | -- other-modules: 70 | 71 | -------------------------------------------------------------------------------- /webapi-swagger/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | webapi-swagger.cabal 3 | *~ -------------------------------------------------------------------------------- /webapi-swagger/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for webapi-swagger 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /webapi-swagger/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 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 Author name here 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 | -------------------------------------------------------------------------------- /webapi-swagger/README.md: -------------------------------------------------------------------------------- 1 | # webapi-swagger 2 | -------------------------------------------------------------------------------- /webapi-swagger/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi-swagger/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import GenerationCore 5 | import Options.Applicative 6 | import Data.Semigroup ((<>)) 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | 10 | data CodegenOpts = CodegenOpts { inPath :: Text 11 | , outPath :: Text 12 | , dhallPath :: Text 13 | , name :: Maybe Text 14 | , prefix :: Maybe Text 15 | , verbose :: Bool 16 | -- , isUrl :: Bool 17 | } deriving (Show, Eq) 18 | 19 | codegenProg :: ParserInfo CodegenOpts 20 | codegenProg = info codegenOpts (fullDesc <> 21 | progDesc "Haskell code generator for swagger" 22 | ) 23 | 24 | codegenOpts :: Parser CodegenOpts 25 | codegenOpts = 26 | CodegenOpts <$> strArgument ( metavar "SWAGGER-FILE-LOCATION" 27 | <> help "Location of swagger file" 28 | ) 29 | <*> strArgument ( metavar "OUTPUT-DIR" 30 | <> help "Directory of generated files" 31 | ) 32 | <*> strArgument ( metavar "DHALL-FILE-LOCATION" 33 | <> help "Directory of the Dhall Config file" 34 | ) 35 | <*> optional 36 | (strOption ( long "name" 37 | <> short 'n' 38 | <> metavar "NAME" 39 | <> help "Name of the generated project" 40 | ) 41 | ) 42 | <*> optional 43 | ( strOption ( long "prefix" 44 | <> short 'f' 45 | <> metavar "PREFIX" 46 | <> help "Prefix to name of generated project" 47 | ) 48 | ) 49 | <*> switch ( long "verbose" 50 | <> short 'v' 51 | <> help "See debug output" 52 | ) 53 | {- 54 | <*> switch ( long "url" 55 | <> short "u" 56 | <> help "Is input location a url" 57 | ) 58 | -} 59 | 60 | main :: IO () 61 | main = do 62 | opts <- execParser codegenProg 63 | runCodeGen (T.unpack (inPath opts)) 64 | (T.unpack (op opts)) 65 | (T.unpack (dhallPath opts)) 66 | (T.unpack (pName opts)) 67 | 68 | where op opts = case T.last (outPath opts) of 69 | '/' -> outPath opts 70 | _ -> outPath opts <> "/" 71 | 72 | pName opts = case name opts of 73 | Nothing -> case take 2 (reverse (T.splitOn "/" (inPath opts))) of 74 | ["", ""] -> error "Panic: invalid input path" 75 | ["", n] -> withPrefix (prefix opts) (T.toLower (stripExtension n)) 76 | [n, _] -> withPrefix (prefix opts) (T.toLower (stripExtension n)) 77 | _ -> error "Panic: impossible case triggered" 78 | Just n -> withPrefix (prefix opts) (T.toLower n) 79 | 80 | withPrefix Nothing n = n 81 | withPrefix (Just p) n = T.toLower p <> "-" <> n 82 | 83 | stripExtension n = head (T.splitOn "." n) 84 | -------------------------------------------------------------------------------- /webapi-swagger/src/ContractGenTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | 6 | module ContractGenTypes where 7 | 8 | -- import Data.Aeson 9 | -- import Data.Text as T 10 | import GHC.Generics 11 | -- import Network.HTTP.Types.Method 12 | import Data.HashMap.Strict 13 | import Control.Monad.Trans.State.Strict 14 | import qualified Data.Map.Lazy as Map 15 | import Data.Hashable 16 | import SwaggerGen 17 | 18 | 19 | type StateConfig a = StateT (HashMap LevelInfo [TypeInfo]) IO (a) 20 | 21 | 22 | type RouteName = String 23 | 24 | type RouteAndMethod = (RouteName, Method) 25 | 26 | -- data StdMethod 27 | -- = GET 28 | -- | POST 29 | -- | HEAD 30 | -- | PUT 31 | -- | DELETE 32 | -- | TRACE 33 | -- | CONNECT 34 | -- | OPTIONS 35 | -- | PATCH 36 | -- deriving (Show, Eq, Generic, Ord) 37 | 38 | -- instance Hashable StdMethod 39 | 40 | 41 | type DerivingClass = String 42 | -- old name, new name 43 | type ModifiedRecords = [(String, String)] 44 | 45 | 46 | data JsonDirection = ToJson | FromJson deriving (Eq) 47 | 48 | instance Show JsonDirection where 49 | show ToJson = "P.ToJSON" 50 | show FromJson = "P.FromJSON" 51 | 52 | data SumTypeCreation = CreateSumType CreateDataType | ExistingType String 53 | deriving (Eq, Show) 54 | 55 | 56 | data PathComponent = PathComp String | PathParamType String 57 | deriving (Eq, Show) 58 | 59 | data SwPathComponent = PathPiece String | PathParamName String 60 | deriving (Eq, Show) 61 | 62 | 63 | -- Phase 1 : Keep global Definitions as `Global DefinitionTy`, Keep all others as Local 64 | -- Need to add argument to getTypeFromSwaggerType function specifying whether Global or Local and next argument also (location/routeMethod) 65 | -- 66 | -- If too many errors, add all TypeInfo as `DefinitionType CreateDataType` 67 | 68 | -- Replace all CreateNewType with CreateDataType 69 | -- Replace all TypeAlias with NewType 70 | -- Replace the TypeAlias generation with NewType generation 71 | 72 | 73 | -- Phase 2 : Add retrieval from Global and add Global where applicable 74 | -- Add LevelInfo to ApiTypeDetails and include the new type, remove the old type. 75 | -- Add proper (appropriate) constructors for `TypeInfo`. 76 | 77 | 78 | data LevelInfo = Global GlobalLocalType | Local GlobalLocalType (RouteName, Method) 79 | deriving (Eq, Show, Generic) 80 | 81 | instance Hashable LevelInfo 82 | 83 | data GlobalLocalType = DefinitionTy | ResponseTy | ParamTy 84 | deriving (Eq, Show, Generic) 85 | 86 | instance Hashable GlobalLocalType 87 | 88 | 89 | data TypeInfo = ApiErrTy CreateDataType NamingCounter -- Depends on Content Type : JSON/XML/PlainText (XML left out for now) Including Nested Type. 90 | | ApiOutTy CreateDataType NamingCounter -- Depends on Content Type : JSON/XML/PlainText (XML left out for now) 91 | | FormParamTy CreateDataType NamingCounter -- FromParam FormParam / ToParam FormParam 92 | | QueryParamTy CreateDataType NamingCounter -- 93 | | FileParamTy CreateDataType NamingCounter -- 94 | | HeaderInTy CreateDataType NamingCounter -- 95 | | ReqBodyTy CreateDataType NamingCounter -- 96 | | ContentTypesTy CreateDataType NamingCounter -- 97 | | HeaderOutTy CreateDataType NamingCounter -- 98 | | DefinitionType CreateDataType NamingCounter -- 99 | deriving (Eq, Show, Generic) 100 | 101 | 102 | data TInfo = ApiErrI 103 | | ApiOutI 104 | | FormParamI 105 | | QueryParamI 106 | | FileParamI 107 | | HeaderInI 108 | | ReqBodyI 109 | | ContentTypesI 110 | | HeaderOutI 111 | | DefinitionI 112 | deriving (Eq, Show, Generic) 113 | 114 | data CreateDataType = SumType DualSumType | ProductType NewData OgName | HNewType String String OgName 115 | deriving (Eq, Show, Generic) 116 | 117 | -- The original name of the types as in the Swagger Doc. 118 | type OgName = String 119 | 120 | type NamingCounter = Maybe Int 121 | 122 | -- constructor, actual type 123 | data DualSumType = BasicEnum String [String] [String] | ComplexSumType String [(String, String)] 124 | deriving (Eq, Show, Generic) 125 | -- TODO : Verify if we need to store OgName for the types of ComplexSumType 126 | 127 | type InnerRecords = [(String, String)] 128 | 129 | data NewData = NewData 130 | { 131 | mName :: String -- Type/Data Constructor Name 132 | , mRecordTypes :: InnerRecords 133 | } deriving (Eq, Show, Generic) 134 | 135 | 136 | data ParamType = FormParam 137 | | QueryParam 138 | | FileParam 139 | | HeaderParam 140 | | BodyParam 141 | deriving (Eq, Show) 142 | 143 | data ContractDetails = ContractDetails 144 | { 145 | routeId :: Int 146 | , routeName :: String 147 | , routePath :: [PathComponent] 148 | , methodData :: Map.Map Method ApiTypeDetails 149 | } deriving (Eq, Show) 150 | 151 | 152 | data ApiTypeDetails = ApiTypeDetails 153 | { 154 | apiOut :: String 155 | , apiErr :: Maybe String 156 | , formParam :: Maybe String 157 | , queryParam :: Maybe String 158 | , fileParam :: Maybe String 159 | , headerIn :: Maybe String 160 | , requestBody :: Maybe String 161 | , contentTypes :: Maybe String 162 | , hasXML :: Bool 163 | -- TODO: cookie in/out and header out need to be added when we encounter them 164 | } deriving (Eq, Show) 165 | 166 | 167 | -- data ApiTypeDetails = ApiTypeDetails 168 | -- { 169 | -- apiOut :: (LevelInfo, String) 170 | -- , apiErr :: (LevelInfo, Maybe String) 171 | -- , formParam :: (LevelInfo, Maybe String) 172 | -- , queryParam :: (LevelInfo, Maybe String) 173 | -- , fileParam :: (LevelInfo, Maybe String) 174 | -- , headerIn :: (LevelInfo, Maybe String) 175 | -- , requestBody :: (LevelInfo, Maybe String) 176 | -- , contentTypes :: (LevelInfo, Maybe String) 177 | -- , headerOut :: (LevelInfo, Maybe String) 178 | -- , hasXML :: Bool 179 | -- } deriving (Eq, Show, Generic) -------------------------------------------------------------------------------- /webapi-swagger/src/HaskellValidation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module HaskellValidation where 5 | 6 | 7 | import Data.Char as Char 8 | import Data.List as DL 9 | import Constants 10 | 11 | setValidConstructorId :: String -> String 12 | setValidConstructorId str = 13 | let (_, validName) = setValidFieldName str 14 | in (Char.toUpper $ DL.head validName):(DL.tail validName) 15 | 16 | 17 | setValidFieldName :: String -> (Bool, String) 18 | setValidFieldName fldName = 19 | -- Replace invalidId Chars, check if hs keyword and modify else return 20 | let (isChanged, invalidsFixed) = fixInvalidId fldName 21 | in case isHsKeyword invalidsFixed of 22 | True -> (True, invalidsFixed ++ "_") 23 | False -> (isChanged, invalidsFixed) 24 | 25 | where 26 | isHsKeyword :: String -> Bool 27 | isHsKeyword str = DL.elem str haskellKeywords 28 | 29 | fixInvalidId :: String -> (Bool, String) 30 | fixInvalidId idVal 31 | | idVal == "" = error "Encountered potential empty Haskell Identifier! Please check the Swagger JSONx" 32 | | idVal == "_" = (True, "holeName") -- ?? TODO : Is this allowed? Discuss 33 | | idVal == "\'" = (True, "singleQuoteId") -- TODO : Is this allowed? 34 | | DL.length idVal == 1 && isValidHsIdChar (DL.head idVal) = (False, fmap Char.toLower idVal) 35 | | otherwise = do 36 | let newVal = replaceInvalidChars ("",DL.tail idVal) (DL.head idVal) 37 | let lCaseNewVal = makeFirstCharAlpha $ (Char.toLower $ DL.head newVal):(DL.tail newVal) 38 | case lCaseNewVal == idVal of 39 | True -> (False, lCaseNewVal) 40 | False -> (True, lCaseNewVal) 41 | 42 | where 43 | 44 | replaceInvalidChars :: (String, String) -> Char -> String 45 | replaceInvalidChars (prev, next) currentChar = 46 | if isValidHsIdChar currentChar && (not $ DL.null next) 47 | then replaceInvalidChars (prev ++ [currentChar], DL.tail next) (DL.head next) 48 | else if isValidHsIdChar currentChar 49 | then prev ++ [currentChar] 50 | -- check for a prefix of invalid chars and return the rest of the next chars 51 | else do 52 | let newNext = snd $ DL.break isValidHsIdChar next 53 | case DL.null newNext of 54 | True -> prev ++ "_" 55 | False -> replaceInvalidChars (prev ++ "_", DL.tail newNext ) (DL.head newNext) 56 | 57 | isValidHsIdChar :: Char -> Bool 58 | isValidHsIdChar x = (Char.isAlphaNum x) || x == '_' || x == '\'' 59 | 60 | makeFirstCharAlpha :: String -> String 61 | makeFirstCharAlpha inpString = 62 | case inpString of 63 | [] -> error "Encountered potential empty Haskell Identifier! Please check the Swagger JSON!" 64 | firstChar:_ -> 65 | case Char.isAlpha firstChar of 66 | True -> inpString 67 | False -> 'h':inpString 68 | -------------------------------------------------------------------------------- /webapi-swagger/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /webapi-swagger/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import System.Environment 6 | import Network.HTTP.Client 7 | import qualified Data.Text as T 8 | import Data.Typeable 9 | import Control.Exception 10 | import Network.HTTP.Types 11 | import qualified Data.ByteString.Lazy as BSL 12 | import ContractGen 13 | import System.Directory 14 | import Control.Monad 15 | import System.Process 16 | import Network.HTTP.Client.TLS 17 | 18 | data InvalidURL = InvalidURL T.Text 19 | deriving (Show, Typeable) 20 | 21 | data InvalidArgs = InvalidArgs 22 | deriving (Show, Typeable) 23 | 24 | instance Exception InvalidURL 25 | instance Exception InvalidArgs 26 | 27 | data Opt = URL 28 | | FP 29 | deriving (Show, Eq) 30 | 31 | main :: IO () 32 | main = do 33 | args <- getArgs 34 | body <- case args of 35 | [ path ] -> do 36 | BSL.readFile path 37 | [ opt, path ] -> do 38 | case parseOpt opt of 39 | Just URL -> fetchFromURL path 40 | Just FP -> BSL.readFile path 41 | Nothing -> throwIO InvalidArgs 42 | _ -> throwIO InvalidArgs 43 | triggerCodegen body 44 | 45 | 46 | where triggerCodegen body = do 47 | let swPath = "/tmp/swagger.json" 48 | cgPath = "/tmp/out/" 49 | cbPath = cgPath <> pkgname 50 | pkgname = "genswagger" 51 | cabalCommand = "cabal new-build" 52 | cgPathExists <- doesPathExist cgPath 53 | when cgPathExists (removeDirectoryRecursive cgPath) 54 | createDirectory cgPath 55 | BSL.writeFile swPath body 56 | runCodeGen swPath cgPath pkgname 57 | _ <- createProcess ((shell cabalCommand) { cwd = Just cbPath }) 58 | return () 59 | 60 | fetchFromURL url = do 61 | manager <- newManager tlsManagerSettings 62 | request <- parseRequest url 63 | response <- httpLbs request manager 64 | case responseStatus response == status200 of 65 | True -> pure (responseBody response) 66 | False -> throwIO (InvalidURL (T.pack url)) 67 | 68 | 69 | 70 | parseOpt "--url" = Just URL 71 | parseOpt "--file" = Just FP 72 | parseOpt _ = Nothing 73 | -------------------------------------------------------------------------------- /webapi-swagger/webapi-swagger.cabal: -------------------------------------------------------------------------------- 1 | name: webapi-swagger 2 | version: 0.1.0.0 3 | description: Generate and consume swagger specification for webapi contracts 4 | homepage: http://byteally.github.io/webapi/ 5 | bug-reports: https://github.com/byteally/webapi/issues 6 | author: Magesh B 7 | maintainer: magesh85@gmail.com 8 | copyright: 2018 Byteally 9 | license: BSD3 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | extra-source-files: 14 | ChangeLog.md 15 | README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/byteally/webapi 20 | 21 | library 22 | exposed-modules: 23 | SwaggerGen 24 | GenerationCore 25 | Constants 26 | ContractGenTypes 27 | HaskellValidation 28 | 29 | other-modules: 30 | Paths_webapi_swagger 31 | hs-source-dirs: 32 | src 33 | build-depends: 34 | base >= 4.9 && < 5 35 | , text >= 1.2 && < 1.3 36 | , swagger2 >= 2.3 && < 2.7 37 | , aeson >= 1.0 && < 1.5 38 | , bytestring >= 0.10 && < 0.11 39 | , insert-ordered-containers >= 0.2 && < 0.3 40 | , haskell-src-exts 41 | , directory 42 | , webapi == 0.4.* 43 | , vector-sized >= 1.0 && < 1.5 44 | , safe >= 0.3 && < 0.4 45 | , finite-typelits 46 | , split 47 | , unordered-containers >= 0.2.6 && < 0.3 48 | , containers >= 0.5 && < 0.7 49 | , http-types >= 0.9 && < 0.13 50 | , transformers >= 0.5 && < 0.6 51 | , webapi-contract == 0.4.* 52 | , vector >= 0.11 && < 0.13 53 | , time >= 1.6 && < 1.10 54 | , interpolate >= 0.2 && < 0.3 55 | , yaml >= 0.8 && < 0.12 56 | , hashable 57 | , mtl 58 | , megaparsec >= 7.0 && < 9 59 | , http-media 60 | , dhall >= 1.20 && < 2 61 | 62 | default-language: Haskell2010 63 | ghc-options: -Wall -Werror -O2 64 | 65 | executable init-swagger-project 66 | main-is: Main.hs 67 | other-modules: 68 | Paths_webapi_swagger 69 | hs-source-dirs: 70 | app 71 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror 72 | build-depends: 73 | base >=4.7 && <5 74 | , webapi-swagger 75 | , optparse-applicative >= 0.14 && < 0.16 76 | , text 77 | default-language: Haskell2010 78 | 79 | test-suite webapi-swagger-test 80 | type: exitcode-stdio-1.0 81 | main-is: Main.hs 82 | other-modules: 83 | Paths_webapi_swagger 84 | hs-source-dirs: 85 | test 86 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 87 | build-depends: 88 | base >=4.7 && <5 89 | , http-client 90 | , webapi-swagger 91 | , text 92 | , http-types 93 | , bytestring 94 | , directory 95 | , process 96 | , http-client-tls 97 | 98 | default-language: Haskell2010 99 | -------------------------------------------------------------------------------- /webapi-xml/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /webapi-xml/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for webapi-xml 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /webapi-xml/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 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 Author name here 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 | -------------------------------------------------------------------------------- /webapi-xml/README.md: -------------------------------------------------------------------------------- 1 | # webapi-xml 2 | -------------------------------------------------------------------------------- /webapi-xml/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi-xml/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = someFunc 7 | -------------------------------------------------------------------------------- /webapi-xml/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /webapi-xml/src/WebApi/XML.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : WebApi.XML 3 | License : BSD3 4 | Stability : experimental 5 | -} 6 | 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE TupleSections #-} 18 | {-# LANGUAGE OverloadedStrings #-} 19 | 20 | module WebApi.XML (XML) where 21 | 22 | import Data.Text.Lazy.Encoding (encodeUtf8Builder) 23 | -- import qualified Data.ByteString as SB 24 | -- import Data.ByteString.Lazy (ByteString) 25 | import Data.Maybe (fromMaybe) 26 | import Data.Proxy 27 | import qualified Data.Text as T 28 | -- import qualified Data.Text.Lazy as LT 29 | import Data.Text.Lazy.Encoding (decodeUtf8) 30 | import Network.HTTP.Media.MediaType 31 | import Network.HTTP.Media (mapContentMedia) 32 | import WebApi.Util 33 | import WebApi.Contract (JSON, PlainText) 34 | import WebApi.ContentTypes 35 | import Data.ByteString.Builder (lazyByteString, Builder) 36 | import Text.XML (Element, renderLBS, parseLBS, def) 37 | -- | Type representing content type of @application/xml@. 38 | data XML 39 | 40 | instance Accept XML where 41 | contentType _ = "application" // "xml" 42 | 43 | instance (ToXML a) => Encode XML a where 44 | encode _ = lazyByteString . renderLBS def . mkDoc . toXML 45 | where mkDoc = undefined 46 | 47 | instance (FromXML a) => Decode XML a where 48 | decode _ = either (Left . show) Right . fromXML . fromDoc . parseLBS def 49 | where fromDoc = undefined 50 | 51 | class ToXML a where 52 | toXML :: a -> Element 53 | 54 | class FromXML a where 55 | fromXML :: Element -> Either T.Text a 56 | 57 | -- class (ToXML a) => Encode a where 58 | -- encode 59 | 60 | -- Define few types and try to write the ToXML and FromXML instances, from there we will try to write GToXML and GFromXML which gives us an idea on how to write the generic instances 61 | -------------------------------------------------------------------------------- /webapi-xml/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /webapi-xml/webapi-xml.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 937f1fa0b4f36c84dbec042f843190e6420cb28a4b87572ebafe38344f083a0e 8 | 9 | name: webapi-xml 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/webapi-xml#readme 13 | bug-reports: https://github.com/githubuser/webapi-xml/issues 14 | author: Author name here 15 | maintainer: example@example.com 16 | copyright: 2018 Author name here 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/githubuser/webapi-xml 27 | 28 | library 29 | exposed-modules: 30 | Lib 31 | WebApi.XML 32 | other-modules: 33 | Paths_webapi_xml 34 | hs-source-dirs: 35 | src 36 | build-depends: 37 | base >=4.7 && <5 38 | , aeson 39 | , text 40 | , webapi-contract 41 | , http-media 42 | , case-insensitive 43 | , bytestring 44 | , xml-conduit 45 | default-language: Haskell2010 46 | 47 | executable webapi-xml-exe 48 | main-is: Main.hs 49 | other-modules: 50 | Paths_webapi_xml 51 | hs-source-dirs: 52 | app 53 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 54 | build-depends: 55 | base >=4.7 && <5 56 | , webapi-xml 57 | default-language: Haskell2010 58 | 59 | test-suite webapi-xml-test 60 | type: exitcode-stdio-1.0 61 | main-is: Spec.hs 62 | other-modules: 63 | Paths_webapi_xml 64 | hs-source-dirs: 65 | test 66 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 67 | build-depends: 68 | base >=4.7 && <5 69 | , webapi-xml 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /webapi/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## 0.3 4 | * WebApiImplementation typeclass is renamed to WebApiServer 5 | * Swapped the order of FromParam and ToParam class parameters. 6 | * Fixed TmpFileBackend for file upload. 7 | * Added fieldModifier to ParamSettings. 8 | * Added support for cookie attributes. 9 | * Fixed RequestBody content type matching. 10 | 11 | ## 0.2.2 12 | * Added support for GHC 8 13 | 14 | ## 0.2.1 15 | 16 | * Added `RequestBody` to the `Request` type. This allows user to have content in request's body with the desired `Content-Type`. 17 | * Added `Request` pattern synonym. 18 | * Added `Field` data type for aliasing field names. 19 | -------------------------------------------------------------------------------- /webapi/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, byteally 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of webapi nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /webapi/README.md: -------------------------------------------------------------------------------- 1 | webapi 2 | ======== 3 | 4 | Introduction to **WebApi** 5 | -------------------------- 6 | 7 | [`Webapi`](https://hackage.haskell.org/package/webapi) is a Haskell library that lets you 8 | 9 | * Write web API services 10 | * Quickly build Haskell client for existing API services 11 | * Generate API console interface for your web API ([coming soon](https://github.com/byteally/webapi-console)) 12 | * Generate a mock server that can mock your responses and requests too. 13 | 14 | 15 | Please take a look at for more details. 16 | -------------------------------------------------------------------------------- /webapi/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /webapi/src/WebApi.hs: -------------------------------------------------------------------------------- 1 | module WebApi 2 | ( module WebApi.Contract 3 | , module WebApi.ContentTypes 4 | , module WebApi.Server 5 | , module WebApi.Client 6 | , module WebApi.Param 7 | , module WebApi.Mock 8 | ) where 9 | 10 | import WebApi.Contract 11 | import WebApi.ContentTypes 12 | import WebApi.Server 13 | import WebApi.Client 14 | import WebApi.Param 15 | import WebApi.Mock 16 | -------------------------------------------------------------------------------- /webapi/src/WebApi/Mock.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : WebApi.Mock 3 | License : BSD3 4 | Stability : experimental 5 | 6 | Once a contract is defined for a web api, a mock server and client for it can be obtained. 'Arbitrary' instances of the data types used in 'Request' and 'Response' is used to generate the request and response. Note that if a different mocking behaviour is required, it is easy enough to write a different implementation. Please take a look at the reference implementation of 'MockServer' for details. 7 | -} 8 | 9 | {-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DataKinds, FlexibleContexts, ScopedTypeVariables, DeriveGeneric #-} 10 | module WebApi.Mock 11 | ( 12 | -- * Mock Server 13 | mockServerSettings 14 | , mockResponse 15 | , mockServer 16 | , MockServer (..) 17 | , MockServerSettings (..) 18 | , MockServerException (..) 19 | , ResponseData (..) 20 | 21 | -- * Mock Client 22 | , mockClient 23 | ) where 24 | 25 | import Control.Exception 26 | import Data.Typeable (Typeable) 27 | import GHC.Generics (Generic) 28 | import Network.HTTP.Types (Status, ok200) 29 | import qualified Network.Wai as Wai 30 | import WebApi.Internal 31 | import WebApi.Contract 32 | import WebApi.ContentTypes 33 | import WebApi.Server 34 | import WebApi.Util 35 | import Test.QuickCheck (Arbitrary, generate, arbitrary) 36 | 37 | -- | Datatype representing a mock server. The parameterization over `p` allows it to be a mock server for any `p`. 38 | newtype MockServer p = MockServer { mockServerSett :: MockServerSettings } 39 | deriving (Eq, Show) 40 | 41 | -- | Determine the data constructor of `Response` to be generated in `mockServer`. 42 | data ResponseData = SuccessData 43 | | ApiErrorData Status 44 | | OtherErrorData 45 | deriving (Eq, Show) 46 | 47 | -- | Settings related to mock server. 48 | data MockServerSettings = MockServerSettings { responseData :: ResponseData } 49 | deriving (Eq, Show) 50 | 51 | -- | Default mock server settings. 52 | mockServerSettings :: MockServerSettings 53 | mockServerSettings = MockServerSettings SuccessData 54 | 55 | instance (WebApi p) => WebApiServer (MockServer p) where 56 | type ApiInterface (MockServer p) = p 57 | 58 | instance ( ApiContract p m r 59 | , Arbitrary (ApiOut m r) 60 | , Arbitrary (ApiErr m r) 61 | , Arbitrary (HeaderOut m r) 62 | , Arbitrary (CookieOut m r) 63 | , Typeable m 64 | , Typeable r 65 | ) => ApiHandler (MockServer p) m r where 66 | handler mock _ = mockResponse (Res :: Resource m r) ((mockServerSett . unTagged) mock) 67 | 68 | -- | Create a mock response from endpoint information and `MockServerSettings` 69 | mockResponse :: forall route m r. ( Arbitrary (ApiOut m r) 70 | , Arbitrary (HeaderOut m r) 71 | , Arbitrary (CookieOut m r) 72 | , Arbitrary (ApiErr m r) 73 | , Typeable m 74 | , Typeable r 75 | ) => route m r -> MockServerSettings -> IO (Response m r) 76 | mockResponse _ msett = case responseData msett of 77 | SuccessData -> mockSuccess 78 | ApiErrorData st -> mockApiError st 79 | OtherErrorData -> mockOtherError 80 | 81 | where mockSuccess :: IO (Response m r) 82 | mockSuccess = do 83 | aout <- generate arbitrary 84 | hout <- generate arbitrary 85 | cout <- generate arbitrary 86 | respondWith ok200 aout hout cout 87 | 88 | mockApiError :: Status -> IO (Response m r) 89 | mockApiError status = do 90 | aerr <- generate arbitrary 91 | herr <- generate arbitrary 92 | cerr <- generate arbitrary 93 | raiseWith status aerr herr cerr 94 | 95 | mockOtherError :: IO (Response m r) 96 | mockOtherError = do 97 | oerr <- generate arbitrary 98 | return (Failure (Right (OtherError (SomeException $ MockServerException oerr)))) 99 | 100 | -- | Datatype representing a mock exception. This exception will be put inside `OtherError`. 101 | data MockServerException = MockServerException { exceptionMsg :: String } 102 | deriving (Show, Generic) 103 | 104 | instance Exception MockServerException 105 | 106 | -- | Create a mock server. 107 | mockServer :: (Router (MockServer p) (Apis p) '(CUSTOM "", '[])) => ServerSettings -> MockServer p -> Wai.Application 108 | mockServer = serverApp 109 | 110 | -- | Create a mock client. 111 | mockClient :: ( Arbitrary (PathParam m r) 112 | , Arbitrary (QueryParam m r) 113 | , Arbitrary (FormParam m r) 114 | , Arbitrary (FileParam m r) 115 | , Arbitrary (HeaderIn m r) 116 | , Arbitrary (CookieIn m r) 117 | , Arbitrary (HListToTuple (StripContents (RequestBody m r))) 118 | , SingMethod m 119 | ) => route m r -> IO (Request m r) 120 | mockClient _ = 121 | Request <$> generate arbitrary 122 | <*> generate arbitrary 123 | <*> generate arbitrary 124 | <*> generate arbitrary 125 | <*> generate arbitrary 126 | <*> generate arbitrary 127 | <*> generate arbitrary 128 | -------------------------------------------------------------------------------- /webapi/src/WebApi/Server.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : WebApi.Server 3 | License : BSD3 4 | Stability : experimental 5 | 6 | Provides the implementation of web api. Given a contract, an implementation of the web api can be provided by using 'WebApiServer' and 'ApiHandler'. 'WebApiServer' has the information pertaining to web api as a whole. 'ApiHandler' provides a way to write the handler for a particular API end point. 7 | 8 | Comparing with the "WebApi.Contract", 'WebApi' and 'ApiContract' has the same relationship as 'WebApiServer' and 'ApiHandler'. 9 | -} 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE MultiParamTypeClasses #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE ExplicitForAll #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | module WebApi.Server 19 | ( 20 | -- * Creating a WAI application 21 | serverApp 22 | , serverSettings 23 | , nestedServerApp 24 | , nestedApi 25 | , apiComponent 26 | , mount 27 | , ServerSettings 28 | 29 | -- * Implementation of Api 30 | , ApiHandler (..) 31 | , ApiException (..) 32 | , WebApiServer (..) 33 | , WebApiRequest 34 | , rawRequest 35 | , respond 36 | , respondWith 37 | , raise 38 | , raiseWith 39 | 40 | -- * Wrapping and unwrapping a 'Tagged' 41 | , unTagged 42 | , toTagged 43 | 44 | -- * Routing 45 | , module WebApi.Router 46 | 47 | -- * Compact Server 48 | , module WebApi.ServerCompact 49 | ) where 50 | 51 | import Control.Monad.Catch 52 | import Data.Proxy 53 | import Data.Typeable 54 | import Network.HTTP.Types hiding (Query) 55 | import qualified Network.Wai as Wai 56 | import WebApi.Contract 57 | import WebApi.Internal 58 | import WebApi.Router 59 | import GHC.TypeLits 60 | import WebApi.ServerCompact 61 | 62 | -- | Creates a successful response from its components. It is assumed that 'HeaderOut' and 'CookieOut' has default definitions. 63 | respond :: ( Monad handM 64 | , (HeaderOut m r) ~ () 65 | , (CookieOut m r) ~ () 66 | ) => ApiOut m r 67 | -> handM (Response m r) 68 | respond out = respondWith ok200 out () () 69 | 70 | -- | Creates a successful response from its components. 71 | respondWith :: ( Monad handM 72 | ) => Status 73 | -> ApiOut m r 74 | -> HeaderOut m r 75 | -> CookieOut m r 76 | -> handM (Response m r) 77 | respondWith status out hdrs cook = return $ Success status out hdrs cook 78 | 79 | -- | This function short circuits returning an `ApiError`.It is assumed that 'HeaderOut' and 'CookieOut' has default definitions. 80 | raise :: ( MonadThrow handM 81 | , Typeable m 82 | , Typeable r 83 | ) => Status 84 | -> ApiErr m r 85 | -> handM (Response m r) 86 | raise status errs = raiseWith' (ApiError status errs Nothing Nothing) 87 | 88 | -- | This function short circuits returning an `ApiError`. 89 | raiseWith :: ( MonadThrow handM 90 | , Typeable m 91 | , Typeable r 92 | ) => Status 93 | -> ApiErr m r 94 | -> HeaderOut m r 95 | -> CookieOut m r 96 | -> handM (Response m r) 97 | raiseWith status errs hdrs cook = raiseWith' (ApiError status errs (Just hdrs) (Just cook)) 98 | 99 | raiseWith' :: ( MonadThrow handM 100 | , Typeable m 101 | , Typeable r 102 | ) => ApiError m r 103 | -> handM (Response m r) 104 | raiseWith' = throwM . ApiException 105 | 106 | -- | Create a WAI application from the information specified in `WebApiServer`, `WebApi`, `ApiContract` and `ApiHandler` classes. 107 | serverApp :: ( iface ~ (ApiInterface server) 108 | , Router server (Apis iface) '(CUSTOM "", '[]) 109 | ) => ServerSettings -> server -> Wai.Application 110 | serverApp _ server = toApplication $ router (apis server) server 111 | where apis :: server -> Proxy (Apis (ApiInterface server)) 112 | apis = const Proxy 113 | 114 | 115 | nestedServerApp :: 116 | ( Router (NestedApplication (app: apps)) 'NestedR '(CUSTOM "", '[]) 117 | ) => NestedApplication (app: apps) -> Wai.Application 118 | nestedServerApp apps = toApplication $ router (Proxy :: Proxy 'NestedR) apps 119 | 120 | mount :: forall (ns :: Symbol) c apps. 121 | ApiComponent c 122 | -> NestedApplication apps 123 | -> NestedApplication ('(ns, ApiInterface c) ': apps) 124 | mount (ApiComponent comp) (NestedApplication apps) = NestedApplication (comp:apps) 125 | 126 | apiComponent :: ( Router server (Apis (ApiInterface server)) '(CUSTOM "", '[]) 127 | ) => server -> ApiComponent server 128 | apiComponent serv = ApiComponent $ serverApp ServerSettings serv 129 | -------------------------------------------------------------------------------- /webapi/src/WebApi/ServerCompact.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE AllowAmbiguousTypes #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | module WebApi.ServerCompact 14 | ( CompactServer (..) 15 | , GetOpIdName 16 | ) where 17 | 18 | import GHC.Records 19 | import GHC.TypeLits 20 | import WebApi.Contract 21 | import WebApi.Internal 22 | import Data.Type.Equality 23 | import Control.Monad.Catch 24 | import Control.Monad.IO.Class 25 | import Data.Kind 26 | 27 | data CompactServer (api :: Type) (server :: (Type -> Type) -> Type) (eff :: Type -> Type) = CompactServer (forall a.WebApiRequest -> eff a -> IO a) (server eff) 28 | 29 | instance (WebApi api, MonadCatch eff, MonadIO eff) => WebApiServer (CompactServer api s eff) where 30 | type HandlerM (CompactServer api s eff) = eff 31 | type ApiInterface (CompactServer api s eff) = api 32 | toIO (CompactServer toIO' _) = toIO' 33 | 34 | instance ( ApiContract api m r 35 | , opname ~ GetOpIdName api (OperationId m r) 36 | , HasField (GetOpIdName api (OperationId m r)) (server eff) handler 37 | , UnifyHandler (handler == (Request m r -> eff (Response m r))) server opname handler (Request m r -> eff (Response m r)) 38 | ) => ApiHandler (CompactServer api server eff) m r where 39 | handler (Tagged (CompactServer _ server)) = unifyHandler @((handler == (Request m r -> eff (Response m r)))) @server @opname $ getField @(GetOpIdName api (OperationId m r)) server 40 | 41 | class UnifyHandler (isEq :: Bool) (server :: (Type -> Type) -> Type) (fn :: Symbol) handlerAct handlerExp where 42 | unifyHandler :: handlerAct -> handlerExp 43 | 44 | 45 | instance (handlerAct ~ handlerExp) => UnifyHandler 'True s fn handlerAct handlerExp where 46 | unifyHandler = id 47 | {-# INLINE unifyHandler #-} 48 | 49 | instance (TypeError 50 | ( 'Text "Type mismatch in the handler field of server: " ':<>: 'ShowType server ':$$: 51 | 'Text "Expected: " ':<>: ('Text fn) ':<>: 'Text " :: " ':<>: 'ShowType handlerExp ':$$: 52 | 'Text "Actual: " ':<>: ('Text fn) ':<>: 'Text " :: " ':<>: 'ShowType handlerAct 53 | )) => UnifyHandler 'False server fn handlerAct handlerExp where 54 | unifyHandler = error "Panic: Unreachable code" 55 | {-# INLINE unifyHandler #-} 56 | 57 | type family GetOpIdName api (opId :: OpId) :: Symbol where 58 | GetOpIdName _ ('OpId _ n) = n 59 | GetOpIdName api ('UndefinedOpId m r) = TypeError ('Text "Compact Server requires OperationId to be defined for every ApiContract instance of " ':<>: 'ShowType api ':$$: 60 | 'Text "Fix: Define OperationId for instance ApiContract " ':<>: 'ShowType m ':<>: 'Text " (" ':<>: 'ShowType r ':<>: 'Text ")" ':$$: 61 | 'Text "Example: type OperationId " ':<>: 'ShowType m ':<>: 'Text " (" ':<>: 'ShowType r ':<>: 'Text ") = 'OpId " ':<>: 'ShowType api ':<>: 'Text " " 62 | ) 63 | 64 | -------------------------------------------------------------------------------- /webapi/tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /webapi/tests/WebApi/MockSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 2 | {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} 3 | module WebApi.MockSpec (spec) where 4 | 5 | import Data.Aeson 6 | import GHC.Generics 7 | import WebApi hiding (get, post, put) 8 | import Test.Hspec 9 | import Test.Hspec.Wai 10 | import Test.QuickCheck 11 | import qualified Network.Wai as Wai 12 | 13 | withApp :: SpecWith ((), Wai.Application) -> Spec 14 | --withApp :: Wai.Application -> Spec 15 | withApp = with (return mockApp) 16 | 17 | mockApp :: Wai.Application 18 | mockApp = mockServer serverSettings (MockServer mockServerSettings :: MockServer MockSpec) 19 | 20 | data MockSpec 21 | 22 | type MockApi = Static "mock" 23 | 24 | data QP = QP { qp1 :: Int, qp2 :: Bool } 25 | deriving (Show, Eq, Generic) 26 | 27 | data MockOut = MockOut { out1 :: Int 28 | , out2 :: Bool 29 | , out3 :: Char 30 | } deriving (Show, Eq, Generic) 31 | 32 | instance ToJSON MockOut where 33 | instance FromParam 'QueryParam QP where 34 | instance Arbitrary MockOut where 35 | arbitrary = MockOut <$> arbitrary 36 | <*> arbitrary 37 | <*> arbitrary 38 | 39 | instance WebApi MockSpec where 40 | type Apis MockSpec = '[ Route '[GET] MockApi ] 41 | 42 | instance ApiContract MockSpec GET MockApi where 43 | type QueryParam GET MockApi = QP 44 | type ApiOut GET MockApi = MockOut 45 | type ApiErr GET MockApi = () 46 | 47 | 48 | spec :: Spec 49 | spec = withApp $ describe "WebApi mockserver" $ do 50 | it "should be 200 ok" $ do 51 | get "mock?qp1=5&qp2=True" `shouldRespondWith` 200 52 | -------------------------------------------------------------------------------- /webapi/tests/WebApi/ParamSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 2 | {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} 3 | module WebApi.ParamSpec (spec) where 4 | 5 | import WebApi 6 | import GHC.Generics 7 | import Data.Text 8 | import Test.Hspec 9 | 10 | data User = User { name :: Text 11 | , age :: Int 12 | } deriving (Show, Eq, Generic) 13 | 14 | instance FromParam 'FormParam User 15 | 16 | {- TODO: Fix the failing test 17 | -- When Maybe T is configure as param in contract, param overflow in case of Nothing :: Maybe T causes problem. One sol might be forcing a additional constraint like HasKeys when a Maybe is configured in the contract 18 | -} 19 | spec = describe "extra keys should be ignored when using Maybe at top level" $ do 20 | pure () {- 21 | it "should return Nothing" $ 22 | fromFormParam [ ("key", "value") 23 | ] == (Validation (Right Nothing) :: Validation [ParamErr] (Maybe User)) 24 | -} 25 | 26 | -------------------------------------------------------------------------------- /webapi/tests/WebApi/RequestSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 2 | {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} 3 | module WebApi.RequestSpec (spec) where 4 | 5 | import WebApi 6 | import Data.Aeson 7 | import Data.Text (Text) 8 | import Network.HTTP.Types.Method (methodPut, methodDelete, methodHead 9 | ,methodPatch, methodConnect, methodTrace, methodOptions) 10 | import Test.Hspec 11 | import Test.Hspec.Wai (with, request, shouldRespondWith, postHtmlForm, matchStatus) 12 | import qualified Test.Hspec.Wai as Hspec.Wai (get) 13 | import GHC.Generics 14 | import Data.ByteString (ByteString) 15 | import Data.Monoid ((<>)) 16 | import Data.List (foldl') 17 | import qualified Network.Wai as Wai 18 | import Data.CaseInsensitive (mk) 19 | import Network.HTTP.Types.Header (Header, hCookie) 20 | import Prelude hiding (FilePath) 21 | 22 | --withApp :: SpecWith Wai.Application -> Spec 23 | withApp :: SpecWith ((),Wai.Application) -> Spec 24 | withApp = with (return reqSpecApp) 25 | 26 | reqSpecApp :: Wai.Application 27 | reqSpecApp = serverApp serverSettings ReqSpecImpl 28 | 29 | data ReqSpec 30 | data ReqSpecImpl = ReqSpecImpl 31 | 32 | {- 33 | data Profile = Profile { name :: Text, age :: Age , desc :: Text } 34 | deriving (Show, Eq, Generic) 35 | 36 | newtype Age = Age { unAge :: Int } 37 | deriving (Show, Eq, Generic) 38 | -} 39 | 40 | data QP = QP { qp1 :: Int , qp2 :: Maybe Bool, qp3 :: Either Text Double } 41 | deriving (Show, Eq, Generic) 42 | 43 | data FoP = FoP { fop :: ByteString } 44 | deriving (Show, Eq, Generic) 45 | 46 | data CP = CP { cp :: Bool } 47 | deriving (Show, Eq, Generic) 48 | 49 | data HP = HP1 { hp1 :: Int } 50 | | HP2 { hp2 :: Bool } 51 | deriving (Show, Eq, Generic) 52 | 53 | data FiP = FiP { fip :: FileInfo } 54 | deriving (Show, Eq, Generic) 55 | 56 | data RB = RB { rb :: Text } 57 | deriving (Show, Eq, Generic) 58 | 59 | instance FromParam 'QueryParam QP where 60 | instance FromParam 'FormParam FoP where 61 | instance FromParam 'Cookie CP where 62 | instance FromHeader HP where 63 | instance FromParam 'FileParam FiP where 64 | 65 | instance ToParam 'QueryParam QP where 66 | instance ToParam 'FormParam FoP where 67 | instance ToParam 'Cookie CP where 68 | instance ToHeader HP where 69 | instance ToParam 'FileParam FiP where 70 | 71 | instance FromJSON RB 72 | 73 | type ApiR = Static "api" 74 | -- type QuickCheckR = Static "autogen" 75 | 76 | instance WebApi ReqSpec where 77 | type Version ReqSpec = () 78 | type Apis ReqSpec = '[ Route '[ GET 79 | , POST 80 | , PUT 81 | , DELETE 82 | , HEAD 83 | , PATCH 84 | , TRACE 85 | , CONNECT 86 | , (CUSTOM ("TEST")) 87 | , OPTIONS 88 | ] ApiR 89 | ] 90 | 91 | instance WebApiServer ReqSpecImpl where 92 | type ApiInterface ReqSpecImpl = ReqSpec 93 | 94 | instance ApiContract ReqSpec GET ApiR where 95 | type QueryParam GET ApiR = QP 96 | type ApiOut GET ApiR = () 97 | 98 | instance ApiContract ReqSpec POST ApiR where 99 | type QueryParam POST ApiR = QP 100 | -- type FileParam POST ApiR = FiP 101 | -- type HeaderIn POST ApiR = HP 102 | -- type CookieIn POST ApiR = CP 103 | type FormParam POST ApiR = FoP 104 | type ApiOut POST ApiR = () 105 | type ApiErr POST ApiR = Text 106 | 107 | instance ApiContract ReqSpec PUT ApiR where 108 | -- type QueryParam PUT ApiR = QP 109 | type HeaderIn PUT ApiR = HP 110 | type CookieIn PUT ApiR = CP 111 | -- type FormParam PUT ApiR = FoP 112 | type RequestBody PUT ApiR = '[RB] 113 | type ApiOut PUT ApiR = () 114 | type ApiErr PUT ApiR = Text 115 | 116 | instance ApiContract ReqSpec DELETE ApiR where 117 | -- type QueryParam DELETE ApiR = QP 118 | -- type HeaderIn DELETE ApiR = HP 119 | -- type CookieIn DELETE ApiR = CP 120 | -- type FormParam DELETE ApiR = FoP 121 | type ApiOut DELETE ApiR = () 122 | 123 | instance ApiContract ReqSpec HEAD ApiR where 124 | -- type QueryParam HEAD ApiR = QP 125 | type ApiOut HEAD ApiR = () 126 | 127 | instance ApiContract ReqSpec PATCH ApiR where 128 | -- type QueryParam PATCH ApiR = QP 129 | -- type HeaderIn PATCH ApiR = HP 130 | -- type CookieIn PATCH ApiR = CP 131 | -- type FormParam PATCH ApiR = FoP 132 | type ApiOut PATCH ApiR = () 133 | 134 | instance ApiContract ReqSpec TRACE ApiR where 135 | -- type QueryParam TRACE ApiR = QP 136 | -- type HeaderIn TRACE ApiR = HP 137 | -- type CookieIn TRACE ApiR = CP 138 | -- type FormParam TRACE ApiR = FoP 139 | type ApiOut TRACE ApiR = () 140 | 141 | instance ApiContract ReqSpec CONNECT ApiR where 142 | -- type QueryParam CONNECT ApiR = QP 143 | -- type HeaderIn CONNECT ApiR = HP 144 | -- type CookieIn CONNECT ApiR = CP 145 | -- type FormParam CONNECT ApiR = FoP 146 | type ApiOut CONNECT ApiR = () 147 | 148 | instance ApiContract ReqSpec (CUSTOM "TEST") ApiR where 149 | -- type QueryParam (CUSTOM "TEST") ApiR = QP 150 | -- type HeaderIn (CUSTOM "TEST") ApiR = HP 151 | -- type CookieIn (CUSTOM "TEST") ApiR = CP 152 | -- type FormParam (CUSTOM "TEST") ApiR = FoP 153 | type ApiOut (CUSTOM "TEST") ApiR = () 154 | 155 | instance ApiContract ReqSpec OPTIONS ApiR where 156 | type ApiOut OPTIONS ApiR = [Text] 157 | 158 | instance ApiHandler ReqSpecImpl (CUSTOM "TEST") ApiR where 159 | handler _ _ = respond () 160 | instance ApiHandler ReqSpecImpl CONNECT ApiR where 161 | handler _ _ = respond () 162 | instance ApiHandler ReqSpecImpl TRACE ApiR where 163 | handler _ _ = respond () 164 | instance ApiHandler ReqSpecImpl HEAD ApiR where 165 | handler _ _ = respond () 166 | instance ApiHandler ReqSpecImpl PATCH ApiR where 167 | handler _ _ = respond () 168 | instance ApiHandler ReqSpecImpl GET ApiR where 169 | handler _ _ = respond () 170 | instance ApiHandler ReqSpecImpl POST ApiR where 171 | handler _ _ = respond () 172 | instance ApiHandler ReqSpecImpl PUT ApiR where 173 | handler _ _ = respond () 174 | instance ApiHandler ReqSpecImpl DELETE ApiR where 175 | handler _ _ = respond () 176 | instance ApiHandler ReqSpecImpl OPTIONS ApiR where 177 | handler _ _ = respond ["GET", "POST"] 178 | 179 | formHeaders :: [(ByteString, ByteString)] -> [(ByteString, ByteString)] -> [Header] 180 | formHeaders headerKvs cookieKvs = map toHeader' headerKvs <> [toCookie' cookieKvs] 181 | where toHeader' (k, v) = (mk k, v) 182 | toCookie' kvs = (hCookie, serializeCookie kvs) 183 | 184 | serializeCookie = foldl' (\acc (k, v) -> acc <> ";" <> k <> "=" <> v) "" 185 | 186 | spec :: Spec 187 | spec = withApp $ describe "WebApi request with payload" $ do 188 | context "GET Request" $ do 189 | it "should be 200 ok" $ do 190 | Hspec.Wai.get "api?qp1=5&qp2=True&qp3.Right=15.60" `shouldRespondWith` 200 191 | context "POST Request" $ do 192 | it "should be 200 ok" $ do 193 | postHtmlForm "api?qp1=5&qp2=True&qp3.Left=foo" [("fop", "foobar")] `shouldRespondWith` 200 194 | context "PUT Request" $ do 195 | it "should be 200 ok" $ do 196 | let headers = formHeaders [("HP1.hp1", "5"), ("Content-Type", "application/json")] [("cp", "True")] 197 | bdy = "{\"rb\":\"foobar\"}" 198 | request methodPut "api" headers bdy `shouldRespondWith` "[]" { matchStatus = 200 } 199 | context "PUT Request with bad body" $ do 200 | it "should be 400 failure" $ do 201 | let headers = formHeaders [("HP1.hp1", "5"), ("Content-Type", "application/json")] [("cp", "True")] 202 | bdy = "{\"jb\":\"foobar\"}" 203 | request methodPut "api" headers bdy `shouldRespondWith` 400 204 | context "DELETE Request" $ do 205 | it "should be 200 ok" $ do 206 | request methodDelete "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } 207 | context "HEAD Request" $ do 208 | it "should be 200 ok" $ do 209 | request methodHead "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } 210 | context "PATCH Request" $ do 211 | it "should be 200 ok" $ do 212 | request methodPatch "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } 213 | context "TRACE Request" $ do 214 | it "should be 200 ok" $ do 215 | request methodTrace "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } 216 | context "OPTIONS Request" $ do 217 | it "should be 200 ok" $ do 218 | request methodOptions "api" [] "" `shouldRespondWith` "[\"GET\",\"POST\"]" { matchStatus = 200 } 219 | context "CONNECT Request" $ do 220 | it "should be 200 ok" $ do 221 | request methodConnect "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } 222 | context "CUSTOM TEST Request" $ do 223 | it "should be 200 ok" $ do 224 | request "TEST" "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } 225 | context "When request is incomplete" $ do 226 | it "should be 400 ok" $ do 227 | let headers = formHeaders [("HP2.hp2", "True"), ("Content-Type", "application/json")] [] 228 | bdy = "{\"rb\":\"foobar\"}" 229 | request methodPut "api" headers bdy `shouldRespondWith` "\"[NotFound \\\"cp\\\"]\"" { matchStatus = 400 } 230 | -------------------------------------------------------------------------------- /webapi/tests/WebApi/ResponseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 2 | {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} 3 | 4 | module WebApi.ResponseSpec (spec) where 5 | 6 | import GHC.Generics 7 | import WebApi hiding (get, put, post) 8 | import Test.Hspec 9 | import qualified Network.Wai as Wai 10 | import Test.Hspec.Wai (with, get, request, shouldRespondWith, matchStatus, (<:>), matchHeaders) 11 | import Network.HTTP.Media.MediaType 12 | import Network.HTTP.Types 13 | import Data.Text 14 | import qualified Data.Text.Lazy as L 15 | import Data.Aeson (ToJSON (..)) 16 | 17 | --withApp :: SpecWith Wai.Application -> Spec 18 | withApp :: SpecWith ((), Wai.Application) -> Spec 19 | withApp = with (return respSpecApp) 20 | 21 | respSpecApp :: Wai.Application 22 | respSpecApp = serverApp serverSettings RespSpecImpl 23 | 24 | data RespSpec 25 | data RespSpecImpl = RespSpecImpl 26 | 27 | data Out = Out { out :: Text } 28 | deriving (Show, Eq, Generic) 29 | data HOut = HOut { hOut :: Text } 30 | deriving (Show, Eq, Generic) 31 | data COut = COut { cOut :: Text } 32 | deriving (Show, Eq, Generic) 33 | data Err = Err { err :: Text } 34 | deriving (Show, Eq, Generic) 35 | 36 | instance ToJSON Err 37 | instance ToJSON Out 38 | instance ToHeader HOut 39 | 40 | instance ToParam 'Cookie COut 41 | 42 | 43 | instance ParamErrToApiErr Err where 44 | toApiErr = const (Err "fail") 45 | 46 | type ApiResp = Static "apiresp" 47 | type ApiWithHeaders = Static "apih" 48 | type ApiWithError = Static "apierror" 49 | type TextCType = Static "text" 50 | type LazyEncoding = Static "lazyencoding" 51 | 52 | instance WebApi RespSpec where 53 | type Apis RespSpec = '[ Route '[GET] ApiResp 54 | , Route '[GET] ApiWithHeaders 55 | , Route '[GET] ApiWithError 56 | , Route '[GET] TextCType 57 | , Route '[GET] LazyEncoding] 58 | 59 | instance WebApiServer RespSpecImpl where 60 | type ApiInterface RespSpecImpl = RespSpec 61 | type HandlerM RespSpecImpl = IO 62 | 63 | instance ApiContract RespSpec GET ApiResp where 64 | type ApiOut GET ApiResp = Out 65 | 66 | instance ApiContract RespSpec GET ApiWithHeaders where 67 | type ApiOut GET ApiWithHeaders = Out 68 | type HeaderOut GET ApiWithHeaders = HOut 69 | type CookieOut GET ApiWithHeaders = COut 70 | 71 | instance ApiContract RespSpec GET ApiWithError where 72 | type ApiOut GET ApiWithError = Out 73 | type ApiErr GET ApiWithError = Err 74 | 75 | instance ApiContract RespSpec GET TextCType where 76 | type ApiOut GET TextCType = L.Text 77 | type ApiErr GET TextCType = L.Text 78 | type ContentTypes GET TextCType = '[PlainText] 79 | 80 | instance ApiContract RespSpec GET LazyEncoding where 81 | type ApiOut GET LazyEncoding = Out 82 | type ContentTypes GET LazyEncoding = '[DummyCType, JSON] 83 | 84 | instance ApiHandler RespSpecImpl GET ApiResp where 85 | handler _ _ = respond (Out "Done") 86 | 87 | instance ApiHandler RespSpecImpl GET ApiWithHeaders where 88 | handler _ _ = respondWith status200 (Out "Done") (HOut "header") (COut "cookie") 89 | 90 | instance ApiHandler RespSpecImpl GET ApiWithError where 91 | handler _ _ = do 92 | -- raise should short circuit 93 | _ <- (raise status500 (Err "fail") :: IO (Response GET ApiWithError)) 94 | -- raiseWith' _ -- (ApiError status500 (Err "fail") Nothing Nothing) -- :: ApiError GET ApiWithError) 95 | -- which means respond will never get called 96 | respond (Out "Done") 97 | 98 | instance ApiHandler RespSpecImpl GET TextCType where 99 | handler _ _ = respond "plaintext" 100 | 101 | instance ApiHandler RespSpecImpl GET LazyEncoding where 102 | handler _ _ = respond (Out "Done") 103 | 104 | 105 | data DummyCType 106 | instance Accept DummyCType where 107 | contentType _ = "application" // "dummy" 108 | 109 | instance Encode DummyCType a where 110 | encode _ = error "Dummy content type not implemented" 111 | 112 | spec :: Spec 113 | spec = withApp $ describe "WebApi response" $ do 114 | context "Simple Response" $ do 115 | it "should be 200 ok" $ do 116 | get "apiresp" `shouldRespondWith` 200 117 | context "Response with response header and cookies" $ do 118 | it "should be 200 ok" $ do 119 | get "apih" `shouldRespondWith` "{\"out\":\"Done\"}" { matchHeaders = [ "hOut" <:> "header" 120 | , "Set-Cookie" <:> "cOut=cookie" 121 | , "Content-Type" <:> "application/json"] 122 | , matchStatus = 200 } 123 | context "Response with api error" $ do 124 | it "should be 500 ok" $ do 125 | get "apierror" `shouldRespondWith` 500 126 | context "Response with text as content type" $ do 127 | it "should be 200 ok" $ do 128 | get "text" `shouldRespondWith` "plaintext" { matchHeaders = ["Content-Type" <:> "text/plain;charset=utf-8"] 129 | , matchStatus = 200 } 130 | context "Response should get encoded lazily" $ do 131 | it "should be 200 ok" $ do 132 | let h = [(hAccept, "application/json")] 133 | request methodGet "lazyencoding" h "" `shouldRespondWith` "{\"out\":\"Done\"}" { matchHeaders = ["Content-Type" <:> "application/json"] 134 | , matchStatus = 200 } 135 | 136 | -------------------------------------------------------------------------------- /webapi/tests/WebApi/RouteSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances #-} 2 | module WebApi.RouteSpec (spec) where 3 | 4 | import WebApi hiding (get, put, post) 5 | import Data.Text (Text) 6 | import Test.Hspec 7 | import Test.Hspec.Wai 8 | import qualified Network.Wai as Wai 9 | 10 | -- withApp :: SpecWith Wai.Application -> Spec 11 | withApp :: SpecWith ((),Wai.Application) -> Spec 12 | withApp = with (return routingSpecApp) 13 | 14 | routingSpecApp :: Wai.Application 15 | routingSpecApp = serverApp serverSettings RoutingSpecImpl 16 | 17 | data RoutingSpec 18 | data RoutingSpecImpl = RoutingSpecImpl 19 | 20 | type StaticRoute1 = "this":/"is":/"a":/"static":/"route" 21 | type StaticRoute2 = Static "static_route" 22 | 23 | type RouteWithParam = "param":/Int 24 | type RouteWithParamAtBegin = Bool:/"param" 25 | type RouteWithParams = Text:/"param1":/Int:/"param2" 26 | type OverlappingRoute = "foo":/"param1":/Int:/"param2" 27 | 28 | type NamespaceR = RoutingSpec :// "foo" :/ "bar" 29 | type NamespaceDyn = RoutingSpec :// "foo" :/ Int :/ "bar" 30 | type NamespaceDynBeg = RoutingSpec :// Int :/ "baz" :/ "bar" 31 | type NamespaceStatic = RoutingSpec :// "bar" 32 | -- type NamespaceJustDyn = RoutingSpec :// Int 33 | 34 | instance WebApi RoutingSpec where 35 | type Version RoutingSpec = () 36 | type Apis RoutingSpec = '[ Route '[GET] StaticRoute1 37 | , Route '[GET] StaticRoute2 38 | , Route '[GET] RouteWithParam 39 | , Route '[GET] RouteWithParamAtBegin 40 | , Route '[GET] OverlappingRoute 41 | , Route '[GET] RouteWithParams 42 | , Route '[GET] NamespaceR 43 | , Route '[GET] NamespaceStatic 44 | , Route '[GET] NamespaceDyn 45 | , Route '[GET] NamespaceDynBeg 46 | -- , Route '[GET] NamespaceJustDyn 47 | ] 48 | 49 | instance ApiContract RoutingSpec GET StaticRoute1 where 50 | type ApiOut GET StaticRoute1 = () 51 | 52 | instance ApiContract RoutingSpec GET StaticRoute2 where 53 | type ApiOut GET StaticRoute2 = () 54 | 55 | instance ApiContract RoutingSpec GET RouteWithParam where 56 | type ApiOut GET RouteWithParam = () 57 | 58 | instance ApiContract RoutingSpec GET RouteWithParamAtBegin where 59 | type ApiOut GET RouteWithParamAtBegin = Text 60 | 61 | instance ApiContract RoutingSpec GET RouteWithParams where 62 | type ApiOut GET RouteWithParams = Text 63 | 64 | instance ApiContract RoutingSpec GET OverlappingRoute where 65 | type ApiOut GET OverlappingRoute = Text 66 | 67 | instance ApiContract RoutingSpec GET NamespaceR where 68 | type ApiOut GET NamespaceR = Text 69 | 70 | instance ApiContract RoutingSpec GET NamespaceDyn where 71 | type ApiOut GET NamespaceDyn = Text 72 | 73 | instance ApiContract RoutingSpec GET NamespaceDynBeg where 74 | type ApiOut GET NamespaceDynBeg = Text 75 | 76 | instance ApiContract RoutingSpec GET NamespaceStatic where 77 | type ApiOut GET NamespaceStatic = Text 78 | 79 | {- 80 | instance ApiContract RoutingSpec GET NamespaceJustDyn where 81 | type ApiOut GET NamespaceJustDyn = Text 82 | -} 83 | 84 | instance WebApiServer RoutingSpecImpl where 85 | type HandlerM RoutingSpecImpl = IO 86 | type ApiInterface RoutingSpecImpl = RoutingSpec 87 | 88 | 89 | instance ApiHandler RoutingSpecImpl GET StaticRoute1 where 90 | handler _ _ = respond () 91 | 92 | instance ApiHandler RoutingSpecImpl GET StaticRoute2 where 93 | handler _ _ = respond () 94 | 95 | instance ApiHandler RoutingSpecImpl GET RouteWithParam where 96 | handler _ _ = respond () 97 | 98 | instance ApiHandler RoutingSpecImpl GET RouteWithParamAtBegin where 99 | handler _ _ = respond "RouteWithParamAtBegin" 100 | 101 | instance ApiHandler RoutingSpecImpl GET RouteWithParams where 102 | handler _ _ = respond "RouteWithParams" 103 | 104 | instance ApiHandler RoutingSpecImpl GET OverlappingRoute where 105 | handler _ _ = respond "OverlappingRoute" 106 | 107 | instance ApiHandler RoutingSpecImpl GET NamespaceR where 108 | handler _ _ = respond "Namespace" 109 | 110 | instance ApiHandler RoutingSpecImpl GET NamespaceStatic where 111 | handler _ _ = respond "NamespaceStatic" 112 | 113 | instance ApiHandler RoutingSpecImpl GET NamespaceDyn where 114 | handler _ _ = respond "NamespaceDyn" 115 | 116 | instance ApiHandler RoutingSpecImpl GET NamespaceDynBeg where 117 | handler _ _ = respond "NamespaceDynBeg" 118 | 119 | {- 120 | instance ApiHandler RoutingSpecImpl GET NamespaceJustDyn where 121 | handler _ _ = respond "NamespaceJustDyn" 122 | -} 123 | 124 | spec :: Spec 125 | spec = withApp $ describe "WebApi routing" $ do 126 | context "static route with only one piece" $ do 127 | it "should be 200 ok" $ do 128 | get "static_route" `shouldRespondWith` 200 129 | context "static route with many pieces" $ do 130 | it "should be 200 ok" $ do 131 | get "this/is/a/static/route" `shouldRespondWith` 200 132 | context "route with param" $ do 133 | it "should be 200 ok" $ do 134 | get "param/5" `shouldRespondWith` 200 135 | context "route with param at beginning" $ do 136 | it "should be 200 ok returning RouteWithParamAtBegin" $ do 137 | get "True/param" `shouldRespondWith` "\"RouteWithParamAtBegin\"" { matchStatus = 200 } 138 | context "route with multiple params" $ do 139 | it "should be 200 ok returning RouteWithParams" $ do 140 | get "bar/param1/5/param2" `shouldRespondWith` "\"RouteWithParams\"" { matchStatus = 200 } 141 | context "overlapping route selected by order" $ do 142 | it "should be 200 ok returning OverlappingRoute" $ do 143 | get "foo/param1/5/param2" `shouldRespondWith` "\"OverlappingRoute\"" { matchStatus = 200 } 144 | context "namespaced route" $ do 145 | it "should be 200 ok returning Namespace" $ do 146 | get "foo/bar" `shouldRespondWith` "\"Namespace\"" { matchStatus = 200 } 147 | context "namespaced static route" $ do 148 | it "should be 200 ok returning NamespaceStatic" $ do 149 | get "bar" `shouldRespondWith` "\"NamespaceStatic\"" { matchStatus = 200 } 150 | context "namespaced dynamic route" $ do 151 | it "should be 200 ok returning NamespaceDyn" $ do 152 | get "foo/5/bar" `shouldRespondWith` "\"NamespaceDyn\"" { matchStatus = 200 } 153 | context "namespaced dynamic route at beginning" $ do 154 | it "should be 200 ok returning NamespaceDynBeg" $ do 155 | get "5/baz/bar" `shouldRespondWith` "\"NamespaceDynBeg\"" { matchStatus = 200 } 156 | {- 157 | context "namespaced route with just one dynamic at the beginning" $ do 158 | it "should be 200 ok returning NamespaceJustDyn" $ do 159 | get "5" `shouldRespondWith` "\"NamespaceJustDyn\"" { matchStatus = 200 } 160 | -} 161 | context "non existing route" $ do 162 | it "should be 404 ok" $ do 163 | get "foo/param1/5/param3" `shouldRespondWith` 404 164 | 165 | -------------------------------------------------------------------------------- /webapi/webapi.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial webapi.cabal generated by cabal init. For further 3 | -- documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: webapi 6 | version: 0.5 7 | synopsis: WAI based library for web api 8 | description: WAI based library for web api 9 | homepage: http://byteally.github.io/webapi/ 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Magesh B 13 | maintainer: magesh85@gmail.com 14 | -- copyright: 15 | -- extra-source-files: 16 | category: Web 17 | build-type: Simple 18 | extra-source-files: ChangeLog.md 19 | source-repository head 20 | type: git 21 | location: https://github.com/byteally/webapi 22 | 23 | 24 | library 25 | exposed-modules: WebApi 26 | , WebApi.Client 27 | , WebApi.Internal 28 | , WebApi.Router 29 | , WebApi.Server 30 | , WebApi.Mock 31 | other-modules: WebApi.ServerCompact 32 | 33 | -- other-extensions: 34 | build-depends: base >= 4.7 && < 5 35 | , aeson >= 0.9 && < 2.4 36 | , bytestring >= 0.10.6.0 && < 0.12 37 | , text >= 1.2 && < 2.2 38 | , time >= 1.5 && < 1.13 39 | , wai-extra >= 3.0 && < 3.3 40 | , http-types >= 0.8 && < 0.13 41 | , http-media >= 0.6 && < 0.9 42 | , webapi-contract == 0.5.* 43 | , wai >= 3.0 && < 3.3 44 | , http-client >= 0.4 && < 0.8 45 | , http-client-tls >= 0.2 && < 0.5 46 | , cookie >= 0.4 && < 0.5 47 | , resourcet >= 1.1 && < 1.3 48 | , exceptions >= 0.8 && < 1 49 | , QuickCheck >= 2.8 && < 2.15 50 | , unliftio >= 0.2 && < 0.3 51 | 52 | hs-source-dirs: src 53 | default-language: Haskell2010 54 | ghc-options: -Wall -Werror -O2 55 | 56 | test-suite unit-tests 57 | type: exitcode-stdio-1.0 58 | main-is: Spec.hs 59 | other-modules: WebApi.RequestSpec 60 | , WebApi.ResponseSpec 61 | , WebApi.RouteSpec 62 | , WebApi.ClientSpec 63 | , WebApi.ParamSpec 64 | , WebApi.MockSpec 65 | 66 | hs-source-dirs: tests 67 | default-language: Haskell2010 68 | cpp-options: -DTEST 69 | ghc-options: -Wall 70 | build-depends: base >= 4.7 && < 5 71 | , aeson >= 0.9 && < 1.5 72 | , case-insensitive == 1.2.* 73 | , wai >= 3.0 && < 3.3 74 | , wai-extra >= 3.0 && < 3.3 75 | , warp 76 | , http-media >= 0.6 && < 0.9 77 | , http-types >= 0.8 && < 0.13 78 | , hspec >= 2.1 && < 2.8 79 | , hspec-wai >= 0.6 && < 0.11 80 | , text >= 1.2 && < 2.2 81 | , bytestring >= 0.10.6.0 && < 0.11 82 | , vector >= 0.10 && < 0.13 83 | , time >= 1.5 && < 1.13 84 | , QuickCheck >= 2.8 && < 2.15 85 | , binary == 0.8.* 86 | , webapi 87 | , webapi-contract 88 | 89 | build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 90 | --------------------------------------------------------------------------------