diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for iso8601-duration + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Niklas Hambüchen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Niklas Hambüchen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/iso8601-duration.cabal b/iso8601-duration.cabal new file mode 100644 --- /dev/null +++ b/iso8601-duration.cabal @@ -0,0 +1,57 @@ +-- Initial iso8601-duration.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: iso8601-duration +version: 0.1.1.0 +synopsis: Types and parser for ISO8601 durations +description: Types and parser for ISO8601 durations and intervals +homepage: https://github.com/meteogrid/iso8601-duration +license: BSD3 +license-file: LICENSE +author: Alberto Valverde (original code from Niklas Hambüchen?) +maintainer: alberto@meteogrid.com +copyright: 2016-2018 Alberto Valverde +category: Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Data.Time.ISO8601.Duration + , Data.Time.ISO8601.Interval + -- other-modules: + other-extensions: ScopedTypeVariables, OverloadedStrings + build-depends: base >= 4.7 && < 4.12 + , bytestring >= 0.10 && < 0.11 + , attoparsec >= 0.13.1 && < 0.14 + , time >= 1.8 && < 1.9 + , bytestring-lexing >= 0.5 && < 0.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -fwarn-incomplete-patterns + -fwarn-incomplete-uni-patterns + +test-suite spec + type: exitcode-stdio-1.0 + build-depends: base + , bytestring + , time + , hspec + , hspec-core >= 1.13 + , QuickCheck + , quickcheck-instances + , iso8601-duration + hs-source-dirs: test + main-is: Spec.hs + other-modules: Data.Time.ISO8601.DurationSpec + Data.Time.ISO8601.IntervalSpec + default-language: Haskell2010 + ghc-options: -Wall + -fwarn-incomplete-patterns + -fwarn-incomplete-uni-patterns + + +source-repository head + type: git + location: https://github.com/meteogrid/iso8601-duration diff --git a/src/Data/Time/ISO8601/Duration.hs b/src/Data/Time/ISO8601/Duration.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/ISO8601/Duration.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Stolen from https://gist.github.com/nh2/16c84db9d10e8869d8ae + +module Data.Time.ISO8601.Duration ( + Duration (..) + , DurDate (..) + , DurTime (..) + , DurYear (..) + , DurMonth (..) + , DurWeek (..) + , DurDay (..) + , DurHour (..) + , DurMinute (..) + , DurSecond (..) + , parseDuration + , duration + , formatDuration + , formatDurationB + , addDuration +) where + +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Monoid ((<>)) +import Data.String (IsString, fromString) +import Data.Time hiding (formatTime) + + + +newtype DurSecond = DurSecond Integer deriving (Eq, Ord, Show) +data DurMinute = DurMinute Integer (Maybe DurSecond) deriving (Eq, Ord, Show) +data DurHour = DurHour Integer (Maybe DurMinute) deriving (Eq, Ord, Show) +data DurTime = DurTimeHour DurHour + | DurTimeMinute DurMinute + | DurTimeSecond DurSecond deriving (Eq, Ord, Show) +newtype DurDay = DurDay Integer deriving (Eq, Ord, Show) +newtype DurWeek = DurWeek Integer deriving (Eq, Ord, Show) +data DurMonth = DurMonth Integer (Maybe DurDay) deriving (Eq, Ord, Show) +data DurYear = DurYear Integer (Maybe DurMonth) deriving (Eq, Ord, Show) +data DurDate = DurDateDay DurDay (Maybe DurTime) + | DurDateMonth DurMonth (Maybe DurTime) + | DurDateYear DurYear (Maybe DurTime) deriving (Eq, Ord, Show) + +data Duration = DurationDate DurDate + | DurationTime DurTime + | DurationWeek DurWeek deriving (Eq, Ord, Show) + + +durSecond :: Parser DurSecond +durMinute :: Parser DurMinute +durHour :: Parser DurHour +durTime :: Parser DurTime +durDay :: Parser DurDay +durWeek :: Parser DurWeek +durMonth :: Parser DurMonth +durYear :: Parser DurYear +durDate :: Parser DurDate +duration :: Parser Duration + +durSecond = DurSecond <$> (decimal <* char 'S') +durMinute = DurMinute <$> (decimal <* char 'M') <*> optional durSecond +durHour = DurHour <$> (decimal <* char 'H') <*> optional durMinute +durTime = char 'T' *> ((DurTimeHour <$> durHour) <|> + (DurTimeMinute <$> durMinute) <|> + (DurTimeSecond <$> durSecond)) +durDay = DurDay <$> (decimal <* char 'D') +durWeek = DurWeek <$> (decimal <* char 'W') +durMonth = DurMonth <$> (decimal <* char 'M') <*> optional durDay +durYear = DurYear <$> (decimal <* char 'Y') <*> optional durMonth +durDate = (DurDateDay <$> durDay <*> optional durTime) <|> + (DurDateMonth <$> durMonth <*> optional durTime) <|> + (DurDateYear <$> durYear <*> optional durTime) + +duration = char 'P' *> ((DurationDate <$> durDate) <|> + (DurationTime <$> durTime) <|> + (DurationWeek <$> durWeek)) + + +parseDuration :: ByteString -> Either String Duration +parseDuration = parseOnly (duration <* endOfInput) + + +formatDuration :: Duration -> ByteString +formatDuration = runBuilder . formatDurationB + +formatDurationB :: Duration -> Builder +formatDurationB dur = "P" <> case dur of + DurationDate date -> formatDate date + DurationTime time -> formatTime time + DurationWeek week -> formatWeek week + where + formatSecond (DurSecond second) = show' second <> "S" + formatMinute (DurMinute minute mbSecond) = + show' minute <> "M" <> maybe "" formatSecond mbSecond + formatHour (DurHour hour mbMinute) = + show' hour <> "H" <> maybe "" formatMinute mbMinute + formatTime time = "T" <> case time of + DurTimeSecond second -> formatSecond second + DurTimeMinute minute -> formatMinute minute + DurTimeHour hour -> formatHour hour + formatDay (DurDay day) = show' day <> "D" + formatWeek (DurWeek week) = show' week <> "W" + formatMonth (DurMonth month mbDay) = + show' month <> "M" <> maybe "" formatDay mbDay + formatYear (DurYear year mbMonth) = + show' year <> "Y" <> maybe "" formatMonth mbMonth + formatDate date = case date of + DurDateDay day mbTime -> formatDay day <> maybe "" formatTime mbTime + DurDateMonth month mbTime -> formatMonth month <> maybe "" formatTime mbTime + DurDateYear year mbTime -> formatYear year <> maybe "" formatTime mbTime + +runBuilder :: Builder -> ByteString +runBuilder = LBS.toStrict . toLazyByteString + +show' :: (Show a, IsString b) => a -> b +show' = fromString . show + + + +addDuration :: Duration -> UTCTime -> UTCTime +addDuration (DurationDate s) = addDurationDate s +addDuration (DurationTime s) = addDurationTime s +addDuration (DurationWeek s) = addDurationWeek s + +addDurationDate :: DurDate -> UTCTime -> UTCTime +addDurationDate (DurDateDay d dt) = + maybe id addDurationTime dt . addDurDay d + +addDurationDate (DurDateMonth m dt) = + maybe id addDurationTime dt . addDurMonth m + +addDurationDate (DurDateYear y dt) = + maybe id addDurationTime dt . addDurYear y + +addDurDay :: DurDay -> UTCTime -> UTCTime +addDurDay (DurDay s) (UTCTime d dt) = UTCTime (addDays s d) dt + +addDurMonth :: DurMonth -> UTCTime -> UTCTime +addDurMonth (DurMonth s m) (UTCTime d dt) = + maybe id addDurDay m $ + UTCTime (addGregorianMonthsRollOver s d) dt + +addDurYear :: DurYear -> UTCTime -> UTCTime +addDurYear (DurYear s m) (UTCTime d dt) = + maybe id addDurMonth m $ + UTCTime (addGregorianYearsRollOver s d) dt + + +addDurationTime :: DurTime -> UTCTime -> UTCTime +addDurationTime = addUTCTime . durTimeToNDT + where + durTimeToNDT (DurTimeHour s) = durHourToNDT s + durTimeToNDT (DurTimeMinute s) = durMinuteToNDT s + durTimeToNDT (DurTimeSecond s) = durSecondToNDT s + + durHourToNDT (DurHour s m) = + fromIntegral (s * 60 * 60) + maybe 0 durMinuteToNDT m + + durMinuteToNDT (DurMinute s m) = + fromIntegral (s * 60) + maybe 0 durSecondToNDT m + + durSecondToNDT (DurSecond s) = fromIntegral s + +addDurationWeek :: DurWeek -> UTCTime -> UTCTime +addDurationWeek (DurWeek w) = addDurDay (DurDay (w*7)) diff --git a/src/Data/Time/ISO8601/Interval.hs b/src/Data/Time/ISO8601/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/ISO8601/Interval.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.Time.ISO8601.Interval ( + IntervalSpec (..) +, Interval (..) +, interval +, isoTime +, parseInterval +, formatInterval +, formatIntervalB +) where + +import Data.Time.ISO8601.Duration + +import Control.Applicative +import Data.Attoparsec.ByteString (Parser) +import Data.Attoparsec.ByteString.Char8 as AP +import Data.ByteString.Lex.Integral (readDecimal) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString.Builder +import Data.Monoid ((<>)) +import Data.String (IsString(..)) +import Data.Time +import Data.Time.Calendar (fromGregorian) +import Data.Time.Calendar.WeekDate (fromWeekDateValid) + + +data IntervalSpec + = StartEnd UTCTime UTCTime + | StartDuration UTCTime Duration + | DurationEnd Duration UTCTime + | JustDuration Duration + deriving ( Eq, Show ) + +data Interval + = Interval IntervalSpec + | RecurringInterval IntervalSpec (Maybe Integer) + deriving ( Eq, Show ) + +parseInterval :: ByteString -> Either String Interval +parseInterval = parseOnly (interval <* endOfInput) + + +interval :: Parser Interval +interval = recurringInterval + <|> simpleInterval + where + recurringInterval = + flip RecurringInterval <$> (char 'R' *> optional decimal <* char '/') + <*> intervalSpec + simpleInterval = Interval <$> intervalSpec + +intervalSpec :: Parser IntervalSpec +intervalSpec = startEnd + <|> startDuration + <|> durationEnd + <|> justDuration + where + startEnd = StartEnd <$> isoTime <*> (char '/' *> isoTime) + startDuration = StartDuration <$> isoTime <*> (char '/' *> duration) + durationEnd = DurationEnd <$> duration <*> (char '/' *> isoTime) + justDuration = JustDuration <$> duration + + +isoTime :: Parser UTCTime +isoTime = do + d <- dayWeek <|> day + dt <- option 0 (oChar 'T' *> diffTime <* oChar 'Z') --FIXME: Parse tz offsets + return (UTCTime d dt) + +day :: Parser Day +day = day2 <|> day1 + where day1 = fromGregorian <$> decimalN 4 + <*> option 1 (char '-' *> intN 2) + <*> option 1 (char '-' *> intN 2) + day2 = fromGregorian <$> decimalN 4 <*> intN 2 <*> intN 2 + +dayWeek :: Parser Day +dayWeek = maybe (fail "Invalid week day") return =<< go + where + go = fromWeekDateValid + <$> decimalN 4 + <*> ("-W" *> intN 2) + <*> option 1 (char '-' *> intN 1) + +diffTime :: Parser DiffTime +diffTime = do + h <- fromIntegral <$> intN 2 + m <- fromIntegral <$> option 0 (oChar ':' *> intN 2) + s <- maybe 0 realToFrac <$> optional (oChar ':' *> scientific) + return (s + m*60 + h*3600) + +intN :: Int -> Parser Int +intN = decimalN + +decimalN :: Integral a => Int -> Parser a +decimalN n = + maybe (fail "not an int") (return . fst) =<< fmap readDecimal (AP.take n) + +oChar :: Char -> Parser (Maybe Char) +oChar = optional . char + + +formatInterval :: Interval -> ByteString +formatInterval = toStrict . toLazyByteString . formatIntervalB + +formatIntervalB :: Interval -> Builder +formatIntervalB (RecurringInterval i r) = "R" <> maybe "" bShow r <> "/" + <> formatIntervalSpec i +formatIntervalB (Interval i) = formatIntervalSpec i + +formatIntervalSpec :: IntervalSpec -> Builder +formatIntervalSpec (StartEnd s1 s2) = formatIsoTime s1 <> "/" <> formatIsoTime s2 +formatIntervalSpec (StartDuration s1 s2) = formatIsoTime s1 <> "/" <> formatDurationB s2 +formatIntervalSpec (DurationEnd s1 s2) = formatDurationB s1 <> "/" <> formatIsoTime s2 +formatIntervalSpec (JustDuration s) = formatDurationB s + +formatIsoTime :: UTCTime -> Builder +formatIsoTime = fromString . formatTime defaultTimeLocale "%FT%T%QZ" + +bShow :: Show a => a -> Builder +bShow = fromString . show diff --git a/test/Data/Time/ISO8601/DurationSpec.hs b/test/Data/Time/ISO8601/DurationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Time/ISO8601/DurationSpec.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.Time.ISO8601.DurationSpec (main, spec) where + +import Data.Time.ISO8601.Duration +import Data.Time +import qualified Data.ByteString.Char8 as BS8 +import Data.String +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + + describe "format/parse" $ do + + prop "is idempotent" $ \(dur :: Duration) -> + counterexample (BS8.unpack (formatDuration dur)) $ + parseDuration (formatDuration dur) === Right dur + + describe "works on hand picked examples" $ do + tryExample "P3Y6M4DT12H30M5S" + tryExample "P6M4D" + + describe "addDuration" $ do + itAddsDuration "P6D" (datetime 2016 11 22 13 14 0) (datetime 2016 11 28 13 14 0) + itAddsDuration "P6DT5H4M" (datetime 2016 11 22 13 14 0) (datetime 2016 11 28 18 18 0) + itAddsDuration "P6DT5H4M61S" (datetime 2016 11 22 13 14 0) (datetime 2016 11 28 18 19 1) + itAddsDuration "P8W" (datetime 2016 11 22 13 14 0) (datetime 2017 1 17 13 14 0) + +itAddsDuration :: Duration -> UTCTime -> UTCTime -> SpecWith (Arg Expectation) +itAddsDuration d t e = it msg $ d `addDuration` t `shouldBe` e where + msg = show (formatDuration d) ++ " `addDuration` " ++ show t ++ " == " ++ show e + +unsafeParseDuration :: BS8.ByteString -> Duration +unsafeParseDuration = either (const (error "unparsable")) id . parseDuration + +datetime :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime +datetime y m d h m' s = UTCTime (fromGregorian y m d) (fromIntegral (h*3600+m'*60+s)) + +instance IsString Duration where + fromString = unsafeParseDuration . fromString + +tryExample :: BS8.ByteString -> SpecWith (Arg Expectation) +tryExample str = it ("parses " ++ BS8.unpack str) $ + fmap formatDuration (parseDuration str) `shouldBe` Right str + + +instance Arbitrary DurSecond where arbitrary = DurSecond <$> (getPositive <$> arbitrary) +instance Arbitrary DurMinute where arbitrary = DurMinute <$> (getPositive <$> arbitrary) <*> arbitrary +instance Arbitrary DurHour where arbitrary = DurHour <$> (getPositive <$> arbitrary) <*> arbitrary +instance Arbitrary DurTime where arbitrary = oneof [ DurTimeHour <$> arbitrary + , DurTimeMinute <$> arbitrary + , DurTimeSecond <$> arbitrary + ] +instance Arbitrary DurDay where arbitrary = DurDay <$> (getPositive <$> arbitrary) +instance Arbitrary DurWeek where arbitrary = DurWeek <$> (getPositive <$> arbitrary) +instance Arbitrary DurMonth where arbitrary = DurMonth <$> (getPositive <$> arbitrary) <*> arbitrary +instance Arbitrary DurYear where arbitrary = DurYear <$> (getPositive <$> arbitrary) <*> arbitrary +instance Arbitrary DurDate where arbitrary = oneof [ DurDateDay <$> arbitrary <*> arbitrary + , DurDateMonth <$> arbitrary <*> arbitrary + , DurDateYear <$> arbitrary <*> arbitrary + ] +instance Arbitrary Duration where arbitrary = oneof [ DurationDate <$> arbitrary + , DurationTime <$> arbitrary + , DurationWeek <$> arbitrary + ] diff --git a/test/Data/Time/ISO8601/IntervalSpec.hs b/test/Data/Time/ISO8601/IntervalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Time/ISO8601/IntervalSpec.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.Time.ISO8601.IntervalSpec (main, spec) where + +-- For Duration Arbitrary instances +import Data.Time.ISO8601.DurationSpec () +import Data.Time.ISO8601.Interval +import Data.Time + +import qualified Data.ByteString.Char8 as BS8 +import Data.Either (isLeft) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Test.QuickCheck.Instances () + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + + prop "format/parse is idempotent" $ \(int :: Interval) -> + counterexample (BS8.unpack (formatInterval int)) $ + parseInterval (formatInterval int) === Right int + + describe "hand picked examples" $ do + parseFormatIdempotent "P3Y6M4DT12H30M5S" + parseFormatIdempotent "P6M4D" + parseShouldSatisfy "20080229/P6M4D" $ \i -> + case i of + Interval (StartDuration t _) -> t == datetime 2008 2 29 0 0 0 + _ -> False + shouldParse "R/2014-12T20/P1W" + shouldNotParse "R/201412T20/P1W" + shouldParse "R/2014/P1W" + shouldParse "R1000/2014/P1W" + shouldParse "R/2014-W01-1T19:00:00/P1W" + shouldNotParse "R/2014-W1-1T19:00:00/P1W" + shouldNotParse "R/2014-W01-8T19:00:00/P1W" + shouldNotParse "R/2014-W54-1T19:00:00/P1W" + +datetime :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime +datetime y m d h m' s = UTCTime (fromGregorian y m d) (fromIntegral (h*3600+m'*60+s)) + + +parseShouldSatisfy :: BS8.ByteString -> (Interval -> Bool) -> SpecWith (Arg Expectation) +parseShouldSatisfy str fun = it ("parses " ++ BS8.unpack str) $ + parseInterval str `shouldSatisfy` either (const False) fun + +shouldParse :: BS8.ByteString -> SpecWith (Arg Expectation) +shouldParse str = parseShouldSatisfy str (const True) + +shouldNotParse :: BS8.ByteString -> SpecWith (Arg Expectation) +shouldNotParse str = it ("does not parse " ++ BS8.unpack str) $ + parseInterval str `shouldSatisfy` isLeft + +parseFormatIdempotent :: BS8.ByteString -> SpecWith (Arg Expectation) +parseFormatIdempotent str = it ("parse/format idempotent on " ++ BS8.unpack str) $ + fmap formatInterval (parseInterval str) `shouldBe` Right str + + +instance Arbitrary Interval where + arbitrary = oneof [ Interval <$> arbitrary + , RecurringInterval <$> arbitrary <*> (fmap getPositive <$> arbitrary) + ] + +instance Arbitrary IntervalSpec where + arbitrary = oneof [ StartEnd <$> arbitrary <*> arbitrary + , StartDuration <$> arbitrary <*> arbitrary + , DurationEnd <$> arbitrary <*> arbitrary + , JustDuration <$> arbitrary + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}