module Database.PostgreSQL.PQTypes.Model.Index (
    TableIndex(..)
  , IndexColumn(..)
  , indexColumn
  , indexColumnWithOperatorClass
  , IndexMethod(..)
  , tblIndex
  , indexOnColumn
  , indexOnColumns
  , indexOnColumnWithMethod
  , indexOnColumnsWithMethod
  , uniqueIndexOnColumn
  , uniqueIndexOnColumnWithCondition
  , uniqueIndexOnColumns
  , indexName
  , sqlCreateIndexMaybeDowntime
  , sqlCreateIndexConcurrently
  , sqlDropIndexMaybeDowntime
  , sqlDropIndexConcurrently
  ) where

import Data.Char
import Data.Function
import Data.String
import Data.Monoid.Utils
import Database.PostgreSQL.PQTypes
import qualified Crypto.Hash as H
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

data TableIndex = TableIndex {
  TableIndex -> [IndexColumn]
idxColumns :: [IndexColumn]
, TableIndex -> [RawSQL ()]
idxInclude :: [RawSQL ()]
, TableIndex -> IndexMethod
idxMethod  :: IndexMethod
, TableIndex -> Bool
idxUnique  :: Bool
, TableIndex -> Bool
idxValid   :: Bool -- ^ If creation of index with CONCURRENTLY fails, index
                     -- will be marked as invalid. Set it to 'False' if such
                     -- situation is expected.
, TableIndex -> Maybe (RawSQL ())
idxWhere   :: Maybe (RawSQL ())
} deriving (TableIndex -> TableIndex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TableIndex -> TableIndex -> Bool
$c/= :: TableIndex -> TableIndex -> Bool
== :: TableIndex -> TableIndex -> Bool
$c== :: TableIndex -> TableIndex -> Bool
Eq, Eq TableIndex
TableIndex -> TableIndex -> Bool
TableIndex -> TableIndex -> Ordering
TableIndex -> TableIndex -> TableIndex
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TableIndex -> TableIndex -> TableIndex
$cmin :: TableIndex -> TableIndex -> TableIndex
max :: TableIndex -> TableIndex -> TableIndex
$cmax :: TableIndex -> TableIndex -> TableIndex
>= :: TableIndex -> TableIndex -> Bool
$c>= :: TableIndex -> TableIndex -> Bool
> :: TableIndex -> TableIndex -> Bool
$c> :: TableIndex -> TableIndex -> Bool
<= :: TableIndex -> TableIndex -> Bool
$c<= :: TableIndex -> TableIndex -> Bool
< :: TableIndex -> TableIndex -> Bool
$c< :: TableIndex -> TableIndex -> Bool
compare :: TableIndex -> TableIndex -> Ordering
$ccompare :: TableIndex -> TableIndex -> Ordering
Ord, Int -> TableIndex -> ShowS
[TableIndex] -> ShowS
TableIndex -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TableIndex] -> ShowS
$cshowList :: [TableIndex] -> ShowS
show :: TableIndex -> String
$cshow :: TableIndex -> String
showsPrec :: Int -> TableIndex -> ShowS
$cshowsPrec :: Int -> TableIndex -> ShowS
Show)

data IndexColumn
  = IndexColumn (RawSQL ()) (Maybe (RawSQL ()))
  deriving Int -> IndexColumn -> ShowS
[IndexColumn] -> ShowS
IndexColumn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexColumn] -> ShowS
$cshowList :: [IndexColumn] -> ShowS
show :: IndexColumn -> String
$cshow :: IndexColumn -> String
showsPrec :: Int -> IndexColumn -> ShowS
$cshowsPrec :: Int -> IndexColumn -> ShowS
Show

-- If one of the two columns doesn't specify the operator class, we just ignore
-- it and still treat them as equivalent.
instance Eq IndexColumn where
  IndexColumn RawSQL ()
x Maybe (RawSQL ())
Nothing == :: IndexColumn -> IndexColumn -> Bool
== IndexColumn RawSQL ()
y Maybe (RawSQL ())
_ = RawSQL ()
x forall a. Eq a => a -> a -> Bool
== RawSQL ()
y
  IndexColumn RawSQL ()
x Maybe (RawSQL ())
_ == IndexColumn RawSQL ()
y Maybe (RawSQL ())
Nothing = RawSQL ()
x forall a. Eq a => a -> a -> Bool
== RawSQL ()
y
  IndexColumn RawSQL ()
x (Just RawSQL ()
x') == IndexColumn RawSQL ()
y (Just RawSQL ()
y') = RawSQL ()
x forall a. Eq a => a -> a -> Bool
== RawSQL ()
y Bool -> Bool -> Bool
&& RawSQL ()
x' forall a. Eq a => a -> a -> Bool
== RawSQL ()
y'

instance Ord IndexColumn where
  compare :: IndexColumn -> IndexColumn -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IndexColumn -> RawSQL ()
indexColumnName

instance IsString IndexColumn where
  fromString :: String -> IndexColumn
fromString String
s = RawSQL () -> Maybe (RawSQL ()) -> IndexColumn
IndexColumn (forall a. IsString a => String -> a
fromString String
s) forall a. Maybe a
Nothing

indexColumn :: RawSQL () -> IndexColumn
indexColumn :: RawSQL () -> IndexColumn
indexColumn RawSQL ()
col = RawSQL () -> Maybe (RawSQL ()) -> IndexColumn
IndexColumn RawSQL ()
col forall a. Maybe a
Nothing

indexColumnWithOperatorClass :: RawSQL () -> RawSQL () -> IndexColumn
indexColumnWithOperatorClass :: RawSQL () -> RawSQL () -> IndexColumn
indexColumnWithOperatorClass RawSQL ()
col RawSQL ()
opclass = RawSQL () -> Maybe (RawSQL ()) -> IndexColumn
IndexColumn RawSQL ()
col (forall a. a -> Maybe a
Just RawSQL ()
opclass)

indexColumnName :: IndexColumn -> RawSQL ()
indexColumnName :: IndexColumn -> RawSQL ()
indexColumnName (IndexColumn RawSQL ()
col Maybe (RawSQL ())
_) = RawSQL ()
col

data IndexMethod =
    BTree
  | GIN
  deriving (IndexMethod -> IndexMethod -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexMethod -> IndexMethod -> Bool
$c/= :: IndexMethod -> IndexMethod -> Bool
== :: IndexMethod -> IndexMethod -> Bool
$c== :: IndexMethod -> IndexMethod -> Bool
Eq, Eq IndexMethod
IndexMethod -> IndexMethod -> Bool
IndexMethod -> IndexMethod -> Ordering
IndexMethod -> IndexMethod -> IndexMethod
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IndexMethod -> IndexMethod -> IndexMethod
$cmin :: IndexMethod -> IndexMethod -> IndexMethod
max :: IndexMethod -> IndexMethod -> IndexMethod
$cmax :: IndexMethod -> IndexMethod -> IndexMethod
>= :: IndexMethod -> IndexMethod -> Bool
$c>= :: IndexMethod -> IndexMethod -> Bool
> :: IndexMethod -> IndexMethod -> Bool
$c> :: IndexMethod -> IndexMethod -> Bool
<= :: IndexMethod -> IndexMethod -> Bool
$c<= :: IndexMethod -> IndexMethod -> Bool
< :: IndexMethod -> IndexMethod -> Bool
$c< :: IndexMethod -> IndexMethod -> Bool
compare :: IndexMethod -> IndexMethod -> Ordering
$ccompare :: IndexMethod -> IndexMethod -> Ordering
Ord)

instance Show IndexMethod where
    show :: IndexMethod -> String
show IndexMethod
BTree = String
"btree"
    show IndexMethod
GIN   = String
"gin"

instance Read IndexMethod where
    readsPrec :: Int -> ReadS IndexMethod
readsPrec Int
_ (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower -> String
"btree") = [(IndexMethod
BTree,String
"")]
    readsPrec Int
_ (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower -> String
"gin")   = [(IndexMethod
GIN,String
"")]
    readsPrec Int
_ String
_       = []

tblIndex :: TableIndex
tblIndex :: TableIndex
tblIndex = TableIndex {
  idxColumns :: [IndexColumn]
idxColumns = []
, idxInclude :: [RawSQL ()]
idxInclude = []
, idxMethod :: IndexMethod
idxMethod = IndexMethod
BTree
, idxUnique :: Bool
idxUnique = Bool
False
, idxValid :: Bool
idxValid = Bool
True
, idxWhere :: Maybe (RawSQL ())
idxWhere = forall a. Maybe a
Nothing
}

indexOnColumn :: IndexColumn -> TableIndex
indexOnColumn :: IndexColumn -> TableIndex
indexOnColumn IndexColumn
column = TableIndex
tblIndex { idxColumns :: [IndexColumn]
idxColumns = [IndexColumn
column] }

-- | Create an index on the given column with the specified method.  No checks
-- are made that the method is appropriate for the type of the column.
indexOnColumnWithMethod :: IndexColumn -> IndexMethod -> TableIndex
indexOnColumnWithMethod :: IndexColumn -> IndexMethod -> TableIndex
indexOnColumnWithMethod IndexColumn
column IndexMethod
method =
    TableIndex
tblIndex { idxColumns :: [IndexColumn]
idxColumns = [IndexColumn
column]
             , idxMethod :: IndexMethod
idxMethod = IndexMethod
method }

indexOnColumns :: [IndexColumn] -> TableIndex
indexOnColumns :: [IndexColumn] -> TableIndex
indexOnColumns [IndexColumn]
columns = TableIndex
tblIndex { idxColumns :: [IndexColumn]
idxColumns = [IndexColumn]
columns }

-- | Create an index on the given columns with the specified method.  No checks
-- are made that the method is appropriate for the type of the column;
-- cf. [the PostgreSQL manual](https://www.postgresql.org/docs/current/static/indexes-multicolumn.html).
indexOnColumnsWithMethod :: [IndexColumn] -> IndexMethod -> TableIndex
indexOnColumnsWithMethod :: [IndexColumn] -> IndexMethod -> TableIndex
indexOnColumnsWithMethod [IndexColumn]
columns IndexMethod
method =
    TableIndex
tblIndex { idxColumns :: [IndexColumn]
idxColumns = [IndexColumn]
columns
             , idxMethod :: IndexMethod
idxMethod = IndexMethod
method }

uniqueIndexOnColumn :: IndexColumn -> TableIndex
uniqueIndexOnColumn :: IndexColumn -> TableIndex
uniqueIndexOnColumn IndexColumn
column = TableIndex {
  idxColumns :: [IndexColumn]
idxColumns = [IndexColumn
column]
, idxInclude :: [RawSQL ()]
idxInclude = []
, idxMethod :: IndexMethod
idxMethod = IndexMethod
BTree
, idxUnique :: Bool
idxUnique = Bool
True
, idxValid :: Bool
idxValid = Bool
True
, idxWhere :: Maybe (RawSQL ())
idxWhere = forall a. Maybe a
Nothing
}

uniqueIndexOnColumns :: [IndexColumn] -> TableIndex
uniqueIndexOnColumns :: [IndexColumn] -> TableIndex
uniqueIndexOnColumns [IndexColumn]
columns = TableIndex {
  idxColumns :: [IndexColumn]
idxColumns = [IndexColumn]
columns
, idxInclude :: [RawSQL ()]
idxInclude = []
, idxMethod :: IndexMethod
idxMethod = IndexMethod
BTree
, idxUnique :: Bool
idxUnique = Bool
True
, idxValid :: Bool
idxValid = Bool
True
, idxWhere :: Maybe (RawSQL ())
idxWhere = forall a. Maybe a
Nothing
}

uniqueIndexOnColumnWithCondition :: IndexColumn -> RawSQL () -> TableIndex
uniqueIndexOnColumnWithCondition :: IndexColumn -> RawSQL () -> TableIndex
uniqueIndexOnColumnWithCondition IndexColumn
column RawSQL ()
whereC = TableIndex {
  idxColumns :: [IndexColumn]
idxColumns = [IndexColumn
column]
, idxInclude :: [RawSQL ()]
idxInclude = []
, idxMethod :: IndexMethod
idxMethod = IndexMethod
BTree
, idxUnique :: Bool
idxUnique = Bool
True
, idxValid :: Bool
idxValid = Bool
True
, idxWhere :: Maybe (RawSQL ())
idxWhere = forall a. a -> Maybe a
Just RawSQL ()
whereC
}

indexName :: RawSQL () -> TableIndex -> RawSQL ()
indexName :: RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex{Bool
[RawSQL ()]
[IndexColumn]
Maybe (RawSQL ())
IndexMethod
idxWhere :: Maybe (RawSQL ())
idxValid :: Bool
idxUnique :: Bool
idxMethod :: IndexMethod
idxInclude :: [RawSQL ()]
idxColumns :: [IndexColumn]
idxWhere :: TableIndex -> Maybe (RawSQL ())
idxValid :: TableIndex -> Bool
idxUnique :: TableIndex -> Bool
idxMethod :: TableIndex -> IndexMethod
idxInclude :: TableIndex -> [RawSQL ()]
idxColumns :: TableIndex -> [IndexColumn]
..} = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL () forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take Int
63 forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
    if Bool
idxUnique then RawSQL ()
"unique_idx__" else RawSQL ()
"idx__"
  , RawSQL ()
tname
  , RawSQL ()
"__"
  , forall m. Monoid m => m -> [m] -> m
mintercalate RawSQL ()
"__" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> RawSQL () -> RawSQL ()
asText Text -> Text
sanitize forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexColumn -> RawSQL ()
indexColumnName) [IndexColumn]
idxColumns
  , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RawSQL ()]
idxInclude
    then RawSQL ()
""
    else RawSQL ()
"$$" forall a. Semigroup a => a -> a -> a
<> forall m. Monoid m => m -> [m] -> m
mintercalate RawSQL ()
"__" (forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> RawSQL () -> RawSQL ()
asText Text -> Text
sanitize) [RawSQL ()]
idxInclude)
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawSQL ()
"" ((RawSQL ()
"__" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> RawSQL ()
hashWhere) Maybe (RawSQL ())
idxWhere
  ]
  where
    asText :: (Text -> Text) -> RawSQL () -> RawSQL ()
asText Text -> Text
f = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL () forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL
    -- See http://www.postgresql.org/docs/9.4/static/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS.
    -- Remove all unallowed characters and replace them by at most one adjacent dollar sign.
    sanitize :: Text -> Text
sanitize = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
go [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      where
        go :: Char -> ShowS
go Char
c String
acc = if Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'
          then Char
c forall a. a -> [a] -> [a]
: String
acc
          else case String
acc of
            (Char
'$':String
_) ->       String
acc
            String
_       -> Char
'$' forall a. a -> [a] -> [a]
: String
acc
    -- hash WHERE clause and add it to index name so that indexes
    -- with the same columns, but different constraints can coexist
    hashWhere :: RawSQL () -> RawSQL ()
hashWhere = (Text -> Text) -> RawSQL () -> RawSQL ()
asText forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.take Int
10
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
H.hash @_ @H.RIPEMD160 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

-- | Create an index. Warning: if the affected table is large, this will prevent
-- the table from being modified during the creation. If this is not acceptable,
-- use 'CreateIndexConcurrentlyMigration'. See
-- https://www.postgresql.org/docs/current/sql-createindex.html for more
-- information.
sqlCreateIndexMaybeDowntime :: RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexMaybeDowntime :: RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexMaybeDowntime = Bool -> RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndex_ Bool
False

-- | Create index concurrently.
sqlCreateIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexConcurrently = Bool -> RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndex_ Bool
True

sqlCreateIndex_ :: Bool -> RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndex_ :: Bool -> RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndex_ Bool
concurrently RawSQL ()
tname idx :: TableIndex
idx@TableIndex{Bool
[RawSQL ()]
[IndexColumn]
Maybe (RawSQL ())
IndexMethod
idxWhere :: Maybe (RawSQL ())
idxValid :: Bool
idxUnique :: Bool
idxMethod :: IndexMethod
idxInclude :: [RawSQL ()]
idxColumns :: [IndexColumn]
idxWhere :: TableIndex -> Maybe (RawSQL ())
idxValid :: TableIndex -> Bool
idxUnique :: TableIndex -> Bool
idxMethod :: TableIndex -> IndexMethod
idxInclude :: TableIndex -> [RawSQL ()]
idxColumns :: TableIndex -> [IndexColumn]
..} = forall a. Monoid a => [a] -> a
mconcat [
    RawSQL ()
"CREATE"
  , if Bool
idxUnique then RawSQL ()
" UNIQUE" else RawSQL ()
""
  , RawSQL ()
" INDEX "
  , if Bool
concurrently then RawSQL ()
"CONCURRENTLY " else RawSQL ()
""
  , RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx
  , RawSQL ()
" ON" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tname
  , RawSQL ()
" USING" forall m. (IsString m, Monoid m) => m -> m -> m
<+> (forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ IndexMethod
idxMethod) ()) forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"("
  , forall m. Monoid m => m -> [m] -> m
mintercalate RawSQL ()
", "
      (forall a b. (a -> b) -> [a] -> [b]
map
        (\case
          IndexColumn RawSQL ()
col Maybe (RawSQL ())
Nothing -> RawSQL ()
col
          IndexColumn RawSQL ()
col (Just RawSQL ()
opclass) -> RawSQL ()
col forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
opclass
        )
        [IndexColumn]
idxColumns)
  , RawSQL ()
")"
  , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RawSQL ()]
idxInclude
    then RawSQL ()
""
    else RawSQL ()
" INCLUDE (" forall a. Semigroup a => a -> a -> a
<> forall m. Monoid m => m -> [m] -> m
mintercalate RawSQL ()
", " [RawSQL ()]
idxInclude forall a. Semigroup a => a -> a -> a
<> RawSQL ()
")"
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawSQL ()
"" (RawSQL ()
" WHERE" forall m. (IsString m, Monoid m) => m -> m -> m
<+>) Maybe (RawSQL ())
idxWhere
  ]

-- | Drop an index. Warning: if you don't want to lock out concurrent operations
-- on the index's table, use 'DropIndexConcurrentlyMigration'. See
-- https://www.postgresql.org/docs/current/sql-dropindex.html for more
-- information.
sqlDropIndexMaybeDowntime :: RawSQL () -> TableIndex -> RawSQL ()
sqlDropIndexMaybeDowntime :: RawSQL () -> TableIndex -> RawSQL ()
sqlDropIndexMaybeDowntime RawSQL ()
tname TableIndex
idx = RawSQL ()
"DROP INDEX" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx

sqlDropIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL ()
sqlDropIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL ()
sqlDropIndexConcurrently RawSQL ()
tname TableIndex
idx = RawSQL ()
"DROP INDEX CONCURRENTLY" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx