Add collation support

persistent-mysql/Database/Persist/MySQL.hs

@@ -618,7 +618,8 @@ getColumns connectInfo getter def cols = do
       ,   "NUMERIC_PRECISION, "
       ,   "NUMERIC_SCALE, "
       ,   "COLUMN_DEFAULT, "
-      ,   "GENERATION_EXPRESSION "
+      ,   "GENERATION_EXPRESSION, "
+      ,   "COLLATION_NAME "
       , "FROM INFORMATION_SCHEMA.COLUMNS "
       , "WHERE TABLE_SCHEMA = ? "
       ,   "AND TABLE_NAME   = ? "
@@ -690,6 +691,7 @@ getColumn connectInfo getter tname [ PersistText cname
                                    , colScale
                                    , default'
                                    , generated
+                                   , collation
                                    ] cRef =
     fmap (either (Left . pack) Right) $
     runExceptT $ do
@@ -752,9 +754,13 @@ getColumn connectInfo getter tname [ PersistText cname
             , cGenerated = generated_
             , cDefaultConstraintName = Nothing
             , cMaxLen = maxLen
+            , cCollation = parseCollation collation
             , cReference = ref
             }
   where
+    parseCollation (PersistText n) = Just (CollationName n)
+    parseCollation _ = Nothing
+
     getRef Nothing = return Nothing
     getRef (Just refName') = do
         -- Foreign key (if any)
@@ -916,7 +922,7 @@ findAlters
     -> Column
     -> [Column]
     -> ([AlterColumn], [Column])
-findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName maxLen ref) cols =
+findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName maxLen collation ref) cols =
     case filter ((name ==) . cName) cols of
     -- new fkey that didn't exist before
         [] ->
@@ -928,7 +934,7 @@ findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName
                         cnstr = [addReference allDefs cname tname name (crFieldCascade cr)]
                     in
                         (Add' col : cnstr, cols)
-        Column _ isNull' type_' def' gen' _defConstraintName' maxLen' ref' : _ ->
+        Column _ isNull' type_' def' gen' _defConstraintName' maxLen' collation ref' : _ ->
             let -- Foreign key
                 refDrop =
                     case (ref == ref', ref') of
@@ -985,7 +991,7 @@ showAlterColumn :: Column -> String
 showAlterColumn = showColumn True
 
 showColumn :: Bool -> Column -> String
-showColumn showReferences (Column n nu t def gen _defConstraintName maxLen ref) = concat
+showColumn showReferences (Column n nu t def gen _defConstraintName maxLen _collation ref) = concat
     [ escapeF n
     , " "
     , showSqlType t maxLen True
@@ -1078,14 +1084,14 @@ showAlterTable table (DropUniqueConstraint cname) = concat
 
 -- | Render an action that must be done on a column.
 showAlter :: EntityNameDB -> AlterColumn -> String
-showAlter table (Change (Column n nu t def gen defConstraintName maxLen _ref)) =
+showAlter table (Change (Column n nu t def gen defConstraintName maxLen collation _ref)) =
     concat
     [ "ALTER TABLE "
     , escapeE table
     , " CHANGE "
     , escapeF n
     , " "
-    , showAlterColumn (Column n nu t def gen defConstraintName maxLen Nothing)
+    , showAlterColumn (Column n nu t def gen defConstraintName maxLen collation Nothing)
     ]
 showAlter table (Add' col) =
     concat

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -771,6 +771,7 @@ getColumns getter def cols = do
             , ",numeric_precision "
             , ",numeric_scale "
             , ",character_maximum_length "
+            , ",collation_name "
             , "FROM information_schema.columns "
             , "WHERE table_catalog=current_database() "
             , "AND table_schema=current_schema() "
@@ -903,6 +904,7 @@ getColumn getter tableName' [ PersistText columnName
                             , numericPrecision
                             , numericScale
                             , maxlen
+                            , collation
                             ] refName_ = runExceptT $ do
     defaultValue' <-
         case defaultValue of
@@ -943,6 +945,7 @@ getColumn getter tableName' [ PersistText columnName
         , cGenerated = fmap stripSuffixes generationExpression'
         , cDefaultConstraintName = Nothing
         , cMaxLen = Nothing
+        , cCollation = parseCollation collation
         , cReference = fmap (\(a,b,c,d) -> ColumnReference a b (mkCascade c d)) ref
         }
 
@@ -954,6 +957,9 @@ getColumn getter tableName' [ PersistText columnName
             , fcOnDelete = parseCascade delText
             }
 
+    parseCollation (PersistText n) = Just (CollationName n)
+    parseCollation _ = Nothing
+
     parseCascade txt =
         case txt of
             "NO ACTION" ->
@@ -1025,7 +1031,8 @@ getColumn getter tableName' [ PersistText columnName
                   , " but got: "
                   , show xs
                   ]
-
+    -- TODO: Refactor this for reuse outside of migration
+    -- autogenerator
     getType "int4"        = pure SqlInt32
     getType "int8"        = pure SqlInt64
     getType "varchar"     = pure SqlString
@@ -1084,11 +1091,11 @@ findAlters
     -- ^ The column that we're searching for potential alterations for.
     -> [Column]
     -> ([AlterColumn], [Column])
-findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName _maxLen ref) cols =
+findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName _maxLen collation ref) cols =
     case List.find (\c -> cName c == name) cols of
         Nothing ->
             ([Add' col], cols)
-        Just (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') ->
+        Just (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' collation' ref') ->
             let refDrop Nothing = []
                 refDrop (Just ColumnReference {crConstraintName=cname}) =
                     [DropReference cname]
@@ -1124,8 +1131,8 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName
                                             Just s -> (:) (Update' col s)
                                  in up [NotNull col]
                             _ -> []
-                modType
-                    | sqlTypeEq sqltype sqltype' = []
+                modTypeAndCollation
+                    | sqlTypeEq sqltype sqltype' && collation == collation' = []
                     -- When converting from Persistent pre-2.0 databases, we
                     -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is
                     -- treated as UTC.
@@ -1135,7 +1142,7 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName
                             , escapeF name
                             , " AT TIME ZONE 'UTC'"
                             ]]
-                    | otherwise = [ChangeType col sqltype ""]
+                    | otherwise = [ChangeType col sqltype collateExpr]
                 modDef =
                     if def == def'
                         || isJust (T.stripPrefix "nextval" =<< def')
@@ -1144,12 +1151,16 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName
                             case def of
                                 Nothing -> [NoDefault col]
                                 Just s  -> [Default col s]
+                collateExpr 
+                    | collation == collation' = mempty
+                    | otherwise = 
+                          maybe mempty (\c -> " COLLATE " <> escapeCl c) $ collation
                 dropSafe =
                     if safeToRemove edef name
                         then error "wtf" [Drop col True]
                         else []
              in
-                ( modRef ++ modDef ++ modNull ++ modType ++ dropSafe
+                ( modRef ++ modDef ++ modNull ++ modTypeAndCollation ++ dropSafe
                 , filter (\c -> cName c /= name) cols
                 )
 
@@ -1194,10 +1205,11 @@ getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crCons
                 return $ NEL.toList $ Util.dbIdColumnsEsc escapeF entDef
 
 showColumn :: Column -> Text
-showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = T.concat
+showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen collation _ref) = T.concat
     [ escapeF n
     , " "
     , showSqlType sqlType'
+    , maybe mempty (\c -> " COLLATE " <> escapeCl c) collation
     , " "
     , if nu then "NULL" else "NOT NULL"
     , case def of
@@ -1352,6 +1364,9 @@ fieldName = escapeF . fieldDBName
 escapeC :: ConstraintNameDB -> Text
 escapeC = escapeWith escape
 
+escapeCl :: CollationName -> Text
+escapeCl = escapeWith escape
+
 escapeE :: EntityNameDB -> Text
 escapeE = escapeWith escape
 

persistent-sqlite/ChangeLog.md

@@ -11,6 +11,11 @@
     * Add `SqlBackendHooks` to allow for instrumentation of queries.
 * [#1327](https://github.com/yesodweb/persistent/pull/1327)
     * Update backend to support new `StatementCache` interface
+* [#1488](https://github.com/yesodweb/persistent/pull/1488)
+    * Add `openRawSqliteConn` for creating `RawSqlite SqlBackend` connections
+      that aren't automatically cleaned-up.
+* [#1459](https://github.com/yesodweb/persistent/pull/1459)
+    * Make use of `CautiousMigration` type alias for clarity.
 
 ## 2.13.0.4
 

persistent-sqlite/Database/Persist/Sqlite.hs

@@ -48,8 +48,10 @@ module Database.Persist.Sqlite
     , ForeignKeyViolation(..)
     , checkForeignKeys
     , RawSqlite
+    , openRawSqliteConn
     , persistentBackend
     , rawSqliteConnection
+    , openRawSqliteConn
     , withRawSqliteConnInfo
     , createRawSqlitePoolFromInfo
     , createRawSqlitePoolFromInfo_
@@ -94,8 +96,8 @@ import qualified Data.Conduit.Combinators as C
 import qualified Data.Conduit.List as CL
 import Data.Foldable (toList)
 import qualified Data.HashMap.Lazy as HashMap
-import Data.Int (Int64)
 import Data.IORef (newIORef)
+import Data.Int (Int64)
 import Data.Maybe
 import Data.Pool (Pool)
 import Data.Text (Text)
@@ -608,12 +610,18 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) =
             , " "
             , showSqlType $ fieldSqlType fd
             , " PRIMARY KEY"
+            , mayCollate $ collation $ fieldAttrs fd
             , mayDefault $ defaultAttribute $ fieldAttrs fd
             , T.concat $ map (sqlColumn isTemp) nonIdCols
             ]
 
     nonIdCols = filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity)) cols
 
+mayCollate :: Maybe CollationName -> Text
+mayCollate c = case c of
+    Nothing -> ""
+    Just c -> " COLLATE " <> escapeCl c
+
 mayDefault :: Maybe Text -> Text
 mayDefault def = case def of
     Nothing -> ""
@@ -625,12 +633,13 @@ mayGenerated gen = case gen of
     Just g -> " GENERATED ALWAYS AS (" <> g <> ") STORED"
 
 sqlColumn :: Bool -> Column -> Text
-sqlColumn noRef (Column name isNull typ def gen _cn _maxLen ref) = T.concat
+sqlColumn noRef (Column name isNull typ def gen _cn _maxLen collation ref) = T.concat
     [ ","
     , escapeF name
     , " "
     , showSqlType typ
     , if isNull then " NULL" else " NOT NULL"
+    , mayCollate collation
     , mayDefault def
     , mayGenerated gen
     , case ref of
@@ -681,6 +690,9 @@ sqlUnique (UniqueDef _ cname cols _) = T.concat
 escapeC :: ConstraintNameDB -> Text
 escapeC = escapeWith escape
 
+escapeCl :: CollationName -> Text
+escapeCl = escapeWith escape
+
 escapeE :: EntityNameDB -> Text
 escapeE = escapeWith escape
 
@@ -938,6 +950,22 @@ data RawSqlite backend = RawSqlite
     , _rawSqliteConnection :: Sqlite.Connection -- ^ The underlying `Sqlite.Connection`
     }
 
+-- | Open a @'RawSqlite' 'SqlBackend'@ connection from a 'SqliteConnectionInfo'.
+--
+-- When using this function, the caller has to accept the responsibility of
+-- cleaning up the resulting connection. To do this, use 'close' with the
+-- 'rawSqliteConnection' - it's enough to simply drop the 'persistBackend'
+-- afterwards.
+--
+-- @since 2.13.2
+openRawSqliteConn
+    :: (MonadUnliftIO m, MonadLoggerIO m)
+    => SqliteConnectionInfo
+    -> m (RawSqlite SqlBackend)
+openRawSqliteConn connInfo = do
+    logFunc <- askLoggerIO
+    liftIO $ openWith RawSqlite connInfo logFunc
+
 instance BackendCompatible b (RawSqlite b) where
     projectBackend = _persistentBackend
 

persistent-test/src/MigrationColumnLengthTest.hs

@@ -10,10 +10,11 @@ share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|
 VaryingLengths
     field1 Int
     field2 T.Text sqltype=varchar(5)
+    field3 T.Text collate=en_US.utf8
 |]
 
 specsWith :: MonadIO m => RunDb SqlBackend m -> Spec
-specsWith runDb =
+specsWith runDb = do
   it "is idempotent" $ runDb $ do
       again <- getMigration migration
       liftIO $ again @?= []

persistent/Database/Persist/Names.hs

@@ -29,6 +29,17 @@ newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text }
 instance DatabaseName FieldNameDB where
     escapeWith f (FieldNameDB n) = f n
 
+-- | A 'CollationName' represents the name of a collation that @persistent@
+-- will associate with a particular field.
+--
+-- @since 2.15.0.0
+newtype CollationName = CollationName { unCollatioName :: Text }
+    deriving (Show, Eq, Read, Ord, Lift)
+
+-- | @since 2.15.0.0
+instance DatabaseName CollationName where
+    escapeWith f (CollationName n) = f n
+
 -- | A 'FieldNameHS' represents the Haskell-side name that @persistent@
 -- will use for a field.
 --

persistent/Database/Persist/Sql.hs

@@ -53,6 +53,7 @@ module Database.Persist.Sql
     , getBackendSpecificForeignKeyName
     , setBackendSpecificForeignKeyName
     , defaultAttribute
+    , collation
       -- * Internal
     , IsolationLevel(..)
     , decorateSQLWithLimitOffset

persistent/Database/Persist/Sql/Internal.hs

@@ -7,6 +7,7 @@
 module Database.Persist.Sql.Internal
     ( mkColumns
     , defaultAttribute
+    , collation
     , BackendSpecificOverrides(..)
     , getBackendSpecificForeignKeyName
     , setBackendSpecificForeignKeyName
@@ -74,6 +75,11 @@ defaultAttribute = findMaybe $ \case
     FieldAttrDefault x -> Just x
     _ -> Nothing
 
+collation :: [FieldAttr] -> Maybe CollationName
+collation = findMaybe $ \case
+    FieldAttrCollate n -> Just (CollationName n)
+    _ -> Nothing
+
 -- | Create the list of columns for the given entity.
 mkColumns
     :: [EntityDef]
@@ -129,6 +135,7 @@ mkColumns allDefs t overrides =
             , cGenerated = fieldGenerated fd
             , cDefaultConstraintName =  Nothing
             , cMaxLen = maxLen $ fieldAttrs fd
+            , cCollation = collation $ fieldAttrs fd
             , cReference = mkColumnReference fd
             }
 
@@ -148,6 +155,7 @@ mkColumns allDefs t overrides =
             , cGenerated = fieldGenerated fd
             , cDefaultConstraintName =  Nothing
             , cMaxLen = maxLen $ fieldAttrs fd
+            , cCollation = collation $ fieldAttrs fd
             , cReference = mkColumnReference fd
             }
 

persistent/Database/Persist/Sql/Types.hs

@@ -27,6 +27,7 @@ data Column = Column
     , cGenerated :: !(Maybe Text)
     , cDefaultConstraintName   :: !(Maybe ConstraintNameDB)
     , cMaxLen    :: !(Maybe Integer)
+    , cCollation :: !(Maybe CollationName)
     , cReference :: !(Maybe ColumnReference)
     }
     deriving (Eq, Ord, Show)

persistent/Database/Persist/TH.hs

@@ -605,6 +605,20 @@ bindCompositeDef ued ucd = do
             }
         |]
 
+-- | TODO: This should call the same `getType` used
+-- in the migration autogenerator before assigning
+-- something as SqlOther, ex.:
+--
+-- > email Text 
+-- ...is assigned to SqlString, whereas:
+--
+-- > email Text sqltype=text
+-- ...is assigned to (SqlOther "text") because of this function.
+--
+-- ...even though all `text` columns get parsed to SqlString
+-- anyway during migration autogeneration.
+--
+-- ...thereby perpetually forcing an unnecessary migration.
 getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
 getSqlType emEntities entityMap field =
     maybe