module Database.MySQL.Base.Types
(
Type(..)
, Seconds
, Protocol(..)
, Option(..)
, Field(..)
, FieldFlag
, FieldFlags
, MYSQL
, MYSQL_RES
, MYSQL_ROW
, MYSQL_ROWS
, MYSQL_ROW_OFFSET
, MyBool
, hasAllFlags
, flagNotNull
, flagPrimaryKey
, flagUniqueKey
, flagMultipleKey
, flagUnsigned
, flagZeroFill
, flagBinary
, flagAutoIncrement
, flagNumeric
, flagNoDefaultValue
, toConnectFlag
) where
import Control.Applicative ((<$>), (<*>), pure)
import Data.Bits ((.|.), (.&.))
import Data.ByteString hiding (intercalate)
import Data.ByteString.Internal (create, memcpy)
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Data.Monoid (Monoid(..))
import Data.Typeable (Typeable)
import Data.Word (Word, Word8)
import Foreign.C.Types (CChar, CInt, CUInt, CULong)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..), peekByteOff)
import qualified Data.IntMap as IntMap
data MYSQL
data MYSQL_RES
data MYSQL_ROWS
type MYSQL_ROW = Ptr (Ptr CChar)
type MYSQL_ROW_OFFSET = Ptr MYSQL_ROWS
type MyBool = CChar
data Type = Decimal
| Tiny
| Short
| Long
| Float
| Double
| Null
| Timestamp
| LongLong
| Int24
| Date
| Time
| DateTime
| Year
| NewDate
| VarChar
| Bit
| NewDecimal
| Enum
| Set
| TinyBlob
| MediumBlob
| LongBlob
| Blob
| VarString
| String
| Geometry
deriving (Enum, Eq, Show, Typeable)
toType :: CInt -> Type
toType v = IntMap.findWithDefault oops (fromIntegral v) typeMap
where
oops = error $ "Database.MySQL: unknown field type " ++ show v
typeMap = IntMap.fromList [
((0), Decimal),
((1), Tiny),
((2), Short),
((3), Long),
((4), Float),
((5), Double),
((6), Null),
((7), Timestamp),
((8), LongLong),
((10), Date),
((11), Time),
((12), DateTime),
((13), Year),
((14), NewDate),
((15), VarChar),
((16), Bit),
((246), NewDecimal),
((247), Enum),
((248), Set),
((249), TinyBlob),
((250), MediumBlob),
((251), LongBlob),
((252), Blob),
((253), VarString),
((254), String),
((255), Geometry)
]
data Field = Field {
fieldName :: ByteString
, fieldOrigName :: ByteString
, fieldTable :: ByteString
, fieldOrigTable :: ByteString
, fieldDB :: ByteString
, fieldCatalog :: ByteString
, fieldDefault :: Maybe ByteString
, fieldLength :: Word
, fieldMaxLength :: Word
, fieldFlags :: FieldFlags
, fieldDecimals :: Word
, fieldCharSet :: Word
, fieldType :: Type
} deriving (Eq, Show, Typeable)
newtype FieldFlags = FieldFlags CUInt
deriving (Eq, Typeable)
instance Show FieldFlags where
show f = '[' : z ++ "]"
where z = intercalate "," . catMaybes $ [
flagNotNull ??? "flagNotNull"
, flagPrimaryKey ??? "flagPrimaryKey"
, flagUniqueKey ??? "flagUniqueKey"
, flagMultipleKey ??? "flagMultipleKey"
, flagUnsigned ??? "flagUnsigned"
, flagZeroFill ??? "flagZeroFill"
, flagBinary ??? "flagBinary"
, flagAutoIncrement ??? "flagAutoIncrement"
, flagNumeric ??? "flagNumeric"
, flagNoDefaultValue ??? "flagNoDefaultValue"
]
flag ??? name | f `hasAllFlags` flag = Just name
| otherwise = Nothing
type FieldFlag = FieldFlags
instance Monoid FieldFlags where
mempty = FieldFlags 0
mappend (FieldFlags a) (FieldFlags b) = FieldFlags (a .|. b)
flagNotNull, flagPrimaryKey, flagUniqueKey, flagMultipleKey :: FieldFlag
flagNotNull = FieldFlags 1
flagPrimaryKey = FieldFlags 2
flagUniqueKey = FieldFlags 4
flagMultipleKey = FieldFlags 8
flagUnsigned, flagZeroFill, flagBinary, flagAutoIncrement :: FieldFlag
flagUnsigned = FieldFlags 32
flagZeroFill = FieldFlags 64
flagBinary = FieldFlags 128
flagAutoIncrement = FieldFlags 512
flagNumeric, flagNoDefaultValue :: FieldFlag
flagNumeric = FieldFlags 32768
flagNoDefaultValue = FieldFlags 4096
hasAllFlags :: FieldFlags -> FieldFlags -> Bool
FieldFlags a `hasAllFlags` FieldFlags b = a .&. b == b
peekField :: Ptr Field -> IO Field
peekField ptr = do
flags <- FieldFlags <$> ((\hsc_ptr -> peekByteOff hsc_ptr 64)) ptr
Field
<$> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 0))) (((\hsc_ptr -> peekByteOff hsc_ptr 36)))
<*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 4))) (((\hsc_ptr -> peekByteOff hsc_ptr 40)))
<*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 8))) (((\hsc_ptr -> peekByteOff hsc_ptr 44)))
<*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 12))) (((\hsc_ptr -> peekByteOff hsc_ptr 48)))
<*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 16))) (((\hsc_ptr -> peekByteOff hsc_ptr 52)))
<*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 20))) (((\hsc_ptr -> peekByteOff hsc_ptr 56)))
<*> (if flags `hasAllFlags` flagNoDefaultValue
then pure Nothing
else Just <$> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 24))) (((\hsc_ptr -> peekByteOff hsc_ptr 60))))
<*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 28)) ptr)
<*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 32)) ptr)
<*> pure flags
<*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 68)) ptr)
<*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 72)) ptr)
<*> (toType <$> ((\hsc_ptr -> peekByteOff hsc_ptr 76)) ptr)
where
uint = fromIntegral :: CUInt -> Word
peekS :: (Ptr Field -> IO (Ptr Word8)) -> (Ptr Field -> IO CUInt)
-> IO ByteString
peekS peekPtr peekLen = do
p <- peekPtr ptr
l <- peekLen ptr
create (fromIntegral l) $ \d -> memcpy d p (fromIntegral l)
instance Storable Field where
sizeOf _ = (84)
alignment _ = alignment (undefined :: Ptr CChar)
peek = peekField
type Seconds = Word
data Protocol = TCP
| Socket
| Pipe
| Memory
deriving (Eq, Read, Show, Enum, Typeable)
data Option =
ConnectTimeout Seconds
| Compress
| NamedPipe
| InitCommand ByteString
| ReadDefaultFile FilePath
| ReadDefaultGroup ByteString
| CharsetDir FilePath
| CharsetName String
| LocalInFile Bool
| Protocol Protocol
| SharedMemoryBaseName ByteString
| ReadTimeout Seconds
| WriteTimeout Seconds
| UseRemoteConnection
| UseEmbeddedConnection
| GuessConnection
| ClientIP ByteString
| SecureAuth Bool
| ReportDataTruncation Bool
| Reconnect Bool
| SSLVerifyServerCert Bool
| FoundRows
| IgnoreSIGPIPE
| IgnoreSpace
| Interactive
| LocalFiles
| MultiResults
| MultiStatements
| NoSchema
deriving (Eq, Read, Show, Typeable)
toConnectFlag :: Option -> CULong
toConnectFlag Compress = 32
toConnectFlag FoundRows = 2
toConnectFlag IgnoreSIGPIPE = 4096
toConnectFlag IgnoreSpace = 256
toConnectFlag Interactive = 1024
toConnectFlag LocalFiles = 128
toConnectFlag MultiResults = 131072
toConnectFlag MultiStatements = 65536
toConnectFlag NoSchema = 16
toConnectFlag _ = 0