1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE PatternGuards #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-# LANGUAGE TypeSynonymInstances #-} 6{-# LANGUAGE UndecidableInstances #-} 7{-# LANGUAGE DataKinds #-} 8 9module Database.Persist.Sql.Class 10 ( RawSql (..) 11 , PersistFieldSql (..) 12 , EntityWithPrefix(..) 13 , unPrefix 14 ) where 15 16import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) 17import Data.Bits (bitSizeMaybe) 18import Data.ByteString (ByteString) 19import Data.Fixed 20import Data.Int 21import qualified Data.IntMap as IM 22import qualified Data.Map as M 23import Data.Maybe (fromMaybe) 24import Data.Monoid ((<>)) 25import Data.Proxy (Proxy(..)) 26import qualified Data.Set as S 27import Data.Text (Text, intercalate, pack) 28import qualified Data.Text as T 29import qualified Data.Text.Lazy as TL 30import Data.Time (UTCTime, TimeOfDay, Day) 31import qualified Data.Vector as V 32import Data.Word 33import Numeric.Natural (Natural) 34import Text.Blaze.Html (Html) 35 36import Database.Persist 37import Database.Persist.Sql.Types 38 39 40-- | Class for data types that may be retrived from a 'rawSql' 41-- query. 42class RawSql a where 43 -- | Number of columns that this data type needs and the list 44 -- of substitutions for @SELECT@ placeholders @??@. 45 rawSqlCols :: (DBName -> Text) -> a -> (Int, [Text]) 46 47 -- | A string telling the user why the column count is what 48 -- it is. 49 rawSqlColCountReason :: a -> String 50 51 -- | Transform a row of the result into the data type. 52 rawSqlProcessRow :: [PersistValue] -> Either Text a 53 54instance PersistField a => RawSql (Single a) where 55 rawSqlCols _ _ = (1, []) 56 rawSqlColCountReason _ = "one column for a 'Single' data type" 57 rawSqlProcessRow [pv] = Single <$> fromPersistValue pv 58 rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." 59 60instance 61 (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) => 62 RawSql (Key a) where 63 rawSqlCols _ key = (length $ keyToValues key, []) 64 rawSqlColCountReason key = "The primary key is composed of " 65 ++ (show $ length $ keyToValues key) 66 ++ " columns" 67 rawSqlProcessRow = keyFromValues 68 69instance 70 (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) => 71 RawSql (Entity record) where 72 rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) 73 where 74 sqlFields = map (((name <> ".") <>) . escape) 75 $ map fieldDB 76 -- Hacky for a composite key because 77 -- it selects the same field multiple times 78 $ entityKeyFields entDef ++ entityFields entDef 79 name = escape (entityDB entDef) 80 entDef = entityDef (Nothing :: Maybe record) 81 rawSqlColCountReason a = 82 case fst (rawSqlCols (error "RawSql") a) of 83 1 -> "one column for an 'Entity' data type without fields" 84 n -> show n ++ " columns for an 'Entity' data type" 85 rawSqlProcessRow row = case splitAt nKeyFields row of 86 (rowKey, rowVal) -> Entity <$> keyFromValues rowKey 87 <*> fromPersistValues rowVal 88 where 89 nKeyFields = length $ entityKeyFields entDef 90 entDef = entityDef (Nothing :: Maybe record) 91 92-- | This newtype wrapper is useful when selecting an entity out of the 93-- database and you want to provide a prefix to the table being selected. 94-- 95-- Consider this raw SQL query: 96-- 97-- > SELECT ?? 98-- > FROM my_long_table_name AS mltn 99-- > INNER JOIN other_table AS ot 100-- > ON mltn.some_col = ot.other_col 101-- > WHERE ... 102-- 103-- We don't want to refer to @my_long_table_name@ every time, so we create 104-- an alias. If we want to select it, we have to tell the raw SQL 105-- quasi-quoter that we expect the entity to be prefixed with some other 106-- name. 107-- 108-- We can give the above query a type with this, like: 109-- 110-- @ 111-- getStuff :: 'SqlPersistM' ['EntityWithPrefix' \"mltn\" MyLongTableName] 112-- getStuff = rawSql queryText [] 113-- @ 114-- 115-- The 'EntityWithPrefix' bit is a boilerplate newtype wrapper, so you can 116-- remove it with 'unPrefix', like this: 117-- 118-- @ 119-- getStuff :: 'SqlPersistM' ['Entity' MyLongTableName] 120-- getStuff = 'unPrefix' @\"mltn\" '<$>' 'rawSql' queryText [] 121-- @ 122-- 123-- The @ symbol is a "type application" and requires the @TypeApplications@ 124-- language extension. 125-- 126-- @since 2.10.5 127newtype EntityWithPrefix (prefix :: Symbol) record 128 = EntityWithPrefix { unEntityWithPrefix :: Entity record } 129 130-- | A helper function to tell GHC what the 'EntityWithPrefix' prefix 131-- should be. This allows you to use a type application to specify the 132-- prefix, instead of specifying the etype on the result. 133-- 134-- As an example, here's code that uses this: 135-- 136-- @ 137-- myQuery :: 'SqlPersistM' ['Entity' Person] 138-- myQuery = map (unPrefix @\"p\") <$> rawSql query [] 139-- where 140-- query = "SELECT ?? FROM person AS p" 141-- @ 142-- 143-- @since 2.10.5 144unPrefix :: forall prefix record. EntityWithPrefix prefix record -> Entity record 145unPrefix = unEntityWithPrefix 146 147instance 148 ( PersistEntity record 149 , KnownSymbol prefix 150 , PersistEntityBackend record ~ backend 151 , IsPersistBackend backend 152 ) 153 => RawSql (EntityWithPrefix prefix record) where 154 rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) 155 where 156 sqlFields = map (((name <> ".") <>) . escape) 157 $ map fieldDB 158 -- Hacky for a composite key because 159 -- it selects the same field multiple times 160 $ entityKeyFields entDef ++ entityFields entDef 161 name = pack $ symbolVal (Proxy :: Proxy prefix) 162 entDef = entityDef (Nothing :: Maybe record) 163 rawSqlColCountReason a = 164 case fst (rawSqlCols (error "RawSql") a) of 165 1 -> "one column for an 'Entity' data type without fields" 166 n -> show n ++ " columns for an 'Entity' data type" 167 rawSqlProcessRow row = case splitAt nKeyFields row of 168 (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey 169 <*> fromPersistValues rowVal 170 where 171 nKeyFields = length $ entityKeyFields entDef 172 entDef = entityDef (Nothing :: Maybe record) 173 174-- | @since 1.0.1 175instance RawSql a => RawSql (Maybe a) where 176 rawSqlCols e = rawSqlCols e . extractMaybe 177 rawSqlColCountReason = rawSqlColCountReason . extractMaybe 178 rawSqlProcessRow cols 179 | all isNull cols = return Nothing 180 | otherwise = 181 case rawSqlProcessRow cols of 182 Right v -> Right (Just v) 183 Left msg -> Left $ "RawSql (Maybe a): not all columns were Null " <> 184 "but the inner parser has failed. Its message " <> 185 "was \"" <> msg <> "\". Did you apply Maybe " <> 186 "to a tuple, perhaps? The main use case for " <> 187 "Maybe is to allow OUTER JOINs to be written, " <> 188 "in which case 'Maybe (Entity v)' is used." 189 where isNull PersistNull = True 190 isNull _ = False 191 192instance (RawSql a, RawSql b) => RawSql (a, b) where 193 rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x) 194 where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta ++ lstb) 195 rawSqlColCountReason x = rawSqlColCountReason (fst x) ++ ", " ++ 196 rawSqlColCountReason (snd x) 197 rawSqlProcessRow = 198 let x = getType processRow 199 getType :: (z -> Either y x) -> x 200 getType = error "RawSql.getType" 201 202 colCountFst = fst $ rawSqlCols (error "RawSql.getType2") (fst x) 203 processRow row = 204 let (rowFst, rowSnd) = splitAt colCountFst row 205 in (,) <$> rawSqlProcessRow rowFst 206 <*> rawSqlProcessRow rowSnd 207 208 in colCountFst `seq` processRow 209 -- Avoids recalculating 'colCountFst'. 210 211instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where 212 rawSqlCols e = rawSqlCols e . from3 213 rawSqlColCountReason = rawSqlColCountReason . from3 214 rawSqlProcessRow = fmap to3 . rawSqlProcessRow 215 216from3 :: (a,b,c) -> ((a,b),c) 217from3 (a,b,c) = ((a,b),c) 218 219to3 :: ((a,b),c) -> (a,b,c) 220to3 ((a,b),c) = (a,b,c) 221 222instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where 223 rawSqlCols e = rawSqlCols e . from4 224 rawSqlColCountReason = rawSqlColCountReason . from4 225 rawSqlProcessRow = fmap to4 . rawSqlProcessRow 226 227from4 :: (a,b,c,d) -> ((a,b),(c,d)) 228from4 (a,b,c,d) = ((a,b),(c,d)) 229 230to4 :: ((a,b),(c,d)) -> (a,b,c,d) 231to4 ((a,b),(c,d)) = (a,b,c,d) 232 233instance (RawSql a, RawSql b, RawSql c, 234 RawSql d, RawSql e) 235 => RawSql (a, b, c, d, e) where 236 rawSqlCols e = rawSqlCols e . from5 237 rawSqlColCountReason = rawSqlColCountReason . from5 238 rawSqlProcessRow = fmap to5 . rawSqlProcessRow 239 240from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e) 241from5 (a,b,c,d,e) = ((a,b),(c,d),e) 242 243to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) 244to5 ((a,b),(c,d),e) = (a,b,c,d,e) 245 246instance (RawSql a, RawSql b, RawSql c, 247 RawSql d, RawSql e, RawSql f) 248 => RawSql (a, b, c, d, e, f) where 249 rawSqlCols e = rawSqlCols e . from6 250 rawSqlColCountReason = rawSqlColCountReason . from6 251 rawSqlProcessRow = fmap to6 . rawSqlProcessRow 252 253from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f)) 254from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f)) 255 256to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) 257to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) 258 259instance (RawSql a, RawSql b, RawSql c, 260 RawSql d, RawSql e, RawSql f, 261 RawSql g) 262 => RawSql (a, b, c, d, e, f, g) where 263 rawSqlCols e = rawSqlCols e . from7 264 rawSqlColCountReason = rawSqlColCountReason . from7 265 rawSqlProcessRow = fmap to7 . rawSqlProcessRow 266 267from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g) 268from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g) 269 270to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) 271to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) 272 273instance (RawSql a, RawSql b, RawSql c, 274 RawSql d, RawSql e, RawSql f, 275 RawSql g, RawSql h) 276 => RawSql (a, b, c, d, e, f, g, h) where 277 rawSqlCols e = rawSqlCols e . from8 278 rawSqlColCountReason = rawSqlColCountReason . from8 279 rawSqlProcessRow = fmap to8 . rawSqlProcessRow 280 281from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h)) 282from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h)) 283 284to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) 285to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) 286 287-- | @since 2.10.2 288instance (RawSql a, RawSql b, RawSql c, 289 RawSql d, RawSql e, RawSql f, 290 RawSql g, RawSql h, RawSql i) 291 => RawSql (a, b, c, d, e, f, g, h, i) where 292 rawSqlCols e = rawSqlCols e . from9 293 rawSqlColCountReason = rawSqlColCountReason . from9 294 rawSqlProcessRow = fmap to9 . rawSqlProcessRow 295 296-- | @since 2.10.2 297from9 :: (a,b,c,d,e,f,g,h,i) -> ((a,b),(c,d),(e,f),(g,h),i) 298from9 (a,b,c,d,e,f,g,h,i) = ((a,b),(c,d),(e,f),(g,h),i) 299 300-- | @since 2.10.2 301to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i) 302to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i) 303 304-- | @since 2.10.2 305instance (RawSql a, RawSql b, RawSql c, 306 RawSql d, RawSql e, RawSql f, 307 RawSql g, RawSql h, RawSql i, 308 RawSql j) 309 => RawSql (a, b, c, d, e, f, g, h, i, j) where 310 rawSqlCols e = rawSqlCols e . from10 311 rawSqlColCountReason = rawSqlColCountReason . from10 312 rawSqlProcessRow = fmap to10 . rawSqlProcessRow 313 314-- | @since 2.10.2 315from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j)) 316from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j)) 317 318-- | @since 2.10.2 319to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j) 320to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j) 321 322-- | @since 2.10.2 323instance (RawSql a, RawSql b, RawSql c, 324 RawSql d, RawSql e, RawSql f, 325 RawSql g, RawSql h, RawSql i, 326 RawSql j, RawSql k) 327 => RawSql (a, b, c, d, e, f, g, h, i, j, k) where 328 rawSqlCols e = rawSqlCols e . from11 329 rawSqlColCountReason = rawSqlColCountReason . from11 330 rawSqlProcessRow = fmap to11 . rawSqlProcessRow 331 332-- | @since 2.10.2 333from11 :: (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b),(c,d),(e,f),(g,h),(i,j),k) 334from11 (a,b,c,d,e,f,g,h,i,j,k) = ((a,b),(c,d),(e,f),(g,h),(i,j),k) 335 336-- | @since 2.10.2 337to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) 338to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) 339 340-- | @since 2.10.2 341instance (RawSql a, RawSql b, RawSql c, 342 RawSql d, RawSql e, RawSql f, 343 RawSql g, RawSql h, RawSql i, 344 RawSql j, RawSql k, RawSql l) 345 => RawSql (a, b, c, d, e, f, g, h, i, j, k, l) where 346 rawSqlCols e = rawSqlCols e . from12 347 rawSqlColCountReason = rawSqlColCountReason . from12 348 rawSqlProcessRow = fmap to12 . rawSqlProcessRow 349 350-- | @since 2.10.2 351from12 :: (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) 352from12 (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) 353 354-- | @since 2.10.2 355to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) 356to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) 357 358extractMaybe :: Maybe a -> a 359extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe") 360 361-- | Tells Persistent what database column type should be used to store a Haskell type. 362-- 363-- ==== __Examples__ 364-- 365-- ===== Simple Boolean Alternative 366-- 367-- @ 368-- data Switch = On | Off 369-- deriving (Show, Eq) 370-- 371-- instance 'PersistField' Switch where 372-- 'toPersistValue' s = case s of 373-- On -> 'PersistBool' True 374-- Off -> 'PersistBool' False 375-- 'fromPersistValue' ('PersistBool' b) = if b then 'Right' On else 'Right' Off 376-- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a Switch: expected PersistBool, received: " <> T.pack (show x) 377-- 378-- instance 'PersistFieldSql' Switch where 379-- 'sqlType' _ = 'SqlBool' 380-- @ 381-- 382-- ===== Non-Standard Database Types 383-- 384-- If your database supports non-standard types, such as Postgres' @uuid@, you can use 'SqlOther' to use them: 385-- 386-- @ 387-- import qualified Data.UUID as UUID 388-- instance 'PersistField' UUID where 389-- 'toPersistValue' = 'PersistDbSpecific' . toASCIIBytes 390-- 'fromPersistValue' ('PersistDbSpecific' uuid) = 391-- case fromASCIIBytes uuid of 392-- 'Nothing' -> 'Left' $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid) 393-- 'Just' uuid' -> 'Right' uuid' 394-- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistDbSpecific, received: "-- > <> T.pack (show x) 395-- 396-- instance 'PersistFieldSql' UUID where 397-- 'sqlType' _ = 'SqlOther' "uuid" 398-- @ 399-- 400-- ===== User Created Database Types 401-- 402-- Similarly, some databases support creating custom types, e.g. Postgres' <https://www.postgresql.org/docs/current/static/sql-createdomain.html DOMAIN> and <https://www.postgresql.org/docs/current/static/datatype-enum.html ENUM> features. You can use 'SqlOther' to specify a custom type: 403-- 404-- > CREATE DOMAIN ssn AS text 405-- > CHECK ( value ~ '^[0-9]{9}$'); 406-- 407-- @ 408-- instance 'PersistFieldSQL' SSN where 409-- 'sqlType' _ = 'SqlOther' "ssn" 410-- @ 411-- 412-- > CREATE TYPE rainbow_color AS ENUM ('red', 'orange', 'yellow', 'green', 'blue', 'indigo', 'violet'); 413-- 414-- @ 415-- instance 'PersistFieldSQL' RainbowColor where 416-- 'sqlType' _ = 'SqlOther' "rainbow_color" 417-- @ 418class PersistField a => PersistFieldSql a where 419 sqlType :: Proxy a -> SqlType 420 421#ifndef NO_OVERLAP 422instance {-# OVERLAPPING #-} PersistFieldSql [Char] where 423 sqlType _ = SqlString 424#endif 425 426instance PersistFieldSql ByteString where 427 sqlType _ = SqlBlob 428instance PersistFieldSql T.Text where 429 sqlType _ = SqlString 430instance PersistFieldSql TL.Text where 431 sqlType _ = SqlString 432instance PersistFieldSql Html where 433 sqlType _ = SqlString 434instance PersistFieldSql Int where 435 sqlType _ 436 | Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32 437 | otherwise = SqlInt64 438instance PersistFieldSql Int8 where 439 sqlType _ = SqlInt32 440instance PersistFieldSql Int16 where 441 sqlType _ = SqlInt32 442instance PersistFieldSql Int32 where 443 sqlType _ = SqlInt32 444instance PersistFieldSql Int64 where 445 sqlType _ = SqlInt64 446instance PersistFieldSql Word where 447 sqlType _ = SqlInt64 448instance PersistFieldSql Word8 where 449 sqlType _ = SqlInt32 450instance PersistFieldSql Word16 where 451 sqlType _ = SqlInt32 452instance PersistFieldSql Word32 where 453 sqlType _ = SqlInt64 454instance PersistFieldSql Word64 where 455 sqlType _ = SqlInt64 456instance PersistFieldSql Double where 457 sqlType _ = SqlReal 458instance PersistFieldSql Bool where 459 sqlType _ = SqlBool 460instance PersistFieldSql Day where 461 sqlType _ = SqlDay 462instance PersistFieldSql TimeOfDay where 463 sqlType _ = SqlTime 464instance PersistFieldSql UTCTime where 465 sqlType _ = SqlDayTime 466instance {-# OVERLAPPABLE #-} PersistFieldSql a => PersistFieldSql [a] where 467 sqlType _ = SqlString 468instance PersistFieldSql a => PersistFieldSql (V.Vector a) where 469 sqlType _ = SqlString 470instance (Ord a, PersistFieldSql a) => PersistFieldSql (S.Set a) where 471 sqlType _ = SqlString 472instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (a,b) where 473 sqlType _ = SqlString 474instance PersistFieldSql v => PersistFieldSql (IM.IntMap v) where 475 sqlType _ = SqlString 476instance PersistFieldSql v => PersistFieldSql (M.Map T.Text v) where 477 sqlType _ = SqlString 478instance PersistFieldSql PersistValue where 479 sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64 480instance PersistFieldSql Checkmark where 481 sqlType _ = SqlBool 482instance (HasResolution a) => PersistFieldSql (Fixed a) where 483 sqlType a = 484 SqlNumeric long prec 485 where 486 prec = round $ (log $ fromIntegral $ resolution n) / (log 10 :: Double) -- FIXME: May lead to problems with big numbers 487 long = prec + 10 -- FIXME: Is this enough ? 488 n = 0 489 _mn = return n `asTypeOf` a 490instance PersistFieldSql Rational where 491 sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC 492 493instance PersistFieldSql Natural where 494 sqlType _ = SqlInt64 495 496-- An embedded Entity 497instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where 498 sqlType _ = SqlString 499