From 93c62d6ed16db569fd6ba8d566c6e374a8f06a40 Mon Sep 17 00:00:00 2001
From: Aleksandr Pak <aleksandr.vl.pak@gmail.com>
Date: Mon, 25 Jul 2022 13:28:30 +0300
Subject: [PATCH] [#114] Fix EntryPath Schema

---
 docs/swagger.json  | 20 ++------------------
 lib/Coffer/Path.hs | 31 ++++++++++++++++++++++++-------
 2 files changed, 26 insertions(+), 25 deletions(-)

diff --git a/docs/swagger.json b/docs/swagger.json
index 24fedf15..d28b297d 100644
--- a/docs/swagger.json
+++ b/docs/swagger.json
@@ -11,20 +11,8 @@
     "components": {
         "schemas": {
             "EntryPath": {
-                "type": "object",
-                "required": [
-                    "unEntryPath"
-                ],
-                "pattern": "(/${pathSegment})+",
-                "properties": {
-                    "unEntryPath": {
-                        "items": {
-                            "$ref": "#/components/schemas/PathSegment"
-                        },
-                        "type": "array",
-                        "minItems": 1
-                    }
-                }
+                "type": "string",
+                "pattern": "(/[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_]*)+"
             },
             "Directory": {
                 "type": "object",
@@ -75,10 +63,6 @@
                     }
                 }
             },
-            "PathSegment": {
-                "type": "string",
-                "pattern": "[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_]*"
-            },
             "NewEntry": {
                 "type": "object",
                 "required": [
diff --git a/lib/Coffer/Path.hs b/lib/Coffer/Path.hs
index e788a7f8..752d1755 100644
--- a/lib/Coffer/Path.hs
+++ b/lib/Coffer/Path.hs
@@ -43,6 +43,7 @@ import Data.Text qualified as T
 import Fmt (Buildable, build, fmt, pretty)
 import GHC.Generics (Generic)
 import Servant (FromHttpApiData(..), ToHttpApiData(..))
+import Text.Interpolation.Nyan
 
 -- $setup
 -- >>> import Fmt (pretty, build)
@@ -71,14 +72,18 @@ instance ToSchema PathSegment where
       & Schema.pattern ?~ pathSegmentPattern
       & type_ ?~ OpenApiString
     where
-      pathSegmentPattern = "[" <> T.pack pathSegmentAllowedCharacters <> "]*"
+      pathSegmentPattern = [int|s|
+        [#{pathSegmentAllowedCharacters}]
+      |]
 
 mkPathSegment :: Text -> Either Text PathSegment
 mkPathSegment segment
   | T.null segment =
       Left "Path segments must contain at least 1 character"
   | T.any (`notElem` pathSegmentAllowedCharacters) segment =
-      Left $ "Path segments can only contain the following characters: '" <> T.pack pathSegmentAllowedCharacters <> "'"
+      Left $ [int|s|
+        Path segments can only contain the following characters: '#{pathSegmentAllowedCharacters}'
+      |]
   | otherwise = Right $ UnsafeMkPathSegment segment
 
 pathSegmentAllowedCharacters :: [Char]
@@ -139,12 +144,24 @@ newtype EntryPath = EntryPath { unEntryPath :: NonEmpty PathSegment }
 instance A.ToJSON EntryPath where
   toJSON = String . pretty
 
+instance ToParamSchema EntryPath where
+  toParamSchema _ =
+    mempty
+      & Schema.pattern ?~ entryPathPattern
+      & type_ ?~ OpenApiString
+    where
+      segmentPattern :: Pattern
+      segmentPattern = [int|s|
+        [#{pathSegmentAllowedCharacters}]*
+      |]
+
+      entryPathPattern :: Pattern
+      entryPathPattern = [int|s|
+        (/#{segmentPattern})+
+      |]
+
 instance ToSchema EntryPath where
-  declareNamedSchema proxy = do
-    namedSchema <- genericDeclareNamedSchema defaultSchemaOptions proxy
-    pure
-      $ namedSchema
-      & schema . Schema.pattern ?~ "(/${pathSegment})+"
+  declareNamedSchema proxy = pure $ NamedSchema (Just "EntryPath") (toParamSchema proxy)
 
 instance ToHttpApiData EntryPath where
   toUrlPiece = fmt . build