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),
               ((9), Int24),
               ((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 100)) ptr
  Field
   <$> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 0))) (((\hsc_ptr -> peekByteOff hsc_ptr 72)))
   <*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 8))) (((\hsc_ptr -> peekByteOff hsc_ptr 76)))
   <*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 16))) (((\hsc_ptr -> peekByteOff hsc_ptr 80)))
   <*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 24))) (((\hsc_ptr -> peekByteOff hsc_ptr 84)))
   <*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 32))) (((\hsc_ptr -> peekByteOff hsc_ptr 88)))
   <*> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 40))) (((\hsc_ptr -> peekByteOff hsc_ptr 92)))
   <*> (if flags `hasAllFlags` flagNoDefaultValue
       then pure Nothing
       else Just <$> peekS (((\hsc_ptr -> peekByteOff hsc_ptr 48))) (((\hsc_ptr -> peekByteOff hsc_ptr 96))))
   <*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 56)) ptr)
   <*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 64)) ptr)
   <*> pure flags
   <*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 104)) ptr)
   <*> (uint <$> ((\hsc_ptr -> peekByteOff hsc_ptr 108)) ptr)
   <*> (toType <$> ((\hsc_ptr -> peekByteOff hsc_ptr 112)) 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 _    = (128)
    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