packages feed

waypoint (empty) → 0.1

raw patch · 10 files changed

+1940/−0 lines, 10 filesdep +basedep +bytestringdep +case-insensitive

Dependencies added: base, bytestring, case-insensitive, containers, free, hedgehog, http-types, profunctors, tasty, tasty-hedgehog, tasty-hunit, text, time, transformers, uuid-types, waypoint, witherable

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Version 0.1++* Initial version.
+ LICENSE view
@@ -0,0 +1,219 @@+Copyright 2025, Renzo Carbonara.++Except where otherwise explicitly mentioned, all of contents of the+"waypoint" project are 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 the+end of this file or 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.+++-------------------------------------------------------------------------------+++                                 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 [yyyy] [name of copyright owner]++   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,8 @@+# waypoint++Bidirectional URL path, URL query string and HTTP headers codecs, for Haskell.++* Copyright © Renzo Carbonara, 2025.++* Licensing terms in `LICENSE` file (`Apache-2.0`).+
+ lib/Waypoint.hs view
@@ -0,0 +1,91 @@+-- | This library provides vocabulary to generate encoders and decoders for URL+-- path segments, URL query strings and HTTP headers, from a single+-- bidirectional definition.+--+-- For example, consider this 'QueryCodec':+--+-- @+-- example :: 'QueryCodec' ('Int', ['String']) ('Int', ['String'])+-- example = '(,)' '<$>' 'query' \"id\" 'fst'+--                '<*>' 'queryMany' \"tag\" 'snd'+-- @+--+-- We could encode a @('Int', ['String'])@ pair into a+-- 'Network.HTTP.Types.QueryText' (from the @http-types@ library):+--+-- @+-- > 'queryEncode' example (4, [])+-- /[(\"id\", Just \"4\")]/+--+-- > 'queryEncode' example (5, ["hello", "world"])+-- /[(\"id\", Just \"5\"), (\"tag\", Just \"hello\"), (\"tag\", Just \"world\")]/+-- @+--+-- Or we could decode a 'Network.HTTP.Types.QueryText' (from the @http-types@+-- library) into a @('Int', ['String'])@ pair:+--+-- @+-- > 'queryDecode' example [(\"id\", Just \"4\")]+-- /Right ((4, []), [])/+--+-- > 'queryDecode' example [(\"id\", Just \"5\"), (\"tag\", Just \"hello\"), (\"tag\", Just \"world\")]+-- /Right ((5, [\"hello\", \"world\"]), [])/+-- @+--+-- Similarly, with 'HeaderCodec' and 'PathCodec'.+--+-- Usually, this is the only module you have to import from this library,+-- unless you are trying to extend its vocabulary somehow.+module Waypoint+   ( -- * Query+    QueryCodec++    -- ** Introduction+   , query+   , queryMaybe+   , querySome+   , queryMany+   , ToQueryValue (..)+   , FromQueryValue (..)++    -- ** Elimination+   , queryEncode+   , queryDecode+   , ErrQuery (..)++    -- * Header+   , HeaderCodec++    -- ** Introduction+   , header+   , headerMaybe+   , headerSome+   , headerMany+   , ToHeaderValue (..)+   , FromHeaderValue (..)++    -- ** Elimination+   , headerEncode+   , headerDecode+   , ErrHeader (..)++    -- * Path+   , PathCodec++    -- ** Introduction+   , path+   , pathLiteral+   , ToPathValue (..)+   , FromPathValue (..)++    -- ** Elimination+   , pathEncode+   , pathDecode+   , ErrPath (..)+   )+where++import Waypoint.Header+import Waypoint.Instances ()+import Waypoint.Path+import Waypoint.Query
+ lib/Waypoint/Header.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Usually, you don't need to import this module unless+-- you are trying to reuse some of 'HeaderCodec'\'s underlying primitives.+-- Just import "Waypoint" instead.+module Waypoint.Header+   ( -- * HeaderValue+    HeaderValue (..)+   , ToHeaderValue (..)+   , FromHeaderValue (..)++    -- * HeaderValues+   , HeaderValues+   , headerValuesOne+   , headerValuesMaybe+   , headerValuesMany+   , headerValuesSome++    -- * HeaderF+   , HeaderF (..)+   , headerFDecode+   , HeaderFDecodeState(..)+   , headerFEncode+   , headerFNames++    -- * Header+   , HeaderCodec (..)+   , headerDecode+   , headerEncode+   , headerNames+   , header+   , headerMaybe+   , headerSome+   , headerMany++    -- * ErrHeader+   , ErrHeader (..)+   )+where++import Control.Applicative+import Control.Applicative.Free.Fast+import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Trans.State.Strict+import Data.ByteString qualified as B+import Data.List qualified as List+import Data.List.NonEmpty qualified as NEL+import Data.Monoid (Endo (..))+import Data.Profunctor+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Tuple+import Network.HTTP.Types qualified as H+import Text.Read (readMaybe)+import Witherable qualified as W+import Prelude++--------------------------------------------------------------------------------++-- | How to encode and decode a single header value+-- (e.g., the @v@ in @k: v@).+data HeaderValue i o = HeaderValue+   { encode :: i -> B.ByteString+   -- ^ __WARNING__: The 'B.ByteString' is literally as it is on the header+   -- value.+   , decode :: B.ByteString -> Maybe o+   -- ^ __WARNING__: The 'B.ByteString' is literally as it is on the header+   -- value.+   }++instance W.Filterable (HeaderValue i) where+   mapMaybe f (HeaderValue i o) = HeaderValue i (o >=> f)++instance Functor (HeaderValue i) where+   fmap = rmap++instance Profunctor HeaderValue where+   dimap f g (HeaderValue i o) = HeaderValue (i . f) (fmap g . o)++-- | 'HeaderValue' based on 'ToHeaderValue' and 'FromHeaderValue'.+headerValue :: (ToHeaderValue i, FromHeaderValue o) => HeaderValue i o+headerValue = HeaderValue toHeaderValue fromHeaderValue++--------------------------------------------------------------------------------++-- | How to encode and decode potentially many header line values+-- (e.g., both @v0@ and @v1@ in multiple lines @k: v0@ and @k: v1@).+data HeaderValues i o = HeaderValues+   { encode :: i -> [B.ByteString]+   , decode :: [B.ByteString] -> Maybe o+   }++instance Functor (HeaderValues i) where+   fmap = rmap++instance Profunctor HeaderValues where+   dimap f g (HeaderValues i o) = HeaderValues (i . f) (fmap g . o)++instance W.Filterable (HeaderValues i) where+   mapMaybe f (HeaderValues i o) = HeaderValues i (o >=> f)++headerValuesOne :: HeaderValue i o -> HeaderValues i o+headerValuesOne v = HeaderValues (pure . v.encode) \case+   [t] -> v.decode t+   _ -> Nothing++headerValuesMaybe :: HeaderValue i o -> HeaderValues (Maybe i) (Maybe o)+headerValuesMaybe v = HeaderValues (maybe [] (pure . v.encode)) \case+   [] -> Just Nothing+   [t] -> Just <$> v.decode t+   _ -> Nothing++headerValuesSome+   :: HeaderValue i o -> HeaderValues (NEL.NonEmpty i) (NEL.NonEmpty o)+headerValuesSome v = HeaderValues (fmap v.encode . NEL.toList) \case+   t : ts -> traverse v.decode (t NEL.:| ts)+   _ -> Nothing++headerValuesMany :: HeaderValue i o -> HeaderValues [i] [o]+headerValuesMany v = HeaderValues (fmap v.encode) (traverse v.decode)++--------------------------------------------------------------------------------++-- | Like 'HeaderValues', but with the added @name@.+data HeaderF i o = HeaderF+   { name :: H.HeaderName+   , values :: HeaderValues i o+   }++instance Functor (HeaderF i) where+   fmap = rmap++instance Profunctor HeaderF where+   dimap f g (HeaderF k v) = HeaderF k (dimap f g v)++instance W.Filterable (HeaderF i) where+   mapMaybe f (HeaderF k v) = HeaderF k (W.mapMaybe f v)++--------------------------------------------------------------------------------++-- | See 'headerFDecode'.+data HeaderFDecodeState = HeaderFDecodeState+   { seen :: Set.Set H.HeaderName+   -- ^ Previously seen header names.+   , input :: [H.Header]+   -- ^ Available raw input to decode.+   }+   deriving (Eq, Show)++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'HeaderF' yourself.+headerFDecode+   :: HeaderF i o+   -> HeaderFDecodeState+   -> Either ErrHeader (o, HeaderFDecodeState)+headerFDecode q = \s ->+   if Set.member q.name s.seen+      then Left $ ErrHeaderBadDecoder q.name+      else do+         let (xs1, xs2) = List.partition (\(k, _) -> k == q.name) s.input+         case q.values.decode (fmap snd xs1) of+            Just a -> Right (a, s{seen = Set.insert q.name s.seen, input = xs2})+            Nothing -> Left $ ErrHeaderDecode q.name++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'HeaderF' yourself.+headerFEncode :: HeaderF i o -> i -> Endo [H.Header]+headerFEncode q = \i ->+   foldMap+      (\v -> Endo ((q.name, v) :))+      (q.values.encode i)+      <> Endo (filter (\(k, _) -> k /= q.name))++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'HeaderF' yourself.+headerFNames :: HeaderF i o -> Endo [H.HeaderName]+headerFNames q = Endo ((q.name :) . filter (/= q.name))++--------------------------------------------------------------------------------++data ErrHeader+   = -- | Error decoding the header value at the given name.+     ErrHeaderDecode H.HeaderName+   | -- | This error means the decoder itself is incorrect. It tried to+     -- decode values associated to the same header name more than once.+     ErrHeaderBadDecoder H.HeaderName+   deriving stock (Eq, Show)+   deriving anyclass (Exception)++--------------------------------------------------------------------------------++-- | Bidirectional codec for encoding an @i@ into HTTP headers, and decoding+-- HTTP headers into an @o@.+--+-- Use 'header', 'headerMaybe', 'headerSome', 'headerMany' and 'Applicative' to+-- construct.+newtype HeaderCodec i o = HeaderCodec (Ap (HeaderF i) o)+   deriving newtype (Functor, Applicative)++instance Profunctor HeaderCodec where+   rmap = fmap+   lmap f (HeaderCodec a) = HeaderCodec $ hoistAp (lmap f) a++-- | Consumes as much of the 'H.Header's as necessary in order to produce @o@.+-- Returns any leftovers in the original order.+headerDecode :: HeaderCodec i o -> [H.Header] -> Either ErrHeader (o, [H.Header])+headerDecode (HeaderCodec af) = \xs0 -> do+   let s0 = HeaderFDecodeState{seen = mempty, input = xs0}+   (o, s1) <- runStateT (runAp (StateT . headerFDecode) af) s0+   pure (o, s1.input)++headerEncode :: HeaderCodec i o -> i -> [H.Header]+headerEncode (HeaderCodec af) = flip appEndo [] . runAp_ headerFEncode af++-- | Names in the order they are encoded and decoded.+headerNames :: HeaderCodec i o -> [H.HeaderName]+headerNames (HeaderCodec af) = appEndo (runAp_ headerFNames af) []++--------------------------------------------------------------------------------++-- | Encode and decode the one the header value for a particular name.+--+-- E.g., @__name__: __value__@.+header+   :: (ToHeaderValue x, FromHeaderValue o)+   => H.HeaderName+   -- ^ Header name.+   -> (i -> x)+   -- ^ @'header' k f == 'lmap' f ('header' k 'id')@, provided just for+   -- convenience.+   -> HeaderCodec i o+header k f =+   HeaderCodec $ liftAp $ HeaderF k $ lmap f $ headerValuesOne headerValue++-- | Encode and decode zero or one header string values for a particular name.+--+-- E.g., @__name__: __value__@, or just no mention of @__name__@ altogether.+headerMaybe+   :: (ToHeaderValue x, FromHeaderValue o)+   => H.HeaderName+   -- ^ Header name.+   -> (i -> Maybe x)+   -- ^ @'headerMaybe' k f == 'lmap' f ('headerMaybe' k 'id')@, provided just for+   -- convenience.+   -> HeaderCodec i (Maybe o)+headerMaybe k f =+   HeaderCodec $ liftAp $ HeaderF k $ lmap f $ headerValuesMaybe headerValue++-- | Encode and decode zero or more header line values for a particular name.+--+-- E.g., @__name__: __value0__@ and @__name__: __value1__@, or just no mention+-- of @__name__@ at all.+headerMany+   :: (ToHeaderValue x, FromHeaderValue o)+   => H.HeaderName+   -- ^ Header name.+   -> (i -> [x])+   -- ^ @'headerMany' k f == 'lmap' f ('headerMany' k 'id')@, provided just for+   -- convenience.+   -> HeaderCodec i [o]+headerMany k f =+   HeaderCodec $ liftAp $ HeaderF k $ lmap f $ headerValuesMany headerValue++-- | Encode and decode one or more header string values for a particular name.+--+-- E.g., @__name__: __value0__@ and @__name__: __value1__@.+headerSome+   :: (ToHeaderValue x, FromHeaderValue o)+   => H.HeaderName+   -- ^ Header name.+   -> (i -> NEL.NonEmpty x)+   -- ^ @'headerSome' k f == 'lmap' f ('headerSome' k 'id')@, provided just for+   -- convenience.+   -> HeaderCodec i (NEL.NonEmpty o)+headerSome k f =+   HeaderCodec $ liftAp $ HeaderF k $ lmap f $ headerValuesSome headerValue++--------------------------------------------------------------------------------++class ToHeaderValue i where+   -- | Render @i@ into a single literal header value.+   --+   -- __WARNING__: The 'B.ByteString' is literally as it is on the header value.+   toHeaderValue :: i -> B.ByteString++class FromHeaderValue o where+   -- | Parse a single literal header value into an @o@.+   --+   -- __WARNING__: The 'B.ByteString' is literally as it is on the header value.+   fromHeaderValue :: B.ByteString -> Maybe o+   default fromHeaderValue :: (Read o) => B.ByteString -> Maybe o+   fromHeaderValue = T.decodeASCII' >=> \t -> readMaybe (T.unpack t)
+ lib/Waypoint/Instances.hs view
@@ -0,0 +1,551 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Waypoint.Instances () where++import Control.Applicative+import Control.Monad+import Data.ByteString qualified as B+import Data.ByteString.Builder qualified as BB+import Data.ByteString.Lazy qualified as BL+import Data.Int+import Data.String+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Time qualified as Time+import Data.Time.Format.ISO8601 qualified as Time+import Data.UUID.Types qualified as UUID+import Data.Word+import Numeric.Natural+import Prelude++import Waypoint.Header+import Waypoint.Path+import Waypoint.Query++--------------------------------------------------------------------------------++instance ToHeaderValue B.ByteString where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = id++instance ToHeaderValue BL.ByteString where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = BL.toStrict++instance ToHeaderValue BB.Builder where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = BL.toStrict . BB.toLazyByteString++instance ToHeaderValue Int where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Int8 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Int16 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Int32 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Int64 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Integer where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Word where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Word8 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Word16 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Word32 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Word64 where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Natural where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Double where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue Float where+   {-# INLINE toHeaderValue #-}+   toHeaderValue = fromString . show++instance ToHeaderValue UUID.UUID where+   toHeaderValue = UUID.toASCIIBytes+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.UTCTime where+   toHeaderValue = toHeaderValue . Time.utcToZonedTime Time.utc+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.ZonedTime where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.LocalTime where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.Day where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.TimeOfDay where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.CalendarDiffDays where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.CalendarDiffTime where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++instance ToHeaderValue Time.TimeZone where+   toHeaderValue = fromString . Time.iso8601Show+   {-# INLINE toHeaderValue #-}++--------------------------------------------------------------------------------++instance FromHeaderValue B.ByteString where+   {-# INLINE fromHeaderValue #-}+   fromHeaderValue = Just++instance FromHeaderValue BL.ByteString where+   {-# INLINE fromHeaderValue #-}+   fromHeaderValue = Just . BL.fromStrict++instance FromHeaderValue Int++instance FromHeaderValue Int8++instance FromHeaderValue Int16++instance FromHeaderValue Int32++instance FromHeaderValue Int64++instance FromHeaderValue Integer++instance FromHeaderValue Word++instance FromHeaderValue Word8++instance FromHeaderValue Word16++instance FromHeaderValue Word32++instance FromHeaderValue Word64++instance FromHeaderValue Natural++instance FromHeaderValue Double++instance FromHeaderValue Float++instance FromHeaderValue UUID.UUID where+   fromHeaderValue = UUID.fromASCIIBytes+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.UTCTime where+   {-# INLINE fromHeaderValue #-}+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue++instance FromHeaderValue Time.ZonedTime where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.LocalTime where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.Day where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.TimeOfDay where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.CalendarDiffDays where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.CalendarDiffTime where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++instance FromHeaderValue Time.TimeZone where+   fromHeaderValue = T.decodeASCII' >=> fromQueryValue+   {-# INLINE fromHeaderValue #-}++--------------------------------------------------------------------------------++instance ToPathValue T.Text where+   {-# INLINE toPathValue #-}+   toPathValue = toQueryValue++instance ToPathValue TL.Text where+   {-# INLINE toPathValue #-}+   toPathValue = toQueryValue++instance ToPathValue TB.Builder where+   toPathValue = TL.toStrict . TB.toLazyText+   {-# INLINE toPathValue #-}++instance ToPathValue String where+   {-# INLINE toPathValue #-}+   toPathValue = toQueryValue++instance ToPathValue Char where+   {-# INLINE toPathValue #-}+   toPathValue = toQueryValue++instance ToPathValue Int++instance ToPathValue Int8++instance ToPathValue Int16++instance ToPathValue Int32++instance ToPathValue Int64++instance ToPathValue Integer++instance ToPathValue Word++instance ToPathValue Word8++instance ToPathValue Word16++instance ToPathValue Word32++instance ToPathValue Word64++instance ToPathValue Natural++instance ToPathValue Double++instance ToPathValue Float++instance ToPathValue UUID.UUID where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.UTCTime where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.ZonedTime where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.LocalTime where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.Day where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.TimeOfDay where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.CalendarDiffDays where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.CalendarDiffTime where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++instance ToPathValue Time.TimeZone where+   toPathValue = toQueryValue+   {-# INLINE toPathValue #-}++--------------------------------------------------------------------------------++instance FromPathValue T.Text where+   {-# INLINE fromPathValue #-}+   fromPathValue = fromQueryValue++instance FromPathValue TL.Text where+   {-# INLINE fromPathValue #-}+   fromPathValue = fromQueryValue++instance FromPathValue String where+   {-# INLINE fromPathValue #-}+   fromPathValue = fromQueryValue++instance FromPathValue Char where+   {-# INLINE fromPathValue #-}+   fromPathValue = fromQueryValue++instance FromPathValue Int++instance FromPathValue Int8++instance FromPathValue Int16++instance FromPathValue Int32++instance FromPathValue Int64++instance FromPathValue Integer++instance FromPathValue Word++instance FromPathValue Word8++instance FromPathValue Word16++instance FromPathValue Word32++instance FromPathValue Word64++instance FromPathValue Natural++instance FromPathValue Double++instance FromPathValue Float++instance FromPathValue UUID.UUID where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.UTCTime where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.ZonedTime where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.LocalTime where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.Day where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.TimeOfDay where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.CalendarDiffDays where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.CalendarDiffTime where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++instance FromPathValue Time.TimeZone where+   fromPathValue = fromQueryValue+   {-# INLINE fromPathValue #-}++--------------------------------------------------------------------------------++instance ToQueryValue T.Text where+   toQueryValue = id+   {-# INLINE toQueryValue #-}++instance ToQueryValue TL.Text where+   toQueryValue = TL.toStrict+   {-# INLINE toQueryValue #-}++instance ToQueryValue TB.Builder where+   toQueryValue = TL.toStrict . TB.toLazyText+   {-# INLINE toQueryValue #-}++instance ToQueryValue String where+   toQueryValue = T.pack+   {-# INLINE toQueryValue #-}++instance ToQueryValue Char where+   {-# INLINE toQueryValue #-}+   toQueryValue = T.singleton++instance ToQueryValue Int+instance ToQueryValue Int8+instance ToQueryValue Int16+instance ToQueryValue Int32+instance ToQueryValue Int64+instance ToQueryValue Integer+instance ToQueryValue Word+instance ToQueryValue Word8+instance ToQueryValue Word16+instance ToQueryValue Word32+instance ToQueryValue Word64+instance ToQueryValue Natural+instance ToQueryValue Double+instance ToQueryValue Float++instance ToQueryValue UUID.UUID where+   toQueryValue = UUID.toText+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @yyyy-mm-ddThh:mm:ss/[.ssssssssssss]/+00:00@+instance ToQueryValue Time.UTCTime where+   toQueryValue = toQueryValue . Time.utcToZonedTime Time.utc+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @yyyy-mm-ddThh:mm:ss/[.ssssssssssss]/±hh:mm@+instance ToQueryValue Time.ZonedTime where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @yyyy-mm-ddThh:mm:ss/[.ssssssssssss]/@+instance ToQueryValue Time.LocalTime where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @yyyy-mm-dd@+instance ToQueryValue Time.Day where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @hh:mm:ss/[.ssssssssssss]/@+instance ToQueryValue Time.TimeOfDay where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @PyYmMdD@+instance ToQueryValue Time.CalendarDiffDays where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @PyYmMdDThHmMs/[.ssssssssssss]/S@+instance ToQueryValue Time.CalendarDiffTime where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++-- | 'Time.ISO8601'. @±hh:mm@+instance ToQueryValue Time.TimeZone where+   toQueryValue = T.pack . Time.iso8601Show+   {-# INLINE toQueryValue #-}++--------------------------------------------------------------------------------++instance FromQueryValue T.Text where+   fromQueryValue = Just+   {-# INLINE fromQueryValue #-}++instance FromQueryValue TL.Text where+   {-# INLINE fromQueryValue #-}+   fromQueryValue = Just . TL.fromStrict++instance FromQueryValue String where+   {-# INLINE fromQueryValue #-}+   fromQueryValue = Just . T.unpack++instance FromQueryValue Char where+   {-# INLINE fromQueryValue #-}+   fromQueryValue = \t -> case T.uncons t of+      Just (c, rest) | T.null rest -> Just c+      _ -> Nothing++instance FromQueryValue Int+instance FromQueryValue Int8+instance FromQueryValue Int16+instance FromQueryValue Int32+instance FromQueryValue Int64+instance FromQueryValue Integer+instance FromQueryValue Word+instance FromQueryValue Word8+instance FromQueryValue Word16+instance FromQueryValue Word32+instance FromQueryValue Word64+instance FromQueryValue Natural+instance FromQueryValue Double+instance FromQueryValue Float++instance FromQueryValue UUID.UUID where+   fromQueryValue = UUID.fromText+   {-# INLINE fromQueryValue #-}++-- | Like for 'Time.ZonedTime'. Compatible with 'ToQueryValue'.+instance FromQueryValue Time.UTCTime where+   fromQueryValue = fmap Time.zonedTimeToUTC . fromQueryValue+   {-# INLINE fromQueryValue #-}++-- | 'Time.ISO8601', or seconds since Epoch with optional decimal+-- part of up to picosecond precission.  Compatible with 'ToQueryValue'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance FromQueryValue Time.ZonedTime where+   fromQueryValue (T.unpack -> s) =+      asum+         [ Time.iso8601ParseM s+         , Time.utcToZonedTime Time.utc+            <$> Time.iso8601ParseM s+         , Time.utcToZonedTime Time.utc+            <$> Time.parseTimeM False Time.defaultTimeLocale "%s%Q" s+         ]++-- | 'Time.ISO8601'. Compatible with 'ToQueryValue'.+instance FromQueryValue Time.LocalTime where+   fromQueryValue = fromQueryValue >=> Time.iso8601ParseM+   {-# INLINE fromQueryValue #-}++-- | 'Time.ISO8601'. Compatible with 'ToQueryValue'.+instance FromQueryValue Time.Day where+   fromQueryValue = fromQueryValue >=> Time.iso8601ParseM+   {-# INLINE fromQueryValue #-}++-- | 'Time.ISO8601'. Compatible with 'ToQueryValue'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance FromQueryValue Time.TimeOfDay where+   fromQueryValue = fromQueryValue >=> Time.iso8601ParseM+   {-# INLINE fromQueryValue #-}++-- | 'Time.ISO8601'. Compatible with 'ToQueryValue'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance FromQueryValue Time.CalendarDiffDays where+   fromQueryValue = fromQueryValue >=> Time.iso8601ParseM+   {-# INLINE fromQueryValue #-}++-- | 'Time.ISO8601'. Compatible with 'ToQueryValue'.+--+-- TODO: Currently precission over picoseconds is successfully parsed but+-- silently floored. This is an issue in "Data.Time.Format.ISO8601". Fix.+instance FromQueryValue Time.CalendarDiffTime where+   fromQueryValue = fromQueryValue >=> Time.iso8601ParseM+   {-# INLINE fromQueryValue #-}++-- | 'Time.ISO8601'. Compatible with 'ToQueryValue'.+instance FromQueryValue Time.TimeZone where+   fromQueryValue = fromQueryValue >=> Time.iso8601ParseM+   {-# INLINE fromQueryValue #-}
+ lib/Waypoint/Path.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Usually, you don't need to import this module unless+-- you are trying to reuse some of 'PathCodec'\'s underlying primitives.+-- Just import "Waypoint" instead.+module Waypoint.Path+   ( -- * PathValue+    PathValue (..)+   , ToPathValue (..)+   , FromPathValue (..)++    -- * PathF+   , PathF (..)+   , pathFDecode+   , PathFDecodeState (..)+   , pathFEncode++    -- * PathCodec+   , PathCodec (..)+   , pathDecode+   , pathEncode+   , path+   , pathLiteral++    -- * ErrPath+   , ErrPath (..)+   )+where++import Control.Applicative+import Control.Applicative.Free.Fast+import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Trans.State.Strict+import Data.Monoid (Endo (..))+import Data.Profunctor+import Data.Text qualified as T+import Text.Read (readMaybe)+import Witherable qualified as W+import Prelude++--------------------------------------------------------------------------------++-- | How to encode and decode a single path segment.+-- (e.g., the @hello@ in @\/hello\/world@.+data PathValue i o = PathValue+   { encode :: i -> T.Text+   , decode :: T.Text -> Maybe o+   }++instance W.Filterable (PathValue i) where+   mapMaybe f (PathValue i o) = PathValue i (o >=> f)++instance Functor (PathValue i) where+   fmap = rmap++instance Profunctor PathValue where+   dimap f g (PathValue i o) = PathValue (i . f) (fmap g . o)++-- | 'PathValue' based on 'ToPathValue' and 'FromPathValue'.+pathValue :: (ToPathValue i, FromPathValue o) => PathValue i o+pathValue = PathValue toPathValue fromPathValue++--------------------------------------------------------------------------------++-- | This datatype seems useless, seeing as we could use 'PathValue' directly.+-- But naming things is hard, so we add this name for consistency with 'QueryF'+-- and 'HeaderF'. Also, we will add metadata here someday.+newtype PathF i o = PathF+   { segment :: PathValue i o+   }+   deriving newtype (Functor, Profunctor, W.Filterable)++-- | See 'pathFDecode'.+data PathFDecodeState = PathFDecodeState+   { index :: Int+   -- ^ Next index.+   , input :: [T.Text]+   -- ^ Available raw input to decode.+   }+   deriving (Eq, Show)++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'PathF' yourself.+pathFDecode+   :: PathF x a -> PathFDecodeState -> Either ErrPath (a, PathFDecodeState)+pathFDecode (PathF ps) = \s ->+   case s.input of+      t : ts1+         | Just a <- ps.decode t ->+            Right (a, s{index = s.index + 1, input = ts1})+      _ -> Left $ ErrPath s.index++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'PathF' yourself.+pathFEncode :: PathF i o -> i -> Endo [T.Text]+pathFEncode p = \i -> Endo (p.segment.encode i :)++--------------------------------------------------------------------------------++-- | Bidirectional codec for encoding an @i@ into URL path segments, and+-- decoding URL path segments into an @o@.+--+-- Use 'path', 'pathLiteral' and 'Applicative' to construct.+newtype PathCodec i o = PathCodec (Ap (PathF i) o)+   deriving newtype (Functor, Applicative)++instance Profunctor PathCodec where+   rmap = fmap+   lmap f (PathCodec a) = PathCodec $ hoistAp (lmap f) a++pathEncode :: PathCodec i o -> i -> [T.Text]+pathEncode (PathCodec af) = flip appEndo [] . runAp_ pathFEncode af++-- | Decodes the given path segments into @o@, if possible.+--+-- Parses from left to right, returning leftover segments, if any.+pathDecode :: PathCodec i o -> [T.Text] -> Either ErrPath (o, [T.Text])+pathDecode = \(PathCodec af) -> \ts0 -> do+   let s0 = PathFDecodeState{index = 0, input = ts0}+   (o, s1) <- runStateT (runAp (StateT . pathFDecode) af) s0+   pure (o, s1.input)++data ErrPath+   = -- | Error parsing the path element at the given index.+     ErrPath Int+   deriving stock (Eq, Show)++instance Exception ErrPath++--------------------------------------------------------------------------------++-- | Encode and decode a path segment.+path+   :: (ToPathValue x, FromPathValue o)+   => (i -> x)+   -- ^ @'path' f == 'lmap' f ('path' 'id')@, provided just for convenience.+   -> PathCodec i o+path f = PathCodec $ liftAp $ PathF $ lmap f pathValue++-- | Literal segment in a URL path.+pathLiteral :: T.Text -> PathCodec i ()+pathLiteral t =+   PathCodec $ liftAp $ PathF $ PathValue (const t) \x -> guard (x == t)++--------------------------------------------------------------------------------++class ToPathValue i where+   -- | Render @i@ into a single path segment.+   toPathValue :: i -> T.Text+   default toPathValue :: (Show i) => i -> T.Text+   {-# INLINE toPathValue #-}+   toPathValue = T.pack . show++class FromPathValue o where+   -- | Parse a single path segment into an @o@.+   fromPathValue :: T.Text -> Maybe o+   default fromPathValue :: (Read o) => T.Text -> Maybe o+   {-# INLINE fromPathValue #-}+   fromPathValue = readMaybe . T.unpack
+ lib/Waypoint/Query.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Usually, you don't need to import this module unless+-- you are trying to reuse some of 'QueryCodec'\'s underlying primitives.+-- Just import "Waypoint" instead.+module Waypoint.Query+   ( -- * QueryValue+    QueryValue (..)+   , ToQueryValue (..)+   , FromQueryValue (..)++    -- * QueryValues+   , QueryValues+   , queryValuesOne+   , queryValuesMaybe+   , queryValuesMany+   , queryValuesSome++    -- * QueryF+   , QueryF (..)+   , queryFDecode+   , QueryFDecodeState(..)+   , queryFEncode+   , queryFKeys++    -- * QueryCodec+   , QueryCodec (..)+   , queryDecode+   , queryEncode+   , queryKeys+   , query+   , queryMaybe+   , querySome+   , queryMany++    -- * ErrQuery+   , ErrQuery (..)+   )+where++import Control.Applicative+import Control.Applicative.Free.Fast+import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Trans.State.Strict+import Data.List qualified as List+import Data.List.NonEmpty qualified as NEL+import Data.Monoid (Endo (..))+import Data.Profunctor+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Tuple+import Network.HTTP.Types qualified as H+import Text.Read (readMaybe)+import Witherable qualified as W+import Prelude++--------------------------------------------------------------------------------++-- | How to encode and decode a single querystring value+-- (e.g., the @v@ in @?k=v@).+data QueryValue i o = QueryValue+   { encode :: i -> T.Text+   , decode :: T.Text -> Maybe o+   }++instance W.Filterable (QueryValue i) where+   mapMaybe f (QueryValue i o) = QueryValue i (o >=> f)++instance Functor (QueryValue i) where+   fmap = rmap++instance Profunctor QueryValue where+   dimap f g (QueryValue i o) = QueryValue (i . f) (fmap g . o)++-- | 'QueryValue' based on 'ToQueryValue' and 'FromQueryValue'.+queryValue :: (ToQueryValue i, FromQueryValue o) => QueryValue i o+queryValue = QueryValue toQueryValue fromQueryValue++--------------------------------------------------------------------------------++-- | How to encode and decode potentially many querystring values+-- (e.g., both @v0@ and @v1@ in @?k=v0&k=v1@).+data QueryValues i o = QueryValues+   { encode :: i -> [T.Text]+   , decode :: [T.Text] -> Maybe o+   }++instance Functor (QueryValues i) where+   fmap = rmap++instance Profunctor QueryValues where+   dimap f g (QueryValues i o) = QueryValues (i . f) (fmap g . o)++instance W.Filterable (QueryValues i) where+   mapMaybe f (QueryValues i o) = QueryValues i (o >=> f)++queryValuesOne :: QueryValue i o -> QueryValues i o+queryValuesOne v = QueryValues (pure . v.encode) \case+   [t] -> v.decode t+   _ -> Nothing++queryValuesMaybe :: QueryValue i o -> QueryValues (Maybe i) (Maybe o)+queryValuesMaybe v = QueryValues (maybe [] (pure . v.encode)) \case+   [] -> Just Nothing+   [t] -> Just <$> v.decode t+   _ -> Nothing++queryValuesSome+   :: QueryValue i o -> QueryValues (NEL.NonEmpty i) (NEL.NonEmpty o)+queryValuesSome v = QueryValues (fmap v.encode . NEL.toList) \case+   t : ts -> traverse v.decode (t NEL.:| ts)+   _ -> Nothing++queryValuesMany :: QueryValue i o -> QueryValues [i] [o]+queryValuesMany v = QueryValues (fmap v.encode) (traverse v.decode)++--------------------------------------------------------------------------------++data QueryF i o = QueryF+   { key :: T.Text+   , values :: QueryValues i o+   }++instance Functor (QueryF i) where+   fmap = rmap++instance Profunctor QueryF where+   dimap f g (QueryF k v) = QueryF k (dimap f g v)++instance W.Filterable (QueryF i) where+   mapMaybe f (QueryF k v) = QueryF k (W.mapMaybe f v)++--------------------------------------------------------------------------------++-- | See 'queryFDecode'.+data QueryFDecodeState = QueryFDecodeState+   { seen :: Set.Set T.Text+   -- ^ Previously seen keys.+   , input :: H.QueryText+   -- ^ Available raw input to decode.+   }+   deriving (Eq, Show)++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'QueryF' yourself.+queryFDecode+   :: QueryF i o+   -> QueryFDecodeState+   -> Either ErrQuery (o, QueryFDecodeState)+queryFDecode q = \s ->+   if Set.member q.key s.seen+      then Left $ ErrQueryBadDecoder q.key+      else do+         let (xs1, xs2) = List.partition (\(k, _) -> k == q.key) s.input+             vs1 = fmap (maybe "" id . snd) xs1+         case q.values.decode vs1 of+            Just a -> Right (a, s{seen = Set.insert q.key s.seen, input = xs2})+            Nothing -> Left $ ErrQueryDecode q.key++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'QueryF' yourself.+queryFEncode :: QueryF i o -> i -> Endo H.QueryText+queryFEncode q = \i ->+   foldMap+      (\v -> Endo ((q.key, if T.null v then Nothing else Just v) :))+      (q.values.encode i)+      <> Endo (filter (\(k, _) -> k /= q.key))++-- | You probably don't need to use this unless you are building an+-- 'Applicative' on top of 'QueryF' yourself.+queryFKeys :: QueryF i o -> Endo [T.Text]+queryFKeys q = Endo ((q.key :) . filter (/= q.key))++--------------------------------------------------------------------------------++data ErrQuery+   = -- | Error decoding the query value at the given key.+     ErrQueryDecode T.Text+   | -- | This error means the decoder itself is incorrect. It tried to+     -- decode values associated to the same query string key more than+     -- once.+     ErrQueryBadDecoder T.Text+   deriving stock (Eq, Show)+   deriving anyclass (Exception)++--------------------------------------------------------------------------------++-- | Bidirectional codec for encoding an @i@ into a URL query string, and+-- decoding a URL query string into an @o@.+--+-- This works for @application/x-www-form-urlencoded@ bodies too.+--+-- Use 'query', 'queryMaybe', 'querySome', 'queryMany' and 'Applicative' to+-- construct.+newtype QueryCodec i o = QueryCodec (Ap (QueryF i) o)+   deriving newtype (Functor, Applicative)++instance Profunctor QueryCodec where+   rmap = fmap+   lmap f (QueryCodec a) = QueryCodec $ hoistAp (lmap f) a++-- | Consumes as much of the 'H.QueryText' as necessary in order to produce @o@.+-- Returns any leftovers in the original order.+queryDecode :: QueryCodec i o -> H.QueryText -> Either ErrQuery (o, H.QueryText)+queryDecode (QueryCodec af) = \xs0 -> do+   let s0 = QueryFDecodeState{seen = mempty, input = xs0}+   (o, s1) <- runStateT (runAp (StateT . queryFDecode) af) s0+   pure (o, s1.input)++queryEncode :: QueryCodec i o -> i -> H.QueryText+queryEncode (QueryCodec af) = flip appEndo [] . runAp_ queryFEncode af++-- | Keys in the order they are encoded and decoded.+queryKeys :: QueryCodec i o -> [T.Text]+queryKeys (QueryCodec af) = appEndo (runAp_ queryFKeys af) []++--------------------------------------------------------------------------------++-- | Encode and decode the one the query string value for a particular key.+--+-- E.g., @?__key__=__value__&...@.+query+   :: (ToQueryValue x, FromQueryValue o)+   => T.Text+   -- ^ Query string key.+   -> (i -> x)+   -- ^ @'query' k f == 'lmap' f ('query' k 'id')@, provided just for+   -- convenience.+   -> QueryCodec i o+query k f =+   QueryCodec $ liftAp $ QueryF k $ lmap f $ queryValuesOne queryValue++-- | Encode and decode zero or one query string values for a particular key.+--+-- E.g., @?__key__=__value__&...@, or just no mention of @__key__@ altogether.+queryMaybe+   :: (ToQueryValue x, FromQueryValue o)+   => T.Text+   -- ^ Query string key.+   -> (i -> Maybe x)+   -- ^ @'queryMaybe' k f == 'lmap' f ('queryMaybe' k 'id')@, provided just for+   -- convenience.+   -> QueryCodec i (Maybe o)+queryMaybe k f =+   QueryCodec $ liftAp $ QueryF k $ lmap f $ queryValuesMaybe queryValue++-- | Encode and decode zero or more query string values for a particular key.+--+-- E.g., @?__key__=__value0__&__key__=__value1__&...@.+queryMany+   :: (ToQueryValue x, FromQueryValue o)+   => T.Text+   -- ^ Query string key.+   -> (i -> [x])+   -- ^ @'queryMany' k f == 'lmap' f ('queryMany' k 'id')@, provided just for+   -- convenience.+   -> QueryCodec i [o]+queryMany k f =+   QueryCodec $ liftAp $ QueryF k $ lmap f $ queryValuesMany queryValue++-- | Encode and decode one or more query string values for a particular key.+--+-- E.g., @?__key__=__value0__&__key__=__value1__&...@.+querySome+   :: (ToQueryValue x, FromQueryValue o)+   => T.Text+   -- ^ Query string key.+   -> (i -> NEL.NonEmpty x)+   -- ^ @'querySome' k f == 'lmap' f ('querySome' k 'id')@, provided just for+   -- convenience.+   -> QueryCodec i (NEL.NonEmpty o)+querySome k f =+   QueryCodec $ liftAp $ QueryF k $ lmap f $ queryValuesSome queryValue++--------------------------------------------------------------------------------++class ToQueryValue i where+   -- | Encode @i@ into a query string value.+   toQueryValue :: i -> T.Text+   default toQueryValue :: (Show i) => i -> T.Text+   {-# INLINE toQueryValue #-}+   toQueryValue = T.pack . show++class FromQueryValue o where+   -- | Decode from one query string value into @o@.+   --+   -- E.g., from @?__key__=__value__&...@.+   fromQueryValue :: T.Text -> Maybe o+   default fromQueryValue :: (Read o) => T.Text -> Maybe o+   {-# INLINE fromQueryValue #-}+   fromQueryValue = readMaybe . T.unpack
+ test/Main.hs view
@@ -0,0 +1,241 @@+module Main (main) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Bits+import Data.ByteString qualified as B+import Data.CaseInsensitive qualified as CI+import Data.Fixed+import Data.Functor.Contravariant+import Data.Int+import Data.List.NonEmpty qualified as NEL+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.String+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time qualified as Time+import Data.Time.Calendar.OrdinalDate qualified as Time+import Data.Time.Clock.POSIX qualified as Time+import Data.Time.Format.ISO8601 qualified as Time+import Data.Typeable+import Data.UUID.Types qualified as UUID+import Data.Word+import Hedgehog qualified as H+import Hedgehog.Gen qualified as H+import Hedgehog.Range qualified as HR+import Numeric.Natural+import Test.Tasty (testGroup)+import Test.Tasty qualified as Tasty+import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.Hedgehog qualified as Tasty+import Test.Tasty.Runners (TestTree)+import Test.Tasty.Runners qualified as Tasty++import Waypoint qualified as E++--------------------------------------------------------------------------------+main :: IO ()+main = do+   Tasty.defaultMainWithIngredients+      [ Tasty.consoleTestReporter+      , Tasty.listingTests+      ]+      $ Tasty.localOption (Tasty.HedgehogTestLimit (Just 1000))+      $ tree++tree :: TestTree+tree =+   testGroup+      "Waypoint"+      [ treeQueryPath+      , treeHeader+      ]++treeQueryPath :: TestTree+treeQueryPath =+   testGroup+      "ToQueryValue/FromQueryValue - ToPathValue/FromPathValue"+      [ t @UUID.UUID uuid4+      , t @Int $ H.integral HR.constantBounded+      , t @Int8 $ H.integral HR.constantBounded+      , t @Int16 $ H.integral HR.constantBounded+      , t @Int32 $ H.integral HR.constantBounded+      , t @Int64 $ H.integral HR.constantBounded+      , t @Word $ H.integral HR.constantBounded+      , t @Word8 $ H.integral HR.constantBounded+      , t @Word16 $ H.integral HR.constantBounded+      , t @Word32 $ H.integral HR.constantBounded+      , t @Word64 $ H.integral HR.constantBounded+      , t @Word64 $ H.integral HR.constantBounded+      , t @Natural $ H.integral $ HR.constant 0 maxNatural+      , t @Integer $ H.integral $ HR.constantFrom 0 minInteger maxInteger+      , t @Char H.unicode+      , t @String $ H.string (HR.constant 0 50) H.unicode+      , t @T.Text $ H.text (HR.constant 0 50) H.unicode+      , t @TL.Text $ fmap TL.fromStrict $ H.text (HR.constant 0 50) H.unicode+      , t @Time.UTCTime $ genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime)+      , t @Time.LocalTime $ Time.utcToLocalTime Time.utc <$> genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime)+      , t @Time.CalendarDiffDays $ calendarDiffDays+      , t @Time.CalendarDiffTime $ Time.calendarTimeDays <$> calendarDiffDays+      , t @Time.TimeOfDay $ timeOfDay+      , t @Time.TimeZone $ timeZone+      , t @Time.Day $ day+      , t @Double $ H.double (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))+      , t @Float $ H.float (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))+      ]+  where+   t+      :: forall a+       . ( Typeable a+         , Eq a+         , Show a+         , E.ToQueryValue a+         , E.FromQueryValue a+         , E.ToPathValue a+         , E.FromPathValue a+         )+      => H.Gen a+      -> TestTree+   t ga =+      testGroup+         (tyConName (typeRepTyCon (typeRep ga)))+         [ testProperty "query" $ H.property do+            a <- H.forAll ga+            Just a H.=== E.fromQueryValue (E.toQueryValue a)+         , testProperty "path" $ H.property do+            a <- H.forAll ga+            Just a H.=== E.fromPathValue (E.toPathValue a)+         ]++treeHeader :: TestTree+treeHeader =+   testGroup+      "ToHeaderValue/FromHeaderValue"+      [ t @UUID.UUID uuid4+      , t @Int $ H.integral HR.constantBounded+      , t @Int8 $ H.integral HR.constantBounded+      , t @Int16 $ H.integral HR.constantBounded+      , t @Int32 $ H.integral HR.constantBounded+      , t @Int64 $ H.integral HR.constantBounded+      , t @Word $ H.integral HR.constantBounded+      , t @Word8 $ H.integral HR.constantBounded+      , t @Word16 $ H.integral HR.constantBounded+      , t @Word32 $ H.integral HR.constantBounded+      , t @Word64 $ H.integral HR.constantBounded+      , t @Word64 $ H.integral HR.constantBounded+      , t @Natural $ H.integral $ HR.constant 0 maxNatural+      , t @Integer $ H.integral $ HR.constantFrom 0 minInteger maxInteger+      , t @Time.UTCTime $ genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime)+      , t @Time.LocalTime $ Time.utcToLocalTime Time.utc <$> genUTCTime (HR.constantFrom epochUTCTime minUTCTime maxUTCTime)+      , t @Time.CalendarDiffDays $ calendarDiffDays+      , t @Time.CalendarDiffTime $ Time.calendarTimeDays <$> calendarDiffDays+      , t @Time.TimeOfDay $ timeOfDay+      , t @Time.TimeZone $ timeZone+      , t @Time.Day $ day+      , t @Double $ H.double (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))+      , t @Float $ H.float (HR.constantFrom 0 (fromIntegral minInteger) (fromIntegral maxInteger))+      ]+  where+   t+      :: forall a+       . ( Typeable a+         , Eq a+         , Show a+         , E.ToHeaderValue a+         , E.FromHeaderValue a+         )+      => H.Gen a+      -> TestTree+   t ga =+      testGroup+         (tyConName (typeRepTyCon (typeRep ga)))+         [ testProperty "header" $ H.property do+            a <- H.forAll ga+            Just a H.=== E.fromHeaderValue (E.toHeaderValue a)+         ]++uuid4 :: (H.MonadGen m) => m UUID.UUID+uuid4 =+   UUID.fromWords64+      <$> H.integral HR.constantBounded+      <*> H.integral HR.constantBounded++calendarDiffDays :: (H.MonadGen m) => m Time.CalendarDiffDays+calendarDiffDays =+   Time.CalendarDiffDays+      <$> H.integral (HR.constantFrom 0 minInteger maxInteger)+      <*> H.integral (HR.constantFrom 0 minInteger maxInteger)++timeZone :: (H.MonadGen m) => m Time.TimeZone+timeZone =+   Time.minutesToTimeZone+      <$> H.integral (HR.constantFrom 0 (negate 3599) 3600)++timeOfDay :: (H.MonadGen m) => m Time.TimeOfDay+timeOfDay =+   Time.TimeOfDay+      <$> H.integral (HR.constantFrom 0 0 23)+      <*> H.integral (HR.constantFrom 0 0 59)+      <*> fmap MkFixed (H.integral (HR.constantFrom 0 0 60_999_999_999_999))++day :: (H.MonadGen m) => m Time.Day+day =+   Time.fromOrdinalDate+      <$> H.integral (HR.constantFrom 0 (-9999) 9999)+      <*> H.integral (HR.constantFrom 1 1 366)++maxNatural :: Natural+maxNatural = 2 ^ (256 :: Int) - 1++maxInteger :: Integer+maxInteger = 2 ^ (255 :: Int) - 1++minInteger :: Integer+minInteger = complement maxInteger++minUTCTime :: Time.UTCTime+minUTCTime = fromJust $ Time.iso8601ParseM "-9999-01-01T00:00:00Z"++maxUTCTime :: Time.UTCTime+maxUTCTime = fromJust $ Time.iso8601ParseM "9999-12-31T24:00:00Z"++epochUTCTime :: Time.UTCTime+epochUTCTime = posixPicoSecondsToUTCTime 0++genUTCTime :: (H.MonadGen m) => H.Range Time.UTCTime -> m Time.UTCTime+genUTCTime =+   fmap posixPicoSecondsToUTCTime+      . H.integral+      . fmap utcTimeToPOSIXPicoSeconds++utcTimeToPOSIXPicoSeconds :: Time.UTCTime -> Integer+utcTimeToPOSIXPicoSeconds t = i+  where+   MkFixed i = Time.nominalDiffTimeToSeconds $ Time.utcTimeToPOSIXSeconds t++posixPicoSecondsToUTCTime :: Integer -> Time.UTCTime+posixPicoSecondsToUTCTime =+   Time.posixSecondsToUTCTime . Time.secondsToNominalDiffTime . MkFixed++path :: (H.MonadGen m) => m [T.Text]+path = H.list (HR.constant 0 9) (H.text (HR.constant 0 9) H.unicode)++query :: (H.MonadGen m) => m (Map.Map T.Text (NEL.NonEmpty T.Text))+query =+   Map.fromListWith (<>) <$> do+      ks <- H.list (HR.constant 0 9) (H.text (HR.constant 0 3) H.unicode)+      forM ks \k -> do+         vs <- H.nonEmpty (HR.constant 1 9) (H.text (HR.constant 0 9) H.unicode)+         pure (k, vs)++header+   :: forall m+    . (H.MonadGen m)+   => m (Map.Map (CI.CI B.ByteString) (NEL.NonEmpty B.ByteString))+header =+   Map.fromListWith (<>) <$> do+      ks <- H.list (HR.constant 0 9) (CI.mk <$> H.bytes (HR.constant 1 9))+      forM ks \k -> do+         vs <- H.nonEmpty (HR.constant 1 9) (H.bytes (HR.constant 1 9))+         pure (k, vs)
+ waypoint.cabal view
@@ -0,0 +1,75 @@+cabal-version: 2.4+name: waypoint+version: 0.1+license: Apache-2.0+license-file: LICENSE+extra-source-files: README.md CHANGELOG.md+author: Renzo Carbonara+maintainer: renλren.zone+copyright: Renzo Carbonara, 2025+category: Web+build-type: Simple+synopsis: Bidirectional URL path, URL query string and HTTP headers codecs+description: Bidirectional URL path, URL query string and HTTP headers codecs+homepage: https://github.com/k0001/hs-waypoint+bug-reports: https://github.com/k0001/hs-waypoint/issues+tested-with: GHC==9.8, GHC==9.10, GHC==9.12++common basic+  default-language: GHC2021+  build-depends: base == 4.*+  default-extensions:+    BlockArguments+    DefaultSignatures+    DerivingStrategies+    DerivingVia+    DeriveAnyClass+    DuplicateRecordFields+    LambdaCase+    OverloadedRecordDot+    OverloadedStrings+    RecordWildCards+    ViewPatterns++library+  import: basic+  ghc-options: -O2 -Wall+  hs-source-dirs: lib+  exposed-modules:+    Waypoint+    Waypoint.Query+    Waypoint.Header+    Waypoint.Path+  other-modules:+    Waypoint.Instances+  build-depends:+    bytestring,+    containers,+    free,+    http-types,+    profunctors,+    text,+    time,+    transformers,+    uuid-types,+    witherable,+++test-suite test+  import: basic+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  ghc-options: -threaded -with-rtsopts=-N+  build-depends:+    bytestring,+    case-insensitive,+    containers,+    waypoint,+    hedgehog,+    tasty,+    tasty-hedgehog,+    tasty-hunit,+    text,+    time,+    uuid-types,