{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This will hopefully be the only module with CPP in it.
module Init (
  (@/=), (@==), (==@)
  , asIO
  , assertNotEqual
  , assertNotEmpty
  , assertEmpty
  , isTravis

  , module Database.Persist.Sql
  , persistSettings
  , MkPersistSettings (..)
  , BackendKey(..)
  , GenerateKey(..)

  , RunDb
  , Runner
   -- re-exports
  , module Database.Persist
  , module Test.Hspec
  , module Test.HUnit
  , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase
  , Int32, Int64
  , Text
  , module Control.Monad.Reader
  , module Control.Monad
  , module Control.Monad.IO.Unlift
  , BS.ByteString
  , SomeException
  , MonadFail
  , TestFn(..)
  , truncateTimeOfDay
  , truncateToMicro
  , truncateUTCTime
  , arbText
  , liftA2
  , changeBackend
  , Proxy(..)
  , UUID(..)
  , sqlSettingsUuid
  ) where

#if !MIN_VERSION_monad_logger(0,3,30)
-- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC
-- 7.10.3
import qualified Control.Monad.Fail as MonadFail
import Control.Monad.IO.Class
import Control.Monad.Logger
#endif

-- needed for backwards compatibility
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Resource.Internal

-- re-exports
import Control.Applicative (liftA2, (<|>))
import Control.Exception (SomeException)
import Control.Monad (forM_, liftM, replicateM, void, when)
import Control.Monad.Fail (MonadFail)
import Control.Monad.Reader
import Data.Char (GeneralCategory(..), generalCategory)
import Data.Fixed (Micro, Pico)
import Data.Proxy
import Data.String (IsString, fromString)
import qualified Data.Text as T
import Data.Time
import Test.Hspec
import Test.QuickCheck.Instances ()

import Data.Aeson (FromJSON, ToJSON, Value(..))
import qualified Data.Text.Encoding as TE
import Database.Persist.ImplicitIdDef (mkImplicitIdDef)
import Database.Persist.TH
       ( MkPersistSettings(..)
       , mkMigrate
       , mkPersist
       , persistLowerCase
       , persistUpperCase
       , setImplicitIdDef
       , share
       , sqlSettings
       )
import Web.Internal.HttpApiData
import Web.PathPieces

-- testing
import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=))
import Test.QuickCheck

import Control.Monad (unless, (>=>))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import qualified Data.ByteString as BS
import Data.IORef
import Data.Text (Text, unpack)
import System.Environment (getEnvironment)
import System.IO.Unsafe

import Database.Persist
import Database.Persist.Sql
import Database.Persist.TH ()

-- Data types
import Data.Int (Int32, Int64)


asIO :: IO a -> IO a
asIO :: IO a -> IO a
asIO IO a
a = IO a
a

(@/=), (@==), (==@) :: (HasCallStack, Eq a, Show a, MonadIO m) => a -> a -> m ()
infix 1 @/= --, /=@
a
actual @/= :: a -> a -> m ()
@/= a
expected = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> a -> a -> IO ()
forall a. (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()
assertNotEqual String
"" a
expected a
actual

infix 1 @==, ==@
a
actual @== :: a -> a -> m ()
@== a
expected = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ a
actual a -> a -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= a
expected
a
expected ==@ :: a -> a -> m ()
==@ a
actual = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ a
expected a -> a -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@=? a
actual

{-
expected /=@ actual = liftIO $ assertNotEqual "" expected actual
-}


assertNotEqual :: (Eq a, Show a, HasCallStack) => String -> a -> a -> Assertion
assertNotEqual :: String -> a -> a -> IO ()
assertNotEqual String
preface a
expected a
actual =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
expected) (String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure String
msg)
  where msg :: String
msg = (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
preface then String
"" else String
preface String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String
"expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n to not equal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
actual

assertEmpty :: (MonadIO m) => [a] -> m ()
assertEmpty :: [a] -> m ()
assertEmpty [a]
xs = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"" ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs)

assertNotEmpty :: (MonadIO m) => [a] -> m ()
assertNotEmpty :: [a] -> m ()
assertNotEmpty [a]
xs = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"" (Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs))

isTravis :: IO Bool
isTravis :: IO Bool
isTravis = IO Bool
isCI

isCI :: IO Bool
isCI :: IO Bool
isCI =  do
    [(String, String)]
env <- IO [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"TRAVIS" [(String, String)]
env Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"CI" [(String, String)]
env of
        Just String
"true" -> Bool
True
        Maybe String
_ -> Bool
False


persistSettings :: MkPersistSettings
persistSettings :: MkPersistSettings
persistSettings = MkPersistSettings
sqlSettings { mpsGeneric :: Bool
mpsGeneric = Bool
True }

instance Arbitrary PersistValue where
    arbitrary :: Gen PersistValue
arbitrary = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> Gen Int64 -> Gen PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Int64, Int64) -> Gen Int64
forall a. Random a => (a, a) -> Gen a
choose (Int64
0, Int64
forall a. Bounded a => a
maxBound)

instance PersistStore backend => Arbitrary (BackendKey backend) where
  arbitrary :: Gen (BackendKey backend)
arbitrary = (Either Text (BackendKey backend) -> BackendKey backend
forall p. Either Text p -> p
errorLeft (Either Text (BackendKey backend) -> BackendKey backend)
-> (PersistValue -> Either Text (BackendKey backend))
-> PersistValue
-> BackendKey backend
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text (BackendKey backend)
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue) (PersistValue -> BackendKey backend)
-> Gen PersistValue -> Gen (BackendKey backend)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Gen PersistValue
forall a. Arbitrary a => Gen a
arbitrary
    where
      errorLeft :: Either Text p -> p
errorLeft Either Text p
x = case Either Text p
x of
          Left Text
e -> String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
e
          Right p
r -> p
r

class GenerateKey backend where
    generateKey :: IO (BackendKey backend)

instance GenerateKey SqlBackend where
    generateKey :: IO (BackendKey SqlBackend)
generateKey = do
        Int64
i <- IORef Int64 -> IO Int64
forall a. IORef a -> IO a
readIORef IORef Int64
keyCounter
        IORef Int64 -> Int64 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int64
keyCounter (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1)
        BackendKey SqlBackend -> IO (BackendKey SqlBackend)
forall (m :: * -> *) a. Monad m => a -> m a
return (BackendKey SqlBackend -> IO (BackendKey SqlBackend))
-> BackendKey SqlBackend -> IO (BackendKey SqlBackend)
forall a b. (a -> b) -> a -> b
$ Int64 -> BackendKey SqlBackend
SqlBackendKey (Int64 -> BackendKey SqlBackend) -> Int64 -> BackendKey SqlBackend
forall a b. (a -> b) -> a -> b
$ Int64
i

keyCounter :: IORef Int64
keyCounter :: IORef Int64
keyCounter = IO (IORef Int64) -> IORef Int64
forall a. IO a -> a
unsafePerformIO (IO (IORef Int64) -> IORef Int64)
-> IO (IORef Int64) -> IORef Int64
forall a b. (a -> b) -> a -> b
$ Int64 -> IO (IORef Int64)
forall a. a -> IO (IORef a)
newIORef Int64
1
{-# NOINLINE keyCounter #-}

-- | A datatype that wraps a function on @entity@ that can has testable results.
--
-- Allows us to write:
--
-- @
-- foo :: entity -> entity -> [TestFn entity] -> Bool
-- foo e0 e1 = all (\(TestFn msg f) -> f e0 == f e1)
-- @
data TestFn entity where
    TestFn
        :: (Show a, Eq a)
        => String
        -> (entity -> a)
        -> TestFn entity

truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay
truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay
truncateTimeOfDay (TimeOfDay Int
h Int
m Pico
s) =
  TimeOfDay -> Gen TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeOfDay -> Gen TimeOfDay) -> TimeOfDay -> Gen TimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m (Pico -> TimeOfDay) -> Pico -> TimeOfDay
forall a b. (a -> b) -> a -> b
$ Pico -> Pico
truncateToMicro Pico
s

-- truncate less significant digits
truncateToMicro :: Pico -> Pico
truncateToMicro :: Pico -> Pico
truncateToMicro Pico
p = let
  p' :: Micro
p' = Rational -> Micro
forall a. Fractional a => Rational -> a
fromRational (Rational -> Micro) -> (Pico -> Rational) -> Pico -> Micro
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Rational
forall a. Real a => a -> Rational
toRational (Pico -> Micro) -> Pico -> Micro
forall a b. (a -> b) -> a -> b
$ Pico
p  :: Micro
  in   Rational -> Pico
forall a. Fractional a => Rational -> a
fromRational (Rational -> Pico) -> (Micro -> Rational) -> Micro -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> Rational
forall a. Real a => a -> Rational
toRational (Micro -> Pico) -> Micro -> Pico
forall a b. (a -> b) -> a -> b
$ Micro
p' :: Pico

truncateUTCTime :: UTCTime -> Gen UTCTime
truncateUTCTime :: UTCTime -> Gen UTCTime
truncateUTCTime (UTCTime Day
d DiffTime
dift) = do
  let pico :: Pico
pico = Rational -> Pico
forall a. Fractional a => Rational -> a
fromRational (Rational -> Pico) -> (DiffTime -> Rational) -> DiffTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Rational
forall a. Real a => a -> Rational
toRational (DiffTime -> Pico) -> DiffTime -> Pico
forall a b. (a -> b) -> a -> b
$ DiffTime
dift :: Pico
      picoi :: Integer
picoi= Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Rational -> Integer) -> (Pico -> Rational) -> Pico -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
1000000000000) (Rational -> Rational) -> (Pico -> Rational) -> Pico -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Rational
forall a. Real a => a -> Rational
toRational (Pico -> Integer) -> Pico -> Integer
forall a b. (a -> b) -> a -> b
$ Pico -> Pico
truncateToMicro Pico
pico :: Integer
      -- https://github.com/lpsmith/postgresql-simple/issues/123
      d' :: Day
d' = Day -> Day -> Day
forall a. Ord a => a -> a -> a
max Day
d (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
1950 Int
1 Int
1
  UTCTime -> Gen UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Gen UTCTime) -> UTCTime -> Gen UTCTime
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime Day
d' (DiffTime -> UTCTime) -> DiffTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
picosecondsToDiffTime Integer
picoi

arbText :: IsString s => Gen s
arbText :: Gen s
arbText =
     String -> s
forall a. IsString a => String -> a
fromString
  (String -> s) -> (Text -> String) -> Text -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter ((GeneralCategory -> [GeneralCategory] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [GeneralCategory]
forbidden) (GeneralCategory -> Bool)
-> (Char -> GeneralCategory) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> GeneralCategory
generalCategory)
  (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFFFF') -- only BMP
  (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0')     -- no nulls
  (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Text -> String
T.unpack
  (Text -> s) -> Gen Text -> Gen s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. Arbitrary a => Gen a
arbitrary
  where forbidden :: [GeneralCategory]
forbidden = [GeneralCategory
NotAssigned, GeneralCategory
PrivateUse]

type Runner backend m =
    ( MonadIO m, MonadUnliftIO m, MonadFail m
    , MonadThrow m, MonadBaseControl IO m
    , PersistStoreWrite backend, PersistStoreWrite (BaseBackend backend)
    , GenerateKey backend
    , HasPersistBackend backend
    , PersistUniqueWrite backend
    , PersistQueryWrite backend
    , backend ~ BaseBackend backend
    , PersistQueryRead backend
    )

type RunDb backend m = ReaderT backend m () -> IO ()

changeBackend
    :: forall backend backend' m. MonadUnliftIO m
    => (backend -> backend')
    -> RunDb backend m
    -> RunDb backend' m
changeBackend :: (backend -> backend') -> RunDb backend m -> RunDb backend' m
changeBackend backend -> backend'
f RunDb backend m
runDb =
    RunDb backend m
runDb RunDb backend m
-> (ReaderT backend' m () -> ReaderT backend m ())
-> RunDb backend' m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (backend -> m ()) -> ReaderT backend m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((backend -> m ()) -> ReaderT backend m ())
-> (ReaderT backend' m () -> backend -> m ())
-> ReaderT backend' m ()
-> ReaderT backend m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((backend' -> m ()) -> (backend -> backend') -> backend -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. backend -> backend'
f) ((backend' -> m ()) -> backend -> m ())
-> (ReaderT backend' m () -> backend' -> m ())
-> ReaderT backend' m ()
-> backend
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT backend' m () -> backend' -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

#if !MIN_VERSION_monad_logger(0,3,30)
-- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC
-- 7.10.3
instance MonadFail (LoggingT (ResourceT IO)) where
    fail = liftIO . MonadFail.fail
#endif

#if MIN_VERSION_resourcet(1,2,0)
-- This instance is necessary because LTS-9 and below are on
-- MonadBaseControl, while LTS 11 and up are on UnliftIO. We can drop this
-- instance (and related CPP) when we drop support for LTS-9 (GHC 8.0).
instance MonadBase b m => MonadBase b (ResourceT m) where
    liftBase :: b α -> ResourceT m α
liftBase = m α -> ResourceT m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> ResourceT m α) -> (b α -> m α) -> b α -> ResourceT m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
instance MonadBaseControl b m => MonadBaseControl b (ResourceT m) where
     type StM (ResourceT m) a = StM m a
     liftBaseWith :: (RunInBase (ResourceT m) b -> b a) -> ResourceT m a
liftBaseWith RunInBase (ResourceT m) b -> b a
f = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
reader' ->
         (RunInBase m b -> b a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b a) -> m a) -> (RunInBase m b -> b a) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase ->
             RunInBase (ResourceT m) b -> b a
f (RunInBase (ResourceT m) b -> b a)
-> RunInBase (ResourceT m) b -> b a
forall a b. (a -> b) -> a -> b
$ m a -> b (StM m a)
RunInBase m b
runInBase (m a -> b (StM m a))
-> (ResourceT m a -> m a) -> ResourceT m a -> b (StM m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(ResourceT IORef ReleaseMap -> m a
r) -> IORef ReleaseMap -> m a
r IORef ReleaseMap
reader')
     restoreM :: StM (ResourceT m) a -> ResourceT m a
restoreM = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (StM m a -> IORef ReleaseMap -> m a) -> StM m a -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IORef ReleaseMap -> m a
forall a b. a -> b -> a
const (m a -> IORef ReleaseMap -> m a)
-> (StM m a -> m a) -> StM m a -> IORef ReleaseMap -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM
#endif

-- * For implicit ID spec

newtype UUID = UUID { UUID -> Text
unUUID :: Text }
    deriving stock
        (Int -> UUID -> String -> String
[UUID] -> String -> String
UUID -> String
(Int -> UUID -> String -> String)
-> (UUID -> String) -> ([UUID] -> String -> String) -> Show UUID
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UUID] -> String -> String
$cshowList :: [UUID] -> String -> String
show :: UUID -> String
$cshow :: UUID -> String
showsPrec :: Int -> UUID -> String -> String
$cshowsPrec :: Int -> UUID -> String -> String
Show, UUID -> UUID -> Bool
(UUID -> UUID -> Bool) -> (UUID -> UUID -> Bool) -> Eq UUID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UUID -> UUID -> Bool
$c/= :: UUID -> UUID -> Bool
== :: UUID -> UUID -> Bool
$c== :: UUID -> UUID -> Bool
Eq, Eq UUID
Eq UUID
-> (UUID -> UUID -> Ordering)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> UUID)
-> (UUID -> UUID -> UUID)
-> Ord UUID
UUID -> UUID -> Bool
UUID -> UUID -> Ordering
UUID -> UUID -> UUID
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 :: UUID -> UUID -> UUID
$cmin :: UUID -> UUID -> UUID
max :: UUID -> UUID -> UUID
$cmax :: UUID -> UUID -> UUID
>= :: UUID -> UUID -> Bool
$c>= :: UUID -> UUID -> Bool
> :: UUID -> UUID -> Bool
$c> :: UUID -> UUID -> Bool
<= :: UUID -> UUID -> Bool
$c<= :: UUID -> UUID -> Bool
< :: UUID -> UUID -> Bool
$c< :: UUID -> UUID -> Bool
compare :: UUID -> UUID -> Ordering
$ccompare :: UUID -> UUID -> Ordering
$cp1Ord :: Eq UUID
Ord, ReadPrec [UUID]
ReadPrec UUID
Int -> ReadS UUID
ReadS [UUID]
(Int -> ReadS UUID)
-> ReadS [UUID] -> ReadPrec UUID -> ReadPrec [UUID] -> Read UUID
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UUID]
$creadListPrec :: ReadPrec [UUID]
readPrec :: ReadPrec UUID
$creadPrec :: ReadPrec UUID
readList :: ReadS [UUID]
$creadList :: ReadS [UUID]
readsPrec :: Int -> ReadS UUID
$creadsPrec :: Int -> ReadS UUID
Read)
    deriving newtype
        ([UUID] -> Encoding
[UUID] -> Value
UUID -> Encoding
UUID -> Value
(UUID -> Value)
-> (UUID -> Encoding)
-> ([UUID] -> Value)
-> ([UUID] -> Encoding)
-> ToJSON UUID
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UUID] -> Encoding
$ctoEncodingList :: [UUID] -> Encoding
toJSONList :: [UUID] -> Value
$ctoJSONList :: [UUID] -> Value
toEncoding :: UUID -> Encoding
$ctoEncoding :: UUID -> Encoding
toJSON :: UUID -> Value
$ctoJSON :: UUID -> Value
ToJSON, Value -> Parser [UUID]
Value -> Parser UUID
(Value -> Parser UUID) -> (Value -> Parser [UUID]) -> FromJSON UUID
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UUID]
$cparseJSONList :: Value -> Parser [UUID]
parseJSON :: Value -> Parser UUID
$cparseJSON :: Value -> Parser UUID
FromJSON, ByteString -> Either Text UUID
Text -> Either Text UUID
(Text -> Either Text UUID)
-> (ByteString -> Either Text UUID)
-> (Text -> Either Text UUID)
-> FromHttpApiData UUID
forall a.
(Text -> Either Text a)
-> (ByteString -> Either Text a)
-> (Text -> Either Text a)
-> FromHttpApiData a
parseQueryParam :: Text -> Either Text UUID
$cparseQueryParam :: Text -> Either Text UUID
parseHeader :: ByteString -> Either Text UUID
$cparseHeader :: ByteString -> Either Text UUID
parseUrlPiece :: Text -> Either Text UUID
$cparseUrlPiece :: Text -> Either Text UUID
FromHttpApiData, UUID -> ByteString
UUID -> Builder
UUID -> Text
(UUID -> Text)
-> (UUID -> Builder)
-> (UUID -> ByteString)
-> (UUID -> Text)
-> ToHttpApiData UUID
forall a.
(a -> Text)
-> (a -> Builder)
-> (a -> ByteString)
-> (a -> Text)
-> ToHttpApiData a
toQueryParam :: UUID -> Text
$ctoQueryParam :: UUID -> Text
toHeader :: UUID -> ByteString
$ctoHeader :: UUID -> ByteString
toEncodedUrlPiece :: UUID -> Builder
$ctoEncodedUrlPiece :: UUID -> Builder
toUrlPiece :: UUID -> Text
$ctoUrlPiece :: UUID -> Text
ToHttpApiData, Text -> Maybe UUID
UUID -> Text
(Text -> Maybe UUID) -> (UUID -> Text) -> PathPiece UUID
forall s. (Text -> Maybe s) -> (s -> Text) -> PathPiece s
toPathPiece :: UUID -> Text
$ctoPathPiece :: UUID -> Text
fromPathPiece :: Text -> Maybe UUID
$cfromPathPiece :: Text -> Maybe UUID
PathPiece)

instance PersistFieldSql UUID where
    sqlType :: Proxy UUID -> SqlType
sqlType Proxy UUID
_ = Text -> SqlType
SqlOther Text
"UUID"

instance PersistField UUID where
    toPersistValue :: UUID -> PersistValue
toPersistValue (UUID Text
txt) =
        LiteralType -> ByteString -> PersistValue
PersistLiteral_ LiteralType
Escaped (Text -> ByteString
TE.encodeUtf8 Text
txt)
    fromPersistValue :: PersistValue -> Either Text UUID
fromPersistValue PersistValue
pv =
        case PersistValue
pv of
            PersistLiteral_ LiteralType
Escaped ByteString
bs ->
                UUID -> Either Text UUID
forall a b. b -> Either a b
Right (UUID -> Either Text UUID) -> UUID -> Either Text UUID
forall a b. (a -> b) -> a -> b
$ Text -> UUID
UUID (ByteString -> Text
TE.decodeUtf8 ByteString
bs)
            PersistValue
_ ->
                Text -> Either Text UUID
forall a b. a -> Either a b
Left Text
"Nope"

sqlSettingsUuid :: Text -> MkPersistSettings
sqlSettingsUuid :: Text -> MkPersistSettings
sqlSettingsUuid Text
defExpr =
    let
        uuidDef :: ImplicitIdDef
uuidDef =
           Text -> ImplicitIdDef
forall t. (Typeable t, PersistFieldSql t) => Text -> ImplicitIdDef
mkImplicitIdDef @UUID Text
defExpr
        settings :: MkPersistSettings
settings =
            ImplicitIdDef -> MkPersistSettings -> MkPersistSettings
setImplicitIdDef ImplicitIdDef
uuidDef MkPersistSettings
sqlSettings
     in
        MkPersistSettings
settings