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