SqlType.hs

{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, DefaultSignatures, DeriveGeneric #-}
-- | Types representable as columns in Selda's subset of SQL.
module Database.Selda.SqlType
  ( SqlType (..), SqlEnum (..)
  , Lit (..), UUID, UUID', RowID, ID, SqlValue (..), SqlTypeRep (..)
  , invalidRowId, isInvalidRowId, toRowId, fromRowId
  , fromId, toId, invalidId, isInvalidId, untyped
  , compLit, litType
  , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat
  , typedUuid, untypedUuid
  ) where
import Control.Applicative ((<|>))
import Control.Exception (Exception (..), throw)
import Data.ByteString (ByteString, empty)
import qualified Data.ByteString.Lazy as BSL
import Data.Int (Int32, Int64)
import Data.Maybe (fromJust)
import Data.Proxy ( Proxy(..) )
import Data.Text (Text, pack, unpack)
import qualified Data.Text.Lazy as LazyText
import Data.Time
    ( defaultTimeLocale,
      parseTimeM,
      Day(ModifiedJulianDay),
      UTCTime(UTCTime),
      ParseTime,
      TimeOfDay(TimeOfDay) )
import Data.Typeable ( Typeable )
import Data.UUID.Types (UUID, toString, fromByteString, nil)
import GHC.Generics (Generic)

-- | Format string used to represent date and time when
--   representing timestamps as text.
--   If at all possible, use 'SqlUTCTime' instead.
sqlDateTimeFormat :: String
sqlDateTimeFormat = "%F %H:%M:%S%Q%z"

-- | Format string used to represent date when
--   representing dates as text.
--   If at all possible, use 'SqlDate' instead.
sqlDateFormat :: String
sqlDateFormat = "%F"

-- | Format string used to represent time of day when
--   representing time as text.
--   If at all possible, use 'SqlTime' instead.
sqlTimeFormat :: String
sqlTimeFormat = "%H:%M:%S%Q%z"

-- | Representation of an SQL type.
data SqlTypeRep
  = TText
  | TRowID
  | TInt64
  | TInt32
  | TFloat
  | TBool
  | TDateTime
  | TDate
  | TTime
  | TBlob
  | TUUID
  | TJSON
    deriving (Show, Eq, Ord)

-- | Any datatype representable in (Selda's subset of) SQL.
class Typeable a => SqlType a where
  -- | Create a literal of this type.
  mkLit :: a -> Lit a
  default mkLit :: (Typeable a, SqlEnum a) => a -> Lit a
  mkLit = LCustom TText . LText . toText

  -- | The SQL representation for this type.
  sqlType :: Proxy a -> SqlTypeRep
  sqlType _ = litType (defaultValue :: Lit a)

  -- | Convert an SqlValue into this type.
  fromSql :: SqlValue -> a
  default fromSql :: (Typeable a, SqlEnum a) => SqlValue -> a
  fromSql = fromText . fromSql

  -- | Default value when using 'def' at this type.
  defaultValue :: Lit a
  default defaultValue :: (Typeable a, SqlEnum a) => Lit a
  defaultValue = mkLit (minBound :: a)

-- | Any type that's bounded, enumerable and has a text representation, and
--   thus representable as a Selda enumerable.
--
--   While it would be more efficient to store enumerables as integers, this
--   makes hand-rolled SQL touching the values inscrutable, and will break if
--   the user a) derives Enum and b) changes the order of their constructors.
--   Long-term, this should be implemented in PostgreSQL as a proper enum
--   anyway, which mostly renders the performance argument moot.
class (Typeable a, Bounded a, Enum a) => SqlEnum a where
  toText :: a -> Text
  fromText :: Text -> a

instance {-# OVERLAPPABLE #-}
    (Typeable a, Bounded a, Enum a, Show a, Read a) => SqlEnum a where
  toText = pack . show
  fromText = read . unpack

-- | An SQL literal.
data Lit a where
  LText     :: !Text       -> Lit Text
  LInt32    :: !Int32      -> Lit Int32
  LInt64    :: !Int64      -> Lit Int64
  LDouble   :: !Double     -> Lit Double
  LBool     :: !Bool       -> Lit Bool
  LDateTime :: !UTCTime    -> Lit UTCTime
  LDate     :: !Day        -> Lit Day
  LTime     :: !TimeOfDay  -> Lit TimeOfDay
  LJust     :: SqlType a => !(Lit a) -> Lit (Maybe a)
  LBlob     :: !ByteString -> Lit ByteString
  LNull     :: SqlType a => Lit (Maybe a)
  LCustom   :: SqlTypeRep  -> Lit a -> Lit b
  LUUID     :: !UUID       -> Lit UUID

-- | The SQL type representation for the given literal.
litType :: Lit a -> SqlTypeRep
litType (LText{})     = TText
litType (LInt32{})    = TInt32
litType (LInt64{})    = TInt64
litType (LDouble{})   = TFloat
litType (LBool{})     = TBool
litType (LDateTime{}) = TDateTime
litType (LDate{})     = TDate
litType (LTime{})     = TTime
litType (LJust x)     = litType x
litType (LBlob{})     = TBlob
litType (x@LNull)     = sqlType (proxyFor x)
  where
    proxyFor :: Lit (Maybe a) -> Proxy a
    proxyFor _ = Proxy
litType (LCustom t _) = t
litType (LUUID{})     = TUUID

instance Eq (Lit a) where
  a == b = compLit a b == EQ

instance Ord (Lit a) where
  compare = compLit

-- | Constructor tag for all literals. Used for Ord instance.
litConTag :: Lit a -> Int
litConTag (LText{})     = 0
litConTag (LInt32{})    = 2
litConTag (LInt64{})    = 3
litConTag (LDouble{})   = 4
litConTag (LBool{})     = 5
litConTag (LDateTime{}) = 6
litConTag (LDate{})     = 7
litConTag (LTime{})     = 8
litConTag (LJust{})     = 9
litConTag (LBlob{})     = 10
litConTag (LNull)       = 11
litConTag (LCustom{})   = 12
litConTag (LUUID{})     = 13

-- | Compare two literals of different type for equality.
compLit :: Lit a -> Lit b -> Ordering
compLit (LText x)     (LText x')     = x `compare` x'
compLit (LInt32 x)    (LInt32 x')    = x `compare` x'
compLit (LInt64 x)    (LInt64 x')    = x `compare` x'
compLit (LDouble x)   (LDouble x')   = x `compare` x'
compLit (LBool x)     (LBool x')     = x `compare` x'
compLit (LDateTime x) (LDateTime x') = x `compare` x'
compLit (LDate x)     (LDate x')     = x `compare` x'
compLit (LTime x)     (LTime x')     = x `compare` x'
compLit (LBlob x)     (LBlob x')     = x `compare` x'
compLit (LJust x)     (LJust x')     = x `compLit` x'
compLit (LCustom _ x) (LCustom _ x') = x `compLit` x'
compLit (LUUID x)     (LUUID x')     = x `compare` x'
compLit a             b              = litConTag a `compare` litConTag b

-- | Some value that is representable in SQL.
data SqlValue where
  SqlInt32   :: !Int32      -> SqlValue
  SqlInt64   :: !Int64      -> SqlValue
  SqlFloat   :: !Double     -> SqlValue
  SqlString  :: !Text       -> SqlValue
  SqlBool    :: !Bool       -> SqlValue
  SqlBlob    :: !ByteString -> SqlValue
  SqlUTCTime :: !UTCTime    -> SqlValue
  SqlTime    :: !TimeOfDay  -> SqlValue
  SqlDate    :: !Day        -> SqlValue
  SqlNull    :: SqlValue

instance Show SqlValue where
  show (SqlInt32 n)   = "SqlInt32 " ++ show n
  show (SqlInt64 n)   = "SqlInt64 " ++ show n
  show (SqlFloat f)   = "SqlFloat " ++ show f
  show (SqlString s)  = "SqlString " ++ show s
  show (SqlBool b)    = "SqlBool " ++ show b
  show (SqlBlob b)    = "SqlBlob " ++ show b
  show (SqlUTCTime t) = "SqlUTCTime " ++ show t
  show (SqlTime t)    = "SqlTime " ++ show t
  show (SqlDate d)    = "SqlDate " ++ show d
  show (SqlNull)      = "SqlNull"

instance Show (Lit a) where
  show (LText s)     = show s
  show (LInt32 i)    = show i
  show (LInt64 i)    = show i
  show (LDouble d)   = show d
  show (LBool b)     = show b
  show (LDateTime s) = show s
  show (LDate s)     = show s
  show (LTime s)     = show s
  show (LBlob b)     = show b
  show (LJust x)     = "Just " ++ show x
  show (LNull)       = "Nothing"
  show (LCustom _ l) = show l
  show (LUUID u)     = toString u

-- | A row identifier for some table.
--   This is the type of auto-incrementing primary keys.
newtype RowID = RowID Int64
  deriving (Eq, Ord, Typeable, Generic)
instance Show RowID where
  show (RowID n) = show n

-- | A row identifier which is guaranteed to not match any row in any table.
invalidRowId :: RowID
invalidRowId = RowID (-1)

-- | Is the given row identifier invalid? I.e. is it guaranteed to not match any
--   row in any table?
isInvalidRowId :: RowID -> Bool
isInvalidRowId (RowID n) = n < 0

-- | Create a row identifier from an integer.
--   Use with caution, preferably only when reading user input.
toRowId :: Int64 -> RowID
toRowId = RowID

-- | Inspect a row identifier.
fromRowId :: RowID -> Int64
fromRowId (RowID n) = n

-- | A typed row identifier.
--   Generic tables should use this instead of 'RowID'.
--   Use 'untyped' to erase the type of a row identifier, and @cast@ from the
--   "Database.Selda.Unsafe" module if you for some reason need to add a type
--   to a row identifier.
newtype ID a = ID {untyped :: RowID}
  deriving (Eq, Ord, Typeable, Generic)
instance Show (ID a) where
  show = show . untyped

-- | An UUID identifying a database row.
newtype UUID' a = UUID { untypedUuid :: UUID }
  deriving (Eq, Ord, Typeable, Generic)
instance Show (UUID' a) where
  show = show . untypedUuid

-- | Convert an untyped UUID to a typed one.
--   Use sparingly, preferably only during deserialization.
typedUuid :: UUID -> UUID' a
typedUuid = UUID

-- | Create a typed row identifier from an integer.
--   Use with caution, preferably only when reading user input.
toId :: Int64 -> ID a
toId = ID . toRowId

-- | Create a typed row identifier from an integer.
--   Use with caution, preferably only when reading user input.
fromId :: ID a -> Int64
fromId (ID i) = fromRowId i

-- | A typed row identifier which is guaranteed to not match any row in any
--   table.
invalidId :: ID a
invalidId = ID invalidRowId

-- | Is the given typed row identifier invalid? I.e. is it guaranteed to not
--   match any row in any table?
isInvalidId :: ID a -> Bool
isInvalidId = isInvalidRowId . untyped

fromSqlError :: String -> a
fromSqlError = throw . FromSqlError

newtype FromSqlError = FromSqlError String
instance Show FromSqlError where
  show (FromSqlError e) = "[SELDA BUG] fromSql: " ++ e
instance Exception FromSqlError

instance SqlType RowID where
  mkLit (RowID n) = LCustom TRowID (LInt64 n)
  sqlType _ = TRowID
  fromSql (SqlInt64 x) = RowID x
  fromSql v          = fromSqlError $ "RowID column with non-int value: " ++ show v
  defaultValue = mkLit invalidRowId

instance Typeable a => SqlType (ID a) where
  mkLit (ID n) = LCustom TRowID (mkLit n)
  sqlType _ = TRowID
  fromSql = ID . fromSql
  defaultValue = mkLit (ID invalidRowId)

instance SqlType Int where
  mkLit n = LCustom TInt64 (LInt64 $ fromIntegral n)
  sqlType _ = TInt64
  fromSql (SqlInt64 x) = fromIntegral x
  fromSql v            = fromSqlError $ "int column with non-int value: " ++ show v
  defaultValue = mkLit (0 :: Int)

instance SqlType Int64 where
  mkLit = LInt64
  sqlType _ = TInt64
  fromSql (SqlInt64 x) = x
  fromSql v          = fromSqlError $ "int64 column with non-int value: " ++ show v
  defaultValue = LInt64 0

instance SqlType Int32 where
  mkLit = LInt32
  sqlType _ = TInt32
  fromSql (SqlInt32 x) = x
  fromSql v          = fromSqlError $ "int32 column with non-int value: " ++ show v
  defaultValue = LInt32 0

instance SqlType Double where
  mkLit = LDouble
  sqlType _ = TFloat
  fromSql (SqlFloat x) = x
  fromSql v            = fromSqlError $ "float column with non-float value: " ++ show v
  defaultValue = LDouble 0

instance SqlType Text where
  mkLit = LText
  sqlType _ = TText
  fromSql (SqlString x) = x
  fromSql v             = fromSqlError $ "text column with non-text value: " ++ show v
  defaultValue = LText ""

instance SqlType LazyText.Text where
  mkLit = LCustom TText . LText . mconcat . LazyText.toChunks
  sqlType _ = TText
  fromSql (SqlString x) = LazyText.fromChunks [x]
  fromSql v             = fromSqlError $ "lazy text column with non-text value: " ++ show v
  defaultValue = mkLit ""

instance SqlType Bool where
  mkLit = LBool
  sqlType _ = TBool
  fromSql (SqlBool x)  = x
  fromSql (SqlInt32 0) = False
  fromSql (SqlInt32 _) = True
  fromSql (SqlInt64 0) = False
  fromSql (SqlInt64 _) = True
  fromSql v            = fromSqlError $ "bool column with non-bool value: " ++ show v
  defaultValue = LBool False

instance SqlType UTCTime where
  mkLit = LDateTime
  sqlType _ = TDateTime
  fromSql (SqlUTCTime t) = t
  fromSql (SqlString s) =
    case withWeirdTimeZone sqlDateTimeFormat (unpack s) of
      Just t -> t
      _      -> fromSqlError $ "bad datetime string: " ++ unpack s
  fromSql v = fromSqlError $ "datetime column with non-datetime value: " ++ show v
  defaultValue = LDateTime $ UTCTime (ModifiedJulianDay 40587) 0

instance SqlType Day where
  mkLit = LDate
  sqlType _ = TDate
  fromSql (SqlDate d) = d
  fromSql (SqlString s) =
    case parseTimeM True defaultTimeLocale sqlDateFormat (unpack s) of
      Just t -> t
      _      -> fromSqlError $ "bad date string: " ++ unpack s
  fromSql v = fromSqlError $ "date column with non-date value: " ++ show v
  defaultValue = LDate $ ModifiedJulianDay 40587

instance SqlType TimeOfDay where
  mkLit = LTime
  sqlType _ = TTime
  fromSql (SqlTime s) = s
  fromSql (SqlString s) =
    case withWeirdTimeZone sqlTimeFormat (unpack s) of
      Just t -> t
      _      -> fromSqlError $ "bad time string: " ++ unpack s
  fromSql v = fromSqlError $ "time column with non-time value: " ++ show v
  defaultValue = LTime $ TimeOfDay 0 0 0

-- | Both PostgreSQL and SQLite to weird things with time zones.
--   Long term solution is to use proper binary types internally for
--   time values, so this is really just an interim solution.
withWeirdTimeZone :: ParseTime t => String -> String -> Maybe t
withWeirdTimeZone fmt s =
  parseTimeM True defaultTimeLocale fmt (s++"00")
  <|> parseTimeM True defaultTimeLocale fmt s
  <|> parseTimeM True defaultTimeLocale fmt (s++"+0000")

instance SqlType ByteString where
  mkLit = LBlob
  sqlType _ = TBlob
  fromSql (SqlBlob x) = x
  fromSql v           = fromSqlError $ "blob column with non-blob value: " ++ show v
  defaultValue = LBlob empty

instance SqlType BSL.ByteString where
  mkLit = LCustom TBlob . LBlob . BSL.toStrict
  sqlType _ = TBlob
  fromSql (SqlBlob x) = BSL.fromStrict x
  fromSql v           = fromSqlError $ "blob column with non-blob value: " ++ show v
  defaultValue = LCustom TBlob (LBlob empty)

-- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID.
instance SqlType UUID where
  mkLit = LUUID
  sqlType _ = TUUID
  fromSql (SqlBlob x) = fromJust . fromByteString $ BSL.fromStrict x
  fromSql v           = fromSqlError $ "UUID column with non-blob value: " ++ show v
  defaultValue = LUUID nil

-- | @defaultValue@ for UUIDs is the all-zero RFC4122 nil UUID.
instance Typeable a => SqlType (UUID' a) where
  mkLit = LCustom TUUID . LUUID . untypedUuid
  sqlType _ = TUUID
  fromSql = typedUuid . fromSql
  defaultValue = LCustom TUUID (LUUID nil)

instance SqlType a => SqlType (Maybe a) where
  mkLit (Just x) = LJust $ mkLit x
  mkLit Nothing  = LNull
  sqlType _ = sqlType (Proxy :: Proxy a)
  fromSql (SqlNull) = Nothing
  fromSql x         = Just $ fromSql x
  defaultValue = LNull

instance SqlType Ordering