linnet (empty) → 0.1.0.0
raw patch · 40 files changed
+3328/−0 lines, 40 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, bytestring-conversion, case-insensitive, either, exceptions, hspec, http-types, io-streams, linnet, mtl, quickcheck-classes, quickcheck-instances, text, transformers, uri-encode, utf8-string, wai, warp
Files
- LICENSE +201/−0
- README.md +59/−0
- Setup.hs +2/−0
- linnet.cabal +110/−0
- src/Linnet.hs +136/−0
- src/Linnet/Bootstrap.hs +72/−0
- src/Linnet/Compile.hs +50/−0
- src/Linnet/ContentTypes.hs +16/−0
- src/Linnet/Decode.hs +72/−0
- src/Linnet/Encode.hs +50/−0
- src/Linnet/Endpoint.hs +297/−0
- src/Linnet/Endpoints.hs +38/−0
- src/Linnet/Endpoints/Bodies.hs +98/−0
- src/Linnet/Endpoints/Cookies.hs +84/−0
- src/Linnet/Endpoints/Entity.hs +18/−0
- src/Linnet/Endpoints/Headers.hs +74/−0
- src/Linnet/Endpoints/Methods.hs +63/−0
- src/Linnet/Endpoints/Params.hs +120/−0
- src/Linnet/Endpoints/Paths.hs +101/−0
- src/Linnet/Errors.hs +34/−0
- src/Linnet/Input.hs +28/−0
- src/Linnet/Internal/Coproduct.hs +130/−0
- src/Linnet/Internal/HList.hs +99/−0
- src/Linnet/Output.hs +241/−0
- src/Linnet/ToResponse.hs +69/−0
- test/BodySpec.hs +77/−0
- test/BootstrapSpec.hs +79/−0
- test/CookieSpec.hs +54/−0
- test/DecodeLaws.hs +30/−0
- test/DecodeSpec.hs +23/−0
- test/EncodeLaws.hs +31/−0
- test/EncodeSpec.hs +24/−0
- test/EndpointSpec.hs +201/−0
- test/EntityEndpointLaws.hs +25/−0
- test/ExtractPathLaws.hs +41/−0
- test/HeaderSpec.hs +48/−0
- test/Instances.hs +333/−0
- test/ParamSpec.hs +52/−0
- test/Spec.hs +1/−0
- test/Util.hs +47/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2019 Sergey Kolbasov++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,59 @@+Linnet+------++Linnet [ˈlɪnɪt] is a lightweight Haskell library for building HTTP API on top of [WAI](http://hackage.haskell.org/package/wai). Library design is heavily inspired by Scala [Finch](https://github.com/finagle/finch).++Check out [linnet.io](http://linnet.io) for documentation.++Badges+------+[](https://travis-ci.com/haskell-linnet/linnet) [](https://gitter.im/haskell-linnet/community) ++Hello world+-----------++Here is an example of running simple application using Warp server:+```haskell+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}++import Control.Exception (SomeException)+import Data.Function ((&))+import Data.Text (Text, append)+import Linnet+import Network.Wai.Handler.Warp (run)++-- It's necessary to define encoding of exceptions for content-type "text/plain". Here it returns no content+instance Encode TextPlain SomeException where+ encode _ = mempty++helloWorld = get(p' "hello" // path @Text) ~>> (\name -> return $ ok ("Hello, " `append` name))++main :: IO ()+main = run 9000 app+where+ app = bootstrap @TextPlain helloWorld & compile & toApp id+```++Now try to call your application with:+```+curl -v http://localhost:9000/hello/linnet+```++Maintainers+-------+* [Sergey Kolbasov](https://github.com/sergeykolbasov)++License+-------+Licensed under the **[Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0)** (the "License");+you may not use this software except in compliance with the License.++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ linnet.cabal view
@@ -0,0 +1,110 @@+cabal-version: 1.12+name: linnet+version: 0.1.0.0+license: Apache+license-file: LICENSE+copyright: 2019 Sergey Kolbasov+maintainer: whoisliar@gmail.com+author: Sergey Kolbasov+homepage: https://github.com/haskell-linnet/linnet#readme+bug-reports: https://github.com/haskell-linnet/linnet/issues+synopsis: Lightweight library for building HTTP API+description:+ Please see the documentation at <http://linnet.io>+category: linnet+build-type: Simple+extra-source-files:+ README.md+ LICENSE++source-repository head+ type: git+ location: https://github.com/haskell-linnet/linnet++library+ exposed-modules:+ Linnet+ Linnet.Bootstrap+ Linnet.Compile+ Linnet.ContentTypes+ Linnet.Decode+ Linnet.Encode+ Linnet.Endpoint+ Linnet.Endpoints+ Linnet.Endpoints.Bodies+ Linnet.Endpoints.Cookies+ Linnet.Endpoints.Entity+ Linnet.Endpoints.Headers+ Linnet.Endpoints.Methods+ Linnet.Endpoints.Params+ Linnet.Endpoints.Paths+ Linnet.Errors+ Linnet.Input+ Linnet.Internal.Coproduct+ Linnet.Internal.HList+ Linnet.Output+ Linnet.ToResponse+ hs-source-dirs: src+ other-modules:+ Paths_linnet+ default-language: Haskell2010+ build-depends:+ base >=4.7 && <5,+ bytestring >=0.10.8.2 && <0.11,+ bytestring-conversion >=0.3.1 && <0.4,+ case-insensitive >=1.2.0.11 && <1.3,+ either >=5.0.1.1 && <5.1,+ exceptions >=0.10.2 && <0.11,+ http-types >=0.12.3 && <0.13,+ io-streams >=1.5.1.0 && <1.6,+ mtl >=2.2.2 && <2.3,+ text >=1.2.3.1 && <1.3,+ transformers >=0.5.6.2 && <0.6,+ uri-encode >=1.5.0.5 && <1.6,+ utf8-string >=1.0.1.1 && <1.1,+ wai >=3.2.2.1 && <3.3,+ warp >=3.2.28 && <3.3++test-suite linnet-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules:+ BodySpec+ BootstrapSpec+ CookieSpec+ DecodeLaws+ DecodeSpec+ EncodeLaws+ EncodeSpec+ EndpointSpec+ EntityEndpointLaws+ ExtractPathLaws+ HeaderSpec+ Instances+ ParamSpec+ Util+ Paths_linnet+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.13.2 && <2.14,+ base >=4.7 && <5,+ bytestring >=0.10.8.2 && <0.11,+ bytestring-conversion >=0.3.1 && <0.4,+ case-insensitive >=1.2.0.11 && <1.3,+ either >=5.0.1.1 && <5.1,+ exceptions >=0.10.2 && <0.11,+ hspec >=2.7.1 && <2.8,+ http-types >=0.12.3 && <0.13,+ io-streams >=1.5.1.0 && <1.6,+ linnet -any,+ mtl >=2.2.2 && <2.3,+ quickcheck-classes >=0.6.1.0 && <0.7,+ quickcheck-instances >=0.3.22 && <0.4,+ text >=1.2.3.1 && <1.3,+ transformers >=0.5.6.2 && <0.6,+ uri-encode >=1.5.0.5 && <1.6,+ utf8-string >=1.0.1.1 && <1.1,+ wai >=3.2.2.1 && <3.3,+ warp >=3.2.28 && <3.3
+ src/Linnet.hs view
@@ -0,0 +1,136 @@+{-|+Module: Linnet+Description: Lightweight HTTP library on top of WAI+Copyright: (c) Sergey Kolbasov, 2019+License: Apache License 2.0++Linnet [ˈlɪnɪt] is a lightweight Haskell library for building HTTP API on top of <http://hackage.haskell.org/package/wai WAI>.+Library design is heavily inspired by Scala <https://github.com/finagle/finch Finch>.++See the detailed documentation on <http://linnet.io linnet.io>.++-}+module Linnet+ (+ -- * Hello world+ -- $helloWorld+ -- * Endpoint and core combinators+ Endpoint(..)+ , (~>)+ , (~>>)+ , (//)+ , (|+|)+ -- ** Method endpoints+ , get+ , post+ , put+ , patch+ , delete+ , head'+ , trace'+ , connect+ , options+ -- ** Path matching endpoints+ , path+ , pathAny+ , pathConst+ , p'+ , pathEmpty+ , paths+ -- ** Query parameters endpoints+ , param+ , paramMaybe+ , params+ , paramsNel+ -- ** Request body endpoints+ , body+ , bodyMaybe+ , textBody+ , textBodyMaybe+ , jsonBody+ , jsonBodyMaybe+ -- ** Cookie endpoints+ , cookie+ , cookieMaybe+ -- ** Header endpoints+ , header+ , headerMaybe+ -- ** Response encoding and request decoding+ , Encode(..)+ , Decode(..)+ -- ** Endpoint output+ , Output(..)+ , ok+ , created+ , accepted+ , noContent+ , badRequest+ , unauthorized+ , paymentRequired+ , forbidden+ , notFound+ , methodNotAllowed+ , notAcceptable+ , conflict+ , gone+ , lengthRequired+ , preconditionFailed+ , requestEntityTooLarge+ , unprocessableEntity+ , tooManyRequests+ , internalServerError+ , notImplemented+ , badGateway+ , serviceUnavailable+ , gatewayTimeout+ -- * Compiling an endpoint+ , bootstrap+ , serve+ , compile+ , toApp+ -- * Running a server+ , run+ -- * Content-Type literals+ , ApplicationJson+ , TextHtml+ , TextPlain+ ) where++import Linnet.Bootstrap+import Linnet.ContentTypes+import Linnet.Decode+import Linnet.Encode+import Linnet.Endpoint+import Linnet.Endpoints+import Linnet.Output+import Network.Wai.Handler.Warp+-- $helloWorld+-- Hello @name@ example using warp server:+--+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE TypeApplications #-}+-- > {-# LANGUAGE TypeSynonymInstances #-}+-- >+-- > import Control.Exception (SomeException)+-- > import Data.Function ((&))+-- > import Data.Text (Text, append)+-- > import Linnet+-- >+-- > -- It's necessary to define encoding of exceptions for content-type "text/plain". Here it returns no content+-- > instance Encode TextPlain SomeException where+-- > encode _ = mempty+-- >+-- > helloWorld = get(p' "hello" // path @Text) ~>> (\name -> return $ ok ("Hello, " `append` name))+-- >+-- > main :: IO ()+-- > main = run 9000 $ bootstrap @TextPlain helloWorld & compile & toApp id+--+-- Now try to call your server with @curl@ command:+--+-- > curl -v http://localhost:9000/hello/linnet+--+-- __Main module exposes only subset of available functions and operators to keep application namespace clean.__+--+-- Explore corresponding modules for additional functionality.
+ src/Linnet/Bootstrap.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Linnet.Bootstrap+ ( bootstrap+ , serve+ , compile+ , toApp+ ) where++import Control.Monad.Reader (ReaderT (..))+import Data.Data (Proxy)+import GHC.Base (Symbol)+import qualified Linnet.Compile as Compile+import Linnet.Endpoint+import Linnet.Internal.Coproduct (CNil, Coproduct)+import Linnet.Internal.HList (HList (..))+import Network.Wai (Application, Request, Response)++newtype Bootstrap (m :: * -> *) cts es =+ Bootstrap es++-- | Create 'Bootstrap' out of single 'Endpoint' and some given Content-Type:+--+-- > bootstrap @TextPlain (pure "foo")+bootstrap ::+ forall (ct :: Symbol) m a. Endpoint m a -> Bootstrap m (Coproduct (Proxy ct) CNil) (HList '[ (Endpoint m a)])+bootstrap ea = Bootstrap @m @(Coproduct (Proxy ct) CNil) (ea ::: HNil)++-- | Add another endpoint to 'Bootstrap' for purpose of serving multiple Content-Types with *different* endpoints+--+-- > bootstrap @TextPlain (pure "foo") & server @ApplicationJson (pure "bar")+serve ::+ forall (ct :: Symbol) cts es m a.+ Endpoint m a+ -> Bootstrap m cts (HList es)+ -> Bootstrap m (Coproduct (Proxy ct) cts) (HList (Endpoint m a ': es))+serve ea (Bootstrap e) = Bootstrap @m @(Coproduct (Proxy ct) cts) (ea ::: e)++-- | Compile 'Bootstrap' into @ReaderT Request m Response@ for further combinations.+-- Might be useful to implement middleware in context of the same monad @m@:+--+-- > bootstrap @TextPlain (pure "foo") & compile+compile ::+ forall cts m es. (Compile.Compile cts m es)+ => Bootstrap m cts es+ -> ReaderT Request m Response+compile (Bootstrap e) = Compile.compile @cts @m e++-- | Convert @ReaderT Request m Response@ into WAI @Application@+--+-- > bootstrap @TextPlain (pure "foo") & compile & toApp id+--+-- The first parameter here is a natural transformation of 'Endpoint's monad @m@ into @IO@.+-- In case if selected monad is @IO@ already then @id@ is just enough. Otherwise, it's a good place to define how to "start"+-- custom monad for each request to come and convert it to @IO@.+--+-- As an example:+--+-- * @ReaderT RequestContext IO@ could be used to pass some data as local context for the request.+--+-- * Some monad for logging (i.e. co-log)+toApp :: (forall a. m a -> IO a) -> ReaderT Request m Response -> Application+toApp toIO !readerT request callback = toIO (runReaderT readerT request) >>= callback
+ src/Linnet/Compile.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Linnet.Compile+ ( Compile(..)+ ) where++import Control.Exception (SomeException)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.Reader (ReaderT(..))+import Data.Data (Proxy)+import GHC.TypeLits (KnownSymbol)+import Linnet.Endpoint+import Linnet.Errors (LinnetError)+import Linnet.Input+import Linnet.Internal.Coproduct+import Linnet.Internal.HList+import Linnet.Output (Output (..), outputToResponse,+ payloadError)+import Linnet.ToResponse (ToResponse)+import Network.HTTP.Types (badRequest400, status404)+import Network.Wai (Request, Response, responseLBS)++class Compile cts m es where+ compile :: es -> ReaderT Request m Response++instance (Monad m) => Compile CNil m (HList '[]) where+ compile _ = ReaderT $ const notFoundResponse++instance (KnownSymbol ct, ToResponse ct a, ToResponse ct SomeException, Compile cts m (HList es), MonadCatch m) =>+ Compile (Coproduct (Proxy ct) cts) m (HList (Endpoint m a ': es)) where+ compile (ea ::: es) =+ ReaderT+ (\req ->+ case runEndpoint (handle respond400 ea) (inputFromRequest req) of+ Matched _ mo -> outputToResponse @a @ct <$> mo+ NotMatched -> runReaderT (compile @cts es) req)++notFoundResponse :: (Applicative m) => m Response+notFoundResponse = pure $ responseLBS status404 [] mempty++respond400 :: (Applicative m) => LinnetError -> m (Output a)+respond400 err = pure $ payloadError badRequest400 err
+ src/Linnet/ContentTypes.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DataKinds #-}++module Linnet.ContentTypes+ ( TextHtml+ , TextPlain+ , ApplicationJson+ ) where++-- | Content-Type literal for @text/html@ encoding+type TextHtml = "text/html"++-- | Content-Type literal for @text/plain@ encoding+type TextPlain = "text/plain"++-- | Content-Type literal for @application/json@ encoding+type ApplicationJson = "application/json"
+ src/Linnet/Decode.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Linnet.Decode+ ( Decode(..)+ , DecodePath(..)+ , DecodeEntity(..)+ ) where++import Control.Arrow (left, right)+import qualified Data.ByteString as B+import qualified Data.ByteString.Conversion as BC+import qualified Data.ByteString.Lazy as BL+import Data.Either.Combinators+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Text.Read (decimal, double, rational, signed)+import GHC.Base (Symbol)+import Linnet.Endpoints.Entity (Entity)+import Linnet.Errors++-- | Decoding of HTTP request payload into some type @a@.+-- Phantom type @ct@ guarantees that compiler checks support of decoding some @a@ from content of given @Content-Type@+-- by looking for specific @Decode@ instance.+class Decode (ct :: Symbol) a where+ decode :: BL.ByteString -> Either LinnetError a++class DecodePath a where+ decodePath :: T.Text -> Maybe a++instance DecodePath T.Text where+ decodePath = Just++instance DecodePath B.ByteString where+ decodePath = Just . TE.encodeUtf8++instance DecodePath Integer where+ decodePath t = rightToMaybe $ fst <$> signed decimal t++instance DecodePath Int where+ decodePath t = rightToMaybe $ fst <$> signed decimal t++instance DecodePath Double where+ decodePath t = rightToMaybe $ fst <$> signed double t++instance DecodePath Float where+ decodePath t = rightToMaybe $ fst <$> signed rational t++class DecodeEntity a where+ decodeEntity :: Entity -> B.ByteString -> Either LinnetError a+ default decodeEntity :: (BC.FromByteString a) =>+ Entity -> B.ByteString -> Either LinnetError a+ decodeEntity entity = left (EntityNotParsed entity . DecodeError . BC.toByteString') . BC.runParser BC.parser++instance DecodeEntity B.ByteString++instance DecodeEntity T.Text++instance DecodeEntity Integer++instance DecodeEntity Int++instance DecodeEntity Double++instance DecodeEntity Float where+ decodeEntity entity = right realToFrac . decodeEntity @Double entity
+ src/Linnet/Encode.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Linnet.Encode+ ( Encode+ , encode+ ) where++import Data.ByteString as BS+import Data.ByteString.Conversion as BC+import Data.ByteString.Lazy as BL+import Data.Text as TS+import Data.Text.Encoding as TSE+import Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding as TLE+import GHC.Base (Symbol)+import Linnet.ContentTypes++-- | Encoding of some type @a@ into payload of HTTP response+-- Phantom type @ct@ guarantees that compiler checks support of encoding of some @a@ into content of given @Content-Type@+-- by looking for specific @Encode@ instance.+class Encode (ct :: Symbol) a where+ encode :: a -> BL.ByteString++instance Encode TextPlain BL.ByteString where+ encode = id++instance Encode TextPlain BS.ByteString where+ encode = BL.fromStrict++instance Encode TextPlain TS.Text where+ encode = BL.fromStrict . TSE.encodeUtf8++instance Encode TextPlain TL.Text where+ encode = TLE.encodeUtf8++instance Encode TextPlain Int where+ encode = BC.toByteString++instance Encode TextPlain Integer where+ encode = BC.toByteString++instance Encode TextPlain Double where+ encode = BC.toByteString++instance Encode TextPlain Float where+ encode = BC.toByteString
+ src/Linnet/Endpoint.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Linnet.Endpoint+ ( EndpointResult(..)+ , Endpoint(..)+ , isMatched+ , maybeReminder+ , lift+ , liftOutputM+ , mapM'+ , mapOutput+ , mapOutputM+ , handle+ , handleAll+ , try+ , transformOutput+ , transform+ , (~>)+ , (~>>)+ , productWith+ , (//)+ , (|+|)+ , root+ , zero+ ) where++import Control.Applicative (Alternative (..))+import Control.Exception (Exception, SomeException)+import qualified Control.Monad.Catch as MC+import GHC.Base (liftA2)+import Linnet.Errors (LinnetError (..))+import Linnet.Input+import Linnet.Internal.Coproduct+import Linnet.Internal.HList+import Linnet.Output+import Network.Wai (Request)++infixl 0 ~>++infixl 0 ~>>++infixr 2 //++infixl 2 |+|++-- | Result of returned by 'Endpoint' that could be either:+--+-- * @Matched@ containing reminder of the input together with 'Output' inside of monad @m@+--+-- * @NotMatched@ in case endpoint doesn't match the input+data EndpointResult (m :: * -> *) a+ = Matched+ { matchedReminder :: Input+ , matchedOutput :: m (Output a)+ }+ | NotMatched++isMatched :: EndpointResult m a -> Bool+isMatched (Matched _ _) = True+isMatched _ = False++maybeReminder :: EndpointResult m a -> Maybe Input+maybeReminder (Matched r _) = Just r+maybeReminder _ = Nothing++instance (Show (m (Output a))) => Show (EndpointResult m a) where+ show (Matched _ out) = "EndpointResult.Matched(" ++ show out ++ ")"+ show NotMatched = "EndpointResult.NotMatched"++instance (Functor m) => Functor (EndpointResult m) where+ fmap f (Matched r m) = Matched r $ (fmap . fmap) f m+ fmap _ NotMatched = NotMatched++-- | Basic Linnet data type that abstracts away operations over HTTP communication.+-- While WAI Application has type of @Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived@,+-- it's practical to treat web applications as functions of @Request -> BusinessLogic -> IO Response@ where @BusinessLogic@+-- is usually a function of @a -> m b@ where @a@ and @b@ are data to be decoded from the request / encoded to response, @m@+-- is some monad, and this is the most interesting part of an application.+--+-- Endpoint's purpose is exactly to abstract details of encoding and decoding, along with routing and the rest, and provide+-- simple interface to encapsulate @BusinessLogic@ into a final web application.+--+-- Business logic is encoded as transformation in @fmap@, @mapOutput@, @mapOutputM@, @mapM@ and the like.+-- Usual way to transform endpoint is to use '~>' and '~>>' operators:+--+-- > get (path @Text) ~> (\segment -> return $ ok segment)+-- Here, '~>' is just an inverted alias for `mapOutputM` function. Often, endpoint is a product of multiple endpoints,+-- and here '~>>' proves to be very handy:+--+-- > get (p' "sum" // path @Int // path @Int) ~>> (\i1 i2 -> return $ ok (i1 + i2) )+--+-- The trick is that '//' defines sequential @AND@ combination of endpoints that is represented as endpoint of 'HList', so+-- instead of dealing with heterogeneous list, it's possible to use '~>>' instead and map with a function of multiple arguments.+--+-- Endpoints are also composable in terms of @OR@ logic with '|+|' operator that is useful for routing:+--+-- > getUsers = get (p' "users") ~>> (ok <$> fetchUsers)+-- > newUser = post (p' "users" // jsonBody @User) ~>> (\user -> ok <$> createUser user)+-- > usersApi = getUsers |+| newUser+--+-- An endpoint might be converted into WAI @Application@ using 'Linnet.Bootstrap.bootstrap' and @\@TypeApplications@ language pragma:+--+-- > main = run 9000 app+-- > where app = bootstrap @TextPlain usersApi & compile & toApp id+data Endpoint (m :: * -> *) a =+ Endpoint+ { runEndpoint :: Input -> EndpointResult m a+ , toString :: String+ }++instance Show (Endpoint m a) where+ show e = "Endpoint(" ++ toString e ++ ")"++instance (Functor m) => Functor (Endpoint m) where+ fmap f e = Endpoint {runEndpoint = fmap f . runEndpoint e, toString = toString e}++instance (MC.MonadCatch m) => Applicative (Endpoint m) where+ pure a = Endpoint {runEndpoint = \i -> Matched i $ pure (ok a), toString = "const"}+ liftA2 fn fa fb = productWith fa fb fn++instance (MC.MonadCatch m) => Alternative (Endpoint m) where+ empty = Endpoint {runEndpoint = const NotMatched, toString = "empty"}+ (<|>) ea eb =+ Endpoint+ { runEndpoint =+ \input ->+ case runEndpoint ea input of+ a@(Matched remA _) ->+ case runEndpoint eb input of+ b@(Matched remB _) ->+ if length (reminder remA) <= length (reminder remB)+ then a+ else b+ NotMatched -> a+ NotMatched -> runEndpoint eb input+ , toString = toString ea ++ "<|>" ++ toString eb+ }++-- | Map over the 'Output' of endpoint with function returning new value @a@ lifted in monad @m@+mapM' :: (Monad m) => (a -> m b) -> Endpoint m a -> Endpoint m b+mapM' fn = transformOutput (>>= traverse fn)++-- | Map over the value of 'Endpoint' with function returning new @Output b@+mapOutput :: (Monad m) => (a -> Output b) -> Endpoint m a -> Endpoint m b+mapOutput fn = mapOutputM $ pure . fn++-- | Map over the value of 'Endpoint' with function returning new @m (Output b)@+mapOutputM :: (Monad m) => (a -> m (Output b)) -> Endpoint m a -> Endpoint m b+mapOutputM fn ea =+ ea+ { runEndpoint =+ \input ->+ case runEndpoint ea input of+ Matched remA ma -> Matched remA $ ma >>= transformM fn+ NotMatched -> NotMatched+ }++transformOutput :: (m (Output a) -> m (Output b)) -> Endpoint m a -> Endpoint m b+transformOutput fn ea =+ ea+ { runEndpoint =+ \input ->+ case runEndpoint ea input of+ Matched remA ma -> Matched remA $ fn ma+ NotMatched -> NotMatched+ }++transform :: (Monad m) => (m a -> m b) -> Endpoint m a -> Endpoint m b+transform fn ea =+ ea+ { runEndpoint =+ \input ->+ case runEndpoint ea input of+ Matched remA ma -> Matched {matchedReminder = remA, matchedOutput = ma >>= traverse (fn . pure)}+ NotMatched -> NotMatched+ }++-- | Handle exception in monad @m@ of Endpoint result using provided function that returns new 'Output'+handle :: (MC.MonadCatch m, Exception e) => (e -> m (Output a)) -> Endpoint m a -> Endpoint m a+handle = transformOutput . MC.handle++-- | Handle all exceptions in monad @m@ of Endpoint result+handleAll :: (MC.MonadCatch m) => (SomeException -> m (Output a)) -> Endpoint m a -> Endpoint m a+handleAll = transformOutput . MC.handleAll++-- | Lift an exception of type @e@ into 'Either'+try :: (Exception e, MC.MonadCatch m) => Endpoint m a -> Endpoint m (Either e a)+try ea =+ ea+ { runEndpoint =+ \input ->+ let traverseEither :: Either e (Output a) -> Output (Either e a)+ traverseEither (Left e) = ok $ Left e+ traverseEither (Right out) = Right <$> out+ in case runEndpoint ea input of+ Matched remA out -> Matched {matchedReminder = remA, matchedOutput = traverseEither <$> MC.try out}+ NotMatched -> NotMatched+ }++-- | Inversed alias for 'mapOutputM'+(~>) :: (Monad m) => Endpoint m a -> (a -> m (Output b)) -> Endpoint m b+(~>) ea fn = mapOutputM fn ea++-- | Advanced version of '~>' operator that allows to map @Endpoint m (HList ls)@+-- over a function of arity N equal to N elements of HList.+-- General rule of thumb when to use this operator is whenever there is an 'HList' on the left side.+(~>>) :: (Monad m, FnToProduct fn ls (m (Output b))) => Endpoint m (HList ls) -> fn -> Endpoint m b+(~>>) ea fn = mapOutputM (fromFunction fn) ea++-- | Lift monadic value @m a@ into 'Endpoint' that always matches+lift :: (Functor m) => m a -> Endpoint m a+lift m = Endpoint {runEndpoint = \i -> Matched i $ fmap ok m, toString = "lift"}++-- | Lift monadic output @m (Output a)@ into 'Endpoint' that always matches+liftOutputM :: m (Output a) -> Endpoint m a+liftOutputM m = Endpoint {runEndpoint = \i -> Matched i m, toString = "liftOutputM"}++-- | Create product of two 'Endpoint's that sequentially match a request.+-- | If some of endpoints doesn't match a request, the final result is also non-matching+productWith ::+ forall m a b c. MC.MonadCatch m+ => Endpoint m a+ -> Endpoint m b+ -> (a -> b -> c)+ -> Endpoint m c+productWith ea eb f =+ ea+ { runEndpoint =+ \req ->+ case runEndpoint ea req of+ Matched aRem aOutM ->+ case runEndpoint eb aRem of+ Matched bRem bOutM ->+ let out = do+ oa <- MC.try aOutM+ ob <- MC.try bOutM+ product_ oa ob+ in Matched bRem out+ NotMatched -> NotMatched+ NotMatched -> NotMatched+ }+ where+ product_ :: Either LinnetError (Output a) -> Either LinnetError (Output b) -> m (Output c)+ product_ eitherA eitherB =+ case (eitherA, eitherB) of+ (Right oa, Right ob) -> pure $ oa >>= \a -> fmap (f a) ob+ (Left a, Left b) -> MC.throwM $ a <> b+ (Left a, _) -> MC.throwM a+ (_, Left b) -> MC.throwM b++-- | Create product of two 'Endpoint's that sequentially match a request and values are adjoined into 'HList'.+-- If some of endpoints doesn't match a request, the final result is also non-matching+(//) :: (MC.MonadCatch m, AdjoinHList (a ': b ': '[]) out) => Endpoint m a -> Endpoint m b -> Endpoint m (HList out)+(//) ea eb =+ Endpoint+ { runEndpoint = runEndpoint $ productWith ea eb (\a b -> adjoin (a ::: b ::: HNil))+ , toString = toString ea ++ " // " ++ toString eb+ }++-- | Create new 'Endpoint' of two endpoints, adjoining values into 'Coproduct'+-- During request resolution the following logic is applied:+--+-- * If none of endpoints match, resulting endpoint is also non-matching+--+-- * If both endpoints match, the more specific one is selected (with shorter reminder)+(|+|) ::+ forall m a b out. (MC.MonadCatch m, AdjoinCoproduct (Coproduct a (Coproduct b CNil)) out)+ => Endpoint m a+ -> Endpoint m b+ -> Endpoint m out+(|+|) ea eb = fmap left ea <|> fmap right eb+ where+ left :: a -> out+ left a = adjoinCoproduct @(Coproduct a (Coproduct b CNil)) $ Inl a+ right :: b -> out+ right b = adjoinCoproduct @(Coproduct a (Coproduct b CNil)) $ Inr (Inl b)++-- | Endpoint that always matches and returns a request from 'Input'+root :: (Applicative m) => Endpoint m Request+root =+ Endpoint+ { runEndpoint = \input -> Matched {matchedReminder = input, matchedOutput = pure . ok $ request input}+ , toString = "root"+ }++-- | Endpoint that always matches and doesn't change any reminder+zero :: (Applicative m) => Endpoint m (HList '[])+zero =+ Endpoint+ {runEndpoint = \input -> Matched {matchedReminder = input, matchedOutput = pure . ok $ HNil}, toString = "zero"}
+ src/Linnet/Endpoints.hs view
@@ -0,0 +1,38 @@+module Linnet.Endpoints+ ( cookie+ , cookieMaybe+ , header+ , headerMaybe+ , get+ , post+ , put+ , patch+ , delete+ , head'+ , trace'+ , connect+ , options+ , param+ , paramMaybe+ , params+ , paramsNel+ , path+ , pathConst+ , p'+ , pathEmpty+ , paths+ , pathAny+ , body+ , bodyMaybe+ , textBody+ , textBodyMaybe+ , jsonBody+ , jsonBodyMaybe+ ) where++import Linnet.Endpoints.Bodies+import Linnet.Endpoints.Cookies+import Linnet.Endpoints.Headers+import Linnet.Endpoints.Methods+import Linnet.Endpoints.Params+import Linnet.Endpoints.Paths
+ src/Linnet/Endpoints/Bodies.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Linnet.Endpoints.Bodies+ ( body+ , bodyMaybe+ , jsonBody+ , jsonBodyMaybe+ , textBody+ , textBodyMaybe+ ) where++import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.ByteString.Lazy as BL+import Linnet.ContentTypes (ApplicationJson, TextPlain)+import Linnet.Decode+import Linnet.Endpoint+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Linnet.Output+import Network.Wai (RequestBodyLength (..),+ lazyRequestBody, requestBodyLength)++decodeBody ::+ forall ct a m. (Decode ct a, MonadThrow m)+ => BL.ByteString+ -> m (Output a)+decodeBody payload =+ case decode @ct @a payload of+ Right a -> pure $ ok a+ Left e -> throwM $ EntityNotParsed Body e++-- | Endpoint that tries to decode body of request into some type @a@ using corresponding 'Decode' instance.+-- Matches if body isn't chunked. May throw an exception in case:+--+-- * Body is empty+--+-- * There was a body decoding error+body ::+ forall ct a m. (Decode ct a, MonadIO m, MonadThrow m)+ => Endpoint m a+body =+ Endpoint+ { runEndpoint =+ \input ->+ case (requestBodyLength . request) input of+ ChunkedBody -> NotMatched+ KnownLength 0 -> Matched {matchedReminder = input, matchedOutput = throwM $ MissingEntity Body}+ KnownLength _ ->+ Matched+ { matchedReminder = input+ , matchedOutput = (liftIO . lazyRequestBody . request) input >>= decodeBody @ct @a+ }+ , toString = "body"+ }++-- | Endpoint that tries to decode body of request into some type @a@ using corresponding 'Decode' instance.+-- Matches if body isn't chunked. May throw an exception in case:+--+-- * There was a body decoding error+bodyMaybe ::+ forall ct a m. (Decode ct a, MonadIO m, MonadThrow m)+ => Endpoint m (Maybe a)+bodyMaybe =+ Endpoint+ { runEndpoint =+ \input ->+ case (requestBodyLength . request) input of+ ChunkedBody -> NotMatched+ KnownLength 0 -> Matched {matchedReminder = input, matchedOutput = pure $ ok Nothing}+ KnownLength _ ->+ Matched+ { matchedReminder = input+ , matchedOutput = (fmap . fmap) Just ((liftIO . lazyRequestBody . request) input >>= decodeBody @ct @a)+ }+ , toString = "bodyMaybe"+ }++-- | Alias for @body \@TextPlain@+textBody :: (Decode TextPlain a, MonadIO m, MonadThrow m) => Endpoint m a+textBody = body @TextPlain++-- | Alias for @bodyMaybe \@TextPlain@+textBodyMaybe :: (Decode TextPlain a, MonadIO m, MonadThrow m) => Endpoint m (Maybe a)+textBodyMaybe = bodyMaybe @TextPlain++-- | Alias for @body \@ApplicationJson@+jsonBody :: (Decode ApplicationJson a, MonadIO m, MonadThrow m) => Endpoint m a+jsonBody = body @ApplicationJson++-- | Alias for @bodyMaybe \@ApplicationJson@+jsonBodyMaybe :: (Decode ApplicationJson a, MonadIO m, MonadThrow m) => Endpoint m (Maybe a)+jsonBodyMaybe = bodyMaybe @ApplicationJson
+ src/Linnet/Endpoints/Cookies.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Linnet.Endpoints.Cookies+ ( cookie+ , cookieMaybe+ ) where++import Control.Monad.Catch (MonadThrow, throwM)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.CaseInsensitive as CI+import Linnet.Decode+import Linnet.Endpoint+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Linnet.Output+import Network.URI.Encode (decodeByteString)+import Network.Wai (requestHeaders)++findCookie :: B.ByteString -> B.ByteString -> Maybe B.ByteString+findCookie name cookies =+ lookup name $+ C8.split ';' cookies >>=+ (\pairs ->+ case C8.split '=' pairs of+ [k, v] -> [(k, decodeByteString v)]+ _ -> [])++-- | Endpoint that tries to decode cookie @name@ from a request.+-- Always matches, but may throw an exception in case:+--+-- * Cookie is not presented in the request+--+-- * There was a cookie decoding error+cookie ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m a+cookie name =+ Endpoint+ { runEndpoint =+ \input ->+ let maybeCookie = (lookup (CI.mk "Cookie") . requestHeaders . request) input >>= findCookie name+ output =+ case maybeCookie of+ Just val ->+ case decodeEntity entity val of+ Left err -> throwM err+ Right v -> return $ ok v+ _ -> throwM $ MissingEntity entity+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "cookie " ++ C8.unpack name+ }+ where+ entity = Cookie name++-- | Endpoint that tries to decode cookie @name@ from a request.+-- Always matches, but may throw an exception in case:+--+-- * There was a cookie decoding error+cookieMaybe ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m (Maybe a)+cookieMaybe name =+ Endpoint+ { runEndpoint =+ \input ->+ let maybeCookie = (lookup (CI.mk "Cookie") . requestHeaders . request) input >>= findCookie name+ output =+ case maybeCookie of+ Just val ->+ case decodeEntity entity val of+ Left err -> throwM err+ Right v -> return $ ok (Just v)+ _ -> return $ ok Nothing+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "cookieMaybe " ++ C8.unpack name+ }+ where+ entity = Header name
+ src/Linnet/Endpoints/Entity.hs view
@@ -0,0 +1,18 @@+module Linnet.Endpoints.Entity+ ( Entity(..)+ ) where++import qualified Data.ByteString as B++data Entity+ = Param+ { entityName :: B.ByteString+ }+ | Header+ { entityName :: B.ByteString+ }+ | Body+ | Cookie+ { entityName :: B.ByteString+ }+ deriving (Eq, Show)
+ src/Linnet/Endpoints/Headers.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Linnet.Endpoints.Headers+ ( header+ , headerMaybe+ ) where++import Control.Monad.Catch (MonadThrow, throwM)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.CaseInsensitive as CI+import Linnet.Decode+import Linnet.Endpoint+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Linnet.Output (ok)+import Network.Wai (requestHeaders)++--required :: forall a m. (DecodeEntity a, Applicative m) => B.ByteString -> Endpoint m a+--required =+-- | Endpoint that tries to decode header @name@ from a request.+-- Always matches, but may throw an exception in case:+--+-- * Headers is not presented in the request+--+-- * There was a header decoding error+header ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m a+header name =+ Endpoint+ { runEndpoint =+ \input ->+ let maybeHeader = (lookup (CI.mk name) . requestHeaders . request) input+ output =+ case maybeHeader of+ Just val ->+ case decodeEntity entity val of+ Left err -> throwM err+ Right v -> return $ ok v+ _ -> throwM $ MissingEntity entity+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "header " ++ C8.unpack name+ }+ where+ entity = Header name++-- | Endpoint that tries to decode header @name@ from a request.+-- Always matches, but may throw an exception in case:+--+-- * There was a header decoding error+headerMaybe ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m (Maybe a)+headerMaybe name =+ Endpoint+ { runEndpoint =+ \input ->+ let maybeHeader = (lookup (CI.mk name) . requestHeaders . request) input+ output =+ case maybeHeader of+ Just val ->+ case decodeEntity entity val of+ Left err -> throwM err+ Right v -> return $ ok (Just v)+ _ -> return $ ok Nothing+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "headerMaybe " ++ C8.unpack name+ }+ where+ entity = Header name
+ src/Linnet/Endpoints/Methods.hs view
@@ -0,0 +1,63 @@+module Linnet.Endpoints.Methods+ ( get+ , post+ , put+ , patch+ , delete+ , head'+ , trace'+ , connect+ , options+ ) where++import Linnet.Endpoint+import Linnet.Input+import Network.HTTP.Types+import Network.Wai (requestMethod)++methodEndpoint :: Method -> Endpoint m a -> Endpoint m a+methodEndpoint method underlying =+ Endpoint+ { runEndpoint =+ \input ->+ if (requestMethod . request) input == method+ then runEndpoint underlying input+ else NotMatched+ , toString = show method ++ " " ++ toString underlying+ }++-- | Turn endpoint into one that matches only for GET requests+get :: Endpoint m a -> Endpoint m a+get = methodEndpoint methodGet++-- | Turn endpoint into one that matches only for POST requests+post :: Endpoint m a -> Endpoint m a+post = methodEndpoint methodPost++-- | Turn endpoint into one that matches only for PUT requests+put :: Endpoint m a -> Endpoint m a+put = methodEndpoint methodPut++-- | Turn endpoint into one that matches only for PATCH requests+patch :: Endpoint m a -> Endpoint m a+patch = methodEndpoint methodPatch++-- | Turn endpoint into one that matches only for DELETE requests+delete :: Endpoint m a -> Endpoint m a+delete = methodEndpoint methodDelete++-- | Turn endpoint into one that matches only for HEAD requests+head' :: Endpoint m a -> Endpoint m a+head' = methodEndpoint methodHead++-- | Turn endpoint into one that matches only for TRACE requests+trace' :: Endpoint m a -> Endpoint m a+trace' = methodEndpoint methodTrace++-- | Turn endpoint into one that matches only for CONNECT requests+connect :: Endpoint m a -> Endpoint m a+connect = methodEndpoint methodConnect++-- | Turn endpoint into one that matches only for OPTIONS requests+options :: Endpoint m a -> Endpoint m a+options = methodEndpoint methodOptions
+ src/Linnet/Endpoints/Params.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Linnet.Endpoints.Params+ ( param+ , paramMaybe+ , params+ , paramsNel+ ) where++import Control.Monad.Catch (MonadThrow, throwM)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import Data.Either (partitionEithers)+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)+import Linnet.Decode+import Linnet.Endpoint+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Linnet.Output (ok)+import Network.Wai (queryString)++-- | Endpoint that tries to decode parameter @name@ from the request query string.+-- Always matches, but may throw an exception in case:+--+-- * Parameter is not presented in request query+--+-- * There was a parameter decoding error+param ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m a+param name =+ Endpoint+ { runEndpoint =+ \input ->+ let maybeParam = (lookup name . queryString . request) input+ output =+ case maybeParam of+ Just (Just val) ->+ case decodeEntity entity val of+ Left err -> throwM err+ Right v -> return $ ok v+ _ -> throwM $ MissingEntity entity+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "param " ++ C8.unpack name+ }+ where+ entity = Param name++-- | Endpoint that tries to decode parameter @name@ from the request query string.+-- Always matches, but may throw an exception in case:+--+-- * There was a parameter decoding error+paramMaybe ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m (Maybe a)+paramMaybe name =+ Endpoint+ { runEndpoint =+ \input ->+ let maybeParam = (lookup name . queryString . request) input+ output =+ case maybeParam of+ Just (Just val) ->+ case decodeEntity entity val of+ Left err -> throwM err+ Right v -> return $ ok (Just v)+ _ -> return $ ok Nothing+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "paramMaybe " ++ C8.unpack name+ }+ where+ entity = Param name++-- | Endpoint that tries to decode all parameters @name@ from the request query string.+-- Always matches, but may throw an exception in case:+--+-- * There was a parameter decoding error of at least one parameter value+params ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m [a]+params name =+ Endpoint+ { runEndpoint =+ \input ->+ let filterParam = filter (\(paramName, _) -> paramName == name)+ ps =+ (filterParam . queryString . request) input >>=+ (\case+ (k, Just v) -> [(k, v)]+ _ -> [])+ (errors, values) = partitionEithers . map (decodeEntity entity . snd) $ ps+ output =+ case nonEmpty errors of+ Just es -> throwM $ LinnetErrors es+ Nothing -> return $ ok values+ in Matched {matchedReminder = input, matchedOutput = output}+ , toString = "params " ++ C8.unpack name+ }+ where+ entity = Param name++-- | Endpoint that tries to decode all parameters @name@ from the request query string.+-- Always matches, but may throw an exception in case:+--+-- * There was a parameter decoding error of at least one parameter value+--+-- * All parameters are empty or missing in request query+paramsNel ::+ forall a m. (DecodeEntity a, MonadThrow m)+ => B.ByteString+ -> Endpoint m (NonEmpty a)+paramsNel name = mapOutputM toNel $ params name+ where+ toNel [] = throwM $ MissingEntity (Param name)+ toNel (h:t) = return $ ok (h :| t)
+ src/Linnet/Endpoints/Paths.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Linnet.Endpoints.Paths+ ( path+ , pathConst+ , p'+ , pathEmpty+ , paths+ , pathAny+ ) where++import Data.Data (Proxy (..), Typeable, typeRep)+import Data.Maybe (maybeToList)+import qualified Data.Text as T+import Linnet.Decode+import Linnet.Endpoint+import Linnet.Input+import Linnet.Internal.HList+import Linnet.Output (ok)++-- | Endpoint that tries to decode head of the current path reminder into specific type. It consumes head of the reminder.+--+-- * If path is empty, Endpoint is not matched+--+-- * If decoding has failed, Endpoint is not matched+path ::+ forall a m. (DecodePath a, Applicative m, Typeable a)+ => Endpoint m a+path =+ Endpoint+ { runEndpoint =+ \input ->+ case reminder input of+ [] -> NotMatched+ (h:t) ->+ case decodePath h of+ Just v -> Matched {matchedReminder = input {reminder = t}, matchedOutput = pure $ ok v}+ Nothing -> NotMatched+ , toString = show (typeRep (Proxy :: Proxy a))+ }++-- | Endpoint that matches only if the head of current path reminder is equal to some given constant value.+-- It consumes head of the reminder.+--+-- * If value matches the provided constant, saves the tail of the path as a reminder+--+-- * Otherwise, resulting endpoint is not matched+pathConst :: (Applicative m) => T.Text -> Endpoint m (HList '[])+pathConst value =+ Endpoint+ { runEndpoint =+ \input ->+ case reminder input of+ [] -> NotMatched+ (h:t) ->+ if h == value+ then Matched {matchedReminder = input {reminder = t}, matchedOutput = pure $ ok HNil}+ else NotMatched+ , toString = T.unpack value+ }++-- | Short alias for pathConst+p' :: (Applicative m) => T.Text -> Endpoint m (HList '[])+p' = pathConst++-- | Endpoint that matches only against empty path reminder+pathEmpty :: Applicative m => Endpoint m (HList '[])+pathEmpty =+ Endpoint+ { runEndpoint =+ \input ->+ case reminder input of+ [] -> Matched input (pure . ok $ HNil)+ _ -> NotMatched+ , toString = "/"+ }++-- | Endpoint that consumes the rest of the path reminder and decode it using provided DecodePath for some type @a@+paths ::+ forall a m. (DecodePath a, Applicative m, Typeable a)+ => Endpoint m [a]+paths =+ Endpoint+ { runEndpoint =+ \input ->+ Matched+ { matchedReminder = input {reminder = []}+ , matchedOutput = pure $ ok (map (decodePath @a) (reminder input) >>= maybeToList)+ }+ , toString = "[" ++ show (typeRep (Proxy :: Proxy a)) ++ "]"+ }++-- | Endpoint that matches any path and discards reminder+pathAny :: (Applicative m) => Endpoint m (HList '[])+pathAny =+ Endpoint+ { runEndpoint = \input -> Matched {matchedReminder = input {reminder = []}, matchedOutput = pure . ok $ HNil}+ , toString = "*"+ }
+ src/Linnet/Errors.hs view
@@ -0,0 +1,34 @@+module Linnet.Errors+ ( LinnetError(..)+ ) where++import Control.Exception (Exception)+import qualified Data.ByteString as B+import Data.List.NonEmpty (NonEmpty (..), toList, (<|))+import Linnet.Endpoints.Entity++data LinnetError+ = MissingEntity+ { missingEntity :: Entity+ }+ | EntityNotParsed+ { notParsedEntity :: Entity+ , entityParsingError :: LinnetError+ }+ | LinnetErrors+ { linnetErrors :: NonEmpty LinnetError+ }+ | DecodeError+ { decodeError :: B.ByteString+ }+ deriving (Eq, Show)++instance Semigroup LinnetError where+ (LinnetErrors es) <> (LinnetErrors es') =+ let (h:t) = toList es+ in LinnetErrors $ h :| (t ++ toList es')+ (LinnetErrors es) <> err = LinnetErrors $ err <| es+ err <> (LinnetErrors es) = LinnetErrors $ err <| es+ e <> e' = LinnetErrors $ e :| [e']++instance Exception LinnetError
+ src/Linnet/Input.hs view
@@ -0,0 +1,28 @@+module Linnet.Input+ ( Input(..)+ , inputGet+ , inputFromRequest+ ) where++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types (QueryItem)+import Network.Wai (Request, defaultRequest, pathInfo,+ queryString, rawPathInfo)++-- | Container for the reminder of the request path and request itself+data Input =+ Input+ { reminder :: [T.Text]+ , request :: Request+ }+ deriving (Show)++inputFromRequest :: Request -> Input+inputFromRequest req = Input {reminder = pathInfo req, request = req}++inputGet :: T.Text -> [QueryItem] -> Input+inputGet path items =+ Input {request = defaultRequest {pathInfo = r, rawPathInfo = TE.encodeUtf8 path, queryString = items}, reminder = r}+ where+ r = T.split (== '/') path
+ src/Linnet/Internal/Coproduct.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Linnet.Internal.Coproduct+ ( Coproduct(..)+ , CNil+ , AdjoinCoproduct(..)+ ) where++data CNil++instance Eq CNil where+ (==) _ _ = True++data Coproduct a b where+ Inl :: a -> Coproduct a b+ Inr :: b -> Coproduct a b+ deriving (Eq)++class ExtendBy l r out | l r -> out where+ left :: r -> out+ right :: l -> out++instance (ExtendLeftBy l r out, ExtendRightBy l r out) => ExtendBy l r out where+ left = extendLeftBy @l+ right = extendRightBy @l @r++-- | Extend coproduct @cs'@ on left with coproduct @cs@, somewhat similar to prepending list @cs@ to @cs'@+class ExtendLeftBy l r out | l r -> out where+ extendLeftBy :: r -> out++instance (Reverse l revL, ExtendLeftBy' revL r out) => ExtendLeftBy l r out where+ extendLeftBy = extendLeft' @revL++class ExtendLeftBy' revL r out | revL r -> out where+ extendLeft' :: r -> out++instance ExtendLeftBy' CNil a a where+ extendLeft' = id++instance (ExtendLeftBy' t (Coproduct h r) out) => ExtendLeftBy' (Coproduct h t) r out where+ extendLeft' r = extendLeft' @t @(Coproduct h r) $ Inr r++-- | Extend coproduct @cs'@ on right with coproduct @cs@, somewhat similar to appending list @cs@ to @cs'@+class ExtendRightBy l r out | l r -> out where+ extendRightBy :: l -> out++instance ExtendRightBy l CNil l where+ extendRightBy = id++instance (ExtendRight l h out, ExtendRightBy out t out') => ExtendRightBy l (Coproduct h t) out' where+ extendRightBy l = extendRightBy @out @t $ extendRight @l @h l++class ExtendRight cs t out | cs t -> out where+ extendRight :: cs -> out++instance (ExtendRight' (ExtendRightT cs) cs t out) => ExtendRight cs t out where+ extendRight = extendRight' @(ExtendRightT cs) @cs @t++class ExtendRight' (isLast :: Bool) cs t out | cs t -> out where+ extendRight' :: cs -> out++instance ExtendRight' 'True (Coproduct h CNil) a (Coproduct h (Coproduct a CNil)) where+ extendRight' (Inl h) = Inl h+ extendRight' (Inr t) = Inr $ Inr t++instance (ExtendRight t a out) => ExtendRight' 'False (Coproduct h t) a (Coproduct h out) where+ extendRight' (Inl h) = Inl h+ extendRight' (Inr t) = Inr $ extendRight @t @a t++type family ExtendRightT a where+ ExtendRightT (Coproduct _ CNil) = 'True+ ExtendRightT _ = 'False++-- | Reverse coproduct+class Reverse cs c | cs -> c where+ reverseCoproduct :: cs -> c++instance (Reverse' CNil cs out) => Reverse cs out where+ reverseCoproduct cs = reverseCoproduct' @CNil $ Right cs++class Reverse' acc cs out | acc cs -> out where+ reverseCoproduct' :: Either acc cs -> out++instance Reverse' acc CNil acc where+ reverseCoproduct' e =+ case e of+ Left acc -> acc++instance (Reverse' (Coproduct a acc) b out) => Reverse' acc (Coproduct a b) out where+ reverseCoproduct' e =+ reverseCoproduct' $+ case e of+ Left acc -> Left $ Inr acc+ Right (Inl h) -> Left $ Inl h+ Right (Inr t) -> Right t++-- | Flatten nested coproduct+class AdjoinCoproduct cs c | cs -> c where+ adjoinCoproduct :: cs -> c++instance (AdjoinCoproduct' (AdjoinCoproductT cs) cs c) => AdjoinCoproduct cs c where+ adjoinCoproduct = adjoinCoproduct' @(AdjoinCoproductT cs)++class AdjoinCoproduct' (isNested :: Bool) cs c | cs -> c where+ adjoinCoproduct' :: cs -> c++instance AdjoinCoproduct' 'False CNil CNil where+ adjoinCoproduct' = id++instance (h ~ h', AdjoinCoproduct t out) => AdjoinCoproduct' 'False (Coproduct h' t) (Coproduct h out) where+ adjoinCoproduct' (Inl h) = Inl h+ adjoinCoproduct' (Inr t) = Inr $ adjoinCoproduct t++instance (AdjoinCoproduct t out, ExtendBy h out out') => AdjoinCoproduct' 'True (Coproduct h t) out' where+ adjoinCoproduct' (Inl h) = right @h @out h+ adjoinCoproduct' (Inr t) = left @h $ adjoinCoproduct t++type family AdjoinCoproductT a where+ AdjoinCoproductT (Coproduct (Coproduct _ _) _) = 'True+ AdjoinCoproductT _ = 'False
+ src/Linnet/Internal/HList.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Linnet.Internal.HList+ ( HList(..)+ , AdjoinHList(..)+ , FnToProduct(..)+ ) where++infixr 6 :::++data HList xs where+ HNil :: HList '[]+ (:::) :: a -> HList as -> HList (a ': as)++class Prepend a b ab | a b -> ab where+ prependHList :: HList a -> HList b -> HList ab++instance (Prepend' (PrependT a b) a b ab) => Prepend a b ab where+ prependHList = prependHList' @(PrependT a b)++class Prepend' (lists :: PrependHList) a b ab | a b -> ab where+ prependHList' :: HList a -> HList b -> HList ab++data PrependHList+ = LeftHNil+ | RightHNil+ | BothHNil+ | NoneHNil++type family PrependT a b where+ PrependT '[] '[] = 'BothHNil+ PrependT _ '[] = 'RightHNil+ PrependT '[] _ = 'LeftHNil+ PrependT _ _ = 'NoneHNil++instance Prepend' 'BothHNil '[] '[] '[] where+ prependHList' _ _ = HNil++instance Prepend' 'LeftHNil '[] b b where+ prependHList' _ b = b++instance Prepend' 'RightHNil a '[] a where+ prependHList' a _ = a++instance (Prepend as (b ': bs) cs) => Prepend' 'NoneHNil (a ': as) (b ': bs) (a ': cs) where+ prependHList' (a ::: as) (b ::: bs) = a ::: prependHList as (b ::: bs)++class AdjoinHList ls l | ls -> l where+ adjoin :: HList ls -> HList l++instance AdjoinHList' (NeedAdjoin ls) ls l => AdjoinHList ls l where+ adjoin = adjoin' @(NeedAdjoin ls)++class AdjoinHList' (needAdjoin :: Bool) ls l | ls -> l where+ adjoin' :: HList ls -> HList l++instance AdjoinHList' 'False '[] '[] where+ adjoin' _ = HNil++instance (AdjoinHList t out) => AdjoinHList' 'False (h ': t) (h ': out) where+ adjoin' (h ::: t) = h ::: adjoin t++instance (AdjoinHList t ao, Prepend a ao po) => AdjoinHList' 'True (HList a ': t) po where+ adjoin' (l ::: t) = prependHList l (adjoin t)++type family NeedAdjoin (l :: [*]) :: Bool where+ NeedAdjoin (HList a ': t) = 'True+ NeedAdjoin '[] = 'False+ NeedAdjoin (a ': t) = 'False++instance Show (HList '[]) where+ show HNil = "HNil"++instance (Show a, Show (HList as)) => Show (HList (a ': as)) where+ show (a ::: as) = show a ++ " ::: " ++ show as++instance Eq (HList '[]) where+ (==) HNil HNil = True++instance (Eq a, Eq (HList as)) => Eq (HList (a ': as)) where+ (==) (a ::: as) (a' ::: as') = a == a' && as == as'++class FnToProduct fn ls out | fn ls -> out, ls out -> fn where+ fromFunction :: fn -> HList ls -> out++instance (v ~ fn) => FnToProduct fn '[] v where+ fromFunction v HNil = v++instance (FnToProduct fnOut tail out) => FnToProduct (input -> fnOut) (input ': tail) out where+ fromFunction fn (input ::: t) = fromFunction (fn input) t
+ src/Linnet/Output.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Linnet.Output+ ( Output(..)+ , Payload(..)+ , ok+ , created+ , accepted+ , noContent+ , badRequest+ , unauthorized+ , paymentRequired+ , forbidden+ , notFound+ , methodNotAllowed+ , notAcceptable+ , conflict+ , gone+ , lengthRequired+ , preconditionFailed+ , requestEntityTooLarge+ , unprocessableEntity+ , tooManyRequests+ , internalServerError+ , notImplemented+ , badGateway+ , serviceUnavailable+ , gatewayTimeout+ , payloadOutput+ , payloadError+ , payloadEmpty+ , transformM+ , withHeader+ , outputToResponse+ ) where++import Control.Exception (Exception, SomeException,+ toException)+import Control.Monad.Catch (MonadThrow (..))+import qualified Data.ByteString as B+import qualified Data.CaseInsensitive as CI+import GHC.TypeLits (KnownSymbol)+import Linnet.ToResponse (ToResponse (..))+import Network.HTTP.Types (Header)+import Network.HTTP.Types.Status+import Network.Wai++-- | Output of 'Endpoint' that carries some 'Payload' @a@ together with response status and headers+data Output a =+ Output+ { outputStatus :: Status+ , outputPayload :: Payload a+ , outputHeaders :: [Header]+ }++-- | Payload of 'Output' that could be:+data Payload a+ = Payload a -- ^ Payload with some value @a@+ | NoPayload -- ^ Represents empty response+ | forall e. Exception e =>+ ErrorPayload e -- ^ Failed payload with an exception inside++deriving instance (Show a) => Show (Payload a)++instance (Show a) => Show (Output a) where+ show out = "Output(" ++ show (statusCode $ outputStatus out) ++ ", " ++ show (outputPayload out) ++ ")"++instance Functor Output where+ fmap f (Output status (Payload a) headers) = Output status (Payload (f a)) headers+ fmap _ (Output status NoPayload headers) = Output status NoPayload headers+ fmap _ (Output status (ErrorPayload e) headers) = Output status (ErrorPayload e) headers++instance Applicative Output where+ pure = ok+ (<*>) (Output _ (Payload f) _) (Output status (Payload a) headers) =+ Output {outputStatus = status, outputPayload = Payload (f a), outputHeaders = headers}+ (<*>) (Output status NoPayload headers) _ = Output status NoPayload headers+ (<*>) (Output status (ErrorPayload e) headers) _ =+ Output {outputStatus = status, outputPayload = ErrorPayload e, outputHeaders = headers}+ (<*>) _ (Output status NoPayload headers) =+ Output {outputStatus = status, outputPayload = NoPayload, outputHeaders = headers}+ (<*>) _ (Output status (ErrorPayload e) headers) =+ Output {outputStatus = status, outputPayload = ErrorPayload e, outputHeaders = headers}++instance Monad Output where+ (>>=) (Output _ (Payload a) _) f = f a+ (>>=) (Output status NoPayload headers) _ =+ Output {outputStatus = status, outputPayload = NoPayload, outputHeaders = headers}+ (>>=) (Output status (ErrorPayload e) headers) _ =+ Output {outputStatus = status, outputPayload = ErrorPayload e, outputHeaders = headers}++instance MonadThrow Output where+ throwM = internalServerError++instance Foldable Output where+ foldMap fn (Output _ (Payload a) _) = fn a+ foldMap _ _ = mempty++instance Traversable Output where+ traverse fn (Output status (Payload a) headers) = (\v -> Output status (Payload v) headers) <$> fn a+ traverse _ (Output status NoPayload headers) =+ pure $ Output {outputStatus = status, outputPayload = NoPayload, outputHeaders = headers}+ traverse _ (Output status (ErrorPayload e) headers) =+ pure $ Output {outputStatus = status, outputPayload = ErrorPayload e, outputHeaders = headers}++-- | Add header to given 'Output'+withHeader :: (B.ByteString, B.ByteString) -> Output a -> Output a+withHeader (k, v) (Output status payload headers) =+ Output {outputStatus = status, outputPayload = payload, outputHeaders = (CI.mk k, v) : headers}++-- | Transform payload of output+transformM :: (Applicative m) => (a -> m (Output b)) -> Output a -> m (Output b)+transformM fn (Output _ (Payload a) _) = fn a+transformM _ (Output status NoPayload headers) =+ pure $ Output {outputStatus = status, outputPayload = NoPayload, outputHeaders = headers}+transformM _ (Output status (ErrorPayload e) headers) =+ pure $ Output {outputStatus = status, outputPayload = ErrorPayload e, outputHeaders = headers}++-- | Create 'Output' with 'Payload' @a@ and status @OK 200@+ok :: a -> Output a+ok = payloadOutput ok200++-- | Create 'Output' with 'Payload' @a@ and status @CREATED 201@+created :: a -> Output a+created = payloadOutput created201++-- | Create 'Output' with @NoPayload@ and status @ACCEPTED 202@+accepted :: Output a+accepted = payloadEmpty accepted202++-- | Create 'Output' with @NoPayload@ and status @NO CONTENT 202@+noContent :: Output a+noContent = payloadEmpty noContent204++-- | Create 'Output' with @ErrorPayload e@ and status @BAD REQUEST 400@+badRequest :: (Exception e) => e -> Output a+badRequest = payloadError badRequest400++-- | Create 'Output' with @ErrorPayload e@ and status @UNAUTHORIZED 401@+unauthorized :: (Exception e) => e -> Output a+unauthorized = payloadError unauthorized401++-- | Create 'Output' with @ErrorPayload e@ and status @PAYMENT REQUIRED 402@+paymentRequired :: (Exception e) => e -> Output a+paymentRequired = payloadError paymentRequired402++-- | Create 'Output' with @ErrorPayload e@ and status @FORBIDDEN 403@+forbidden :: (Exception e) => e -> Output a+forbidden = payloadError forbidden403++-- | Create 'Output' with @ErrorPayload e@ and status @NOT FOUND 404@+notFound :: (Exception e) => e -> Output a+notFound = payloadError notFound404++-- | Create 'Output' with @ErrorPayload e@ and status @METHOD NOT ALLOWED 405@+methodNotAllowed :: (Exception e) => e -> Output a+methodNotAllowed = payloadError methodNotAllowed405++-- | Create 'Output' with @ErrorPayload e@ and status @NOT ACCEPTABLE 406@+notAcceptable :: (Exception e) => e -> Output a+notAcceptable = payloadError notAcceptable406++-- | Create 'Output' with @ErrorPayload e@ and status @CONFLICT 409@+conflict :: (Exception e) => e -> Output a+conflict = payloadError conflict409++-- | Create 'Output' with @ErrorPayload e@ and status @GONE 410@+gone :: (Exception e) => e -> Output a+gone = payloadError gone410++-- | Create 'Output' with @ErrorPayload e@ and status @LENGTH REQUIRED 411@+lengthRequired :: (Exception e) => e -> Output a+lengthRequired = payloadError lengthRequired411++-- | Create 'Output' with @ErrorPayload e@ and status @PRECONDITIONED FAILED 412@+preconditionFailed :: (Exception e) => e -> Output a+preconditionFailed = payloadError preconditionFailed412++-- | Create 'Output' with @ErrorPayload e@ and status @REQUEST ENTITY TOO LARGE 413@+requestEntityTooLarge :: (Exception e) => e -> Output a+requestEntityTooLarge = payloadError requestEntityTooLarge413++-- | Create 'Output' with @ErrorPayload e@ and status @UNPROCESSABLE ENTITY 422@+unprocessableEntity :: (Exception e) => e -> Output a+unprocessableEntity = payloadError unprocessableEntity422++-- | Create 'Output' with @ErrorPayload e@ and status @TOO MANY REQUESTS 422@+tooManyRequests :: (Exception e) => e -> Output a+tooManyRequests = payloadError tooManyRequests429++-- | Create 'Output' with @ErrorPayload e@ and status @INTERNAL SERVER ERROR 500@+internalServerError :: (Exception e) => e -> Output a+internalServerError = payloadError internalServerError500++-- | Create 'Output' with @ErrorPayload e@ and status @NOT IMPLEMENTED 501@+notImplemented :: (Exception e) => e -> Output a+notImplemented = payloadError notImplemented501++-- | Create 'Output' with @ErrorPayload e@ and status @BAD GATEWAY 502@+badGateway :: (Exception e) => e -> Output a+badGateway = payloadError badGateway502++-- | Create 'Output' with @ErrorPayload e@ and status @SERVICE UNAVAILABLE 503@+serviceUnavailable :: (Exception e) => e -> Output a+serviceUnavailable = payloadError serviceUnavailable503++-- | Create 'Output' with @ErrorPayload e@ and status @GATEWAY TIMEOUT 504@+gatewayTimeout :: (Exception e) => e -> Output a+gatewayTimeout = payloadError gatewayTimeout504++-- | Create successful 'Output' with payload @a@ and given status+payloadOutput :: Status -> a -> Output a+payloadOutput status payload = Output {outputStatus = status, outputPayload = Payload payload, outputHeaders = []}++-- | Create failed 'Output' with exception @e@ and given status+payloadError :: (Exception e) => Status -> e -> Output a+payloadError status err = Output {outputStatus = status, outputPayload = ErrorPayload err, outputHeaders = []}++-- | Create empty 'Output' with given status+payloadEmpty :: Status -> Output a+payloadEmpty status = Output {outputStatus = status, outputPayload = NoPayload, outputHeaders = []}++outputToResponse ::+ forall a ct. (KnownSymbol ct, ToResponse ct a, ToResponse ct SomeException)+ => Output a+ -> Response+outputToResponse output =+ let response =+ case outputPayload output of+ Payload a -> toResponse @ct a+ NoPayload -> toResponse @ct ()+ ErrorPayload e -> toResponse @ct $ toException e+ in (mapResponseStatus (const (outputStatus output)) . mapResponseHeaders (++ outputHeaders output)) response
+ src/Linnet/ToResponse.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Linnet.ToResponse+ ( ToResponse(..)+ ) where++import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import Data.Proxy (Proxy(..))+import GHC.Base (Symbol)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Linnet.Encode (Encode(..))+import Linnet.Internal.Coproduct (CNil, Coproduct(..))+import Network.HTTP.Types (status200, status404)+import Network.Wai (Response, responseLBS)++-- | Type-class to convert a value of type @a@ into Response with Content-Type of @ct@+class ToResponse (ct :: Symbol) a where+ toResponse :: a -> Response++instance (ToResponse' (ValueT a) ct a) => ToResponse ct a where+ toResponse = toResponse' @(ValueT a) @ct++class ToResponse' (value :: Value) (ct :: Symbol) a where+ toResponse' :: a -> Response++instance (Encode ct a, KnownSymbol ct) => ToResponse' 'Value ct a where+ toResponse' a = mkResponse @ct $ encode @ct a++instance ToResponse' 'ResponseValue ct Response where+ toResponse' = id++instance (KnownSymbol ct) => ToResponse' 'UnitValue ct () where+ toResponse' _ = mkResponse @ct mempty++instance ToResponse' 'CNilValue ct CNil where+ toResponse' _ = responseLBS status404 [] mempty++instance (ToResponse ct a, ToResponse ct b) => ToResponse' 'CoproductValue ct (Coproduct a b) where+ toResponse' (Inl a) = toResponse @ct a+ toResponse' (Inr b) = toResponse @ct b++mkResponse ::+ forall ct. (KnownSymbol ct)+ => BL.ByteString+ -> Response+mkResponse = responseLBS status200 [("Content-Type", C8.pack $ symbolVal (Proxy :: Proxy ct))]++data Value+ = Value+ | ResponseValue+ | CoproductValue+ | CNilValue+ | UnitValue++type family ValueT (a :: *) :: Value where+ ValueT (Coproduct _ _) = 'CoproductValue+ ValueT CNil = 'CNilValue+ ValueT Response = 'ResponseValue+ ValueT () = 'UnitValue+ ValueT _ = 'Value
+ test/BodySpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module BodySpec+ ( spec+ ) where++import Control.Concurrent (MVar, newMVar, putMVar, readMVar,+ tryTakeMVar)+import Control.Exception (SomeException, toException)+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import Data.ByteString.Conversion (ToByteString, toByteString')+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import Debug.Trace (trace)+import EntityEndpointLaws+import Instances+import Linnet+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Network.Wai (Request (..),+ RequestBodyLength (..))+import Test.Hspec+import Test.QuickCheck (property)+import Test.QuickCheck.Monadic (assert, monadicIO)+import Util++withBody :: (ToByteString a) => MVar a -> Input+withBody mvar =+ let i = inputGet "/" []+ req = request i+ mBody = do+ result <- tryTakeMVar mvar+ return+ (case result of+ Just value -> toByteString' value+ Nothing -> mempty)+ in i {request = req {requestBody = mBody, requestBodyLength = KnownLength 123}}++withEmptyBody :: Input+withEmptyBody =+ let i = inputGet "/" []+ req = request i+ in i {request = req {requestBody = pure mempty, requestBodyLength = KnownLength 0}}++spec :: Spec+spec = do+ it "decodes body correctly" $+ property $ \(foo :: Foo) ->+ monadicIO $ do+ let e = textBody @Foo @IO+ mvar <- liftIO $ newMVar (show foo)+ result <- liftIO $ resultOutputEither (runEndpoint e (withBody mvar))+ assert $ result == (Right $ Just (ok foo))+ it "decodes optional body correctly" $+ property $ \(foo :: Foo) ->+ monadicIO $ do+ let e = textBodyMaybe @Foo @IO+ mvar <- liftIO $ newMVar (show foo)+ result <- liftIO $ resultOutputEither (runEndpoint e (withBody mvar))+ assert $ result == (Right $ Just (ok (Just foo)))+ it "throws an error if body is missing" $ do+ let e = textBody @Foo @IO+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Left $ toException (MissingEntity Body))+ it "throws an error if body is malformed" $ do+ let e = textBody @Foo @IO+ mvar <- newMVar ("foo" :: T.Text)+ result <- resultOutputEither (runEndpoint e (withBody mvar))+ result `shouldBe` (Left $ toException (EntityNotParsed Body (DecodeError "Couldn't parse Foo")))+ it "returns nothing if body is not required" $ do+ let e = textBodyMaybe @Foo @IO+ result <- resultOutputEither (runEndpoint e withEmptyBody)+ result `shouldBe` (Right $ Just $ ok Nothing)
+ test/BootstrapSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module BootstrapSpec where++import Test.Hspec++import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)+import Control.Monad.Catch (throwM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ReaderT (..))+import qualified Data.CaseInsensitive as CI+import Data.Function ((&))+import Data.Functor.Identity (runIdentity)+import qualified Data.Text as T+import Instances+import Linnet+import Linnet.Bootstrap+import Linnet.Endpoint+import Linnet.Errors+import Linnet.Output+import Network.HTTP.Types (status400, status404)+import Network.Wai (defaultRequest, pathInfo,+ responseHeaders, responseStatus)+import Network.Wai.Internal (ResponseReceived (..))+import Test.QuickCheck (property)+import Test.QuickCheck.Monadic (assert, monadicIO)++spec :: Spec+spec = do+ it "compiles endpoint to Kleisli" $+ property $ \(out :: (Output T.Text)) ->+ monadicIO $ do+ let readerT = bootstrap @TextPlain (liftOutputM (return out)) & compile+ result <- liftIO $ runReaderT readerT defaultRequest+ assert (result == outputToResponse @T.Text @TextPlain out)+ it "responds with corresponding content-type" $+ property $ \(out :: (Output T.Text)) ->+ monadicIO $ do+ let readerT = bootstrap @TextPlain (liftOutputM (return out)) & compile+ result <- liftIO $ runReaderT readerT defaultRequest+ let maybeContentType = lookup (CI.mk "Content-Type") (responseHeaders result)+ assert (maybeContentType == Just "text/plain")+ it "responds with 404" $+ property $ \(out :: (Output T.Text)) ->+ monadicIO $ do+ let readerT = bootstrap @TextPlain (p' "foo" ~>> (return . ok $ ("text" :: T.Text))) & compile+ result <- liftIO $ runReaderT readerT defaultRequest+ assert (responseStatus result == status404)+ it "responds with 400 on LinnetError" $+ property $ \(out :: (Output T.Text)) ->+ monadicIO $ do+ let endpoint = liftOutputM (throwM $ DecodeError "oops") :: Endpoint IO T.Text+ let readerT = bootstrap @TextPlain endpoint & compile+ result <- liftIO $ runReaderT readerT defaultRequest+ assert (responseStatus result == status400)+ it "serves different content-types" $+ property $ \(out :: (Output T.Text)) ->+ monadicIO $ do+ let text = get (p' "foo") ~>> return out+ let html = get (p' "bar") ~>> return out+ let readerT = bootstrap @TextPlain text & serve @TextHtml html & compile+ textResult <- liftIO $ runReaderT readerT (defaultRequest {pathInfo = ["foo"]})+ htmlResult <- liftIO $ runReaderT readerT (defaultRequest {pathInfo = ["bar"]})+ let contentType = lookup (CI.mk "Content-Type")+ let maybeTextContentType = contentType (responseHeaders textResult)+ let maybeHtmlContentType = contentType (responseHeaders htmlResult)+ assert (maybeTextContentType == Just "text/plain")+ assert (maybeHtmlContentType == Just "text/html")+ it "compiles into WAI application" $+ property $ \(out :: (Output T.Text)) ->+ monadicIO $ do+ let app = bootstrap @TextPlain (liftOutputM (return out)) & compile & toApp id+ mvar <- liftIO newEmptyMVar+ let callback req = ResponseReceived <$ putMVar mvar req+ _ <- liftIO $ app defaultRequest callback+ response <- liftIO $ takeMVar mvar+ assert (response == outputToResponse @T.Text @TextPlain out)
+ test/CookieSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module CookieSpec+ ( spec+ ) where++import Control.Exception (SomeException, toException)+import qualified Data.ByteString as BS+import Data.ByteString.Conversion (ToByteString, toByteString')+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import EntityEndpointLaws+import Instances+import Linnet+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Network.Wai (Request (..))+import Test.Hspec+import Util+import Network.URI.Encode (encodeByteString)++withCookie :: (ToByteString a) => BS.ByteString -> a -> Input+withCookie key value =+ let i = inputGet "/" []+ req = request i+ headers = requestHeaders req+ in i+ { request =+ req+ { requestHeaders =+ headers ++ [(CI.mk "Cookie", key `BS.append` "=" `BS.append` encodeByteString (toByteString' value))]+ }+ }++spec :: Spec+spec = do+ checkLaws "Text" $ entityEndpointLaws @T.Text @(Either SomeException) (cookie "x") (withCookie "x")+ checkLaws "Int" $ entityEndpointLaws @Int @(Either SomeException) (cookie "x") (withCookie "x")+ checkLaws "Double" $ entityEndpointLaws @Double @(Either SomeException) (cookie "x") (withCookie "x")+ checkLaws "Float" $ entityEndpointLaws @Float @(Either SomeException) (cookie "x") (withCookie "x")+ it "throws an error if cookie is missing" $ do+ let e = cookie @BS.ByteString @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Left $ toException (MissingEntity (Cookie "foo")))+ it "throws an error if header is malformed" $ do+ let e = cookie @Int @IO "foo"+ result <- resultOutputEither (runEndpoint e (withCookie "foo" ("bar" :: BS.ByteString)))+ result `shouldBe` (Left $ toException (EntityNotParsed (Cookie "foo") (DecodeError "Failed reading: Invalid Int")))+ it "returns nothing if cookie is not required" $ do+ let e = cookieMaybe @BS.ByteString @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Right $ Just $ ok Nothing)
+ test/DecodeLaws.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module DecodeLaws where++import Data.ByteString.Conversion (ToByteString, toByteString')+import Data.Text (pack)+import qualified Data.Text as T+import Linnet.Decode+import Linnet.Endpoints.Entity (Entity)+import Test.QuickCheck (Arbitrary, property)+import Test.QuickCheck.Classes (Laws (..))++decodePathLaws ::+ forall a. (DecodePath a, Arbitrary a, Show a, Eq a)+ => (a -> T.Text)+ -> Laws+decodePathLaws encode = Laws "DecodePath" laws+ where+ roundTrip = property $ \(a :: a) -> decodePath (encode a) == Just a+ laws = [("roundTrip", roundTrip)]++decodeEntityLaws ::+ forall a. (DecodeEntity a, Arbitrary a, Show a, Eq a, Arbitrary Entity, ToByteString a)+ => Laws+decodeEntityLaws = Laws "DecodeEntity" laws+ where+ roundTrip = property $ \(a :: a, entity :: Entity) -> decodeEntity entity (toByteString' a) == Right a+ laws = [("roundTrip", roundTrip)]
+ test/DecodeSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeApplications #-}++module DecodeSpec+ ( spec+ ) where++import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import DecodeLaws+import Instances+import Test.Hspec (Spec, describe)+import Test.QuickCheck.Instances+import Util++spec :: Spec+spec = do+ checkLaws "Text" $ decodePathLaws @T.Text id+ checkLaws "Integer" $ decodePathLaws @Integer (T.pack . show)+ checkLaws "Int" $ decodePathLaws @Int (T.pack . show)+ checkLaws "Text" $ decodeEntityLaws @T.Text+ checkLaws "Integer" $ decodeEntityLaws @Integer+ checkLaws "Int" $ decodeEntityLaws @Int
+ test/EncodeLaws.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module EncodeLaws+ ( encodeLaws+ , encodeTextLaws+ ) where++import Data.ByteString.Conversion (ToByteString, toByteString)+import GHC.Base (Symbol)+import Linnet (TextPlain)+import Linnet.Encode+import Test.QuickCheck (Arbitrary, property)+import Test.QuickCheck.Classes (Laws (..))++encodeLaws ::+ forall a (ct :: Symbol). (ToByteString a, Encode ct a, Arbitrary a, Show a)+ => Laws+encodeLaws = Laws "Encode" properties+ where+ roundTrip = property $ \(a :: a) -> encode @ct @a a == toByteString a+ properties = [("roundTrip", roundTrip)]++encodeTextLaws ::+ forall a. (ToByteString a, Encode TextPlain a, Arbitrary a, Show a)+ => Laws+encodeTextLaws = encodeLaws @a @TextPlain
+ test/EncodeSpec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeApplications #-}++module EncodeSpec+ ( spec+ ) where++import EncodeLaws+import Test.Hspec+import Test.QuickCheck.Instances+import Util++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++spec :: Spec+spec = do+ checkLaws "Text" (encodeTextLaws @T.Text)+ checkLaws "Text.Lazy" (encodeTextLaws @TL.Text)+ checkLaws "ByteString" (encodeTextLaws @BS.ByteString)+ checkLaws "ByteString.Lazy" (encodeTextLaws @BL.ByteString)+ checkLaws "Int" (encodeTextLaws @Int)+ checkLaws "Double" (encodeTextLaws @Double)
+ test/EndpointSpec.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module EndpointSpec+ ( spec+ ) where++import Control.Applicative ((<|>))+import Control.Exception (SomeException, fromException,+ toException)+import Control.Monad.Catch (throwM)+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as B+import Data.Either (isLeft, lefts)+import Data.Function ((&))+import Data.Functor.Identity+import Data.List (uncons)+import Data.List.NonEmpty (NonEmpty (..), toList)+import Data.Maybe (isNothing, maybeToList)+import qualified Data.Text as T+import Debug.Trace (trace)+import ExtractPathLaws+import Instances+import Linnet+import Linnet.Endpoint+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Linnet.Internal.Coproduct (Coproduct (..))+import Linnet.Internal.HList+import Linnet.Output (withHeader)+import Network.HTTP.Types (methodConnect, methodDelete,+ methodGet, methodHead,+ methodOptions, methodPatch,+ methodPost, methodPut, methodTrace)+import Network.Wai (requestMethod)+import Test.Hspec+import Test.QuickCheck (conjoin, property)+import Test.QuickCheck.Monadic (assert, monadicIO, run)+import Util++spec :: Spec+spec = do+ checkLaws "Text" $ extractPathLaws @T.Text+ checkLaws "Int" $ extractPathLaws @Int+ it "supports simple fmap" $+ property $ \(i :: Input) ->+ resultValueUnsafe (runEndpoint (T.toUpper <$> path @T.Text) i) ==+ Identity (fmap T.toUpper . headOption $ reminder i)+ it "supports transformOutput" $+ property $ \(e :: Endpoint (Either SomeException) String) ->+ transformOutput ((fmap . fmap) length) e == fmap length e+ it "supports transform" $+ property $ \(e :: Endpoint (Either SomeException) String) -> transform (fmap length) e == fmap length e+ it "propagates default (Ok) output" $+ property $ \(i :: Input) ->+ resultOutputUnsafe (runEndpoint (path @T.Text) i) == Identity (fmap ok . headOption $ reminder i)+ it "propagates default (Ok) output through fmap, mapM'" $+ property $ \(i :: Input) ->+ let expected = ok . T.length <$> (headOption . reminder) i+ endpoint = path @T.Text+ in resultOutputUnsafe (runEndpoint (fmap T.length endpoint) i) == Identity expected &&+ resultOutputUnsafe (runEndpoint (mapM' (pure . T.length) endpoint) i) == Identity expected+ it "propagates output through mapOutputM" $+ property $ \(i :: Input) ->+ let expected i = withHeader ("Foo", "Bar") $ created i+ in resultOutputUnsafe (runEndpoint (mapOutputM (pure . expected . T.length) $ path @T.Text) i) ==+ Identity (fmap (expected . T.length) (headOption $ reminder i))+ it "matches one path segment" $+ property $ \(i :: Input) ->+ let v = (maybeToList . headOption . reminder $ i) >>= (\s -> [matchedReminder $ runEndpoint (p' @Identity s) i])+ in null v || v == [i {reminder = tail . reminder $ i}]+ it "matches the entire input with pathAny" $+ property $ \(i :: Input) -> matchedReminder (runEndpoint (pathAny @Identity) i) == i {reminder = []}+ it "matches empty path" $+ property $ \(i :: Input) ->+ let result = runEndpoint (pathEmpty @Identity) i+ in (null (reminder i) && isMatched result) || (reminder i /= [] && not (isMatched result))+ it "matches the HTTP method" $+ let matchMethod :: B.ByteString -> (Endpoint Identity (HList '[]) -> Endpoint Identity (HList '[])) -> Input -> Bool+ matchMethod method f input =+ let result = runEndpoint (f zero) input+ in ((requestMethod . request) input == method && maybeReminder result == Just input) ||+ ((requestMethod . request) input /= method && isNothing (maybeReminder result))+ in conjoin+ [ property $ matchMethod methodGet get+ , property $ matchMethod methodPost post+ , property $ matchMethod methodPut put+ , property $ matchMethod methodPatch patch+ , property $ matchMethod methodDelete delete+ , property $ matchMethod methodHead head'+ , property $ matchMethod methodOptions options+ , property $ matchMethod methodConnect connect+ , property $ matchMethod methodTrace trace'+ ]+ it "always matches with identity instance" $+ property $ \(i :: Input) -> maybeReminder (runEndpoint (zero @Identity) i) == Just i+ it "matches & consumes the entire input" $+ property $ \(i :: Input) ->+ let e = foldl (//) (zero @(Either SomeException)) $ map p' (reminder i)+ in maybeReminder (runEndpoint e i) == Just (i {reminder = []})+ it "shouldn't match if one of the endpoints has failed in (//) composition" $+ property $ \(i :: Input, s :: T.Text) ->+ isNothing (maybeReminder (runEndpoint (pathAny @(Either SomeException) // p' s) i))+ it "matches if at least one of the endpoints succeed in alternative <|>" $+ let matchOneOfTwo :: (T.Text -> Endpoint IO (HList '[])) -> Input -> Bool+ matchOneOfTwo f input = isNothing v || v == Just input {reminder = tail $ reminder input}+ where+ v = f <$> (headOption . reminder) input >>= (\e -> maybeReminder (runEndpoint e input))+ in conjoin+ [ property $ matchOneOfTwo (\s -> p' s <|> p' (T.reverse s))+ , property $ matchOneOfTwo (\s -> p' (T.reverse s) <|> p' s)+ ]+ it "always responds with the same output if it's constant" $+ conjoin+ [ property $ \(t :: T.Text) ->+ monadicIO $ do+ p <- liftIO $ resultValueUnsafe (runEndpoint (pure t) (inputGet "/" []))+ l <- liftIO $ resultValueUnsafe (runEndpoint (lift $ pure t) (inputGet "/" []))+ assert (p == Just t)+ assert (l == Just t)+ , property $ \(out :: Output T.Text) ->+ resultOutputUnsafe (runEndpoint (liftOutputM $ pure out) (inputGet "/" [])) == Identity (Just out)+ ]+ it "handles the exception raised in a monad" $+ property $ \(i :: Input, s :: T.Text) ->+ monadicIO $ do+ let e = lift (throwM @IO (TestException "test")) & handle (\(e :: TestException) -> return $ created s)+ result <- liftIO $ runEndpoint e i & resultOutputEither+ assert (result == Right (Just (created s)))+ it "re-raises the exception if it wasn't handled" $+ property $ \(i :: Input, s :: T.Text) ->+ monadicIO $ do+ let e :: Endpoint IO T.Text = lift (throwM @IO (TestException "test"))+ result <- liftIO $ runEndpoint e i & resultOutputEither+ assert (result == Left (toException $ TestException "test"))+ it "throws MissingEntity if an item wasn't found" $ do+ let i = inputGet "/" []+ let name = "test"+ let (endpoints, exceptions) =+ unzip+ [ (param @T.Text name, MissingEntity $ Param name)+ , (T.intercalate ";" . toList <$> paramsNel @T.Text name, MissingEntity $ Param name)+ , (header @T.Text name, MissingEntity $ Header name)+ , (cookie @T.Text name, MissingEntity $ Cookie name)+ , (textBody @T.Text, MissingEntity Body)+ ]+ results <- lefts <$> mapM (\e -> runEndpoint e i & resultOutputEither) endpoints+ map fromException results `shouldBe` Just <$> exceptions+ it "accumulates Linnet errors in product" $+ property $ \(i :: Input, e :: LinnetError, e' :: LinnetError) ->+ monadicIO $ do+ let ea = lift @IO @Int (throwM e)+ let eb = lift @IO @Int (throwM e')+ result <- liftIO $ resultOutputEither (runEndpoint (ea // eb) i)+ result' <- liftIO $ resultOutputEither (runEndpoint (eb // ea) i)+ assert (result == (Left $ toException (e <> e')))+ assert (result' == (Left $ toException (e' <> e)))+ it "fails fast once non-Linnet error is observed" $+ property $ \(i :: Input, e :: LinnetError) ->+ monadicIO $ do+ let exception = TestException "foo"+ let ea = lift @IO @Int (throwM e)+ let eb = lift @IO @Int (throwM exception)+ result <- liftIO $ resultOutputEither (runEndpoint (ea // eb) i)+ result' <- liftIO $ resultOutputEither (runEndpoint (eb // ea) i)+ assert (result == (Left $ toException exception))+ assert (result' == (Left $ toException exception))+ it "selects endpoint with the least reminder" $+ property $ \(i :: Input, s :: T.Text) ->+ monadicIO $ do+ let e1 = foldl (\acc segment -> acc // p' segment) zero (reminder i) ~>> return (ok True)+ let e2 = e1 // p' s ~>> (\t -> return $ ok (5 :: Int))+ let composition = e1 |+| e2+ let composition' = e2 |+| e1+ let newInput = i {reminder = reminder i ++ [s]}+ let endpointResult1 = runEndpoint e1 newInput+ let endpointResult2 = runEndpoint e2 newInput+ assert $ isMatched endpointResult1+ assert $ isMatched endpointResult2+ result <- liftIO $ resultValueUnsafe (runEndpoint composition newInput)+ result' <- liftIO $ resultValueUnsafe (runEndpoint composition' newInput)+ assert (result == Just (Inr (Inl 5)))+ assert (result' == Just (Inl 5))+ it "returns request in root endpoint" $+ property $ \(i :: Input) -> resultValueUnsafe (runEndpoint root i) == Identity (Just $ request i)+ it "adjoins endpoints together in //" $ do+ let i = inputGet "foo/bar/zoo" []+ let endpoint = (path @T.Text // path @T.Text // path @T.Text) ~>> (\p1 p2 p3 -> return $ ok (p1, p2, p3))+ result <- liftIO $ resultValueUnsafe $ runEndpoint endpoint i+ result `shouldBe` Just ("foo", "bar", "zoo")+ it "catches exception with try" $+ property $ \(i :: Input) ->+ monadicIO $ do+ let exception = TestException "foo"+ let endpoint = (lift $ throwM exception) :: Endpoint IO Int+ let handled = try endpoint+ result <- liftIO $ resultValueUnsafe (runEndpoint handled i)+ assert $ result == Just (Left exception)
+ test/EntityEndpointLaws.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}++module EntityEndpointLaws+ ( entityEndpointLaws+ ) where++import Linnet+import Linnet.Decode (DecodeEntity (..))+import Linnet.Input (Input (..))+import Test.QuickCheck (Arbitrary, property)+import Test.QuickCheck.Classes (Laws (..))+import Util+entityEndpointLaws ::+ forall a m. (DecodeEntity a, Eq (m (Maybe a)), Applicative m, Arbitrary a, Show a)+ => Endpoint m a+ -> (a -> Input)+ -> Laws+entityEndpointLaws endpoint serialize = Laws "EntityEndpoint" properties+ where+ roundTrip =+ property $ \(a :: a) ->+ let + i = serialize a+ in resultValueUnsafe (runEndpoint endpoint i) == pure (Just a)+ properties = [("roundTrip", roundTrip)]
+ test/ExtractPathLaws.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module ExtractPathLaws+ ( extractPathLaws+ ) where++import Data.Data (Typeable)+import Data.Function ((&))+import Data.Functor.Identity (Identity (..))+import Data.Maybe (isNothing, maybeToList)+import Instances+import Linnet+import Linnet.Decode+import Linnet.Endpoint (maybeReminder)+import Linnet.Input (Input (..))+import Test.QuickCheck (Arbitrary, property)+import Test.QuickCheck.Classes (Laws (..))+import Util++extractPathLaws ::+ forall a. (DecodePath a, Arbitrary a, Typeable a, Eq a)+ => Laws+extractPathLaws = Laws "ExtractPath" properties+ where+ one = path @a+ tail' = paths @a+ extractOne =+ property $ \(i :: Input) ->+ let result = runEndpoint one i+ v = (headOption . reminder) i >>= decodePath @a+ in resultValueUnsafe result == Identity v &&+ (isNothing v || maybeReminder result == Just i {reminder = (tail . reminder) i})+ extractTail =+ property $ \(i :: Input) ->+ let result = runEndpoint tail' i+ in resultValueUnsafe result == Identity (Just $ reminder i >>= maybeToList . decodePath @a) &&+ maybeReminder result == Just i {reminder = []}+ properties = [("extractOne", extractOne), ("extractTail", extractTail)]
+ test/HeaderSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module HeaderSpec+ ( spec+ ) where++import Control.Exception (SomeException, toException)+import qualified Data.ByteString as BS+import Data.ByteString.Conversion (ToByteString, toByteString')+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import EntityEndpointLaws+import Instances+import Linnet+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Network.Wai (Request (..))+import Test.Hspec+import Util++withHeader :: (ToByteString a) => BS.ByteString -> a -> Input+withHeader key value =+ let i = inputGet "/" []+ req = request i+ headers = requestHeaders req+ in i {request = req {requestHeaders = headers ++ [(CI.mk key, toByteString' value)]}}++spec :: Spec+spec = do+ checkLaws "ByteString" $ entityEndpointLaws @BS.ByteString @(Either SomeException) (header "x") (withHeader "x")+ checkLaws "Text" $ entityEndpointLaws @T.Text @(Either SomeException) (header "x") (withHeader "x")+ checkLaws "Int" $ entityEndpointLaws @Int @(Either SomeException) (header "x") (withHeader "x")+ checkLaws "Double" $ entityEndpointLaws @Double @(Either SomeException) (header "x") (withHeader "x")+ checkLaws "Float" $ entityEndpointLaws @Float @(Either SomeException) (header "x") (withHeader "x")+ it "throws an error if header is missing" $ do+ let e = header @BS.ByteString @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Left $ toException (MissingEntity (Header "foo")))+ it "throws an error if header is malformed" $ do+ let e = header @Int @IO "foo"+ result <- resultOutputEither (runEndpoint e (withHeader "foo" ("bar" :: BS.ByteString)))+ result `shouldBe` (Left $ toException (EntityNotParsed (Header "foo") (DecodeError "Failed reading: Invalid Int")))+ it "returns nothing if cookie is not required" $ do+ let e = headerMaybe @BS.ByteString @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Right $ Just $ ok Nothing)
+ test/Instances.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Instances+ ( TestException(..)+ , Foo(..)+ ) where++import Control.Applicative (empty)+import Control.Exception (Exception,+ SomeException (..),+ catch, toException)+import qualified Control.Monad.Catch as MC+import qualified Data.ByteString as B+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8 as C8+import Data.ByteString.Conversion (ToByteString (..))+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as C8L+import qualified Data.CaseInsensitive as CI+import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty (..), toList)+import Data.Maybe (listToMaybe)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import GHC.IO (unsafePerformIO)+import Linnet (Decode (..), Encode (..),+ TextHtml, TextPlain)+import Linnet.Endpoint+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Linnet.Output+import qualified Network.HTTP.Types as HTTP+import Network.Wai (Request, defaultRequest,+ pathInfo, queryString,+ requestBody,+ requestHeaders,+ requestMethod,+ strictRequestBody)+import Network.Wai.Internal (Response (..))+import Test.QuickCheck (Arbitrary (..),+ CoArbitrary (..), Gen,+ NonEmptyList, choose,+ elements, getNonEmpty,+ listOf, oneof, sample',+ suchThat, vectorOf)+import Test.QuickCheck.Instances.ByteString+import Test.QuickCheck.Instances.Text+import Util++genNonEmptyTuple :: Gen (B.ByteString, B.ByteString)+genNonEmptyTuple = do+ t1 <- suchThat arbitrary (/= B.empty)+ t2 <- suchThat arbitrary (/= B.empty)+ return (t1, t2)++genHeader :: Gen (CI.CI B.ByteString, B.ByteString)+genHeader = do+ (t1, t2) <- genNonEmptyTuple+ return (CI.mk t1, t2)++genParam :: Gen (B.ByteString, Maybe B.ByteString)+genParam = do+ (t1, t2) <- genNonEmptyTuple+ t2' <- elements [Just t2, Nothing]+ return (t1, t2')++genCookie :: Gen (CI.CI B.ByteString, B.ByteString)+genCookie = do+ kvs <- listOf genNonEmptyTuple+ let values = map (\t -> fst t `B.append` "=" `B.append` snd t) kvs+ return (CI.mk ("Cookie" :: B.ByteString), C8.intercalate ";" values)++genPath :: Gen [T.Text]+genPath = do+ size <- choose (0, 20)+ vectorOf size $ oneof [suchThat arbitrary (/= T.empty), T.pack . show <$> arbitrary @Int, elements ["true", "false"]]++genMethod :: Gen B.ByteString+genMethod =+ elements+ [ HTTP.methodGet+ , HTTP.methodPost+ , HTTP.methodHead+ , HTTP.methodPut+ , HTTP.methodDelete+ , HTTP.methodTrace+ , HTTP.methodConnect+ , HTTP.methodOptions+ , HTTP.methodPatch+ ]++genRequest :: Gen Request+genRequest = do+ path <- genPath+ cookie <- genCookie+ headers <- listOf genHeader+ params <- listOf genParam+ method <- genMethod+ return+ defaultRequest+ { requestMethod = method+ , queryString = params+ , requestBody = pure mempty+ , pathInfo = path+ , requestHeaders = cookie : headers+ }++genInput :: Gen Input+genInput = do+ req <- genRequest+ return Input {reminder = pathInfo req, request = req}++genStatus :: Gen HTTP.Status+genStatus =+ elements+ [ HTTP.continue100+ , HTTP.switchingProtocols101+ , HTTP.ok200+ , HTTP.created201+ , HTTP.accepted202+ , HTTP.nonAuthoritative203+ , HTTP.noContent204+ , HTTP.resetContent205+ , HTTP.partialContent206+ , HTTP.multipleChoices300+ , HTTP.movedPermanently301+ , HTTP.found302+ , HTTP.seeOther303+ , HTTP.notModified304+ , HTTP.useProxy305+ , HTTP.temporaryRedirect307+ , HTTP.permanentRedirect308+ , HTTP.badRequest400+ , HTTP.unauthorized401+ , HTTP.paymentRequired402+ , HTTP.forbidden403+ , HTTP.notFound404+ , HTTP.methodNotAllowed405+ , HTTP.notAcceptable406+ , HTTP.proxyAuthenticationRequired407+ , HTTP.requestTimeout408+ , HTTP.conflict409+ , HTTP.gone410+ , HTTP.lengthRequired411+ , HTTP.preconditionFailed412+ , HTTP.requestEntityTooLarge413+ , HTTP.requestURITooLong414+ , HTTP.unsupportedMediaType415+ , HTTP.requestedRangeNotSatisfiable416+ , HTTP.expectationFailed417+ , HTTP.imATeapot418+ , HTTP.unprocessableEntity422+ , HTTP.preconditionRequired428+ , HTTP.tooManyRequests429+ , HTTP.requestHeaderFieldsTooLarge431+ , HTTP.internalServerError500+ , HTTP.notImplemented501+ , HTTP.badGateway502+ , HTTP.serviceUnavailable503+ , HTTP.gatewayTimeout504+ , HTTP.networkAuthenticationRequired511+ , HTTP.httpVersionNotSupported505+ ]++genOutputMeta :: Gen (HTTP.Status, [(CI.CI B.ByteString, B.ByteString)])+genOutputMeta = do+ status <- genStatus+ headers <- listOf genHeader+ cookie <- genCookie+ return (status, cookie : headers)++genEmptyOutput :: Gen (Output a)+genEmptyOutput = do+ (status, headers) <- genOutputMeta+ return $ Output {outputStatus = status, outputHeaders = headers, outputPayload = NoPayload}++genFailureOutput :: Gen (Output a)+genFailureOutput = do+ (status, headers) <- genOutputMeta+ str <- arbitrary+ return $ Output {outputStatus = status, outputHeaders = headers, outputPayload = ErrorPayload $ TestException str}++genPayloadOutput :: (Arbitrary a) => Gen (Output a)+genPayloadOutput = do+ (status, headers) <- genOutputMeta+ a <- arbitrary+ return $ Output {outputStatus = status, outputHeaders = headers, outputPayload = Payload a}++genOutput :: (Arbitrary a) => Gen (Output a)+genOutput = oneof [genPayloadOutput, genEmptyOutput, genFailureOutput]++genEmptyEndpoint :: (MC.MonadCatch m) => Gen (Endpoint m a)+genEmptyEndpoint = pure empty++genConstEndpoint :: (MC.MonadCatch m, Arbitrary a) => Gen (Endpoint m a)+genConstEndpoint = pure <$> arbitrary++genErrorEndpoint :: (MC.MonadThrow m) => Gen (Endpoint m a)+genErrorEndpoint = lift . MC.throwM . TestException <$> arbitrary++genEndpoint ::+ forall m a. (Arbitrary (Input -> Output a), Monad m)+ => Gen (Endpoint m a)+genEndpoint = do+ f <- arbitrary @(Input -> Output a)+ return $+ Endpoint+ { runEndpoint = \input -> Matched {matchedReminder = input, matchedOutput = pure $ (f input)}+ , toString = "arbitrary"+ }++genEntity :: Gen Entity+genEntity = oneof [genParamEntity, genHeaderEntity, genCookieEntity, genBodyEntity]+ where+ genParamEntity = Param <$> arbitrary+ genHeaderEntity = Header <$> arbitrary+ genCookieEntity = Cookie <$> arbitrary+ genBodyEntity = pure Body++genLinnetError :: Gen LinnetError+genLinnetError = oneof [genDecodeError, genMissingEntity, genEntityNotParsed]+ where+ genDecodeError = DecodeError <$> arbitrary+ genMissingEntity = MissingEntity <$> genEntity+ genEntityNotParsed = EntityNotParsed <$> genEntity <*> genLinnetError+ genLinnetErrors =+ LinnetErrors <$> do+ h <- genLinnetError+ t <- listOf genLinnetError+ return $ h :| t++newtype TestException =+ TestException String+ deriving (Show, Eq)++instance Exception TestException++instance Arbitrary Request where+ arbitrary = genRequest++instance Arbitrary Entity where+ arbitrary = genEntity++instance Arbitrary Input where+ arbitrary = genInput++instance CoArbitrary (CI.CI B.ByteString) where+ coarbitrary ci = coarbitrary (CI.original ci)++instance CoArbitrary Input where+ coarbitrary input gen =+ coarbitrary (reminder input) gen & coarbitrary ((requestMethod . request) input) &+ coarbitrary ((requestHeaders . request) input) &+ coarbitrary ((queryString . request) input)++instance Arbitrary LinnetError where+ arbitrary = genLinnetError++instance Arbitrary a => Arbitrary (Output a) where+ arbitrary = genOutput++instance (Arbitrary a, MC.MonadCatch m) => Arbitrary (Endpoint m a) where+ arbitrary = oneof [genEndpoint, genErrorEndpoint, genConstEndpoint, genEmptyEndpoint]++instance (Eq a) => Eq (Payload a) where+ (==) (Payload a) (Payload b) = a == b+ (==) NoPayload NoPayload = True+ (==) (ErrorPayload ea) (ErrorPayload eb) = show (toException ea) == show (toException eb)+ (==) _ _ = False++instance (Eq a) => Eq (Output a) where+ (==) (Output sa pa ha) (Output sb pb hb) = sa == sb && pa == pb && ha == hb++instance Eq Input where+ (==) i i' = reminder i == reminder i' && request i == request i'++instance Eq SomeException where+ (==) e e' = show e == show e'++instance Eq Request where+ (==) r r' = show r == show r'++instance Eq (m (Output a)) => Eq (EndpointResult m a) where+ (==) (Matched i m) (Matched i' m') = i == i' && m == m'+ (==) NotMatched NotMatched = True+ (==) _ _ = False++instance Eq (m (Output a)) => Eq (Endpoint m a) where+ (==) ea eb = runEndpoint ea input == runEndpoint eb input+ where+ input = head . unsafePerformIO . sample' $ genInput++instance Decode TextPlain T.Text where+ decode = Right . TE.decodeUtf8 . BL.toStrict++instance Eq a => Eq (IO a) where+ (==) i i' = unsafePerformIO (tryAll i) == unsafePerformIO (tryAll i')+ where+ tryAll m = MC.catchAll (fmap Right m) (pure . Left)++instance Eq Response where+ (==) (ResponseBuilder s hs b) (ResponseBuilder s' hs' b') =+ s == s && hs == hs' && toLazyByteString b == toLazyByteString b'++newtype Foo =+ Foo+ { x :: String+ }+ deriving (Show, Read, Eq)++instance Arbitrary Foo where+ arbitrary = Foo <$> arbitrary++instance Decode TextPlain Foo where+ decode bs =+ case (reads . C8.unpack . BL.toStrict) bs of+ [(foo, _)] -> Right foo+ _ -> Left (DecodeError "Couldn't parse Foo")++instance Encode ct SomeException where+ encode = C8L.pack . show++instance Encode TextHtml T.Text where+ encode = BL.fromStrict . TE.encodeUtf8
+ test/ParamSpec.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module ParamSpec where++import Control.Exception (SomeException, fromException,+ toException)+import qualified Data.ByteString as BS+import Data.ByteString.Conversion (ToByteString, toByteString')+import Data.Functor.Identity (Identity)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Text as T+import EntityEndpointLaws+import Instances+import Linnet+import Linnet.Endpoints.Entity+import Linnet.Errors+import Linnet.Input+import Test.Hspec+import Util++withParam :: (ToByteString a) => BS.ByteString -> a -> Input+withParam key a = inputGet "/" [(key, Just $ toByteString' a)]++spec :: Spec+spec = do+ checkLaws "ByteString" $ entityEndpointLaws @BS.ByteString @(Either SomeException) (param "x") (withParam "x")+ checkLaws "Text" $ entityEndpointLaws @T.Text @(Either SomeException) (param "x") (withParam "x")+ checkLaws "Int" $ entityEndpointLaws @Int @(Either SomeException) (param "x") (withParam "x")+ checkLaws "Double" $ entityEndpointLaws @Double @(Either SomeException) (param "x") (withParam "x")+ checkLaws "Float" $ entityEndpointLaws @Float @(Either SomeException) (param "x") (withParam "x")+ it "throws an error if param is missing" $ do+ let e = param @BS.ByteString @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Left $ toException (MissingEntity (Param "foo")))+ it "throws an error if param is malformed" $ do+ let e = param @Int @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" [("foo", Just "bar")]))+ result `shouldBe` (Left $ toException (EntityNotParsed (Param "foo") (DecodeError "Failed reading: Invalid Int")))+ it "collect errors in params & paramsNel" $ do+ let ps = params @Int @IO "test"+ let psNel = paramsNel @Int @IO "test"+ let exception = LinnetErrors $ EntityNotParsed (Param "test") (DecodeError "Failed reading: Invalid Int") :| []+ let i = inputGet "/" [("test", Just "foo")]+ result <- resultOutputEither (runEndpoint ps i)+ result `shouldBe` (Left $ toException exception)+ result' <- resultOutputEither (runEndpoint psNel i)+ result' `shouldBe` (Left $ toException exception)+ it "returns nothing if param is not required" $ do+ let e = paramMaybe @BS.ByteString @IO "foo"+ result <- resultOutputEither (runEndpoint e (inputGet "/" []))+ result `shouldBe` (Right $ Just $ ok Nothing)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Util.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Util+ ( resultValueUnsafe+ , resultOutputEither+ , resultOutputUnsafe+ , headOption+ , checkLaws+ ) where++import Control.Exception (Exception (..), SomeException (..))+import Control.Monad.Catch+import Linnet.Endpoint (EndpointResult (..))+import Linnet.Output+import Test.Hspec (Example (..), SpecWith, describe, it)+import Test.QuickCheck (Property, property)+import Test.QuickCheck.Classes (Laws (..))++headOption :: [a] -> Maybe a+headOption [] = Nothing+headOption (h:t) = Just h++resultOutputUnsafe :: (Applicative m) => EndpointResult m a -> m (Maybe (Output a))+resultOutputUnsafe (Matched _ m) = fmap Just m+resultOutputUnsafe NotMatched = pure Nothing++resultValueUnsafe :: (Applicative m) => EndpointResult m a -> m (Maybe a)+resultValueUnsafe (Matched _ m) =+ fmap+ (\case+ Output _ (Payload a) _ -> Just a+ _ -> Nothing)+ m+resultValueUnsafe NotMatched = pure Nothing++resultOutputEither :: (MonadCatch m) => EndpointResult m a -> m (Either SomeException (Maybe (Output a)))+resultOutputEither endpointResult =+ case endpointResult of+ NotMatched -> pure $ Right Nothing+ Matched {matchedOutput = m} -> catchAll (fmap (Right . Just) m) (pure . Left)++checkLaws :: String -> Laws -> SpecWith ()+checkLaws name laws = describe (lawsTypeclass laws ++ " @" ++ name) properties+ where+ properties :: SpecWith ()+ properties = mapM_ (uncurry it) (lawsProperties laws)