{- |

Copyright : Flipstone Technology Partners 2023
License   : MIT
Stability : Stable

This module provides the very basics for [sqlcommenter](https://google.github.io/sqlcommenter)
support.

@since 1.0.0.0
-}
module Orville.PostgreSQL.Raw.SqlCommenter
  ( SqlCommenterAttributes
  , addSqlCommenterAttributes
  )
where

import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Network.URI as URI

import qualified Orville.PostgreSQL.Raw.RawSql as RawSql

{- | The representation of 'T.Text' key/value pairs for supporting the sqlcommenter specification.
  This allows you to attach key/values of 'T.Text' that supporting systems can use for advanced
  metrics. See [sqlcommenter](https://google.github.io/sqlcommenter) for details of the
  specification.

@since 1.0.0.0
-}
type SqlCommenterAttributes = Map.Map T.Text T.Text

{- | Adds a given @SqlCommenter@ set of key/value 'T.Text' pairs to a 'RawSql.SqlExpression'. This
  performs all of the required serialization for the given values. Note that no values are
  automatically added here, so any that you may wish to add can be freely set without a name clash
  of any kind from this function itself.

@since 1.0.0.0
-}
addSqlCommenterAttributes :: RawSql.SqlExpression a => SqlCommenterAttributes -> a -> a
addSqlCommenterAttributes :: forall a. SqlExpression a => SqlCommenterAttributes -> a -> a
addSqlCommenterAttributes SqlCommenterAttributes
commenter a
a =
  RawSql -> a
forall a. SqlExpression a => RawSql -> a
RawSql.unsafeFromRawSql (RawSql -> a) -> RawSql -> a
forall a b. (a -> b) -> a -> b
$
    a -> RawSql
forall a. SqlExpression a => a -> RawSql
RawSql.toRawSql a
a
      RawSql -> RawSql -> RawSql
forall a. Semigroup a => a -> a -> a
<> SqlCommenterAttributes -> RawSql
keyValueSerializationToRawSql SqlCommenterAttributes
commenter

keyValueSerializationToRawSql :: SqlCommenterAttributes -> RawSql.RawSql
keyValueSerializationToRawSql :: SqlCommenterAttributes -> RawSql
keyValueSerializationToRawSql =
  Text -> RawSql
RawSql.fromText (Text -> RawSql)
-> (SqlCommenterAttributes -> Text)
-> SqlCommenterAttributes
-> RawSql
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlCommenterAttributes -> Text
keyValueSerialization

{- | Perform the sqlcommenter serialization on for the whole @SqlCommenter@ map of key/value pairs.
     The spec can be found
     [here](https://google.github.io/sqlcommenter/spec/#key-value-serialization)

@since 1.0.0.0
-}
keyValueSerialization :: SqlCommenterAttributes -> T.Text
keyValueSerialization :: SqlCommenterAttributes -> Text
keyValueSerialization =
  Text -> Text
wrapInSqlComment (Text -> Text)
-> (SqlCommenterAttributes -> Text)
-> SqlCommenterAttributes
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
addCommasAndConcat ([Text] -> Text)
-> (SqlCommenterAttributes -> [Text])
-> SqlCommenterAttributes
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. Ord a => [a] -> [a]
List.sort ([Text] -> [Text])
-> (SqlCommenterAttributes -> [Text])
-> SqlCommenterAttributes
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> Text
concatWithEquals ([(Text, Text)] -> [Text])
-> (SqlCommenterAttributes -> [(Text, Text)])
-> SqlCommenterAttributes
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlCommenterAttributes -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (SqlCommenterAttributes -> [(Text, Text)])
-> (SqlCommenterAttributes -> SqlCommenterAttributes)
-> SqlCommenterAttributes
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlCommenterAttributes -> SqlCommenterAttributes
valueSerialization (SqlCommenterAttributes -> SqlCommenterAttributes)
-> (SqlCommenterAttributes -> SqlCommenterAttributes)
-> SqlCommenterAttributes
-> SqlCommenterAttributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlCommenterAttributes -> SqlCommenterAttributes
keySerialization

addCommasAndConcat :: [T.Text] -> T.Text
addCommasAndConcat :: [Text] -> Text
addCommasAndConcat [] = String -> Text
T.pack String
"''"
addCommasAndConcat [Text]
txts = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
List.intersperse (String -> Text
T.pack String
",") [Text]
txts

concatWithEquals :: (T.Text, T.Text) -> T.Text
concatWithEquals :: (Text, Text) -> Text
concatWithEquals (Text
k, Text
v) =
  Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v

-- | The spec can be found [here](https://google.github.io/sqlcommenter/spec/#key-serialization)
keySerialization :: SqlCommenterAttributes -> SqlCommenterAttributes
keySerialization :: SqlCommenterAttributes -> SqlCommenterAttributes
keySerialization =
  (Text -> Text) -> SqlCommenterAttributes -> SqlCommenterAttributes
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Text -> Text
escapeText

-- | The spec can be found [here](https://google.github.io/sqlcommenter/spec/#value-serialization)
valueSerialization :: SqlCommenterAttributes -> SqlCommenterAttributes
valueSerialization :: SqlCommenterAttributes -> SqlCommenterAttributes
valueSerialization =
  (Text -> Text) -> SqlCommenterAttributes -> SqlCommenterAttributes
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
wrapInSingleQuote (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeQuote (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeText)

-- Here we ensure there is a space before the comment
wrapInSqlComment :: T.Text -> T.Text
wrapInSqlComment :: Text -> Text
wrapInSqlComment Text
txt =
  String -> Text
T.pack String
" /*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
"*/"

wrapInSingleQuote :: T.Text -> T.Text
wrapInSingleQuote :: Text -> Text
wrapInSingleQuote Text
txt =
  String -> Text
T.pack String
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
"'"

escapeQuote :: T.Text -> T.Text
escapeQuote :: Text -> Text
escapeQuote =
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace (String -> Text
T.pack String
"'") (String -> Text
T.pack String
"\'")

escapeText :: T.Text -> T.Text
escapeText :: Text -> Text
escapeText =
  String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escapeStr (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

escapeStr :: String -> String
escapeStr :: String -> String
escapeStr = (Char -> Bool) -> String -> String
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent