diff --git a/Text/XML/XSD.hs b/Text/XML/XSD.hs --- a/Text/XML/XSD.hs +++ b/Text/XML/XSD.hs @@ -1,5 +1,120 @@ -module Text.XML.XSD( - module Text.XML.XSD.DateTime - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE EmptyDataDecls #-} -import Text.XML.XSD.DateTime +module Text.XML.XSD + ( E18 + , Atto + , boolean + , toBoolean + , decimal + , integer + , toSigned + , long + , int + , short + , byte + , unsignedInteger + , unsignedLong + , unsignedInt + , unsignedShort + , unsignedByte + , float + , double + , fastDouble + , module Text.XML.XSD.DateTime + ) where + +import Text.XML.XSD.DateTime + +import Control.Monad (when) +import Data.Fixed (Fixed, HasResolution(..), resolution) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Builder.Int as TBI +import qualified Data.Text.Read as TR +import Data.Word (Word8, Word16, Word32, Word64) + +data E18 + +instance HasResolution E18 where + resolution _ = 1000000000000000000 + +type Atto = Fixed E18 + +checkReader :: Either String (a, Text) -> Either String a +checkReader res = + do (val, t) <- res + when (t /= "") $ Left "leftovers" + return val + +-- checkReader (Left msg) = Left msg +-- checkReader (Right (val, t)) +-- | t /= "" = Left "leftovers" +-- | otherwise = Right val + +boolean :: Text -> Either String Bool +boolean t = + if t == "true" || t == "1" + then Right True + else if t == "false" || t == "0" + then Right False + else Left $ "invalid boolean '" ++ T.unpack t ++ "'" + +toBoolean :: Bool -> Text +toBoolean True = "true" +toBoolean False = "false" + +decimal :: Text -> Either String Atto +decimal = checkReader . TR.rational + +signed :: Integral a => Text -> Either String a +signed = checkReader . TR.signed TR.decimal + +unsigned :: Integral a => Text -> Either String a +unsigned = checkReader . TR.decimal + +toSigned :: Integral a => a -> Text +toSigned = TL.toStrict . TB.toLazyText . TBI.decimal + +integer :: Integral a => Text -> Either String a +integer = signed + +long :: Text -> Either String Int64 +long = signed + +int :: Text -> Either String Int32 +int = signed + +short :: Text -> Either String Int16 +short = signed + +byte :: Text -> Either String Int8 +byte = signed + +-- | What XSD calls @nonNegativeInteger@. +unsignedInteger :: Integral a => Text -> Either String a +unsignedInteger = unsigned + +unsignedLong :: Text -> Either String Word64 +unsignedLong = unsigned + +unsignedInt :: Text -> Either String Word32 +unsignedInt = unsigned + +unsignedShort :: Text -> Either String Word16 +unsignedShort = unsigned + +unsignedByte :: Text -> Either String Word8 +unsignedByte = unsigned + +float :: Text -> Either String Float +float = checkReader . TR.rational + +double :: Text -> Either String Double +double = checkReader . TR.rational + +fastDouble :: Text -> Either String Double +fastDouble = checkReader . TR.double diff --git a/Text/XML/XSD/DateTime.hs b/Text/XML/XSD/DateTime.hs --- a/Text/XML/XSD/DateTime.hs +++ b/Text/XML/XSD/DateTime.hs @@ -1,187 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | XSD @dateTime@ data structure -module Text.XML.XSD.DateTime( - DateTime, - dateTime', - dateTime, - toZonedTime, - fromZonedTime, - zonedTime', - zonedTime, - toUTCTime, - fromUTCTime, - utcTime', - utcTime - ) where +module Text.XML.XSD.DateTime + ( DateTime(..) + , isZoned + , isUnzoned + , dateTime' + , dateTime + , toText + , fromZonedTime + , toUTCTime + , fromUTCTime + , toLocalTime + , fromLocalTime + , utcTime' + , utcTime + , localTime' + , localTime + ) where -import Text.ParserCombinators.Parsec -import Data.Char -import Data.Ord -import Data.Maybe -import Data.Time -import Data.Function -import Control.Monad -import Control.Arrow +import Control.Applicative (pure, (<$>), (*>), (<|>)) +import Control.Monad (when) +import Data.Attoparsec.Text (Parser, char, digit) +import qualified Data.Attoparsec.Text as A +import Data.Char (isDigit, ord) +import Data.Fixed (Pico, showFixed) +import Data.Maybe (maybeToList) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Builder.Int as TBI +import qualified Data.Text.Read as TR +import Data.Time +import Data.Time.Calendar.MonthDay (monthLength) --- | XSD @dateTime@ data structure -data DateTime = DateTime Bool Int Int Int Int Int Int (Maybe String) Offset +-- | XSD @dateTime@ data structure +-- . Briefly, a @dateTime@ +-- uses the Gregorian calendar and may or may not have an associated +-- timezone. If it has a timezone, then the canonical representation +-- of that date time is in UTC. +-- +-- Note, it is not possible to establish a total order on @dateTime@ +-- since non-timezoned are considered to belong to some unspecified +-- timezone. +data DateTime = DtZoned UTCTime + | DtUnzoned LocalTime + deriving (Eq) -dateTimeConstr :: Bool - -> Int - -> Int - -> Int - -> Int - -> Int - -> Int - -> Maybe [Char] - -> Offset - -> DateTime -dateTimeConstr neg yy mm dd hhh mmm sss ssss tz = DateTime neg yy mm dd hhh mmm sss (fmap (filter isDigit) ssss) tz +-- | Internal helper that creates a date time. Note, if the given hour +-- is 24 then the minutes and seconds are assumed to be 0. +mkDateTime :: Integer -- ^ Year + -> Int -- ^ Month + -> Int -- ^ Day + -> Int -- ^ Hours + -> Int -- ^ Minutes + -> Pico -- ^ Seconds + -> Maybe Pico -- ^ Time zone offset + -> DateTime +mkDateTime y m d hh mm ss mz = + case mz of + Just z -> DtZoned $ addUTCTime (negate $ realToFrac z) uTime + Nothing -> DtUnzoned lTime + where + day = addDays (if hh == 24 then 1 else 0) (fromGregorian y m d) + tod = TimeOfDay (if hh == 24 then 0 else hh) mm ss + lTime = LocalTime day tod + uTime = UTCTime day (timeOfDayToTime tod) instance Show DateTime where - show (DateTime neg yy mm dd hhh mmm sss ssss tz) = - join [if neg then "-" else [], showy yy, "-", showi mm, "-", showi dd, "T", showi hhh, ":", showi mmm, ":", showi sss, seconds ssss,show tz] + show = T.unpack . toText instance Read DateTime where - readList s = [(maybeToList (dateTime s), [])] - -instance Eq DateTime where - (==) = (==) `on` (zonedTimeToLocalTime . toZonedTime &&& zonedTimeZone . toZonedTime) - -instance Ord DateTime where - compare = comparing (zonedTimeToLocalTime . toZonedTime &&& zonedTimeZone . toZonedTime) + readList s = [(maybeToList (dateTime . T.pack $ s), [])] -- | Parses the string into a @dateTime@ or may fail with a parse error. -dateTime' :: String -> Either ParseError DateTime -dateTime' = parse parseDateTime "DateTime parser" +dateTime' :: Text -> Either String DateTime +dateTime' = A.parseOnly (parseDateTime <|> fail "bad date time") -- | Parses the string into a @dateTime@ or may fail. -dateTime :: String -> Maybe DateTime +dateTime :: Text -> Maybe DateTime dateTime = either (const Nothing) Just . dateTime' --- | Converts a @dateTime@ to a zoned time. -toZonedTime :: DateTime -> ZonedTime -toZonedTime (DateTime neg yy mm dd hhh mmm sss ssss tz) = - ZonedTime ( - LocalTime (fromGregorian (fromIntegral ((if neg then negate else id) yy)) mm dd) ( - TimeOfDay hhh mmm (realToFrac (read (show sss ++ seconds ssss) :: Double)))) (timeZone tz) - --- | Converts a zoned time to a @dateTime@. -fromZonedTime :: ZonedTime -> DateTime -fromZonedTime (ZonedTime (LocalTime d (TimeOfDay hhh mmm sss)) (TimeZone m _ _)) = - let (yy, mm, dd) = toGregorian d - (sss1, sss2) = properFraction sss - (hz, mz) = m `quotRem` 60 - in dateTimeConstr (yy < 0) (abs (fromIntegral yy)) mm dd hhh mmm sss1 (Just (trimTail (== '0') (drop 2 $ show sss2))) (Offset False (Just (hz < 0)) (Just hz) (Just mz)) +toText :: DateTime -> Text +toText = TL.toStrict . TB.toLazyText . dtBuilder + where + dtBuilder (DtZoned uTime) = ltBuilder (utcToLocalTime utc uTime) <> "Z" + dtBuilder (DtUnzoned lTime) = ltBuilder lTime + ltBuilder (LocalTime day (TimeOfDay hh mm sss)) = + let (y, m, d) = toGregorian day + in buildInt4 y + <> "-" + <> buildUInt2 m + <> "-" + <> buildUInt2 d + <> "T" + <> buildUInt2 hh + <> ":" + <> buildUInt2 mm + <> ":" + <> buildSeconds sss --- | Parses the string in a @dateTime@ then converts to a zoned time and may fail with a parse error. -zonedTime' :: String -> Either ParseError ZonedTime -zonedTime' = fmap toZonedTime . dateTime' +buildInt4 :: Integer -> TB.Builder +buildInt4 year = + let absYear = abs year + k x = if absYear < x then ("0" <>) else id + in k 1000 . k 100 . k 10 $ TBI.decimal year --- | Parses the string in a @dateTime@ then converts to a zoned time and may fail. -zonedTime :: String -> Maybe ZonedTime -zonedTime = fmap toZonedTime . dateTime +buildUInt2 :: Int -> TB.Builder +buildUInt2 x = (if x < 10 then ("0" <>) else id) $ TBI.decimal x --- | Converts a @dateTime@ to a UTC time. -toUTCTime :: DateTime -> UTCTime -toUTCTime = uncurry localTimeToUTC . (zonedTimeZone &&& zonedTimeToLocalTime) . toZonedTime +buildSeconds :: Pico -> TB.Builder +buildSeconds secs = (if secs < 10 then ("0" <>) else id) + $ TB.fromString (showFixed True secs) --- | Converts a UTC time to a @dateTime@. -fromUTCTime :: UTCTime -> DateTime -fromUTCTime (UTCTime d t) = - let (yy, mm, dd) = toGregorian d - TimeOfDay hhh mmm sss = timeToTimeOfDay t - (sss1, sss2) = properFraction sss - in dateTimeConstr (yy < 0) (abs (fromIntegral yy)) mm dd hhh mmm sss1 (Just (trimTail (== '0') (drop 2 $ show sss2))) (Offset True Nothing Nothing Nothing) +-- | Converts a zoned time to a @dateTime@. +fromZonedTime :: ZonedTime -> DateTime +fromZonedTime = fromUTCTime . zonedTimeToUTC --- | Parses the string in a @dateTime@ then converts to a UTC time and may fail with a parse error. -utcTime' :: String -> Either ParseError UTCTime -utcTime' = fmap toUTCTime . dateTime' +-- | Whether the given @dateTime@ is timezoned. +isZoned :: DateTime -> Bool +isZoned (DtZoned _) = True +isZoned (DtUnzoned _) = False --- | Parses the string in a @dateTime@ then converts to a UTC time and may fail. -utcTime :: String -> Maybe UTCTime -utcTime = fmap toUTCTime . dateTime +-- | Whether the given @dateTime@ is non-timezoned. +isUnzoned :: DateTime -> Bool +isUnzoned = not . isZoned --- not exported +-- | Attempts to convert a @dateTime@ to a UTC time. The attempt fails +-- if the given @dateTime@ is non-timezoned. +toUTCTime :: DateTime -> Maybe UTCTime +toUTCTime (DtZoned time) = Just time +toUTCTime _ = Nothing -data Offset = Offset Bool (Maybe Bool) (Maybe Int) (Maybe Int) - deriving Eq +-- | Converts a UTC time to a timezoned @dateTime@. +fromUTCTime :: UTCTime -> DateTime +fromUTCTime = DtZoned -instance Show Offset where - show (Offset False Nothing Nothing Nothing) = [] - show (Offset True Nothing Nothing Nothing) = "Z" - show (Offset False (Just neg) (Just hh) (Just mm)) = join [if neg then "-" else "+", showi hh, ":", showi mm] - show _ = error "Offset invariant not met" +-- | Attempts to convert a @dateTime@ to a local time. The attempt +-- fails if the given @dateTime@ is timezoned. +toLocalTime :: DateTime -> Maybe LocalTime +toLocalTime (DtUnzoned time) = Just time +toLocalTime _ = Nothing -timeZone :: Offset -> TimeZone -timeZone (Offset False Nothing Nothing Nothing) = TimeZone 0 False "undetermined" -timeZone (Offset True Nothing Nothing Nothing) = TimeZone 0 False "UTC" -timeZone (Offset False (Just neg) (Just hh) (Just mm)) = TimeZone ((if neg then negate else id) hh * 60 + mm) False (join ["UTC", if neg then "-" else "+", showi hh, ":", showi mm]) -timeZone _ = error "Offset invariant not met" +-- | Converts a local time to an non-timezoned @dateTime@. +fromLocalTime :: LocalTime -> DateTime +fromLocalTime = DtUnzoned -seconds :: Maybe String -> String -seconds (Just s) = - case s of - "" -> [] - _ -> '.' : s -seconds Nothing = [] +-- | Parses the string in a @dateTime@ then converts to a UTC time and +-- may fail with a parse error. +utcTime' :: Text -> Either String UTCTime +utcTime' txt = dateTime' txt >>= maybe (Left err) Right . toUTCTime + where + err = "input time is non-timezoned" -showi :: (Show a, Num a, Ord a) => a -> String -showi n = (if n < 10 then ('0':) else id) (show n) +-- | Parses the string in a @dateTime@ then converts to a UTC time and +-- may fail. +utcTime :: Text -> Maybe UTCTime +utcTime txt = dateTime txt >>= toUTCTime -showy :: (Show a, Num a, Ord a) => a -> String -showy n = let k t = if n < t then ('0':) else id - in k 1000 (k 100 (k 10 (show n))) +-- | Parses the string in a @dateTime@ then converts to a local time +-- and may fail with a parse error. +localTime' :: Text -> Either String LocalTime +localTime' txt = dateTime' txt >>= maybe (Left err) Right . toLocalTime + where + err = "input time is non-timezoned" -parseOffset :: GenParser Char st Offset -parseOffset = let e = const (Offset False Nothing Nothing Nothing) `fmap` eof - z = const (Offset True Nothing Nothing Nothing) `fmap` char 'Z' - o = do neg <- fmap (== '-') (char '+' <|> char '-') - hh <- p2imax 14 - _ <- char ':' - mm <- p2imax (if hh == 14 then 0 else 59) - return (Offset False (Just neg) (Just hh) (Just mm)) - in e <|> z <|> o +-- | Parses the string in a @dateTime@ then converts to a local time +-- time and may fail. +localTime :: Text -> Maybe LocalTime +localTime txt = dateTime txt >>= toLocalTime -parseDateTime :: GenParser Char st DateTime -parseDateTime = do neg <- isJust `fmap` optionMaybe (char '-') - yy <- yearParser +-- | Parser of the @dateTime@ lexical representation. +parseDateTime :: Parser DateTime +parseDateTime = do yy <- yearParser _ <- char '-' mm <- p2imax 12 _ <- char '-' - dd <- p2imax ([31, if isLeapYear (fromIntegral yy) then 29 else 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] !! (mm - 1)) + dd <- p2imax (monthLength (isLeapYear $ fromIntegral yy) mm) _ <- char 'T' - hhh <- p2imax 23 + hhh <- p2imax 24 _ <- char ':' mmm <- p2imax 59 _ <- char ':' - sss <- p2imax 59 - ssss <- optionMaybe fractionalSeconds + sss <- secondParser + when (hhh == 24 && (mmm /= 0 || sss /= 0)) + $ fail "invalid time, past 24:00:00" o <- parseOffset - return (dateTimeConstr neg yy mm dd hhh mmm sss ssss o) + return $ mkDateTime yy mm dd hhh mmm sss o -yearParser :: GenParser Char st Int -yearParser = do d1 <- digit - d2 <- digit - d3 <- digit - d4 <- digit - ds <- many digit - if not (null ds) && d1 == '0' - then unexpected "leading zero in year" - else return (read ([d1, d2, d3, d4] ++ ds)) +-- | Parse timezone offset. +parseOffset :: Parser (Maybe Pico) +parseOffset = (A.endOfInput *> pure Nothing) + <|> + (char 'Z' *> pure (Just 0)) + <|> + (do sign <- (char '+' *> pure 1) <|> (char '-' *> pure (-1)) + hh <- fromIntegral <$> p2imax 14 + _ <- char ':' + mm <- fromIntegral <$> p2imax (if hh == 14 then 0 else 59) + return . Just $ sign * (hh * 3600 + mm * 60)) -fractionalSeconds :: GenParser Char st String -fractionalSeconds = do _ <- char '.' - many1 digit +yearParser :: Parser Integer +yearParser = do sign <- (char '-' *> pure (-1)) <|> pure 1 + ds <- A.takeWhile isDigit + when (T.length ds < 4) + $ fail "need at least four digits in year" + when (T.length ds > 4 && T.head ds == '0') + $ fail "leading zero in year" + let Right (absyear, _) = TR.decimal ds + when (absyear == 0) + $ fail "year zero disallowed" + return $ sign * absyear -p2imax :: Int -> GenParser Char st Int +secondParser :: Parser Pico +secondParser = do d1 <- digit + d2 <- digit + frac <- readFrac <$> (char '.' *> A.takeWhile isDigit) + <|> pure 0 + return (read [d1, d2] + frac) + where + readFrac ds = read $ '0' : '.' : T.unpack ds + +p2imax :: Int -> Parser Int p2imax m = do a <- digit b <- digit - let n = read [a, b] - if n > m then unexpected ("value " ++ show n ++ " exceeded maximum " ++ show m) else return n - --- examples = ["2009-10-10T03:10:10-05:00", "2119-10-10T03:10:10.4-15:26", "0009-10-10T03:10:10+15:00", "2009-10-10T03:10:10Z", "-2009-05-10T21:08:59-05:00", "-9399-12-31T13:10:10+15:00", "-2009-10-10T03:10:10Z"] - --- not exported - -trimTail :: (a -> Bool) -> [a] -> [a] -trimTail = (reverse .) . (. reverse) . dropWhile + let n = 10 * val a + val b + if n > m + then fail $ "value " ++ show n ++ " exceeded maximum " ++ show m + else return n + where + val c = ord c - ord '0' diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Time.Clock (UTCTime) +import Debug.Trace +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit hiding (Test) +--import Test.QuickCheck () +import qualified Data.Text as T +import Test.QuickCheck.Instances () + +import Text.XML.XSD + +import DateTime + +booleanTests :: Test +booleanTests = testGroup "Boolean" + $ parseTests ++ renderTests + where + mkParseTest (t, e) = testCase ("Parse " ++ T.unpack t) + (boolean t @?= Right e) + parseTests = map mkParseTest [ ("1", True) + , ("true", True) + , ("0", False) + , ("false", False) + ] + renderTests = + [ testCase "Render True" $ toBoolean True @?= "true" + , testCase "Render False" $ toBoolean False @?= "false" + ] + +main :: IO () +main = defaultMain [ booleanTests + , DateTime.tests + ] diff --git a/xsd.cabal b/xsd.cabal --- a/xsd.cabal +++ b/xsd.cabal @@ -1,5 +1,5 @@ Name: xsd -Version: 0.3.7 +Version: 0.4.0 License: BSD3 License-File: LICENSE Synopsis: XML Schema data structures @@ -10,17 +10,30 @@ Maintainer: Stefan Wehr Copyright: 2010 Tony Morris, 2013 Stefan Wehr build-type: Simple -cabal-version: >= 1.2 - -Flag small_base - Description: Choose the new, split-up base package. +cabal-version: >= 1.8 Library - if flag(small_base) - Build-Depends: base < 5 && >= 3, parsec, time >= 1.2.0.3 - else - Build-Depends: base < 5 && >= 3, parsec, time >= 1.2.0.3 - - GHC-Options: -Wall + Build-Depends: base < 5 && >= 4.5 + , attoparsec == 0.10.* + , text == 0.11.* + , time >= 1.2.0.3 + GHC-Options: -Wall Exposed-Modules: Text.XML.XSD Text.XML.XSD.DateTime + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: . test + ghc-options: -rtsopts + build-depends: base + , bytestring + , time + , text + , attoparsec + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , QuickCheck == 2.* + , quickcheck-instances + , HUnit