functora-uri package wip

Author: functora

pub/functora/functora.cabal

@@ -158,6 +158,17 @@ common pkg-aes
     , Crypto
     , pkcs7
 
+common pkg-uri
+  import:         pkg
+  hs-source-dirs: src/uri
+  build-depends:
+    , base
+    , modern-uri
+    , tomland
+
+  if ((impl(ghcjs) || arch(javascript)) || os(wasi))
+    build-depends: jsaddle
+
 common pkg-cfg
   import:         pkg
   hs-source-dirs: src/cfg
@@ -298,6 +309,15 @@ library aes
     Functora.Aes
     Functora.AesOrphan
 
+library uri
+  import:          pkg-uri
+  build-depends:   functora
+  exposed:         True
+  visibility:      public
+  exposed-modules:
+    Functora.Uri
+    Functora.Uri.ToQuery
+
 library cfg
   import:          pkg-cfg
   build-depends:   functora
@@ -410,14 +430,16 @@ test-suite functora-test
     Functora.Tags.TestFgpt
     Functora.Tags.TestSing
     Functora.TagsSpec
+    Functora.UriSpec
     Functora.WebSpec
 
   if flag(ghcid)
     import:
       pkg-prelude, pkg-qr, pkg-aes,
       pkg-cfg, pkg-web, pkg-sql,
       pkg-money, pkg-rates, pkg-tags,
-      pkg-soplate, pkg-elm2miso, pkg-bolt11
+      pkg-soplate, pkg-elm2miso, pkg-bolt11,
+      pkg-uri
 
     ghc-options:   -Wno-unused-packages
     other-modules:
@@ -442,6 +464,8 @@ test-suite functora-test
       Functora.TagsFamily
       Functora.TagsOrphan
       Functora.Unicode
+      Functora.Uri
+      Functora.Uri.ToQuery
       Functora.Web
       Functora.WebOrphan
 
@@ -457,4 +481,5 @@ test-suite functora-test
       , rates
       , soplate
       , tags
+      , uri
       , web

pub/functora/src/functora-ghcjs.cabal

@@ -167,7 +167,7 @@ common pkg
 
 library
   import:          pkg
-  hs-source-dirs:  prelude qr aes money web rates tags cfg
+  hs-source-dirs:  prelude qr aes money web rates tags cfg uri
 
   if !os(wasi)
     hs-source-dirs:  bolt11
@@ -188,6 +188,8 @@ library
     Functora.Rfc2397
     Functora.Tags
     Functora.Unicode
+    Functora.Uri
+    Functora.Uri.ToQuery
     Functora.Web
     Functora.WebOrphan
 
@@ -200,7 +202,7 @@ test-suite functora-ghcjs-test
   type:           exitcode-stdio-1.0
   main-is:        Spec.hs
   cpp-options:    -DNOSOP
-  hs-source-dirs: prelude qr aes money web rates tags cfg elm2miso test
+  hs-source-dirs: prelude qr aes money web rates tags cfg elm2miso test uri
 
   if !os(wasi)
     hs-source-dirs: bolt11
@@ -234,6 +236,7 @@ test-suite functora-ghcjs-test
     Functora.Tags.TestFgpt
     Functora.Tags.TestSing
     Functora.TagsSpec
+    Functora.UriSpec
     Functora.WebSpec
 
   other-modules:
@@ -254,5 +257,7 @@ test-suite functora-ghcjs-test
     Functora.TagsFamily
     Functora.TagsOrphan
     Functora.Unicode
+    Functora.Uri
+    Functora.Uri.ToQuery
     Functora.Web
     Functora.WebOrphan

pub/functora/src/test/Functora/UriSpec.hs

@@ -0,0 +1,40 @@
+module Functora.UriSpec (spec) where
+
+import Functora.Prelude
+import Functora.Uri
+import Test.Hspec
+import Text.URI
+
+data Foo = Foo
+  { fooBar :: Int,
+    fooBuz :: Text,
+    fooBuf :: String
+  }
+  deriving stock (Eq, Ord, Show, Data, Generic)
+
+instance ToQuery Foo
+
+mkSample :: (MonadThrow m) => m (Foo, [QueryParam])
+mkSample = do
+  let bar = 123 :: Int
+  let buz = "example" :: Text
+  let buf = "Hello, World!" :: String
+  kBar <- mkQueryKey "bar"
+  vBar <- mkQueryValue $ inspect bar
+  kBuz <- mkQueryKey "buz"
+  vBuz <- mkQueryValue buz
+  kBuf <- mkQueryKey "buf"
+  vBuf <- mkQueryValue $ from @String @Text buf
+  pure
+    ( Foo bar buz buf,
+      [ QueryParam kBar vBar,
+        QueryParam kBuz vBuz,
+        QueryParam kBuf vBuf
+      ]
+    )
+
+spec :: Spec
+spec = do
+  focus . it "ToQuery" $ do
+    sample <- mkSample
+    toQuery (fst sample) `shouldBe` snd sample

pub/functora/src/uri/Functora/Uri.hs

@@ -0,0 +1,3 @@
+module Functora.Uri (module X) where
+
+import Functora.Uri.ToQuery as X

pub/functora/src/uri/Functora/Uri/ToQuery.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Functora.Uri.ToQuery (ToQuery (..)) where
+
+import Functora.Prelude
+import GHC.Generics hiding (from)
+import qualified GHC.Generics as G
+import Text.URI
+import qualified Toml
+#if defined(__GHCJS__) && defined(ghcjs_HOST_OS) && defined(wasi_HOST_OS)
+import Data.JSString (JSString)
+#endif
+
+class (Typeable a) => ToQuery a where
+  toQuery :: a -> [QueryParam]
+  default toQuery :: (Generic a, GToQuery (Rep a)) => a -> [QueryParam]
+  toQuery = gToQuery (Toml.stripTypeNamePrefix $ Proxy @a) . G.from
+
+class GToQuery f where
+  gToQuery :: (String -> String) -> f p -> [QueryParam]
+
+-- Handle datatype metadata
+instance (GToQuery a) => GToQuery (M1 D c a) where
+  gToQuery fmt (M1 x) = gToQuery fmt x
+
+-- Handle constructor metadata
+instance (GToQuery a) => GToQuery (M1 C c a) where
+  gToQuery fmt (M1 x) = gToQuery fmt x
+
+instance (Selector s, ToQueryField a) => GToQuery (M1 S s (K1 i a)) where
+  gToQuery fmt m1@(M1 (K1 a)) = do
+    let name = selName m1
+    if null name
+      then mempty -- Skip if there is no field name (like unnamed tuples)
+      else do
+        k <- mkQueryKey . pack $ fmt name
+        v <- mkQueryValue $ toQueryField a
+        pure $ QueryParam k v
+
+-- Handle product type
+instance (GToQuery a, GToQuery b) => GToQuery (a :*: b) where
+  gToQuery fmt (a :*: b) = gToQuery fmt a ++ gToQuery fmt b
+
+class ToQueryField a where
+  toQueryField :: a -> Text
+
+instance ToQueryField Text where
+  toQueryField = id
+
+instance ToQueryField String where
+  toQueryField = from @String @Text
+
+instance ToQueryField Int where
+  toQueryField = inspect
+
+instance ToQueryField Integer where
+  toQueryField = inspect
+
+#if defined(__GHCJS__) && defined(ghcjs_HOST_OS) && defined(wasi_HOST_OS)
+instance ToQueryField JSString where
+  toQueryField = from @JSString @Text
+#endif