1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
{-# LANGUAGE CPP,ForeignFunctionInterface #-}
module DB.HSQL.Type.Time where
import Control.Monad(mplus)
import System.IO.Unsafe(unsafePerformIO)
import System.Time(ClockTime(..),CalendarTime(..)
,getClockTime,toCalendarTime,toUTCTime)
import Text.ParserCombinators.ReadP(ReadP,char,skipSpaces,readP_to_S)
import Text.Read.Lex(readDecP)
import Foreign(Ptr,allocaBytes,pokeByteOff)
import Foreign.C(CTime(..),CInt)
import DB.HSQL.Type
(SqlType(SqlTimeTZ,SqlTime,SqlDate,SqlDateTimeTZ,SqlDateTime
,SqlTimeStamp,SqlText))
import Database.HSQL.Types(SqlBind(..))
#include <time.h>
-- |
mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime
mkClockTime year mon mday hour min sec tz =
unsafePerformIO $ do
allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
(#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt)
(#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt)
(#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
(#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)
(#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt)
(#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)
(#poke struct tm,tm_isdst) p_tm (-1 :: CInt)
t <- mktime p_tm
let t'=
#if __GLASGOW_HASKELL__ >= 603
fromEnum t
#else
t
#endif
return (TOD (fromIntegral t' + fromIntegral (tz-currTZ)) 0)
foreign import ccall unsafe
mktime :: Ptr () -> IO CTime
-- |
{-# NOINLINE currTZ #-}
currTZ :: Int
currTZ =
ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime)) -- Hack
-- |
parseTZ :: ReadP Int
parseTZ =
(char '+' >> readDecP) `mplus` (char '-' >> fmap negate readDecP)
-- |
f_read :: ReadP a -> String -> Maybe a
f_read f s = case readP_to_S f s of
[(x,_)] -> Just x
-- |
readHMS :: ReadP (Int, Int, Int)
readHMS = do
hour <- readDecP
char ':'
minutes <- readDecP
char ':'
seconds <- readDecP
return (hour, minutes, seconds)
-- |
readYMD :: ReadP (Int, Int, Int)
readYMD = do
year <- readDecP
char '-'
month <- readDecP
char '-'
day <- readDecP
return (year, month, day)
-- |
readDateTime :: ReadP (Int, Int, Int, Int, Int, Int)
readDateTime = do
(year, month, day) <- readYMD
skipSpaces
(hour, minutes, seconds) <- readHMS
return (year, month, day, hour, minutes, seconds)
-- |
instance SqlBind ClockTime where
fromSqlValue SqlTimeTZ s = f_read getTimeTZ s
where getTimeTZ :: ReadP ClockTime
getTimeTZ = do
(hour, minutes, seconds) <- readHMS
(char '.' >> readDecP) `mplus` (return 0)
tz <- parseTZ
return (mkClockTime 1970 1 1 hour minutes seconds (tz*3600))
fromSqlValue SqlTime s = f_read getTime s
where getTime :: ReadP ClockTime
getTime = do
(hour, minutes, seconds) <- readHMS
return (mkClockTime 1970 1 1 hour minutes seconds currTZ)
fromSqlValue SqlDate s = f_read getDate s
where getDate :: ReadP ClockTime
getDate = do
(year, month, day) <- readYMD
return (mkClockTime year month day 0 0 0 currTZ)
fromSqlValue SqlDateTimeTZ s = f_read getDateTimeTZ s
where getDateTimeTZ :: ReadP ClockTime
getDateTimeTZ = do
(year, month, day, hour, minutes, seconds) <- readDateTime
char '.' >> readDecP -- ) `mplus` (return 0)
tz <- parseTZ
return (mkClockTime year month day
hour minutes seconds
(tz*3600))
-- The only driver which seems to report the type as SqlTimeStamp seems
-- to be the MySQL driver. MySQL (at least 4.1) uses the same format for
-- datetime and timestamp columns.
-- Allow SqlText to support SQLite, which reports everything as SqlText
fromSqlValue t s
| t == SqlDateTime || t == SqlTimeStamp || t == SqlText =
f_read getDateTime s
where getDateTime :: ReadP ClockTime
getDateTime = do
(year, month, day, hour, minutes, seconds) <-
readDateTime
return (mkClockTime year month day
hour minutes seconds
currTZ)
fromSqlValue _ _ = Nothing
toSqlValue ct =
'\'' : (shows (ctYear t) . score .
shows (ctMonth t) . score .
shows (ctDay t) . space .
shows (ctHour t) . colon .
shows (ctMin t) . colon .
shows (ctSec t)) "'"
where t = toUTCTime ct
score = showChar '-'
space = showChar ' '
colon = showChar ':'
|
