Truncate large names, with an opaleye tag to avoid collisions

src/Rel8/Statement.hs

@@ -59,7 +59,7 @@ import Rel8.Schema.Table (TableSchema (..))
 import Rel8.Statement.Rows (Rows (..))
 import Rel8.Table (Table)
 import Rel8.Table.Cols (fromCols)
-import Rel8.Table.Name (namesFromLabelsWithA, showNames)
+import Rel8.Table.Name (namesFromLabelsTagged, showNames)
 import Rel8.Table.Serialize (parse)
 
 -- semigroupoids
@@ -192,14 +192,7 @@ statementReturning pp = Statement $ do
     tag <- Opaleye.fresh
     let
       relation = Opaleye.tagWith tag "statement"
-      symbol labels = do
-        subtag <- Opaleye.fresh
-        let
-          suffix = Opaleye.tagWith tag (Opaleye.tagWith subtag "")
-        pure $ take (63 - length suffix) label ++ suffix
-        where
-          label = fold (intersperse "/" labels)
-      names = namesFromLabelsWithA symbol `evalState` Opaleye.start
+      names = namesFromLabelsTagged tag
       columns = Just $ showNames names
       query =
         fromCols <$> each

src/Rel8/Statement/Select.hs

@@ -46,7 +46,7 @@ import Rel8.Schema.Name ( Selects )
 import Rel8.Statement (Statement, statementReturning)
 import Rel8.Table ( Table )
 import Rel8.Table.Cols ( toCols )
-import Rel8.Table.Name ( namesFromLabels )
+import Rel8.Table.Name ( namesFromLabelsTagged )
 import Rel8.Table.Opaleye ( castTable, exprsWithNames )
 import qualified Rel8.Table.Opaleye as T
 import Rel8.Table.Undefined ( undefined )
@@ -62,15 +62,16 @@ select query = statementReturning (ppSelect query)
 
 ppSelect :: Table Expr a => Query a -> State Opaleye.Tag Doc
 ppSelect query = do
+  relationTag <- Opaleye.fresh
   (exprs, primQuery) <- Opaleye.runSimpleSelect (toOpaleye query)
   let
+    names = namesFromLabelsTagged relationTag
     (exprs', primQuery') = case optimize primQuery of
       Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
       Unit -> (exprs, Opaleye.Unit)
       Optimized pq -> (exprs, pq)
   pure $ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
   where
-    names = namesFromLabels
     never = pure (toPrimExpr false)
 
 

src/Rel8/Table/Name.hs

@@ -11,10 +11,12 @@
 
 module Rel8.Table.Name
   ( namesFromLabels
+  , namesFromLabelsTagged
   , namesFromLabelsWith
   , namesFromLabelsWithA
   , showLabels
   , showNames
+  , shortenName
   )
 where
 
@@ -26,6 +28,9 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
 import Data.Maybe ( fromMaybe )
 import Prelude
 
+-- opaleye
+import qualified Opaleye.Internal.Tag as Opaleye
+
 -- rel8
 import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
 import Rel8.Schema.Name ( Name( Name ) )
@@ -35,15 +40,41 @@ import Rel8.Table ( Table(..) )
 -- semigroupoids
 import Data.Functor.Apply (Apply)
 
+-- transformers
+import Control.Monad.Trans.State.Strict (State, evalState)
+
 
 -- | Construct a table in the 'Name' context containing the names of all
--- columns. Nested column names will be combined with @/@.
+-- columns. Nested column names will be combined with @/@, the resulting
+-- name will be truncated and a unique tag appended to the end of the name
+-- so that the resulting name has 63 or less characters (Postgres' default
+-- maximum column name length).
 --
--- See also: 'namesFromLabelsWith'.
+-- See also: 'namesFromLabelsTagged', 'namesFromLabelsWith'.
 namesFromLabels :: Table Name a => a
-namesFromLabels = namesFromLabelsWith go
+namesFromLabels = namesFromLabelsWithA (shortenName Nothing) `evalState` Opaleye.start
+
+
+-- | Similar to 'namesFromLabels', but receives an additional 'Opaleye.Tag'
+-- to distinguish between relations. Resulting names will also have 63 or
+-- less characters.
+namesFromLabelsTagged :: Table Name a => Opaleye.Tag -> a
+namesFromLabelsTagged relationTag = namesFromLabelsWithA (shortenName (Just relationTag)) `evalState` Opaleye.start
+
+
+-- | Map a non-empty list of labels to a short SQL identifier with an opaleye tag appended,
+-- truncated if it would be too large.
+shortenName :: Maybe Opaleye.Tag -> NonEmpty String -> State Opaleye.Tag String
+shortenName mtag labels = do
+  subtag <- Opaleye.fresh
+  let
+    addRelationTag = case mtag of
+      Nothing -> id
+      Just tag -> Opaleye.tagWith tag
+    suffix = addRelationTag (Opaleye.tagWith subtag "")
+  pure $ take (63 - length suffix) label ++ suffix
   where
-    go = fold . intersperse "/"
+    label = fold (intersperse "/" labels)
 
 
 -- | Construct a table in the 'Name' context containing the names of all

tests/Main.hs

@@ -35,7 +35,7 @@ import Data.Foldable ( for_ )
 import Data.Fixed (Centi)
 import Data.Functor (void)
 import Data.Int ( Int32, Int64 )
-import Data.List ( nub, sort )
+import Data.List ( isInfixOf, nub, sort )
 import Data.Maybe ( catMaybes )
 import Data.Ratio ((%))
 import Data.Word (Word32)
@@ -68,7 +68,7 @@ import qualified Hasql.Transaction as Hasql
 import qualified Hasql.Transaction.Sessions as Hasql
 
 -- hedgehog
-import Hedgehog ( annotate, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
+import Hedgehog ( annotate, assert, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
@@ -160,6 +160,7 @@ tests =
     , testSelectArray getTestDatabase
     , testNestedMaybeTable getTestDatabase
     , testEvaluate getTestDatabase
+    , testSelectTruncated getTestDatabase
     , testShowCreateTable getTestDatabase
     ]
   where
@@ -1344,3 +1345,53 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
     normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
     normalize [] = []
     normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
+
+
+-- Field name is 42 chars
+data LongLabelTable f = LongLabelTable
+  { aFieldNameDefinitelyLongerThanThirtyCharsA :: Rel8.Column f Text
+  , aFieldNameDefinitelyLongerThanThirtyCharsB :: Rel8.Column f Text
+  }
+  deriving stock Generic
+  deriving anyclass Rel8.Rel8able
+
+deriving stock instance Eq (LongLabelTable Result)
+deriving stock instance Ord (LongLabelTable Result)
+deriving stock instance Show (LongLabelTable Result)
+
+
+-- Field name is 51 chars, nested with the 42 above, we'll get more than 63,
+-- triggering truncation.
+data NestedForLargerThan63 f = NestedForLargerThan63
+  { aFieldNameDefinitelyLongerThanThirtyCharsNestedWith :: LongLabelTable f
+  }
+  deriving stock Generic
+  deriving anyclass Rel8.Rel8able
+
+deriving stock instance Eq (NestedForLargerThan63 Result)
+deriving stock instance Ord (NestedForLargerThan63 Result)
+deriving stock instance Show (NestedForLargerThan63 Result)
+
+
+testSelectTruncated :: IO TmpPostgres.DB -> TestTree
+testSelectTruncated = databasePropertyTest "select truncates long column aliases" \transaction -> do
+  rows <- forAll $ Gen.list (Range.linear 0 10) ((,) <$> genText <*> genText)
+
+  let q = Rel8.values $ map (\(tA, tB) -> NestedForLargerThan63 (LongLabelTable (Rel8.lit tA) (Rel8.lit tB))) rows
+      sqlText = Rel8.showStatement (Rel8.select q)
+  annotate sqlText
+
+  -- Check that long names do not exist
+  assert $ not $ "aFieldNameDefinitelyLongerThanThirtyCharsA" `isInfixOf` sqlText
+  assert $ not $ "aFieldNameDefinitelyLongerThanThirtyCharsB" `isInfixOf` sqlText
+
+  -- Find the short names
+  assert $ "aFieldNameDefinitelyLongerThanThirtyCharsNestedWith/aFieldN_1_1" `isInfixOf` sqlText
+  assert $ "aFieldNameDefinitelyLongerThanThirtyCharsNestedWith/aFieldN_2_1" `isInfixOf` sqlText
+
+  transaction do
+    selected <- lift do
+      statement () $ Rel8.run $ Rel8.select q
+    sort (map (((,) <$> aFieldNameDefinitelyLongerThanThirtyCharsA <*>  aFieldNameDefinitelyLongerThanThirtyCharsB)
+      . aFieldNameDefinitelyLongerThanThirtyCharsNestedWith) selected)
+      === sort rows

tests/Rel8/Generic/Rel8able/Test.hs

@@ -28,6 +28,7 @@ import qualified Data.Aeson.KeyMap as Aeson
 
 -- base
 import Data.Fixed ( Fixed ( MkFixed ), E2 )
+import Data.Foldable ( fold )
 import Data.Int ( Int16, Int32, Int64 )
 import Data.Functor.Identity ( Identity(..) )
 import qualified Data.List.NonEmpty as NonEmpty
@@ -71,7 +72,6 @@ import Rel8 (
   Result,
   TableSchema (TableSchema),
   ToExprs,
-  namesFromLabels,
   namesFromLabelsWith,
  )
 import qualified Rel8
@@ -106,7 +106,7 @@ import qualified Data.Vector as Vector
 makeSchema :: forall f. Rel8able f => QualifiedName -> TableSchema (f Name)
 makeSchema name = TableSchema
   { name = name
-  , columns = namesFromLabels @(f Name)
+  , columns = namesFromLabelsWith @(f Name) (fold . NonEmpty.intersperse "/")
   }