| Module : Database.Util Copyright : (c) 2004 Oleg Kiselyov, Alistair Bayley License : BSD-style Maintainer : oleg@pobox.com, alistair@abayley.org Stability : experimental Portability : non-portable Utility functions. Mostly used in database back-ends, and tests. > {-# LANGUAGE TypeSynonymInstances #-} > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE OverlappingInstances #-} > {-# LANGUAGE UndecidableInstances #-} > module Database.Util where > import System.Time > import Control.Monad.Trans (liftIO) > import Control.Monad.Reader > import Data.Int > import Data.List > import Data.Char > import Data.Time > import Data.Word (Word8) > import Foreign.Ptr (Ptr, castPtr) > import Foreign.Marshal.Array (peekArray) > import Numeric (showHex) > import Text.Printf MyShow requires overlapping AND undecidable instances. > class Show a => MyShow a where show_ :: a -> String > instance MyShow String where show_ s = s > instance (Show a) => MyShow a where show_ s = show s | Like 'System.IO.print', except that Strings are not escaped or quoted. > print_ :: (MonadIO m, MyShow a) => a -> m () > print_ s = liftIO (putStrLn (show_ s)) | Convenience for making UTCTimes. Assumes the time given is already UTC time i.e. there's no timezone adjustment. > mkUTCTime :: (Integral a, Real b) => a -> a -> a -> a -> a -> b -> UTCTime > mkUTCTime year month day hour minute second = > localTimeToUTC (hoursToTimeZone 0) > (LocalTime > (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) > (TimeOfDay (fromIntegral hour) (fromIntegral minute) (realToFrac second))) > mkCalTime :: Integral a => a -> a -> a -> a -> a -> a -> CalendarTime > mkCalTime year month day hour minute second = > CalendarTime > { ctYear = fromIntegral year > , ctMonth = toEnum (fromIntegral month - 1) > , ctDay = fromIntegral day > , ctHour = fromIntegral hour > , ctMin = fromIntegral minute > , ctSec = fromIntegral second > , ctPicosec = 0 > , ctWDay = Sunday > , ctYDay = -1 > , ctTZName = "UTC" > , ctTZ = 0 > , ctIsDST = False > } 20040822073512 10000000000 (10 ^ 10) * year 100000000 (10 ^ 8) * month 1000000 (10 ^ 6) * day 10000 (10^4) * hour Use quot and rem, /not/ div and mod, so that we get sensible behaviour for -ve numbers. > int64ToDateParts :: Int64 -> (Int64, Int64, Int64, Int64, Int64, Int64) > int64ToDateParts i = > let > year1 = (i `quot` 10000000000) > month = ((abs i) `rem` 10000000000) `quot` 100000000 > day = ((abs i) `rem` 100000000) `quot` 1000000 > hour = ((abs i) `rem` 1000000) `quot` 10000 > minute = ((abs i) `rem` 10000) `quot` 100 > second = ((abs i) `rem` 100) > in (year1, month, day, hour, minute, second) > datePartsToInt64 :: > (Integral a1, Integral a2, Integral a3, Integral a4, Integral a5, Integral a6) > => (a1, a2, a3, a4, a5, a6) -> Int64 > datePartsToInt64 (year, month, day, hour, minute, second) = > let > yearm :: Int64 > yearm = 10000000000 > sign :: Int64 > sign = if year < 0 then -1 else 1 > in yearm * fromIntegral year > + sign * 100000000 * fromIntegral month > + sign * 1000000 * fromIntegral day > + sign * 10000 * fromIntegral hour > + sign * 100 * fromIntegral minute > + sign * fromIntegral second > calTimeToInt64 :: CalendarTime -> Int64 > calTimeToInt64 ct = > datePartsToInt64 > ( ctYear ct, fromEnum (ctMonth ct) + 1, ctDay ct > , ctHour ct, ctMin ct, ctSec ct) > utcTimeToInt64 utc = > let > (LocalTime ltday time) = utcToLocalTime (hoursToTimeZone 0) utc > (TimeOfDay hour minute second) = time > (year, month, day) = toGregorian ltday > in datePartsToInt64 (year, month, day, hour, minute, round second) > int64ToCalTime :: Int64 -> CalendarTime > int64ToCalTime i = > let (year, month, day, hour, minute, second) = int64ToDateParts i > in mkCalTime year month day hour minute second > int64ToUTCTime :: Int64 -> UTCTime > int64ToUTCTime i = > let (year, month, day, hour, minute, second) = int64ToDateParts i > in mkUTCTime year month day hour minute second > zeroPad n i = > if i < 0 > then "-" ++ (zeroPad n (abs i)) > else take (n - length (show i)) (repeat '0') ++ show i > substr i n s = take n (drop (i-1) s) > wordsBy :: (Char -> Bool) -> String -> [String] > wordsBy pred s = skipNonMatch pred s 2 states: - skipNonMatch is for when we are looking for the start of our next word - scanWord is for when we are currently scanning a word > skipNonMatch :: (Char -> Bool) -> String -> [String] > skipNonMatch pred "" = [] > skipNonMatch pred (c:cs) > | pred c = scanWord pred cs [c] > | otherwise = skipNonMatch pred cs > scanWord pred "" acc = [reverse acc] > scanWord pred (c:cs) acc > | pred c = scanWord pred cs (c:acc) > | otherwise = [reverse acc] ++ skipNonMatch pred cs > positions :: Eq a => [a] -> [a] -> [Int] > positions [] _ = [] > positions s ins = map fst (filter (isPrefixOf s . snd) (zip [1..] (tails ins))) 1234567890123456789012345 "2006-11-24 07:51:49.228+00" "2006-11-24 07:51:49.228" "2006-11-24 07:51:49.228 BC" "2006-11-24 07:51:49+00 BC" FIXME use TZ to specify timezone? Not necessary, PostgreSQL always seems to output +00 for timezone. It's already adjusted the time, I think. Need to test this with different server timezones, though. > pgDatetimetoUTCTime :: String -> UTCTime > pgDatetimetoUTCTime s = > let (year, month, day, hour, minute, second, tz) = pgDatetimeToParts s > in mkUTCTime year month day hour minute second > isoDatetimeToUTCTime s = pgDatetimetoUTCTime s > pgDatetimetoCalTime :: String -> CalendarTime > pgDatetimetoCalTime s = > let (year, month, day, hour, minute, second, tz) = pgDatetimeToParts s > in mkCalTime year month day hour minute (round second) isInfixOf is defined in the Data.List that comes with ghc-6.6, but it is not in the libs that come with ghc-6.4.1. > myIsInfixOf srch list = or (map (isPrefixOf srch) (tails list)) Parses ISO format datetimes, and also the variation that PostgreSQL uses. > pgDatetimeToParts :: String -> (Int, Int, Int, Int, Int, Double, Int) > pgDatetimeToParts s = > let > pred c = isAlphaNum c || c == '.' > ws = wordsBy pred s > parts :: [Int]; parts = map read (take 5 ws) > secs :: Double; secs = read (ws!!5) > hasTZ = myIsInfixOf "+" s > tz :: Int; tz = if hasTZ then read (ws !! 6) else 0 > isBC = myIsInfixOf "BC" s > -- It seems only PostgreSQL uses the AD/BC suffix. > -- If BC is present then we need to do something odd with the year. > year :: Int; year = if isBC then (- ((parts !! 0) - 1)) else parts !! 0 > in (year, (parts !! 1), (parts !! 2) > , (parts !! 3), (parts !! 4), secs, tz) > utcTimeToIsoString :: (Integral a, Integral b) => > UTCTime -> String -> (a -> a) -> (b -> String) -> String > utcTimeToIsoString utc dtSep adjYear mkSuffix = > let > (LocalTime ltday time) = utcToLocalTime (hoursToTimeZone 0) utc > (TimeOfDay hour minute second) = time > (year1, month, day) = toGregorian ltday > suffix = mkSuffix (fromIntegral year1) > year = adjYear (fromIntegral year1) > s1 :: Double; s1 = realToFrac second > secs :: String; secs = printf "%09.6f" s1 > in zeroPad 4 year > ++ "-" ++ zeroPad 2 month > ++ "-" ++ zeroPad 2 day > ++ dtSep ++ zeroPad 2 hour > ++ ":" ++ zeroPad 2 minute > ++ ":" ++ secs > ++ "+00" ++ suffix > utcTimeToPGDatetime :: UTCTime -> String > utcTimeToPGDatetime utc = utcTimeToIsoString utc "T" adjYear mkSuffix > where > mkSuffix year1 = if year1 < 1 then " BC" else " AD" > adjYear year1 = if year1 < 1 then abs(year1 - 1) else year1 > utcTimeToIsoDatetime :: UTCTime -> String > utcTimeToIsoDatetime utc = utcTimeToIsoString utc "T" id (const "Z") > utcTimeToOdbcDatetime :: UTCTime -> String > utcTimeToOdbcDatetime utc = utcTimeToIsoString utc " " id (const "") | Assumes CalendarTime is also UTC i.e. ignores ctTZ component. > calTimeToPGDatetime :: CalendarTime -> String > calTimeToPGDatetime ct = > let > (year1, month, day, hour, minute, second, pico, tzsecs) = > ( ctYear ct, fromEnum (ctMonth ct) + 1, ctDay ct > , ctHour ct, ctMin ct, ctSec ct, ctPicosec ct, ctTZ ct) > suffix = if year1 < 1 then " BC" else " AD" > year = if year1 < 1 then abs(year1 - 1) else year1 > s1 :: Double; s1 = realToFrac second + ((fromIntegral pico) / (10.0 ^ 12) ) > secs :: String; secs = printf "%09.6f" s1 > in zeroPad 4 year > ++ "-" ++ zeroPad 2 month > ++ "-" ++ zeroPad 2 day > ++ " " ++ zeroPad 2 hour > ++ ":" ++ zeroPad 2 minute > ++ ":" ++ secs > ++ "+00" ++ suffix > printArrayContents :: Int -> Ptr Word8 -> IO () > printArrayContents sz ptr = do > putStrLn ("printBufferContents: sz = " ++ show sz) > l <- peekArray sz ptr > let > toHex :: Word8 -> String; > toHex i = (if i < 16 then "0" else "") ++ showHex i "" > --let h :: [String]; h = map toHex l > putStrLn (concat (intersperse " " (map toHex l))) > let > toChar :: Word8 -> String > toChar i = if 31 < i && i < 127 then [chr (fromIntegral i)] else " " > putStrLn (concat (intersperse " " (map toChar l)))