iCalendar-0.4.0.3/0000755000000000000000000000000012540267567011742 5ustar0000000000000000iCalendar-0.4.0.3/LICENSE0000644000000000000000000000275612540267567012761 0ustar0000000000000000Copyright (c) 2012, Tingtun AS 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 Tingtun AS 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. iCalendar-0.4.0.3/Setup.hs0000644000000000000000000000005612540267567013377 0ustar0000000000000000import Distribution.Simple main = defaultMain iCalendar-0.4.0.3/iCalendar.cabal0000644000000000000000000000350512540267567014613 0ustar0000000000000000name: iCalendar version: 0.4.0.3 synopsis: iCalendar data types, parser, and printer. description: Data definitions, parsing and printing of the iCalendar format (RFC5545). homepage: http://github.com/chrra/iCalendar bug-reports: http://github.com/chrra/iCalendar/issues license: BSD3 license-file: LICENSE author: Christian Rødli Amble maintainer: cra@cra.no copyright: (c) Tingtun stability: experimental category: Text build-type: Simple tested-with: GHC==7.6.1 cabal-version: >=1.8 source-repository head type: git location: git://github.com/chrra/iCalendar.git flag network-uri description: Get Network.URI from the network-uri package default: True library exposed-modules: Text.ICalendar.Types , Text.ICalendar.Parser , Text.ICalendar.Printer , Text.ICalendar other-modules: Text.ICalendar.Parser.Common , Text.ICalendar.Parser.Components , Text.ICalendar.Parser.Content , Text.ICalendar.Parser.Parameters , Text.ICalendar.Parser.Properties , Paths_iCalendar if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 && < 2.7 else build-depends: network >= 2.4 && < 2.6 build-depends: base >=4.5 && <5, time >=1.5, data-default >=0.3 , case-insensitive >=0.4 , bytestring >=0.10 && < 0.11, parsec >=3.1.0 , text, containers >= 0.5 && < 0.6, mime >=0.4.0.2 , mtl >=2.1.0, old-locale, base64-bytestring ==1.0.* ghc-options: -Wall iCalendar-0.4.0.3/Text/0000755000000000000000000000000012540267567012666 5ustar0000000000000000iCalendar-0.4.0.3/Text/ICalendar.hs0000644000000000000000000000034312540267567015044 0ustar0000000000000000module Text.ICalendar ( module Text.ICalendar.Parser , module Text.ICalendar.Printer , module Text.ICalendar.Types ) where import Text.ICalendar.Parser import Text.ICalendar.Printer import Text.ICalendar.Types iCalendar-0.4.0.3/Text/ICalendar/0000755000000000000000000000000012540267567014510 5ustar0000000000000000iCalendar-0.4.0.3/Text/ICalendar/Types.hs0000644000000000000000000006334612540267567016164 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -- | ICalendar types, based on RFC5545. module Text.ICalendar.Types ( module Text.ICalendar.Types ) where import Codec.MIME.Type (MIMEType) import Data.ByteString.Lazy.Char8 (ByteString) import Data.CaseInsensitive (CI) import Data.Default import Data.Map (Map) import qualified Data.Map as M import Data.Monoid import Data.Set (Set) import Data.Text.Lazy (Text, pack) import Data.Time import Data.Typeable (Typeable) import Data.Version (Version (..), showVersion) import Network.URI (URI) import Paths_iCalendar (version) -- | Language. newtype Language = Language (CI Text) -- TODO: RFC5646 types and parser. deriving (Eq, Show, Ord, Typeable) type CalAddress = URI -- | One other parameter, either x-param or iana-param. data OtherParam = OtherParam (CI Text) [Text] deriving (Show, Eq, Ord, Typeable) -- | Other parameters, either x-param or other iana-param. data OtherParams = OtherParams (Set OtherParam) deriving (Show, Eq, Ord, Typeable) instance Default OtherParams where def = OtherParams def -- | VCalendar component. 3.4. data VCalendar = VCalendar { vcProdId :: ProdId , vcVersion :: ICalVersion , vcScale :: Scale , vcMethod :: Maybe Method , vcOther :: Set OtherProperty , vcTimeZones :: Map Text VTimeZone -- ^ Map TZID-value VTimeZone , vcEvents :: Map (Text, Maybe (Either Date DateTime)) VEvent -- ^ Map (UID-value, Maybe RecurrenceID-value) VEvent , vcTodos :: Map (Text, Maybe (Either Date DateTime)) VTodo -- ^ Map (UID-value, Maybe RecurrenceID-value) VTodo , vcJournals :: Map (Text, Maybe (Either Date DateTime)) VJournal -- ^ Map (UID-value, Maybe RecurrenceID-value) VJournal , vcFreeBusys :: Map Text VFreeBusy -- ^ Map UID-value VFreeBusy , vcOtherComps :: Set VOther } deriving (Show, Eq, Ord, Typeable) instance Default VCalendar where def = VCalendar (ProdId ("-//haskell.org/NONSGML iCalendar-" <> pack (showVersion version) <> "//EN") def) (MaxICalVersion (Version [2,0] []) def) def Nothing def def def def def def def -- | 'vcMethod' is ignored at the moment. -- -- Picks the left in most cases. -- -- On UID/RecurrenceId/TZID clash, picks the 'VEvent's, 'VTodo's and -- 'VJournal's with the highest ('Sequence', 'DTStamp'), the 'VTimeZone's -- with the highest 'LastModified', and 'VFreeBusy' with the highest 'DTStamp'. -- -- If the Sequence, DTStamp or LastModified is the same, picks the left. instance Monoid VCalendar where mempty = def mappend a b = VCalendar { vcProdId = vcProdId a , vcVersion = vcVersion a , vcScale = vcScale a , vcMethod = vcMethod a , vcOther = vcOther a <> vcOther b , vcTimeZones = merge tz (vcTimeZones a) (vcTimeZones b) , vcEvents = merge ev (vcEvents a) (vcEvents b) , vcTodos = merge td (vcTodos a) (vcTodos b) , vcJournals = merge jo (vcJournals a) (vcJournals b) , vcFreeBusys = merge fb (vcFreeBusys a) (vcFreeBusys b) , vcOtherComps = vcOtherComps a <> vcOtherComps b } where merge f = M.mergeWithKey (((Just .) .) . const f) id id tz c d = if vtzLastMod c >= vtzLastMod d then c else d ev c d = if (veSeq c, veDTStamp c) >= (veSeq d, veDTStamp d) then c else d td c d = if (vtSeq c, vtDTStamp c) >= (vtSeq d, vtDTStamp d) then c else d jo c d = if (vjSeq c, vjDTStamp c) >= (vjSeq d, vjDTStamp d) then c else d fb c d = if vfbDTStamp c >= vfbDTStamp d then c else d -- | Product Identifier. 3.7.3. data ProdId = ProdId { prodIdValue :: Text , prodIdOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Version. 3.7.4. data ICalVersion = MaxICalVersion { versionMax :: Version , versionOther :: OtherParams } | MinMaxICalVersion { versionMax :: Version , versionMin :: Version , versionOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Calendar Scale. 3.7.1. data Scale = Scale { scaleValue :: CI Text , scaleOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) instance Default Scale where def = Scale "GREGORIAN" def -- | Method. 3.7.2. data Method = Method { methodValue :: CI Text -- TODO: iTIP, RFC5546 , methodOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Event Component. 3.6.1. data VEvent = VEvent { veDTStamp :: DTStamp , veUID :: UID , veClass :: Class -- ^ 'def' = 'Public' , veDTStart :: Maybe DTStart , veCreated :: Maybe Created , veDescription :: Maybe Description , veGeo :: Maybe Geo , veLastMod :: Maybe LastModified , veLocation :: Maybe Location , veOrganizer :: Maybe Organizer , vePriority :: Priority -- ^ 'def' = 0 , veSeq :: Sequence -- ^ 'def' = 0 , veStatus :: Maybe EventStatus , veSummary :: Maybe Summary , veTransp :: TimeTransparency -- ^ 'def' = 'Opaque' , veUrl :: Maybe URL , veRecurId :: Maybe RecurrenceId , veRRule :: Set RRule , veDTEndDuration :: Maybe (Either DTEnd DurationProp) , veAttach :: Set Attachment , veAttendee :: Set Attendee , veCategories :: Set Categories , veComment :: Set Comment , veContact :: Set Contact , veExDate :: Set ExDate , veRStatus :: Set RequestStatus , veRelated :: Set RelatedTo , veResources :: Set Resources , veRDate :: Set RDate , veAlarms :: Set VAlarm , veOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | To-Do Component. 3.6.2 data VTodo = VTodo { vtDTStamp :: DTStamp , vtUID :: UID , vtClass :: Class -- ^ 'def' = 'Public' , vtCompleted :: Maybe Completed , vtCreated :: Maybe Created , vtDescription :: Maybe Description , vtDTStart :: Maybe DTStart , vtGeo :: Maybe Geo , vtLastMod :: Maybe LastModified , vtLocation :: Maybe Location , vtOrganizer :: Maybe Organizer , vtPercent :: Maybe PercentComplete , vtPriority :: Priority -- ^ 'def' = 0 , vtRecurId :: Maybe RecurrenceId , vtSeq :: Sequence -- ^ 'def' = 0 , vtStatus :: Maybe TodoStatus , vtSummary :: Maybe Summary , vtUrl :: Maybe URL , vtRRule :: Set RRule , vtDueDuration :: Maybe (Either Due DurationProp) , vtAttach :: Set Attachment , vtAttendee :: Set Attendee , vtCategories :: Set Categories , vtComment :: Set Comment , vtContact :: Set Contact , vtExDate :: Set ExDate , vtRStatus :: Set RequestStatus , vtRelated :: Set RelatedTo , vtResources :: Set Resources , vtRDate :: Set RDate , vtAlarms :: Set VAlarm , vtOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | Journal Component. 3.6.3 data VJournal = VJournal { vjDTStamp :: DTStamp , vjUID :: UID , vjClass :: Class -- ^ 'def' = 'Public' , vjCreated :: Maybe Created , vjDTStart :: Maybe DTStart , vjLastMod :: Maybe LastModified , vjOrganizer :: Maybe Organizer , vjRecurId :: Maybe RecurrenceId , vjSeq :: Sequence -- ^ 'def' = 0 , vjStatus :: Maybe JournalStatus , vjSummary :: Maybe Summary , vjUrl :: Maybe URL , vjRRule :: Set RRule , vjAttach :: Set Attachment , vjAttendee :: Set Attendee , vjCategories :: Set Categories , vjComment :: Set Comment , vjContact :: Set Contact , vjDescription :: Set Description , vjExDate :: Set ExDate , vjRelated :: Set RelatedTo , vjRDate :: Set RDate , vjRStatus :: Set RequestStatus , vjOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | Free/Busy Component. 3.6.4 data VFreeBusy = VFreeBusy { vfbDTStamp :: DTStamp , vfbUID :: UID , vfbContact :: Maybe Contact , vfbDTStart :: Maybe DTStart , vfbDTEnd :: Maybe DTEnd , vfbOrganizer :: Maybe Organizer , vfbUrl :: Maybe URL , vfbAttendee :: Set Attendee , vfbComment :: Set Comment , vfbFreeBusy :: Set FreeBusy , vfbRStatus :: Set RequestStatus , vfbOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | Time Zone Component. 3.6.5. data VTimeZone = VTimeZone { vtzId :: TZID , vtzLastMod :: Maybe LastModified , vtzUrl :: Maybe TZUrl , vtzStandardC :: Set TZProp , vtzDaylightC :: Set TZProp , vtzOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | Time zone property, also 3.6.5. data TZProp = TZProp { tzpDTStart :: DTStart , tzpTZOffsetTo :: UTCOffset , tzpTZOffsetFrom :: UTCOffset , tzpRRule :: Set RRule -- SHOULD NOT have multiple RRules. , tzpComment :: Set Comment , tzpRDate :: Set RDate , tzpTZName :: Set TZName , tzpOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | VAlarm component. 3.6.6. data VAlarm = VAlarmAudio { vaTrigger :: Trigger , vaRepeat :: Repeat -- ^ 'def' = 0 , vaDuration :: Maybe DurationProp , vaAudioAttach :: Maybe Attachment , vaOther :: Set OtherProperty , vaActionOther :: OtherParams } | VAlarmDisplay { vaDescription :: Description , vaTrigger :: Trigger , vaRepeat :: Repeat , vaDuration :: Maybe DurationProp , vaOther :: Set OtherProperty , vaActionOther :: OtherParams } | VAlarmEmail { vaDescription :: Description , vaTrigger :: Trigger , vaSummary :: Summary , vaAttendee :: Set Attendee , vaRepeat :: Repeat , vaDuration :: Maybe DurationProp , vaMailAttach :: Set Attachment , vaOther :: Set OtherProperty , vaActionOther :: OtherParams } | VAlarmX { vaAction :: CI Text , vaTrigger :: Trigger , vaActionOther :: OtherParams , vaOther :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | Any other component not recognized. data VOther = VOther { voName :: CI Text , voProps :: Set OtherProperty } deriving (Show, Eq, Ord, Typeable) -- | Attachment. 3.8.1.1. data Attachment = UriAttachment { attachFmtType :: Maybe MIMEType , attachUri :: URI , attachOther :: OtherParams } | BinaryAttachment { attachFmtType :: Maybe MIMEType , attachContent :: ByteString , attachOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Categories. 3.8.1.2. data Categories = Categories { categoriesValues :: Set Text , categoriesLanguage :: Maybe Language , categoriesOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Classification. 3.8.1.3. data Class = Class { classValue :: ClassValue , classOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) instance Default Class where def = Class def def -- | Classification value. 3.8.1.3. -- Unrecognized ClassValueX MUST be treated as Private. data ClassValue = Public | Private | Confidential | ClassValueX (CI Text) deriving (Show, Eq, Ord, Typeable) instance Default ClassValue where def = Public -- | Date-Time Completed. 3.8.2.1. data Completed = Completed { completedValue :: DateTime , completedOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Comment. 3.8.1.4. data Comment = Comment { commentValue :: Text , commentAltRep :: Maybe URI , commentLanguage :: Maybe Language , commentOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Description. 3.8.1.5. data Description = Description { descriptionValue :: Text , descriptionAltRep :: Maybe URI , descriptionLanguage :: Maybe Language , descriptionOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Geographic Position. 3.8.1.6. data Geo = Geo { geoLat :: Float , geoLong :: Float , geoOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Location. 3.8.1.7. data Location = Location { locationValue :: Text , locationAltRep :: Maybe URI , locationLanguage :: Maybe Language , locationOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Percent complete. 3.8.1.8. data PercentComplete = PercentComplete { percentCompleteValue :: Int , percentCompleteOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Priority. 3.8.1.9. data Priority = Priority { priorityValue :: Int , priorityOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) instance Default Priority where def = Priority 0 def -- | Resources. 3.8.1.10. data Resources = Resources { resourcesValue :: Set Text , resourcesAltRep :: Maybe URI , resourcesLanguage :: Maybe Language , resourcesOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Status, but only for Events. 3.8.1.11. data EventStatus = TentativeEvent { eventStatusOther :: OtherParams } | ConfirmedEvent { eventStatusOther :: OtherParams } | CancelledEvent { eventStatusOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Status, but only for TODOs. 3.8.1.11. data TodoStatus = TodoNeedsAction { todoStatusOther :: OtherParams } | CompletedTodo { todoStatusOther :: OtherParams } | InProcessTodo { todoStatusOther :: OtherParams } | CancelledTodo { todoStatusOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Status, but only for Journals. 3.8.1.11. data JournalStatus = DraftJournal { journalStatusOther :: OtherParams } | FinalJournal { journalStatusOther :: OtherParams } | CancelledJournal { journalStatusOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Summary. 3.8.1.12. data Summary = Summary { summaryValue :: Text , summaryAltRep :: Maybe URI , summaryLanguage :: Maybe Language , summaryOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Date. 3.3.4 data Date = Date { dateValue :: Day } deriving (Show, Eq, Ord, Typeable) -- | Date-Time value. 3.3.5. data DateTime = FloatingDateTime { dateTimeFloating :: LocalTime } | UTCDateTime { dateTimeUTC :: UTCTime } | ZonedDateTime { dateTimeFloating :: LocalTime , dateTimeZone :: Text } deriving (Show, Eq, Ord, Typeable) -- | Date-Time End. 3.8.2.2. data DTEnd = DTEndDateTime { dtEndDateTimeValue :: DateTime , dtEndOther :: OtherParams } | DTEndDate { dtEndDateValue :: Date , dtEndOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Date-Time Due. 3.8.2.3. data Due = DueDateTime { dueDateTimeValue :: DateTime , dueOther :: OtherParams } | DueDate { dueDateValue :: Date , dueOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Date-Time Start. 3.8.2.4. data DTStart = DTStartDateTime { dtStartDateTimeValue :: DateTime , dtStartOther :: OtherParams } | DTStartDate { dtStartDateValue :: Date , dtStartOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Duration value. 3.3.6. data Duration -- TODO(?): Convert to DiffTime? = DurationDate { durSign :: Sign -- ^ 'def' = 'Positive' , durDay :: Int , durHour :: Int , durMinute :: Int , durSecond :: Int } | DurationTime { durSign :: Sign , durHour :: Int , durMinute :: Int , durSecond :: Int } | DurationWeek { durSign :: Sign , durWeek :: Int } deriving (Show, Eq, Ord, Typeable) -- | Sign. data Sign = Positive | Negative deriving (Show, Eq, Ord, Typeable) instance Default Sign where def = Positive -- | Duration property. 3.8.2.5. data DurationProp = DurationProp { durationValue :: Duration , durationOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) data FreeBusy = FreeBusy { freeBusyType :: FBType , freeBusyPeriods :: Set UTCPeriod , freeBusyOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Period of time. 3.3.9. data Period = PeriodDates DateTime DateTime | PeriodDuration DateTime Duration deriving (Show, Eq, Ord, Typeable) -- | Period of time which must be UTC, as in FreeBusy. 3.3.9. data UTCPeriod = UTCPeriodDates UTCTime UTCTime | UTCPeriodDuration UTCTime Duration deriving (Show, Eq, Ord, Typeable) -- | Free/Busy Time Type. 3.2.9. -- -- Unrecognized FBTypeX MUST be treated as Busy. data FBType = Free | Busy | BusyUnavailable | BusyTentative | FBTypeX (CI Text) deriving (Show, Eq, Ord, Typeable) instance Default FBType where def = Busy -- | Time Transparency. 3.8.2.7. data TimeTransparency = Opaque { timeTransparencyOther :: OtherParams } | Transparent { timeTransparencyOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) instance Default TimeTransparency where def = Opaque def -- | Time Zone Identifier. 3.8.3.1. data TZID = TZID { tzidValue :: Text , tzidGlobal :: Bool , tzidOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Time Zone Name. 3.8.3.2. data TZName = TZName { tzNameValue :: Text , tzNameLanguage :: Maybe Language , tzNameOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | UTC Offset. 3.3.14, 3.8.3.4, and 3.8.3.3. (unified-ish) data UTCOffset = UTCOffset { utcOffsetValue :: Int -- ^ Number of seconds away from UTC , utcOffsetOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Time Zone URL. 3.8.3.5. data TZUrl = TZUrl { tzUrlValue :: URI , tzUrlOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Attendee. 3.8.4.1. data Attendee = Attendee { attendeeValue :: CalAddress , attendeeCUType :: CUType -- ^ 'def' = 'Individual' , attendeeMember :: Set CalAddress , attendeeRole :: Role -- ^ 'def' = 'ReqParticipant' , attendeePartStat :: PartStat -- ^ 'def' = 'PartStatNeedsAction' , attendeeRSVP :: Bool , attendeeDelTo :: Set CalAddress , attendeeDelFrom :: Set CalAddress , attendeeSentBy :: Maybe CalAddress , attendeeCN :: Maybe Text , attendeeDir :: Maybe URI , attendeeLanguage :: Maybe Language , attendeeOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Calendar User Type. 3.2.3. -- -- Unrecognized CUTypeX MUST be treated as Unknown. data CUType = Individual | Group | Resource | Room | Unknown | CUTypeX (CI Text) deriving (Show, Eq, Ord, Typeable) instance Default CUType where def = Individual -- | Role. 3.2.16. data Role = Chair | ReqParticipant | OptParticipant | NonParticipant | RoleX (CI Text) deriving (Show, Eq, Ord, Typeable) instance Default Role where def = ReqParticipant -- | Participation Status. 3.2.12. data PartStat -- Splitting requires splitting attendee too... = PartStatNeedsAction | Accepted | Declined | Tentative | Delegated | PartStatCompleted | InProcess | PartStatX (CI Text) deriving (Show, Eq, Ord, Typeable) instance Default PartStat where def = PartStatNeedsAction -- | Contact. 3.8.4.2. data Contact = Contact { contactValue :: Text , contactAltRep :: Maybe URI , contactLanguage :: Maybe Language , contactOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Organizer. 3.8.4.3. -- -- TODO: CAL-ADDRESS-related properties. data Organizer = Organizer { organizerValue :: CalAddress , organizerCN :: Maybe Text , organizerDir :: Maybe URI , organizerSentBy :: Maybe CalAddress , organizerLanguage :: Maybe Language , organizerOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Recurrence ID. 3.8.4.4. data RecurrenceId = RecurrenceIdDate { recurrenceIdDate :: Date , recurrenceIdRange :: Maybe Range , recurrenceIdOther :: OtherParams } | RecurrenceIdDateTime { recurrenceIdDateTime :: DateTime , recurrenceIdRange :: Maybe Range , recurrenceIdOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Recurrence Identifier Range. 3.2.13 data Range = ThisAndFuture | ThisAndPrior deriving (Show, Eq, Ord, Typeable) -- | Related To. 3.8.4.5. data RelatedTo = RelatedTo { relatedToValue :: Text , relatedToType :: RelationshipType , relatedToOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Relationship Type. 3.2.15. -- -- Unrecognized RelationshipTypeX values MUST be treated as Parent. data RelationshipType = Parent | Child | Sibling | RelationshipTypeX (CI Text) deriving (Show, Eq, Ord, Typeable) instance Default RelationshipType where def = Parent -- | Uniform Resource Locator. 3.8.4.6. data URL = URL { urlValue :: URI , urlOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Unique Identifier. 3.8.4.7. data UID = UID { uidValue :: Text , uidOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Exception Date-Times. 3.8.5.1. data ExDate = ExDates { exDates :: Set Date , exDateOther :: OtherParams } | ExDateTimes { exDateTimes :: Set DateTime , exDateOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Recurrence Date-Times. 3.8.5.2. data RDate = RDateDates { rDateDates :: Set Date , rDateOther :: OtherParams } | RDateDateTimes { rDateDateTimes :: Set DateTime , rDateOther :: OtherParams } | RDatePeriods { rDatePeriods :: Set Period , rDateOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Frequency in recurrences. 3.3.10. data Frequency = Secondly | Minutely | Hourly | Daily | Weekly | Monthly | Yearly deriving (Show, Eq, Ord, Typeable) -- | Weekday, in recurrences. 3.3.10. data Weekday = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Show, Eq, Ord, Bounded, Enum, Typeable) -- | Recur value. 3.3.10. data Recur = Recur { recurFreq :: Frequency , recurUntilCount :: Maybe (Either (Either Date DateTime) Int) , recurInterval :: Int , recurBySecond :: [Int] , recurByMinute :: [Int] , recurByHour :: [Int] , recurByDay :: [Either (Int, Weekday) Weekday] , recurByMonthDay :: [Int] , recurByYearDay :: [Int] , recurByWeekNo :: [Int] , recurByMonth :: [Int] , recurBySetPos :: [Int] , recurWkSt :: Weekday } deriving (Show, Eq, Ord, Typeable) -- | Recurrence Rule. 3.8.5.3. data RRule = RRule { rRuleValue :: Recur , rRuleOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Repeat count. 3.8.6.2. data Repeat = Repeat { repeatValue :: Integer , repeatOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) instance Default Repeat where def = Repeat 0 def -- | Alarm Trigger Relationship. 3.2.14. data AlarmTriggerRelationship = Start | End deriving (Show, Eq, Ord, Typeable) instance Default AlarmTriggerRelationship where def = Start -- | Trigger. 3.8.6.3. data Trigger = TriggerDuration { triggerDuration :: Duration , triggerRelated :: AlarmTriggerRelationship -- ^ 'def' = 'Start' , triggerOther :: OtherParams } | TriggerDateTime { triggerDateTime :: UTCTime , triggerOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Date-Time Created. 3.8.7.1. data Created = Created { createdValue :: UTCTime , createdOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Date-Time Stamp. 3.8.7.2. data DTStamp = DTStamp { dtStampValue :: UTCTime , dtStampOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Last Modified. 3.8.7.3. data LastModified = LastModified { lastModifiedValue :: UTCTime , lastModifiedOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Sequence number. 3.8.7.4. data Sequence = Sequence { sequenceValue :: Integer , sequenceOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) instance Default Sequence where def = Sequence 0 def -- | Request Status. 3.8.8.3. data RequestStatus = RequestStatus { requestStatusCode :: [Int] , requestStatusDesc :: Text , requestStatusLanguage :: Maybe Language , requestStatusExt :: Maybe Text , requestStatusOther :: OtherParams } deriving (Show, Eq, Ord, Typeable) -- | Any other property. data OtherProperty = OtherProperty { otherName :: CI Text , otherValue :: ByteString , otherParams :: OtherParams } deriving (Show, Eq, Ord, Typeable) iCalendar-0.4.0.3/Text/ICalendar/Parser.hs0000644000000000000000000000502412540267567016301 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module Text.ICalendar.Parser ( parseICalendar , parseICalendarFile , parseICal , parseICalFile , DecodingFunctions(..) ) where import Control.Applicative import Control.Monad import Control.Monad.Error import Control.Monad.RWS (runRWS) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as B import Data.Monoid import Prelude import Text.Parsec.ByteString.Lazy () import Text.Parsec.Pos import Text.Parsec.Prim hiding (many, (<|>)) import Text.Parsec.Text.Lazy () import Text.ICalendar.Parser.Common import Text.ICalendar.Parser.Components import Text.ICalendar.Parser.Content import Text.ICalendar.Types -- | Parse a ByteString containing iCalendar data. -- -- Returns either an error, or a tuple of the result and a list of warnings. parseICalendar :: DecodingFunctions -> FilePath -- ^ Used in error messages. -> ByteString -> Either String ([VCalendar], [String]) parseICalendar s f bs = do a <- either (Left . show) Right $ runParser parseToContent s f bs when (null a) $ throwError "Missing content." let xs = map (runCP s . parseVCalendar) a (x, w) <- ((flip.).) flip foldM ([], []) xs $ \(x, ws) (g, (pos, _), w) -> case g of Left e -> Left $ show pos ++ ": " ++ e Right y -> Right (y:x, w <> ws) return (x, w) -- | Deprecated synonym for parseICalendar parseICal :: DecodingFunctions -> FilePath -> ByteString -> Either String ([VCalendar], [String]) parseICal = parseICalendar {-# DEPRECATED parseICal "Use parseICalendar instead" #-} -- | Parse an iCalendar file. parseICalendarFile :: DecodingFunctions -> FilePath -> IO (Either String ([VCalendar], [String])) parseICalendarFile s f = parseICal s f <$> B.readFile f -- | Deprecated synonym for parseICalendarFile parseICalFile :: DecodingFunctions -> FilePath -> IO (Either String ([VCalendar], [String])) parseICalFile = parseICalendarFile {-# DEPRECATED parseICalFile "Use parseICalendarFile instead" #-} runCP :: DecodingFunctions -> ContentParser a -> (Either String a, (SourcePos, [Content]), [String]) runCP s = ((flip .) . flip) runRWS s (undefined, undefined) . runErrorT iCalendar-0.4.0.3/Text/ICalendar/Printer.hs0000644000000000000000000010553512540267567016500 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} module Text.ICalendar.Printer ( EncodingFunctions(..) , printICalendar , printICal ) where import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad hiding (forM_, mapM_) import Control.Monad.RWS (MonadState (get, put), MonadWriter (tell), RWS, asks, modify, runRWS) import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Builder (Builder) import qualified Data.ByteString.Lazy.Builder as Bu import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.CaseInsensitive as CI import Data.Char (ord, toUpper) import Data.Default import Data.Foldable (forM_, mapM_) import Data.Monoid import Data.Set (Set) import qualified Data.Set as S import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import Data.Time (FormatTime ()) import qualified Data.Time as Time import qualified Data.Version as Ver import qualified Network.URI as URI import Prelude hiding (mapM_) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif import Text.Printf (printf) import Codec.MIME.Type (MIMEType, showMIMEType) import qualified Data.ByteString.Base64.Lazy as B64 import Text.ICalendar.Types -- | Functions for encoding into bytestring builders. data EncodingFunctions = EncodingFunctions { efChar2Bu :: Char -> Builder , efChar2Len :: Char -> Int -- ^ How many octets the character is encoded. } utf8Len :: Char -> Int utf8Len c | o < 0x80 = 1 | o < 0x800 = 2 | o < 0x10000 = 3 | o < 0x200000 = 4 | o < 0x4000000 = 5 | otherwise = 6 where o = ord c newtype AltRep = AltRep URI.URI newtype CN = CN Text newtype Dir = Dir URI.URI newtype Member = Member (Set URI.URI) newtype DelTo = DelTo (Set URI.URI) newtype DelFrom = DelFrom (Set URI.URI) newtype RSVP = RSVP Bool newtype SentBy = SentBy CalAddress data Quoting = NeedQuotes | Optional | NoQuotes deriving (Eq, Ord, Show) -- | UTF8. instance Default EncodingFunctions where def = EncodingFunctions Bu.charUtf8 utf8Len type ContentPrinter = RWS EncodingFunctions Builder Int -- | Print a VCalendar object to a ByteString. printICalendar :: EncodingFunctions -> VCalendar -> ByteString printICalendar r v = (\(_, _, x) -> Bu.toLazyByteString x) $ runRWS (printVCalendar v) r 0 -- | Deprecated synonym for printICalendar printICal :: EncodingFunctions -> VCalendar -> ByteString printICal = printICalendar {-# DEPRECATED printICal "Use printICalendar instead" #-} -- {{{ Component printers printVCalendar :: VCalendar -> ContentPrinter () printVCalendar VCalendar {..} = do line "BEGIN:VCALENDAR" ln $ do prop "VERSION" $ versionOther vcVersion -- Should be first for printValue vcVersion -- compatibility. ln $ do prop "PRODID" $ prodIdOther vcProdId text $ prodIdValue vcProdId ln $ do prop "CALSCALE" $ scaleOther vcScale text . CI.original $ scaleValue vcScale forM_ vcMethod $ \meth -> do prop "METHOD" $ methodOther meth ln . text . CI.original $ methodValue meth mapM_ printProperty vcOther mapM_ printVTimeZone vcTimeZones mapM_ printVEvent vcEvents mapM_ printVTodo vcTodos mapM_ printVJournal vcJournals mapM_ printVFreeBusy vcFreeBusys mapM_ printVOther vcOtherComps line "END:VCALENDAR" printVTimeZone :: VTimeZone -> ContentPrinter () printVTimeZone VTimeZone {..} = do line "BEGIN:VTIMEZONE" ln $ do prop "TZID" $ tzidOther vtzId text $ tzidValue vtzId printProperty vtzLastMod forM_ vtzUrl $ \url -> do prop "TZURL" $ tzUrlOther url ln . printShow $ tzUrlValue url mapM_ (printTZProp "STANDARD") vtzStandardC mapM_ (printTZProp "DAYLIGHT") vtzDaylightC mapM_ printProperty vtzOther line "END:VTIMEZONE" printTZProp :: ByteString -> TZProp -> ContentPrinter () printTZProp name TZProp {..} = do line $ "BEGIN:" <> name printProperty tzpDTStart ln $ do prop "TZOFFSETTO" $ utcOffsetOther tzpTZOffsetTo printUTCOffset $ utcOffsetValue tzpTZOffsetTo ln $ do prop "TZOFFSETFROM" $ utcOffsetOther tzpTZOffsetTo printUTCOffset $ utcOffsetValue tzpTZOffsetFrom printProperty tzpRRule printProperty tzpComment printProperty tzpRDate forM_ tzpTZName $ \TZName {..} -> ln $ do prop "TZNAME" $ toParam tzNameLanguage <> toParam tzNameOther text tzNameValue mapM_ printProperty tzpOther line $ "END:" <> name printVEvent :: VEvent -> ContentPrinter () printVEvent VEvent {..} = do line "BEGIN:VEVENT" printProperty veDTStamp printProperty veUID printProperty veDTStart printProperty veClass printProperty veCreated printProperty veDescription printProperty veGeo printProperty veLastMod printProperty veLocation printProperty veOrganizer printProperty vePriority printProperty veSeq printProperty veStatus printProperty veSummary printProperty veTransp printProperty veUrl printProperty veRecurId printProperty veRRule printProperty veDTEndDuration printProperty veAttach printProperty veAttendee printProperty veCategories printProperty veComment printProperty veContact printProperty veExDate printProperty veRStatus printProperty veRelated printProperty veResources printProperty veRDate forM_ veAlarms printVAlarm printProperty veOther line "END:VEVENT" printVTodo :: VTodo -> ContentPrinter () printVTodo VTodo {..} = do line "BEGIN:VTODO" printProperty vtDTStamp printProperty vtUID printProperty vtClass printProperty vtCompleted printProperty vtCreated printProperty vtDescription printProperty vtDTStart printProperty vtGeo printProperty vtLastMod printProperty vtLocation printProperty vtOrganizer printProperty vtPercent printProperty vtPriority printProperty vtSeq printProperty vtRecurId printProperty vtStatus printProperty vtSummary printProperty vtUrl printProperty vtRRule printProperty vtDueDuration printProperty vtAttach printProperty vtAttendee printProperty vtCategories printProperty vtComment printProperty vtContact printProperty vtExDate printProperty vtRStatus printProperty vtRelated printProperty vtResources printProperty vtRDate forM_ vtAlarms printVAlarm printProperty vtOther line "END:VTODO" printVJournal :: VJournal -> ContentPrinter () printVJournal VJournal {..} = do line "BEGIN:VJOURNAL" printProperty vjDTStamp printProperty vjUID printProperty vjClass printProperty vjCreated printProperty vjDescription printProperty vjDTStart printProperty vjLastMod printProperty vjOrganizer printProperty vjSeq printProperty vjRecurId printProperty vjStatus printProperty vjSummary printProperty vjUrl printProperty vjRRule printProperty vjAttach printProperty vjAttendee printProperty vjCategories printProperty vjComment printProperty vjContact printProperty vjExDate printProperty vjRStatus printProperty vjRelated printProperty vjRDate printProperty vjOther line "END:VJOURNAL" printVFreeBusy :: VFreeBusy -> ContentPrinter () printVFreeBusy VFreeBusy {..} = do line "BEGIN:VFREEBUSY" printProperty vfbDTStamp printProperty vfbUID printProperty vfbContact printProperty vfbDTStart printProperty vfbDTEnd printProperty vfbOrganizer printProperty vfbUrl printProperty vfbAttendee printProperty vfbComment printProperty vfbFreeBusy printProperty vfbRStatus printProperty vfbOther line "END:VFREEBUSY" printVOther :: VOther -> ContentPrinter () printVOther VOther {..} = do ln . out $ "BEGIN:V" <> CI.original voName mapM_ printProperty voProps ln . out $ "END:V" <> CI.original voName printVAlarm :: VAlarm -> ContentPrinter () printVAlarm va = do line "BEGIN:VALARM" prop "ACTION" $ vaActionOther va case va of VAlarmAudio {..} -> do ln $ bytestring "AUDIO" printProperty vaTrigger repAndDur printProperty vaAudioAttach printProperty vaOther VAlarmDisplay {..} -> do ln $ bytestring "DISPLAY" printProperty vaTrigger printProperty vaDescription repAndDur printProperty vaOther VAlarmEmail {..} -> do ln $ bytestring "EMAIL" printProperty vaTrigger printProperty vaDescription printProperty vaSummary printProperty vaAttendee repAndDur printProperty vaMailAttach printProperty vaOther VAlarmX {..} -> do ln . out $ CI.original vaAction printProperty vaTrigger printProperty vaOther line "END:VALARM" where repAndDur = unless (vaRepeat va == def) $ do printProperty $ vaRepeat va unless (repeatValue (vaRepeat va) == 0) $ forM_ (vaDuration va) printProperty -- }}} -- {{{ Property printers. class IsProperty a where printProperty :: a -> ContentPrinter () instance IsProperty a => IsProperty (Set a) where printProperty = mapM_ printProperty instance IsProperty a => IsProperty (Maybe a) where printProperty (Just x) = printProperty x printProperty _ = return () instance (IsProperty a, IsProperty b) => IsProperty (Either a b) where printProperty (Left x) = printProperty x printProperty (Right x) = printProperty x instance IsProperty FreeBusy where printProperty FreeBusy {..} = ln $ do prop "FREEBUSY" $ toParam freeBusyOther <> toParam freeBusyType printN printValue $ S.toList freeBusyPeriods instance IsProperty PercentComplete where printProperty PercentComplete {..} = ln $ do prop "PERCENT-COMPLETE" percentCompleteOther printShow percentCompleteValue instance IsProperty Completed where printProperty Completed {..} = ln $ do prop "COMPLETED" completedOther printValue completedValue instance IsProperty DurationProp where printProperty DurationProp {..} = ln $ do prop "DURATION" durationOther printValue durationValue instance IsProperty Repeat where printProperty Repeat {..} = ln $ do prop "REPEAT" repeatOther printShow repeatValue instance IsProperty DTEnd where printProperty dtend = ln $ prop "DTEND" dtend >> printValue dtend instance IsProperty Due where printProperty due = ln $ prop "DUE" due >> printValue due instance IsProperty DTStamp where printProperty x = ln $ prop "DTSTAMP" x >> printValue x instance IsProperty UID where printProperty UID {..} = ln $ prop "UID" uidOther >> text uidValue instance IsProperty DTStart where printProperty x = ln $ prop "DTSTART" x >> printValue x instance IsProperty Class where printProperty c@Class {..} | c == def = return () | otherwise = ln $ do prop "CLASS" classOther printValue classValue instance IsProperty Created where printProperty Created {..} = ln $ do prop "CREATED" createdOther printUTCTime createdValue instance IsProperty Description where printProperty Description {..} = ln $ do prop "DESCRIPTION" $ toParam (AltRep <$> descriptionAltRep) <> toParam descriptionLanguage <> toParam descriptionOther text descriptionValue instance IsProperty Geo where printProperty Geo {..} = ln $ do prop "GEO" geoOther out . T.pack $ printf "%.6f;%.6f" geoLat geoLong instance IsProperty LastModified where printProperty LastModified {..} = ln $ do prop "LAST-MODIFIED" lastModifiedOther printUTCTime lastModifiedValue instance IsProperty Location where printProperty Location {..} = ln $ do prop "LOCATION" $ toParam (AltRep <$> locationAltRep) <> toParam locationLanguage <> toParam locationOther text locationValue instance IsProperty Organizer where printProperty Organizer {..} = ln $ do prop "ORGANIZER" $ toParam (CN <$> organizerCN) <> toParam (Dir <$> organizerDir) <> toParam (SentBy <$> organizerSentBy) <> toParam organizerLanguage <> toParam organizerOther printShow organizerValue instance IsProperty Priority where printProperty x | x == def = return () | otherwise = ln $ do prop "PRIORITY" $ priorityOther x printShow $ priorityValue x instance IsProperty Sequence where printProperty x | x == def = return () | otherwise = ln $ do prop "SEQUENCE" $ sequenceOther x printShow $ sequenceValue x instance IsProperty EventStatus where printProperty s = ln $ do prop "STATUS" $ eventStatusOther s printValue s instance IsProperty TodoStatus where printProperty s = ln $ do prop "STATUS" $ todoStatusOther s printValue s instance IsProperty JournalStatus where printProperty s = ln $ do prop "STATUS" $ journalStatusOther s printValue s instance IsProperty Summary where printProperty Summary {..} = ln $ do prop "SUMMARY" $ toParam (AltRep <$> summaryAltRep) <> toParam summaryLanguage <> toParam summaryOther text summaryValue instance IsProperty TimeTransparency where printProperty x | x == def = return () | otherwise = ln $ do prop "TRANSP" $ timeTransparencyOther x printValue x instance IsProperty URL where printProperty URL {..} = ln $ prop "URL" urlOther >> printShow urlValue instance IsProperty RecurrenceId where printProperty r = ln $ prop "RECURRENCE-ID" r >> printValue r instance IsProperty RRule where printProperty RRule {..} = ln $ do prop "RRULE" rRuleOther printValue rRuleValue instance IsProperty Attachment where printProperty a = ln $ prop "ATTACH" a >> printValue a instance IsProperty Attendee where printProperty att@Attendee {..} = ln $ do prop "ATTENDEE" att printValue attendeeValue instance IsProperty Categories where printProperty Categories {..} = ln $ do prop "CATEGORIES" $ toParam categoriesOther <> toParam categoriesLanguage texts $ S.toList categoriesValues instance IsProperty Comment where printProperty Comment {..} = ln $ do prop "COMMENT" $ toParam (AltRep <$> commentAltRep) <> toParam commentLanguage <> toParam commentOther text commentValue instance IsProperty Contact where printProperty Contact {..} = ln $ do prop "CONTACT" $ toParam (AltRep <$> contactAltRep) <> toParam contactLanguage <> toParam contactOther text contactValue instance IsProperty ExDate where printProperty exd = ln $ do prop "EXDATE" exd case exd of ExDates {..} -> printN printValue $ S.toList exDates ExDateTimes {..} -> printN printValue $ S.toList exDateTimes instance IsProperty RequestStatus where printProperty RequestStatus {..} = ln $ do prop "REQUEST-STATUS" $ toParam requestStatusLanguage <> toParam requestStatusOther (\z -> case z of (x:xs) -> do printShow x sequence_ [putc '.' >> printShow y | y <- xs] [] -> return ()) requestStatusCode putc ';' text requestStatusDesc forM_ requestStatusExt $ \x -> putc ';' >> text x instance IsProperty RelatedTo where printProperty RelatedTo {..} = ln $ do prop "RELATED-TO" $ toParam relatedToOther <> toParam relatedToType text relatedToValue instance IsProperty Resources where printProperty Resources {..} = ln $ do prop "RESOURCES" $ toParam (AltRep <$> resourcesAltRep) <> toParam resourcesLanguage <> toParam resourcesOther texts $ S.toList resourcesValue instance IsProperty RDate where printProperty r = ln $ prop "RDATE" r >> printValue r instance IsProperty OtherProperty where printProperty OtherProperty {..} = ln $ do out (CI.original otherName) mapM_ param $ toParam otherParams out ":" bytestring otherValue instance IsProperty Trigger where printProperty tr@TriggerDuration {..} = ln $ do prop "TRIGGER" tr printValue triggerDuration printProperty tr@TriggerDateTime {..} = ln $ do prop "TRIGGER" tr printUTCTime triggerDateTime -- | Print a generic property. prop :: ToParam a => ByteString -> a -> ContentPrinter () prop b x = do put (fromIntegral $ BS.length b) tell (Bu.lazyByteString b) mapM_ param $ toParam x out ":" -- }}} -- {{{ Parameter "printers". class ToParam a where toParam :: a -> [(Text, [(Quoting, Text)])] instance ToParam a => ToParam (Maybe a) where toParam Nothing = [] toParam (Just x) = toParam x instance ToParam a => ToParam (Set a) where toParam s = case S.maxView s of Nothing -> [] Just (x, _) -> toParam x instance ToParam ExDate where toParam ExDates {..} = [("VALUE", [(NoQuotes, "DATE")])] <> toParam exDateOther toParam ExDateTimes {..} = toParam exDateOther <> toParam (fst <$> S.maxView exDateTimes) instance ToParam AltRep where toParam (AltRep x) = [("ALTREP", [(NeedQuotes, T.pack $ show x)])] instance ToParam SentBy where toParam (SentBy x) = [("SENT-BY", [(NeedQuotes, T.pack $ show x)])] instance ToParam Dir where toParam (Dir x) = [("DIR", [(NeedQuotes, T.pack $ show x)])] instance ToParam DateTime where toParam ZonedDateTime {..} = [("TZID", [(Optional, dateTimeZone)])] toParam _ = [] instance ToParam DTEnd where toParam DTEndDateTime {..} = toParam dtEndOther <> toParam dtEndDateTimeValue toParam DTEndDate {..} = [("VALUE", [(NoQuotes, "DATE")])] <> toParam dtEndOther instance ToParam Due where toParam DueDateTime {..} = toParam dueOther <> toParam dueDateTimeValue toParam DueDate {..} = [("VALUE", [(NoQuotes, "DATE")])] <> toParam dueOther instance ToParam CN where toParam (CN x) = [("CN", [(Optional, x)])] instance ToParam DTStart where toParam DTStartDateTime {..} = toParam dtStartDateTimeValue <> toParam dtStartOther toParam DTStartDate {..} = [("VALUE", [(NoQuotes, "DATE")])] <> toParam dtStartOther instance ToParam RDate where toParam RDateDates {..} = [("VALUE", [(NoQuotes, "DATE")])] <> toParam rDateOther toParam RDatePeriods {..} = [("VALUE", [(NoQuotes, "PERIOD")])] <> toParam rDateOther <> toParam (fst <$> S.maxView rDatePeriods) toParam RDateDateTimes {..} = toParam rDateDateTimes <> toParam rDateOther instance ToParam Period where toParam (PeriodDates x _) = toParam x toParam (PeriodDuration x _) = toParam x instance ToParam DTStamp where toParam DTStamp {..} = toParam dtStampOther instance ToParam OtherParams where toParam (OtherParams l) = fromOP <$> S.toList l where fromOP (OtherParam x y) = (CI.original x, (Optional,) <$> y) instance ToParam Language where toParam (Language x) = [("LANGUAGE", [(Optional, CI.original x)])] instance ToParam TZName where toParam TZName {..} = toParam tzNameLanguage <> toParam tzNameOther instance ToParam x => ToParam [x] where toParam = mconcat . map toParam instance ToParam (Text, [(Quoting, Text)]) where toParam = (:[]) instance ToParam RecurrenceId where toParam RecurrenceIdDate {..} = [("VALUE", [(NoQuotes, "DATE")])] <> toParam recurrenceIdRange <> toParam recurrenceIdOther toParam RecurrenceIdDateTime {..} = toParam recurrenceIdDateTime <> toParam recurrenceIdRange <> toParam recurrenceIdOther instance ToParam Range where toParam ThisAndFuture = [("RANGE", [(NoQuotes, "THISANDFUTURE")])] toParam _ = [] -- ThisAndPrior MUST NOT be generated. instance ToParam FBType where toParam x | x == def = [] toParam Free = [("FBTYPE", [(NoQuotes, "FREE")])] toParam Busy = [("FBTYPE", [(NoQuotes, "BUSY")])] toParam BusyUnavailable = [("FBTYPE", [(NoQuotes, "BUSY-UNAVAILABLE")])] toParam BusyTentative = [("FBTYPE", [(NoQuotes, "BUSY-TENTATIVE")])] toParam (FBTypeX x) = [("FBTYPE", [(Optional, CI.original x)])] instance ToParam MIMEType where toParam m = [("FMTTYPE", [(NoQuotes, T.fromStrict $ showMIMEType m)])] instance ToParam Attachment where toParam UriAttachment {..} = toParam attachFmtType <> toParam attachOther toParam BinaryAttachment {..} = toParam attachFmtType <> toParam attachOther <> [ ("VALUE", [(NoQuotes, "BINARY")]) , ("ENCODING", [(NoQuotes, "BASE64")])] instance ToParam CUType where toParam x | x == def = [] toParam Individual = [("CUTYPE", [(NoQuotes, "INDIVIDUAL")])] toParam Group = [("CUTYPE", [(NoQuotes, "GROUP")])] toParam Resource = [("CUTYPE", [(NoQuotes, "RESOURCE")])] toParam Room = [("CUTYPE", [(NoQuotes, "ROOM")])] toParam Unknown = [("CUTYPE", [(NoQuotes, "UNKNOWN")])] toParam (CUTypeX x) = [("CUTYPE", [(Optional, CI.original x)])] instance ToParam Member where toParam (Member x) | S.null x = [] toParam (Member x) = [( "MEMBER" , (NeedQuotes,) . T.pack . show <$> S.toList x)] instance ToParam Role where toParam x | x == def = [] toParam Chair = [("ROLE", [(NoQuotes, "CHAIR")])] toParam ReqParticipant = [("ROLE", [(NoQuotes, "REQ-PARTICIPANT")])] toParam OptParticipant = [("ROLE", [(NoQuotes, "OPT-PARTICIPANT")])] toParam NonParticipant = [("ROLE", [(NoQuotes, "NON-PARTICIPANT")])] toParam (RoleX x) = [("ROLE", [(Optional, CI.original x)])] instance ToParam PartStat where toParam x | x == def = [] toParam PartStatNeedsAction = [("PARTSTAT", [(NoQuotes, "NEEDS-ACTION")])] toParam Accepted = [("PARTSTAT", [(NoQuotes, "ACCEPTED")])] toParam Declined = [("PARTSTAT", [(NoQuotes, "DECLINED")])] toParam Tentative = [("PARTSTAT", [(NoQuotes, "TENTATIVE")])] toParam Delegated = [("PARTSTAT", [(NoQuotes, "DELEGATED")])] toParam PartStatCompleted = [("PARTSTAT", [(NoQuotes, "COMPLETED")])] toParam InProcess = [("PARTSTAT", [(NoQuotes, "IN-PROCESS")])] toParam (PartStatX x) = [("PARTSTAT", [(Optional, CI.original x)])] instance ToParam RelationshipType where toParam x | x == def = [] toParam Parent = [("RELTYPE", [(NoQuotes, "PARENT")])] toParam Child = [("RELTYPE", [(NoQuotes, "CHILD")])] toParam Sibling = [("RELTYPE", [(NoQuotes, "SIBLING")])] toParam (RelationshipTypeX x) = [("RELTYPE", [(Optional, CI.original x)])] instance ToParam RSVP where toParam (RSVP False) = [] toParam (RSVP True) = [("RSVP", [(NoQuotes, "TRUE")])] instance ToParam DelTo where toParam (DelTo x) | S.null x = [] | otherwise = [( "DELEGATED-TO" , (NeedQuotes,) . T.pack . show <$> S.toList x)] instance ToParam DelFrom where toParam (DelFrom x) | S.null x = [] | otherwise = [( "DELEGATED-FROM" , (NeedQuotes,) . T.pack . show <$> S.toList x)] instance ToParam Attendee where toParam Attendee {..} = toParam attendeeCUType <> toParam (Member attendeeMember) <> toParam attendeeRole <> toParam attendeePartStat <> toParam (RSVP attendeeRSVP) <> toParam (DelTo attendeeDelTo) <> toParam (DelFrom attendeeDelFrom) <> toParam (SentBy <$> attendeeSentBy) <> toParam (CN <$> attendeeCN) <> toParam (Dir <$> attendeeDir) <> toParam attendeeLanguage <> toParam attendeeOther instance ToParam AlarmTriggerRelationship where toParam x | x == def = [] toParam Start = [("RELATED", [(NoQuotes, "START")])] toParam End = [("RELATED", [(NoQuotes, "END")])] instance ToParam Trigger where toParam TriggerDuration {..} = toParam triggerOther <> toParam triggerRelated toParam TriggerDateTime {..} = toParam triggerOther <> [("VALUE", [(NoQuotes, "DATE-TIME")])] -- }}} -- {{{ Value printers printUTCOffset :: Int -> ContentPrinter () printUTCOffset n = do case signum n of -1 -> putc '-' _ -> putc '+' out . T.pack $ printf "%02d" t out . T.pack $ printf "%02d" m when (s > 0) . out . T.pack $ printf "%02d" s where (m', s) = abs n `divMod` 60 (t, m) = m' `divMod` 60 printNWeekday :: Either (Int, Weekday) Weekday -> ContentPrinter () printNWeekday (Left (n, w)) = printShow n >> printValue w printNWeekday (Right x) = printValue x printShow :: Show a => a -> ContentPrinter () printShow = out . T.pack . show printShowN :: Show a => [a] -> ContentPrinter () printShowN = printN printShow printN :: (a -> ContentPrinter ()) -> [a] -> ContentPrinter () printN m (x:xs) = m x >> sequence_ [putc ',' >> m x' | x' <- xs] printN _ _ = return () printShowUpper :: Show a => a -> ContentPrinter () printShowUpper = out . T.pack . map toUpper . show printUTCTime :: Time.UTCTime -> ContentPrinter () printUTCTime = out . T.pack . formatTime "%C%y%m%dT%H%M%SZ" class IsValue a where printValue :: a -> ContentPrinter () instance IsValue ICalVersion where printValue MaxICalVersion {..} = out . T.pack $ Ver.showVersion versionMax printValue MinMaxICalVersion {..} = do out . T.pack $ Ver.showVersion versionMin putc ';' out . T.pack $ Ver.showVersion versionMax instance IsValue Recur where printValue Recur {..} = do out "FREQ=" printShowUpper recurFreq forM_ recurUntilCount $ \x -> case x of Left y -> out ";UNTIL=" >> printValue y Right y -> out ";COUNT=" >> printShow y when (recurInterval /= 1) $ out ";INTERVAL=" >> printShow recurInterval unless (null recurBySecond) $ out ";BYSECOND=" >> printShowN recurBySecond unless (null recurByMinute) $ out ";BYMINUTE=" >> printShowN recurByMinute unless (null recurByHour) $ out ";BYHOUR=" >> printShowN recurByHour unless (null recurByDay) $ out ";BYDAY=" >> printN printNWeekday recurByDay unless (null recurByMonthDay) $ out ";BYMONTHDAY=" >> printShowN recurByMonthDay unless (null recurByYearDay) $ out ";BYYEARDAY=" >> printShowN recurByYearDay unless (null recurByWeekNo) $ out ";BYWEEKNO=" >> printShowN recurByWeekNo unless (null recurByMonth) $ out ";BYMONTH=" >> printShowN recurByMonth unless (null recurBySetPos) $ out ";BYSETPOS=" >> printShowN recurBySetPos unless (recurWkSt == Monday) $ out ";WKST=" >> printValue recurWkSt instance IsValue TimeTransparency where printValue Opaque {} = out "OPAQUE" printValue Transparent {} = out "TRANSPARENT" instance IsValue DTEnd where printValue DTEndDateTime {..} = printValue dtEndDateTimeValue printValue DTEndDate {..} = printValue dtEndDateValue instance IsValue Due where printValue DueDateTime {..} = printValue dueDateTimeValue printValue DueDate {..} = printValue dueDateValue instance IsValue EventStatus where printValue TentativeEvent {} = out "TENTATIVE" printValue ConfirmedEvent {} = out "CONFIRMED" printValue CancelledEvent {} = out "CANCELLED" instance IsValue TodoStatus where printValue TodoNeedsAction {} = out "NEEDS-ACTION" printValue CompletedTodo {} = out "COMPLETED" printValue InProcessTodo {} = out "IN-PROCESS" printValue CancelledTodo {} = out "CANCELLED" instance IsValue JournalStatus where printValue DraftJournal {} = out "DRAFT" printValue FinalJournal {} = out "FINAL" printValue CancelledJournal {} = out "CANCELLED" instance IsValue ClassValue where printValue (ClassValueX x) = out $ CI.original x printValue x = printShowUpper x instance IsValue Weekday where printValue Sunday = out "SU" printValue Monday = out "MO" printValue Tuesday = out "TU" printValue Wednesday = out "WE" printValue Thursday = out "TH" printValue Friday = out "FR" printValue Saturday = out "SA" instance IsValue Date where printValue Date {..} = out . T.pack $ formatTime "%C%y%m%d" dateValue instance IsValue DateTime where printValue FloatingDateTime {..} = out . T.pack $ formatTime "%C%y%m%dT%H%M%S" dateTimeFloating printValue UTCDateTime {..} = printUTCTime dateTimeUTC printValue ZonedDateTime {..} = out . T.pack $ formatTime "%C%y%m%dT%H%M%S" dateTimeFloating instance IsValue (Either Date DateTime) where printValue (Left x) = printValue x printValue (Right x) = printValue x instance IsValue DTStamp where printValue DTStamp {..} = printUTCTime dtStampValue instance IsValue DTStart where printValue DTStartDateTime {..} = printValue dtStartDateTimeValue printValue DTStartDate {..} = printValue dtStartDateValue instance IsValue URI.URI where printValue = printShow instance IsValue Duration where printValue DurationDate {..} = do when (durSign == Negative) $ putc '-' putc 'P' printShow durDay >> putc 'D' putc 'T' printShow durHour >> putc 'H' printShow durMinute >> putc 'M' printShow durSecond >> putc 'S' printValue DurationTime {..} = do when (durSign == Negative) $ putc '-' out "PT" printShow durHour >> putc 'H' printShow durMinute >> putc 'M' printShow durSecond >> putc 'S' printValue DurationWeek {..} = do when (durSign == Negative) $ putc '-' out "P" printShow durWeek >> putc 'W' instance IsValue RecurrenceId where printValue RecurrenceIdDate {..} = printValue recurrenceIdDate printValue RecurrenceIdDateTime {..} = printValue recurrenceIdDateTime instance IsValue Period where printValue (PeriodDates f t) = printValue f >> putc '/' >> printValue t printValue (PeriodDuration f d) = printValue f >> putc '/' >> printValue d instance IsValue UTCPeriod where printValue (UTCPeriodDates f t) = printUTCTime f >> putc '/' >> printUTCTime t printValue (UTCPeriodDuration f d) = printUTCTime f >> putc '/' >> printValue d instance IsValue RDate where printValue RDateDates {..} = printN printValue $ S.toList rDateDates printValue RDateDateTimes {..} = printN printValue $ S.toList rDateDateTimes printValue RDatePeriods {..} = printN printValue $ S.toList rDatePeriods instance IsValue Attachment where printValue UriAttachment {..} = printShow attachUri printValue BinaryAttachment {..} = bytestring $ B64.encode attachContent -- }}} -- {{{ Lib ln :: ContentPrinter () -> ContentPrinter () ln x = x >> newline param :: (Text, [(Quoting, Text)]) -> ContentPrinter () param (n, xs) = putc ';' >> out n >> putc '=' >> paramVals xs paramVals :: [(Quoting, Text)] -> ContentPrinter () paramVals (x:xs) = paramVal x >> sequence_ [putc ',' >> paramVal x' | x' <- xs] paramVals _ = return () paramVal :: (Quoting, Text) -> ContentPrinter () paramVal (NeedQuotes, t) = putc '"' >> out t >> putc '"' paramVal (NoQuotes, t) = out t paramVal (_, t) = paramVal (NeedQuotes, t) texts :: [Text] -> ContentPrinter () texts (x:xs) = text x >> sequence_ [putc ',' >> text x' | x' <- xs] texts _ = return () text :: Text -> ContentPrinter () text t = case T.uncons t of Just (';', r) -> out "\\;" >> text r Just ('\n', r) -> out "\\n" >> text r Just (',', r) -> out "\\," >> text r Just ('\\', r) -> out "\\\\" >> text r Just (c, r) -> putc c >> text r Nothing -> return () bytestring :: ByteString -> ContentPrinter () bytestring = BS.foldl' (\m c -> m >> putc8 c) (return ()) out :: Text -> ContentPrinter () out t = case T.uncons t of Just (c, r) -> putc c >> out r Nothing -> return () putc :: Char -> ContentPrinter () putc c = do x <- get (b, clen) <- asks (efChar2Bu &&& efChar2Len) let cl = clen c when (x + cl > 75) foldLine tell $ b c modify (+ cl) putc8 :: Char -> ContentPrinter () putc8 c = do x <- get when (x >= 75) foldLine tell $ Bu.char8 c modify (+ 1) foldLine :: ContentPrinter () foldLine = tell (Bu.byteString "\r\n ") >> put 1 newline :: ContentPrinter () newline = tell (Bu.byteString "\r\n") >> put 0 -- | Output a whole line. Must be less than 75 bytes. line :: ByteString -> ContentPrinter () line b = tell (Bu.lazyByteString b) >> newline formatTime :: FormatTime t => String -> t -> String formatTime = Time.formatTime defaultTimeLocale -- }}} iCalendar-0.4.0.3/Text/ICalendar/Parser/0000755000000000000000000000000012540267567015744 5ustar0000000000000000iCalendar-0.4.0.3/Text/ICalendar/Parser/Common.hs0000644000000000000000000004201512540267567017532 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Text.ICalendar.Parser.Common where import Control.Applicative import Control.Arrow (second) import Control.Monad.Error hiding (mapM) import Control.Monad.RWS (MonadState (get, put), MonadWriter (tell), RWS, asks, modify) import qualified Data.ByteString.Lazy.Builder as Bu import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as B import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Char import Data.Default import Data.List (partition) import Data.Maybe import Data.Monoid import Data.Set (Set) import qualified Data.Set as S import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as TE import Data.Time (Day, LocalTime (LocalTime), TimeOfDay (), UTCTime (UTCTime)) import qualified Data.Time as Time import Data.Traversable (mapM) import qualified Network.URI as URI import Prelude hiding (mapM) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif import qualified Text.Parsec as P import Text.Parsec.Combinator hiding (optional) import Text.Parsec.Prim hiding ((<|>)) import Text.ICalendar.Types -- | Content lines, separated into components. 3.1. data Content = ContentLine P.SourcePos (CI Text) [(CI Text, [Text])] ByteString | Component P.SourcePos (CI Text) [Content] deriving (Show, Eq, Ord) type TextParser = P.Parsec ByteString DecodingFunctions type ContentParser = ErrorT String -- Fatal errors. (RWS DecodingFunctions [String] -- Warnings. (P.SourcePos, [Content])) -- | Functions for decoding 'ByteString's into 'Text'. data DecodingFunctions = DecodingFunctions { dfBS2Text :: ByteString -> Text , dfBS2IText :: ByteString -> CI Text } -- | UTF8. instance Default DecodingFunctions where def = DecodingFunctions TE.decodeUtf8 (CI.mk . TE.decodeUtf8) -- | Parse text. 3.3.11 parseText' :: ByteString -> ContentParser ([Text], ByteString) parseText' bs = do c <- asks dfBS2Text case runParser ((,) <$> texts <*> getInput) () "text" bs of Left e -> throwError $ "parseText': " ++ show e Right (x, r) -> return ( map (c . Bu.toLazyByteString) x , r) where texts = sepBy1 text (P.char ',') <|> return [mempty] text = do x <- P.satisfy isTSafe' case x of '\\' -> do y <- P.anyChar case y of '\\' -> nxt '\\' ';' -> nxt ';' ',' -> nxt ',' z | z `elem` ['n','N'] -> nxt '\n' _ -> fail $ "unexpected " ++ show x y -> nxt y -- isTSafe + 0x22, 0x3A, and 0x5C is pattern matched against. isTSafe' c = let n = ord c in n == 9 || (n >= 0x20 && n <= 0x2B) || (n >= 0x2D && n <= 0x3A) || (n >= 0x3C && n /= 0x7F) nxt c = (Bu.char8 c <>) <$> (text <|> return mempty) -- | Chech that there's no remainding text after the parser is done. noRestText :: ([Text], ByteString) -> ContentParser [Text] noRestText (x, "") = return x noRestText (_, x) = throwError $ "noRestText: remainding text: " ++ show x -- | Parse text, not allowing any remainding text. parseText :: ByteString -> ContentParser [Text] parseText = noRestText <=< parseText' -- | Parse a DateTime value. 3.3.5 parseDateTime :: Maybe Text -- ^ Time Zone ID -> ByteString -> ContentParser DateTime parseDateTime mTZ bs = do str <- asks $ T.unpack . ($ bs) . dfBS2Text let dayRes = parseDateStr str Just (day, rest') = dayRes t = take 1 rest' timeRes = parseTimeStr $ drop 1 rest' Just (time, isUTC) = timeRes when (isNothing (dayRes >> timeRes) || t /= "T") . throwError $ "parseDateTime: " ++ str when (isUTC && isJust mTZ) $ tell ["parseDateTime: TZID on UTC timezone: " ++ str] return $ case (mTZ, isUTC) of (Nothing, False) -> FloatingDateTime (LocalTime day time) (Just tz, False) -> ZonedDateTime (LocalTime day time) tz (_, True) -> UTCDateTime (UTCTime day $ Time.timeOfDayToTime time) -- | Parse a string to a Day. 3.3.4 parseDateStr :: String -> Maybe (Day, String) parseDateStr = lastToMaybe . Time.readSTime True defaultTimeLocale "%Y%m%d" -- | Parse a string to a TimeOfDay, and a bool if it's in UTC. parseTimeStr :: String -> Maybe (TimeOfDay, Bool) parseTimeStr s = do (t, r) <- lastToMaybe (Time.readSTime True defaultTimeLocale "%H%M%S" s) case r of "Z" -> return (t, True) "" -> return (t, False) _ -> fail "" -- | Parse a Date value. 3.3.4 parseDate :: ByteString -> ContentParser Date parseDate bs = do str <- asks $ T.unpack . ($ bs) . dfBS2Text let dayRes = parseDateStr str Just (day, rest) = dayRes when (isNothing dayRes) . throwError $ "parseDate: " ++ str unless (null rest) $ tell ["parseDate: extra content: " ++ rest] return $ Date day -- {{{ Misc parsers parseURI :: String -> ContentParser URI.URI parseURI s = case URI.parseURI s of Just x -> return x Nothing -> throwError $ "Invalid URI: " ++ show s -- | Convert a 'DateTime' to 'UTCTime', giving an appropriate error. mustBeUTC :: DateTime -> ContentParser UTCTime mustBeUTC (UTCDateTime x) = return x mustBeUTC _ = throwError "DateTime-value must be UTC" -- | Parse something simple with only a Text-field for the content, and -- 'OtherParams'. parseSimple :: (Text -> OtherParams -> b) -> Content -> ContentParser b parseSimple k (ContentLine _ _ o bs) = do c <- valueOnlyOne =<< parseText bs return $ k c (toO o) parseSimple _ x = throwError $ "parseSimple: " ++ show x -- | Parse something simple with only a CI Text-field for the content, and -- 'OtherParams'. parseSimpleI :: (CI Text -> OtherParams -> b) -> Content -> ContentParser b parseSimpleI k (ContentLine _ _ o bs) = do c <- asks dfBS2IText return $ k (c bs) (toO o) parseSimpleI _ x = throwError $ "parseSimpleI: " ++ show x -- | Parse something simple with only a Int-field for the content, and -- 'OtherParams'. parseSimpleRead :: forall a b. Read a => (a -> OtherParams -> b) -> Content -> ContentParser b parseSimpleRead k (ContentLine _ _ o bs) = do let r = maybeRead $ B.unpack bs :: Maybe a when (isNothing r) . throwError $ "parseSimpleRead: " ++ show bs return $ k (fromJust r) (toO o) parseSimpleRead _ x = throwError $ "parseSimpleRead: " ++ show x -- | Parse something b with alternative representations, language -- specification, and 'OtherParams'. parseAltRepLang' :: ([Text] -> ContentParser b) -> (b -> Maybe URI.URI -> Maybe Language -> OtherParams -> a) -> Content -> ContentParser a parseAltRepLang' m f (ContentLine _ _ o bs) = do t <- m =<< parseText bs uri <- mapM (parseURI <=< paramOnlyOne) $ T.unpack .: lookup "ALTREP" o lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o let o' = filter (\(x, _) -> x `notElem` ["ALTREP", "LANGUAGE"]) o return $ f t uri lang (toO o') parseAltRepLang' _ _ x = throwError $ "parseAltRepLang': " ++ show x -- | Parse something 'Text' with alternative representations, language -- specification, and 'OtherParams'. parseAltRepLang :: (Text -> Maybe URI.URI -> Maybe Language -> OtherParams -> a) -> Content -> ContentParser a parseAltRepLang = parseAltRepLang' lenientTextOnlyOne where lenientTextOnlyOne :: [Text] -> ContentParser Text lenientTextOnlyOne [x] = return x lenientTextOnlyOne [] = throwError "Must have one value, not zero." lenientTextOnlyOne xs = do tell ["Illegal comma in value that only allows one TEXT, assuming literal comma was intended."] return $ T.intercalate "," xs -- | Parse something '[Text]' with alternative representations, language -- specification, and 'OtherParams'. parseAltRepLangN :: (Set Text -> Maybe URI.URI -> Maybe Language -> OtherParams -> a) -> Content -> ContentParser a parseAltRepLangN = parseAltRepLang' (return . S.fromList) -- | Parse something simple with only a URI-field for the content, and -- 'OtherParams'. parseSimpleURI :: (URI.URI -> OtherParams -> a) -> Content -> ContentParser a parseSimpleURI f (ContentLine _ _ o bs) = do uri <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text) return . f uri $ toO o parseSimpleURI _ x = throwError $ "parseSimpleURI: " ++ show x -- | Parse something which has either a 'Date' or a 'DateTime' value, and -- 'OtherParams'. Uses DateTime if there is no value parameter. parseSimpleDateOrDateTime :: (DateTime -> OtherParams -> a) -> (Date -> OtherParams -> a) -> Content -> ContentParser a parseSimpleDateOrDateTime dt d (ContentLine _ _ o bs) = do (typ, tzid, o') <- typTzIdO o case typ of "DATE-TIME" -> do x <- parseDateTime tzid bs return . dt x $ toO o' "DATE" -> do x <- parseDate bs return . d x $ toO o' _ -> throwError $ "Invalid type: " ++ show typ parseSimpleDateOrDateTime _ _ x = throwError $ "parseSimpleDateOrDateTime: " ++ show x -- | Parse something which has a set of either a 'Date' or a 'DateTime' value, -- and 'OtherParams'. Uses DateTime if there is no value parameter. parseSimpleDatesOrDateTimes :: (Set DateTime -> OtherParams -> a) -> (Set Date -> OtherParams -> a) -> Content -> ContentParser a parseSimpleDatesOrDateTimes dt d (ContentLine _ _ o bs) = do (typ, tzid, o') <- typTzIdO o case typ of "DATE-TIME" -> do x <- S.fromList .: mapM (parseDateTime tzid) $ B.split ',' bs return . dt x $ toO o' "DATE" -> do x <- S.fromList .: mapM parseDate $ B.split ',' bs return . d x $ toO o' _ -> throwError $ "Invalid type: " ++ show typ parseSimpleDatesOrDateTimes _ _ x = throwError $ "parseSimpleDatesOrDateTimes: " ++ show x typTzIdO :: [(CI Text, [Text])] -> ContentParser (Text, Maybe Text, [(CI Text, [Text])]) typTzIdO o = do typ <- paramOnlyOne . fromMaybe ["DATE-TIME"] $ lookup "VALUE" o tzid <- mapM paramOnlyOne $ if typ == "DATE-TIME" then lookup "TZID" o else Nothing let f x = x /= "VALUE" && (typ /= "DATE-TIME" || x /= "TZID") o' = filter (f . fst) o return (typ, tzid, o') -- | Parse something which has only a DateTime value, and 'OtherParams'. parseSimpleDateTime :: (DateTime -> OtherParams -> a) -> Content -> ContentParser a parseSimpleDateTime dt (ContentLine _ _ o bs) = do tzid <- mapM paramOnlyOne $ lookup "TZID" o let o' = filter ((/="TZID") . fst) o flip dt (toO o') <$> parseDateTime tzid bs parseSimpleDateTime _ x = throwError $ "parseSimpleDateTime: " ++ show x parseSimpleUTC :: (UTCTime -> OtherParams -> a) -> Content -> ContentParser a parseSimpleUTC dt (ContentLine _ _ o bs) = flip dt (toO o) <$> (mustBeUTC =<< parseDateTime Nothing bs) parseSimpleUTC _ x = throwError $ "parseSimpleUTC: " ++ show x -- | Convert a property dictionary to 'OtherParams'. toO :: [(CI Text, [Text])] -> OtherParams toO = OtherParams . S.fromList . map (uncurry OtherParam) -- | Get the remaining properties. otherProperties :: ContentParser (Set OtherProperty) otherProperties = do opts <- snd <$> get modify (second $ const []) S.fromList <$> mapM lineToOtherProp opts where lineToOtherProp (ContentLine _ n opts bs) = return (OtherProperty n bs $ toO opts) lineToOtherProp c@Component {} = down c . throwError $ "Unconsumed component: " ++ show c neg :: TextParser (Int -> Int) neg = maybe id (\x -> if x == '-' then negate else id) <$> optional (P.oneOf "+-") digits :: TextParser Int digits = foldl1 ((+).(*10)) . map digitToInt <$> many1 P.digit digitsN :: TextParser [Int] digitsN = sepBy1 digits (P.char ',') -- }}} -- | Set the parser context. down :: Content -> ContentParser a -> ContentParser a down (Component p _ x) = down' (p, x) down x@(ContentLine p _ _ _) = down' (p, [x]) -- | Set the parser context. down' :: (P.SourcePos, [Content]) -> ContentParser a -> ContentParser a down' x m = get >>= \old -> put x >> m <* put old -- | Many optional components named ... optCompN :: Ord a => CI Text -> (Content -> ContentParser a) -> ContentParser (Set a) optCompN s f = optN f . partition (`isComponentNamed` s) =<< snd <$> get -- | One required line named ... reqLine1 :: CI Text -> (Content -> ContentParser a) -> ContentParser a reqLine1 s f = req1 s f . partition (`isLineNamed` s) =<< snd <$> get -- | One optional line named ... optLine1 :: Default b => CI Text -> (Content -> ContentParser b) -> ContentParser b optLine1 s f = opt1 f . partition (`isLineNamed` s) =<< snd <$> get -- | Many optional lines named ... optLineN :: Ord b => CI Text -> (Content -> ContentParser b) -> ContentParser (Set b) optLineN s f = optN f . partition (`isLineNamed` s) =<< snd <$> get -- | Many lines named ..., at least one required. reqLineN :: Ord b => CI Text -> (Content -> ContentParser b) -> ContentParser (Set b) reqLineN s f = reqN s f . partition (`isLineNamed` s) =<< snd <$> get -- | One required ... req1 :: CI Text -> (Content -> ContentParser b) -> ([Content], [Content]) -> ContentParser b req1 _ f ([x], xs) = modify (second $ const xs) >> down x (f x) req1 s _ ([], _) = throwError $ "Missing content: " ++ show s req1 _ f (x:xs, xs') = do modify (second $ const xs') tell (map (("Extra content: " ++) . show) xs) down x $ f x -- | One optional ... opt1 :: Default b => (Content -> ContentParser b) -> ([Content], [Content]) -> ContentParser b opt1 f ([x], xs) = modify (second $ const xs) >> down x (f x) opt1 _ ([], _) = return def opt1 f (x:xs, xs') = do modify (second $ const xs') tell (map (("Extra content: " ++) . show) xs) down x $ f x -- | Many optional ... optN :: Ord b => (Content -> ContentParser b) -> ([Content], [Content]) -> ContentParser (Set b) optN f (xs, xs') = do modify (second $ const xs') S.fromList <$> mapM (\x -> down x (f x)) xs -- | Many ..., at least one required. reqN :: Ord b => CI Text -- ^ What, needed for the error. -> (Content -> ContentParser b) -> ([Content], [Content]) -> ContentParser (Set b) reqN w f (xs, xs') = do modify (second $ const xs') o <- S.fromList <$> mapM (\x -> down x (f x)) xs when (S.size o < 1) . throwError $ "At least one required: " ++ show w return o -- | Only allow one parameter value. paramOnlyOne :: [a] -> ContentParser a paramOnlyOne [x] = return x paramOnlyOne _ = throwError "Only one parameter value allowed." valueOnlyOne :: [a] -> ContentParser a valueOnlyOne [x] = return x valueOnlyOne [] = throwError "Must have one value, not zero." valueOnlyOne _ = throwError "Only one value allowed." -- | Line predicate. isLineNamed :: Content -> CI Text -> Bool isLineNamed (ContentLine _ n _ _) n' | n == n' = True isLineNamed _ _ = False -- | Component name predicate. isComponentNamed :: Content -> CI Text -> Bool isComponentNamed (Component _ n _) n' | n == n' = True isComponentNamed _ _ = False isComponent :: Content -> Bool isComponent Component {} = True isComponent _ = False -- Util maybeRead :: Read a => String -> Maybe a maybeRead = fst .: lastToMaybe . reads lastToMaybe :: [a] -> Maybe a lastToMaybe x = if null x then Nothing else Just $ last x (.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (.:) = fmap fmap fmap infixl 4 .: iCalendar-0.4.0.3/Text/ICalendar/Parser/Components.hs0000644000000000000000000003260512540267567020433 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Text.ICalendar.Parser.Components where import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad.Error hiding (mapM) import Control.Monad.RWS (MonadState (get), tell) import qualified Data.CaseInsensitive as CI import qualified Data.Foldable as F import Data.List (partition) import qualified Data.Map as M import Data.Maybe import Data.Set (Set) import qualified Data.Set as S import Text.ICalendar.Parser.Common import Text.ICalendar.Parser.Properties import Text.ICalendar.Types -- | Parse a VCALENDAR component. 3.4 parseVCalendar :: Content -> ContentParser VCalendar parseVCalendar c@(Component _ "VCALENDAR" _) = down c $ do vcProdId <- reqLine1 "PRODID" (parseSimple ProdId) vcVersion <- reqLine1 "VERSION" parseVersion vcScale <- optLine1 "CALSCALE" (parseSimpleI Scale) vcMethod <- optLine1 "METHOD" (parseSimpleI ((Just .) . Method)) vcTimeZones <- f (tzidValue . vtzId) =<< optCompN "VTIMEZONE" parseVTimeZone vcEvents <- f (uidValue . veUID &&& recur . veRecurId) =<< optCompN "VEVENT" (parseVEvent vcMethod) vcTodos <- f (uidValue . vtUID &&& recur . vtRecurId) =<< optCompN "VTODO" parseVTodo vcJournals <- f (uidValue . vjUID &&& recur . vjRecurId) =<< optCompN "VJOURNAL" parseVJournal vcFreeBusys <- f (uidValue . vfbUID) =<< optCompN "VFREEBUSY" parseVFreeBusy vcOtherComps <- otherComponents vcOther <- otherProperties return VCalendar {..} where recur :: Maybe RecurrenceId -> Maybe (Either Date DateTime) recur Nothing = Nothing recur (Just (RecurrenceIdDate x _ _)) = Just (Left x) recur (Just (RecurrenceIdDateTime x _ _)) = Just (Right x) f :: Ord b => (a -> b) -> Set a -> ContentParser (M.Map b a) f g = F.foldlM h M.empty where h m e = let k = g e in if k `M.member` m then throwError "Duplicate UID/RecurId/TZID." else return $ M.insert k e m parseVCalendar _ = throwError "parseVCalendar: Content given not a VCALENDAR\ \ component." -- | Parse a VEVENT component. 3.6.1 parseVEvent :: Maybe Method -> Content -> ContentParser VEvent parseVEvent mmethod (Component _ "VEVENT" _) = do veDTStamp <- reqLine1 "DTSTAMP" $ parseSimpleUTC DTStamp veUID <- reqLine1 "UID" $ parseSimple UID veDTStart <- optLine1 "DTSTART" $ Just .: parseSimpleDateOrDateTime DTStartDateTime DTStartDate when (isNothing mmethod && isNothing veDTStart) $ throwError "A VEVENT in a VCALENDAR without a METHOD requires a \ \DTSTART property." veClass <- optLine1 "CLASS" parseClass veCreated <- optLine1 "CREATED" (Just .: parseCreated) veDescription <- optLine1 "DESCRIPTION" . parseAltRepLang $ (((Just .) .) .) . Description veGeo <- optLine1 "GEO" (Just .: parseGeo) veLastMod <- optLine1 "LAST-MODIFIED" (Just .: parseLastModified) veLocation <- optLine1 "LOCATION" . parseAltRepLang $ (((Just .) .) .) . Location veOrganizer <- optLine1 "ORGANIZER" (Just .: parseOrganizer) vePriority <- optLine1 "PRIORITY" (parseSimpleRead Priority) veSeq <- optLine1 "SEQUENCE" (parseSimpleRead Sequence) veStatus <- optLine1 "STATUS" (Just .: parseEventStatus) veSummary <- optLine1 "SUMMARY" . parseAltRepLang $ (((Just .) .) .) . Summary veTransp <- optLine1 "TRANSP" parseTransp veUrl <- optLine1 "URL" (Just .: parseSimpleURI URL) veRecurId <- optLine1 "RECURRENCE-ID" $ Just .: parseRecurId veDTStart veRRule <- optLineN "RRULE" $ parseRRule veDTStart when (S.size veRRule > 1) $ tell ["SHOULD NOT have multiple RRules."] veDTEndDuration <- parseXDurationOpt "DTEND" DTEndDateTime DTEndDate veDTStart veAttach <- optLineN "ATTACH" parseAttachment veAttendee <- optLineN "ATTENDEE" parseAttendee veCategories <- optLineN "CATEGORIES" parseCategories veComment <- optLineN "COMMENT" $ parseAltRepLang Comment veContact <- optLineN "CONTACT" $ parseAltRepLang Contact veExDate <- optLineN "EXDATE" parseExDate veRStatus <- optLineN "REQUEST-STATUS" parseRequestStatus veRelated <- optLineN "RELATED-TO" parseRelatedTo veResources <- optLineN "RESOURCES" $ parseAltRepLangN Resources veRDate <- optLineN "RDATE" parseRDate veAlarms <- optCompN "VALARM" parseVAlarm veOther <- otherProperties return VEvent {..} parseVEvent _ x = throwError $ "parseVEvent: " ++ show x -- | Parse a VTODO component. parseVTodo :: Content -> ContentParser VTodo parseVTodo (Component _ "VTODO" _) = do vtDTStamp <- reqLine1 "DTSTAMP" $ parseSimpleUTC DTStamp vtUID <- reqLine1 "UID" $ parseSimple UID vtClass <- optLine1 "CLASS" parseClass vtCompleted <- optLine1 "COMPLETED" . parseSimpleDateTime $ (Just .) . Completed vtCreated <- optLine1 "CREATED" (Just .: parseCreated) vtDTStart <- optLine1 "DTSTART" $ Just .: parseSimpleDateOrDateTime DTStartDateTime DTStartDate vtDescription <- optLine1 "DESCRIPTION" . parseAltRepLang $ (((Just .) .) .) . Description vtGeo <- optLine1 "GEO" (Just .: parseGeo) vtLastMod <- optLine1 "LAST-MODIFIED" (Just .: parseLastModified) vtLocation <- optLine1 "LOCATION" . parseAltRepLang $ (((Just .) .) .) . Location vtOrganizer <- optLine1 "ORGANIZER" (Just .: parseOrganizer) vtPercent <- optLine1 "PERCENT-COMPLETE" $ Just .: parseSimpleRead PercentComplete vtPriority <- optLine1 "PRIORITY" $ parseSimpleRead Priority vtRecurId <- optLine1 "RECURRENCE-ID" (Just .: parseRecurId vtDTStart) vtSeq <- optLine1 "SEQUENCE" $ parseSimpleRead Sequence vtStatus <- optLine1 "STATUS" (Just .: parseTodoStatus) vtSummary <- optLine1 "SUMMARY" . parseAltRepLang $ (((Just .) .) .) . Summary vtUrl <- optLine1 "URL" (Just .: parseSimpleURI URL) vtRRule <- optLineN "RRULE" $ parseRRule vtDTStart when (S.size vtRRule > 1) $ tell ["SHOULD NOT have multiple RRules."] vtDueDuration <- parseXDurationOpt "DUE" DueDateTime DueDate vtDTStart vtAttach <- optLineN "ATTACH" parseAttachment vtAttendee <- optLineN "ATTENDEE" parseAttendee vtCategories <- optLineN "CATEGORIES" parseCategories vtComment <- optLineN "COMMENT" $ parseAltRepLang Comment vtContact <- optLineN "CONTACT" $ parseAltRepLang Contact vtExDate <- optLineN "EXDATE" parseExDate vtRStatus <- optLineN "REQUEST-STATUS" parseRequestStatus vtRelated <- optLineN "RELATED-TO" parseRelatedTo vtResources <- optLineN "RESOURCES" $ parseAltRepLangN Resources vtRDate <- optLineN "RDATE" parseRDate vtAlarms <- optCompN "VALARM" parseVAlarm vtOther <- otherProperties return VTodo {..} parseVTodo x = throwError $ "parseVTodo: " ++ show x -- | Parse a VTIMEZONE component. 3.6.5 parseVTimeZone :: Content -> ContentParser VTimeZone parseVTimeZone (Component _ "VTIMEZONE" _) = do vtzId <- reqLine1 "TZID" parseTZID vtzLastMod <- optLine1 "LAST-MODIFIED" (Just .: parseLastModified) vtzUrl <- optLine1 "TZURL" (Just .: parseSimpleURI TZUrl) vtzStandardC <- optCompN "STANDARD" parseTZProp vtzDaylightC <- optCompN "DAYLIGHT" parseTZProp when (S.size vtzStandardC + S.size vtzDaylightC < 1) . throwError $ "VTIMEZONE must include at least one of the STANDARD or \ \DAYLIGHT components." vtzOther <- otherProperties return VTimeZone {..} parseVTimeZone x = throwError $ "parseVTimeZone: " ++ show x -- | Parse a STANDARD or DAYLIGHT component, tzprop. 3.6.5 parseTZProp :: Content -> ContentParser TZProp parseTZProp (Component _ n _) | n `elem` ["STANDARD", "DAYLIGHT"] = do tzpDTStart <- reqLine1 "DTSTART" $ parseSimpleDateOrDateTime DTStartDateTime DTStartDate tzpTZOffsetTo <- reqLine1 "TZOFFSETTO" parseUTCOffset tzpTZOffsetFrom <- reqLine1 "TZOFFSETFROM" parseUTCOffset tzpRRule <- optLineN "RRULE" (parseRRule $ Just tzpDTStart) when (S.size tzpRRule > 1) $ tell ["SHOULD NOT have multiple RRules."] tzpComment <- optLineN "COMMENT" (parseAltRepLang Comment) tzpRDate <- optLineN "RDATE" parseRDate tzpTZName <- optLineN "TZNAME" parseTZName tzpOther <- otherProperties return TZProp {..} parseTZProp x = throwError $ "parseTZProp: " ++ show x -- | Parse a VALARM component. 3.6.6 parseVAlarm :: Content -> ContentParser VAlarm parseVAlarm (Component _ "VALARM" _) = do (ao, a') <- reqLine1 "ACTION" (\(ContentLine _ _ o bs) -> return (o, bs)) a <- valueOnlyOne =<< parseText a' vaTrigger <- reqLine1 "TRIGGER" parseTrigger let vaActionOther = toO ao case CI.mk a of "AUDIO" -> do (vaRepeat, vaDuration) <- repAndDur vaAudioAttach <- optLine1 "ATTACH" $ Just .: parseAttachment vaOther <- otherProperties return VAlarmAudio {..} "DISPLAY" -> do (vaRepeat, vaDuration) <- repAndDur vaDescription <- reqLine1 "DESCRIPTION" $ parseAltRepLang Description vaOther <- otherProperties return VAlarmDisplay {..} "EMAIL" -> do (vaRepeat, vaDuration) <- repAndDur vaDescription <- reqLine1 "DESCRIPTION" $ parseAltRepLang Description vaSummary <- reqLine1 "SUMMARY" $ parseAltRepLang Summary vaAttendee <- reqLineN "ATTENDEE" parseAttendee vaMailAttach <- optLineN "ATTACH" parseAttachment vaOther <- otherProperties return VAlarmEmail {..} vaAction -> do vaOther <- otherProperties return VAlarmX {..} where repAndDur = do rep <- optLine1 "REPEAT" $ parseSimpleRead Repeat dur <- optLine1 "DURATION" $ Just .: parseDurationProp Nothing -- Liberal interpretation: when (repeatValue rep > 0 && isNothing dur) . throwError $ "parseVAlarm: when REPEAT > 0, DURATION must \ \ be specified." return (rep, dur) parseVAlarm x = throwError $ "parseVAlarm: " ++ show x parseVJournal :: Content -> ContentParser VJournal parseVJournal (Component _ "VJOURNAL" _) = do vjDTStamp <- reqLine1 "DTSTAMP" $ parseSimpleUTC DTStamp vjUID <- reqLine1 "UID" $ parseSimple UID vjClass <- optLine1 "CLASS" parseClass vjCreated <- optLine1 "CREATED" (Just .: parseCreated) vjDTStart <- optLine1 "DTSTART" $ Just .: parseSimpleDateOrDateTime DTStartDateTime DTStartDate vjDescription <- optLineN "DESCRIPTION" $ parseAltRepLang Description vjLastMod <- optLine1 "LAST-MODIFIED" (Just .: parseLastModified) vjOrganizer <- optLine1 "ORGANIZER" (Just .: parseOrganizer) vjRecurId <- optLine1 "RECURRENCE-ID" (Just .: parseRecurId vjDTStart) vjSeq <- optLine1 "SEQUENCE" $ parseSimpleRead Sequence vjStatus <- optLine1 "STATUS" (Just .: parseJournalStatus) vjSummary <- optLine1 "SUMMARY" . parseAltRepLang $ (((Just .) .) .) . Summary vjUrl <- optLine1 "URL" (Just .: parseSimpleURI URL) vjRRule <- optLineN "RRULE" $ parseRRule vjDTStart when (S.size vjRRule > 1) $ tell ["SHOULD NOT have multiple RRules."] vjAttach <- optLineN "ATTACH" parseAttachment vjAttendee <- optLineN "ATTENDEE" parseAttendee vjCategories <- optLineN "CATEGORIES" parseCategories vjComment <- optLineN "COMMENT" $ parseAltRepLang Comment vjContact <- optLineN "CONTACT" $ parseAltRepLang Contact vjExDate <- optLineN "EXDATE" parseExDate vjRStatus <- optLineN "REQUEST-STATUS" parseRequestStatus vjRelated <- optLineN "RELATED-TO" parseRelatedTo vjRDate <- optLineN "RDATE" parseRDate vjOther <- otherProperties return VJournal {..} parseVJournal x = throwError $ "parseVJournal: " ++ show x parseVFreeBusy :: Content -> ContentParser VFreeBusy parseVFreeBusy (Component _ "VFreeBusy" _) = do vfbDTStamp <- reqLine1 "DTSTAMP" $ parseSimpleUTC DTStamp vfbUID <- reqLine1 "UID" $ parseSimple UID vfbContact <- optLine1 "CONTACT" $ Just .: parseAltRepLang Contact vfbDTStart <- optLine1 "DTSTART" $ Just .: parseSimpleDateOrDateTime DTStartDateTime DTStartDate vfbDTEnd <- optLine1 "DTEND" $ Just .: parseSimpleDateOrDateTime DTEndDateTime DTEndDate vfbOrganizer <- optLine1 "ORGANIZER" $ Just .: parseOrganizer vfbAttendee <- optLineN "ATTENDEE" parseAttendee vfbComment <- optLineN "COMMENT" $ parseAltRepLang Comment vfbRStatus <- optLineN "REQUEST-STATUS" parseRequestStatus vfbUrl <- optLine1 "URL" (Just .: parseSimpleURI URL) vfbFreeBusy <- optLineN "FREEBUSY" parseFreeBusy vfbOther <- otherProperties return VFreeBusy {..} parseVFreeBusy x = throwError $ "parseVFreeBusy: " ++ show x otherComponents :: ContentParser (Set VOther) otherComponents = optN parseVOther . partition isComponent =<< snd <$> get parseVOther :: Content -> ContentParser VOther parseVOther (Component _ voName _) = do voProps <- otherProperties return VOther {..} parseVOther x = throwError $ "parseVOther: "++ show x iCalendar-0.4.0.3/Text/ICalendar/Parser/Content.hs0000644000000000000000000001022612540267567017713 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Text.ICalendar.Parser.Content where import Control.Applicative import Control.Monad import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Builder as Bu import Data.CaseInsensitive (CI) import Data.Char import Data.Monoid import Data.Text.Lazy (Text) import qualified Text.Parsec as P import Text.Parsec.ByteString.Lazy () import Text.Parsec.Combinator hiding (optional) import Text.Parsec.Prim hiding (many, (<|>)) import Text.Parsec.Text.Lazy () import Text.ICalendar.Parser.Common parseToContent :: TextParser [Content] parseToContent = do content <- sepEndBy1 contentline newline f <- dfBS2IText <$> getState return $ componentalize f content newline :: TextParser () newline = (char '\r' >> void (optional $ char '\n')) <|> void (char '\n') componentalize :: (ByteString -> CI Text) -> [Content] -> [Content] componentalize f (ContentLine p "BEGIN" [] n:xs) = let (com, rest) = break g xs g (ContentLine _ "END" [] en) | f en == n' = True g _ = False n' = f n in Component p n' (componentalize f com) : componentalize f (drop 1 rest) componentalize f (x:xs) = x:componentalize f xs componentalize _ _ = [] -- | Specialized scan function which unfolds lines. scan :: s -- ^ Initial state. -> (s -> Maybe Char -> Maybe (Maybe s)) -- ^ Nothing: Fail. -- Just Nothing: Done, don't use last char. -- Just (Just state): Continue, collecting char unless EOF. -> TextParser ByteString scan state f = go state mempty where go st buf = do _ <- many (try unfold) c <- lookAhead (Just <$> P.anyChar <|> Nothing <$ P.eof) case (c, f st c) of (_, Nothing) -> mzero (Just c', Just (Just st')) -> P.anyChar *> go st' (buf <> Bu.char8 c') (_, _) -> return $ Bu.toLazyByteString buf unfold = (P.char '\r' >> optional (P.char '\n') >> P.oneOf " \t") <|> (P.char '\n' >> P.oneOf " \t") takeWhile1 :: (Char -> Bool) -> TextParser ByteString takeWhile1 p = scan False f "takeWhile1 ..." where f g (Just x) | p x = Just (Just True) | g = Just Nothing | otherwise = Nothing f g _ | g = Just Nothing | otherwise = Nothing char :: Char -> TextParser ByteString char c = scan True f show c where f True x = if Just c == x then Just (Just False) else Nothing f False _ = Just Nothing isControl', isSafe, isValue, isQSafe, isName :: Char -> Bool isControl' c = c /= '\t' && isControl c isSafe c = not (isControl' c) && c `notElem` ("\";:,"::String) isValue c = let n = fromEnum c in n == 32 || n == 9 || (n >= 0x21 && n /= 0x7F) isQSafe c = isValue c && c /= '"' isName c = isAsciiUpper c || isAsciiLower c || isDigit c || c == '-' contentline :: TextParser Content contentline = do pos <- getPosition n <- name ps <- many (char ';' >> param) _ <- char ':' val <- value <|> return mempty return $ ContentLine pos n ps val where value :: TextParser ByteString value = takeWhile1 isValue "value" param :: TextParser (CI Text, [Text]) param = do n <- name _ <- char '=' vs <- sepBy1 paramValue (char ',') return (n, vs) name :: TextParser (CI Text) name = dfBS2IText <$> getState <*> takeWhile1 isName "name" paramValue :: TextParser Text paramValue = paramtext <|> quotedString paramtext :: TextParser Text paramtext = dfBS2Text <$> getState <*> takeWhile1 isSafe "paramtext" quotedString :: TextParser Text quotedString = (do _ <- char '"' s <- takeWhile1 isQSafe <|> return mempty _ <- char '"' dfBS2Text <$> getState <*> pure s) "quoted string" iCalendar-0.4.0.3/Text/ICalendar/Parser/Parameters.hs0000644000000000000000000002127212540267567020407 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Text.ICalendar.Parser.Parameters where import Control.Applicative import Control.Monad.Error import Control.Monad.RWS (MonadWriter (tell)) import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as B import Data.CaseInsensitive (CI) import Data.Char import Data.Default import Data.Maybe import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import Codec.MIME.Parse (parseMIMEType) import Codec.MIME.Type (MIMEType, mimeType) import qualified Text.Parsec as P import Text.Parsec.Combinator hiding (optional) import Text.Parsec.Perm import Text.Parsec.Prim hiding ((<|>)) import Text.ICalendar.Parser.Common import Text.ICalendar.Types parseAlarmTriggerRelationship :: CI Text -> ContentParser AlarmTriggerRelationship parseAlarmTriggerRelationship "START" = return Start parseAlarmTriggerRelationship "END" = return End parseAlarmTriggerRelationship x = throwError $ "parseAlarmTriggerRelationship: " ++ show x -- | Parse relationship type. 3.2.15 parseRelationshipType :: CI Text -> RelationshipType parseRelationshipType "PARENT" = Parent parseRelationshipType "CHILD" = Child parseRelationshipType "SIBLING" = Sibling parseRelationshipType x = RelationshipTypeX x -- | Parse bool. 3.3.2 parseBool :: CI Text -> ContentParser Bool parseBool "TRUE" = return True parseBool "FALSE" = return False parseBool x = throwError $ "parseBool: " ++ show x -- | Parse recurrence identifier range. 3.2.13 parseRange :: CI Text -> ContentParser Range parseRange "THISANDFUTURE" = return ThisAndFuture parseRange "THISANDPRIOR" = do tell ["THISANDPRIOIR RANGE is deprecated."] return ThisAndPrior parseRange x = throwError $ "parseRange: " ++ show x -- | Parse free/busy time type. 3.2.9. parseFBType :: CI Text -> FBType parseFBType "FREE" = Free parseFBType "BUSY" = Busy parseFBType "BUSY-UNAVAILABLE" = BusyUnavailable parseFBType "BUSY-TENTATIVE" = BusyTentative parseFBType x = FBTypeX x -- | Parse participation status. 3.2.12 parsePartStat :: CI Text -> PartStat parsePartStat "NEEDS-ACTION" = PartStatNeedsAction parsePartStat "ACCEPTED" = Accepted parsePartStat "DECLINED" = Declined parsePartStat "TENTATIVE" = Tentative parsePartStat "DELEGATED" = Delegated parsePartStat "COMPLETED" = PartStatCompleted parsePartStat "IN-PROCESS" = InProcess parsePartStat x = PartStatX x -- | Parse role. parseRole :: CI Text -> Role parseRole "CHAIR" = Chair parseRole "REQ-PARTICIPANT" = ReqParticipant parseRole "OPT-PARTICIPANT" = OptParticipant parseRole "NON-PARTICIPANT" = NonParticipant parseRole x = RoleX x parseCUType :: CI Text -> CUType parseCUType "INDIVIDUAL" = Individual parseCUType "GROUP" = Group parseCUType "RESOURCE" = Resource parseCUType "ROOM" = Room parseCUType "UNKNOWN" = Unknown parseCUType x = CUTypeX x parseMime :: Text -> ContentParser MIMEType parseMime t = let m = mimeType .: parseMIMEType $ T.toStrict t in maybe (throwError $ "parseMime: " ++ show t) return m -- | Parse Duration. 3.3.6 parseDuration :: String -- ^ Parser context. -> ByteString -- ^ What to parse. -> ContentParser Duration parseDuration what bs = case runParser dur def what bs of Left e -> throwError $ "Invalid duration: " ++ unlines [show bs, show e] Right x -> return x where dur = do si <- sign _ <- P.char 'P' day <- optional . try $ digits <* P.char 'D' time <- optional $ do _ <- P.char 'T' h <- optional . try $ digits <* P.char 'H' m <- optional . try $ digits <* P.char 'M' s <- optional . try $ digits <* P.char 'S' return (h, m, s) week <- optional . try $ digits <* P.char 'W' P.eof case (day, time, week) of (Just d, x, Nothing) -> let (h, m, s) = deMHms x in return $ DurationDate si d h m s (Nothing, x@(Just _), Nothing) -> let (h, m, s) = deMHms x in return $ DurationTime si h m s (Nothing, Nothing, Just w) -> return $ DurationWeek si w (_, _, _) -> fail "Invalid." sign = fromMaybe Positive <$> optional (Positive <$ P.char '+' <|> Negative <$ P.char '-') deMHms (Just (h, m, s)) = (fromMaybe 0 h, fromMaybe 0 m, fromMaybe 0 s) deMHms Nothing = (0, 0, 0) -- | Parse Recur-value. 3.3.10. -- Partly implemented in parsec. parseRecur :: DTStart -> TextParser (ContentParser Recur) parseRecur dts = permute (mkRecur <$$> (freq <* term) <|?> (Nothing, untilCount <* term) <|?> (1, istring "INTERVAL=" *> digits <* term) <|?> ([], istring "BYSECOND=" *> digitsN <* term) <|?> ([], istring "BYMINUTE=" *> digitsN <* term) <|?> ([], istring "BYHOUR=" *> digitsN <* term) <|?> ([], istring "BYDAY=" *> sepBy wday (P.char ',') <* term) <|?> ([], istring "BYMONTHDAY=" *> onum <* term) <|?> ([], istring "BYYEARDAY=" *> onum <* term) <|?> ([], istring "BYWEEKNO=" *> onum <* term) <|?> ([], istring "BYMONTH=" *> digitsN <* term) <|?> ([], istring "BYSETPOS=" *> onum <* term) <|?> (Monday, istring "WKST=" *> weekday <* term)) <* P.eof where freq = istring "FREQ=" *> frequency frequency = Secondly <$ istring "SECONDLY" <|> Minutely <$ istring "MINUTELY" <|> Hourly <$ istring "HOURLY" <|> Daily <$ istring "DAILY" <|> Weekly <$ istring "WEEKLY" <|> Monthly <$ istring "MONTHLY" <|> Yearly <$ istring "YEARLY" weekday = Sunday <$ istring "SU" <|> Monday <$ istring "MO" <|> Tuesday <$ istring "TU" <|> Wednesday <$ istring "WE" <|> Thursday <$ istring "TH" <|> Friday <$ istring "FR" <|> Saturday <$ istring "SA" wday = Right <$> weekday <|> (Left .) . (,) <$> (neg <*> digits) <*> weekday onum = sepBy1 (neg <*> digits) (P.char ',') untilCount = istring "UNTIL=" *> until' <|> istring "COUNT=" *> (Just . Right <$> digits) until' = do txt <- manyTill P.anyChar (void (P.char ';') <|> P.eof) return . Just . Left $ case dts of DTStartDateTime _ _ -> Right <$> parseDateTime Nothing (B.pack txt) DTStartDate _ _ -> Left <$> parseDate (B.pack txt) term = optional (P.char ';') istring :: String -> TextParser () istring = void . try . mapM (\c -> P.char c <|> P.char (toLower c)) mkRecur f uc i s m h d md yd wn mo sp wkst = do uc' <- case uc of Just (Left x) -> Just . Left <$> x Just (Right y) -> return . Just $ Right y Nothing -> return Nothing return $ Recur f uc' i s m h d md yd wn mo sp wkst parseUTCPeriod :: ByteString -> ContentParser UTCPeriod parseUTCPeriod bs = do let (dateTime', x) = B.drop 1 <$> B.break (=='/') bs when (B.null x) . throwError $ "Invalid UTCperiod: " ++ show bs dateTime <- mustBeUTC =<< parseDateTime Nothing dateTime' case B.head x of z | z `elem` ("+-P"::String) -> UTCPeriodDuration dateTime <$> parseDuration "period" x _ -> UTCPeriodDates dateTime <$> (mustBeUTC =<< parseDateTime Nothing x) parsePeriod :: Maybe Text -> ByteString -> ContentParser Period parsePeriod tzid bs = do let (dateTime', x) = B.drop 1 <$> B.break (=='/') bs when (B.null x) . throwError $ "Invalid period: " ++ show bs dateTime <- parseDateTime tzid dateTime' case B.head x of z | z `elem` ("+-P"::String) -> PeriodDuration dateTime <$> parseDuration "period" x _ -> PeriodDates dateTime <$> parseDateTime tzid x iCalendar-0.4.0.3/Text/ICalendar/Parser/Properties.hs0000644000000000000000000004355112540267567020444 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} module Text.ICalendar.Parser.Properties where import Control.Applicative import Control.Monad.Error hiding (mapM) import Control.Monad.RWS (asks) import qualified Data.ByteString.Base64.Lazy as B64 import qualified Data.ByteString.Lazy.Char8 as B import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Char import Data.Default import Data.Maybe import qualified Data.Set as S import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import Data.Traversable (mapM) import qualified Data.Version as Ver import Prelude hiding (mapM) import Text.ParserCombinators.ReadP (readP_to_S) import Text.Parsec.Prim hiding ((<|>)) import Text.ICalendar.Parser.Common import Text.ICalendar.Parser.Parameters import Text.ICalendar.Types parseFreeBusy :: Content -> ContentParser FreeBusy parseFreeBusy (ContentLine _ "FREEBUSY" o bs) = do typ <- maybe (return def) (parseFBType . CI.mk .: paramOnlyOne) $ lookup "FBTYPE" o periods <- S.fromList .: mapM parseUTCPeriod $ B.split ',' bs return $ FreeBusy typ periods (toO $ filter ((/="FBTYPE").fst) o) parseFreeBusy x = throwError $ "parseFreeBusy: " ++ show x parseXDurationOpt :: CI Text -> (DateTime -> OtherParams -> a) -> (Date -> OtherParams -> a) -> Maybe DTStart -> ContentParser (Maybe (Either a DurationProp)) parseXDurationOpt w a b dts = do dte <- optLine1 w $ Just .: parseSimpleDateOrDateTime a b dur <- optLine1 "DURATION" $ Just .: parseDurationProp dts case (dte, dur) of (Nothing, Nothing) -> return Nothing (Just x, Nothing) -> return . Just $ Left x (Nothing, Just x) -> return . Just $ Right x _ -> throwError "Either DTEND or DURATION can be specified, but not \ \both." -- | Parse trigger. 3.8.6.3 parseTrigger :: Content -> ContentParser Trigger parseTrigger (ContentLine _ "TRIGGER" o bs) = do value <- paramOnlyOne . fromMaybe ["DURATION"] $ lookup "VALUE" o case value of "DURATION" -> do rel <- maybe (return def) (parseAlarmTriggerRelationship . CI.mk <=< paramOnlyOne) $ lookup "RELATED" o let o' = filter (\(x,_) -> x /= "VALUE" && x /= "RELATED") o val <- parseDuration "TRIGGER" bs return $ TriggerDuration val rel (toO o') "DATE-TIME" -> do val <- mustBeUTC =<< parseDateTime Nothing bs let o' = filter (\(x, _) -> x /= "VALUE") o return $ TriggerDateTime val (toO o') x -> throwError $ "parseTrigger: invalid value: " ++ show x parseTrigger x = throwError $ "parseTrigger: " ++ show x -- | Parse related to. 3.8.4.5 parseRelatedTo :: Content -> ContentParser RelatedTo parseRelatedTo (ContentLine _ "RELATED-TO" o bs) = do val <- valueOnlyOne =<< parseText bs typ <- maybe (return def) (parseRelationshipType . CI.mk .: paramOnlyOne) $ lookup "RELTYPE" o return $ RelatedTo val typ (toO $ filter (\(x,_) -> x /= "RELTYPE") o) parseRelatedTo x = throwError $ "parseRelatedTo: " ++ show x -- | Parse request status. 3.8.8.3 parseRequestStatus :: Content -> ContentParser RequestStatus parseRequestStatus (ContentLine _ "REQUEST-STATUS" o bs) = do let (statcode', rest) = B.break (==';') bs statcode :: Maybe [Int] statcode = mapM (maybeRead . B.unpack) $ B.split '.' statcode' when (isNothing statcode) . throwError $ "parseRequestStatus: invalid code: " ++ show bs when (B.null rest) . throwError $ "parseRequestStatus: missing statdesc: " ++ show bs (statdesc, rest') <- (\(a,b) -> (,b) <$> valueOnlyOne a) <=< parseText' $ B.tail rest statext <- if B.null rest' then return Nothing else do when (B.head rest' /= ';') . throwError $ "parseRequestStatus: bad desc: " ++ show bs Just <$> (valueOnlyOne =<< parseText (B.tail rest')) lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o let o' = filter (\(x, _) -> x `notElem` ["LANGUAGE"]) o return $ RequestStatus (fromJust statcode) statdesc lang statext (toO o') parseRequestStatus x = throwError $ "parseRequestStatus: " ++ show x -- | Parse exception date-times. 3.8.5.1 parseExDate :: Content -> ContentParser ExDate parseExDate (ContentLine _ "EXDATE" o bs) = do (typ, tzid, o') <- typTzIdO o let bs' = B.split ',' bs case typ of "DATE-TIME" -> do xs <- mapM (parseDateTime tzid) bs' return . ExDateTimes (S.fromList xs) $ toO o' "DATE" -> do xs <- mapM parseDate bs' return . ExDates (S.fromList xs) $ toO o' _ -> throwError $ "Invalid type: " ++ show typ parseExDate x = throwError $ "parseExDate: " ++ show x -- | Parse categories. 3.8.1.2 parseCategories :: Content -> ContentParser Categories parseCategories (ContentLine _ "CATEGORIES" o bs) = do vals <- parseText bs lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o let o' = filter (\(x, _) -> x `notElem` ["LANGUAGE"]) o return $ Categories (S.fromList vals) lang (toO o') parseCategories x = throwError $ "parseCategories: " ++ show x -- | Parse attendee. 3.8.4.1 parseAttendee :: Content -> ContentParser Attendee parseAttendee (ContentLine _ "ATTENDEE" o bs) = do attendeeValue <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text) attendeeCUType <- g (parseCUType . CI.mk .: paramOnlyOne) $ lookup "CUTYPE" o attendeeMember <- g (S.fromList .: mapM (parseURI . T.unpack)) $ lookup "MEMBER" o attendeeRole <- g (parseRole . CI.mk .: paramOnlyOne) $ lookup "ROLE" o attendeePartStat <- g (parsePartStat . CI.mk .: paramOnlyOne) $ lookup "PARTSTAT" o attendeeRSVP <- maybe (return False) (parseBool . CI.mk <=< paramOnlyOne) $ lookup "RSVP" o attendeeDelTo <- g (S.fromList .: mapM (parseURI . T.unpack)) $ lookup "DELEGATED-TO" o attendeeDelFrom <- g (S.fromList .: mapM (parseURI . T.unpack)) $ lookup "DELEGATED-FROM" o attendeeSentBy <- mapM (parseURI . T.unpack <=< paramOnlyOne) $ lookup "SENT-BY" o attendeeCN <- mapM paramOnlyOne $ lookup "CN" o attendeeDir <- mapM (parseURI . T.unpack <=< paramOnlyOne) $ lookup "DIR" o attendeeLanguage <- mapM (Language . CI.mk .: paramOnlyOne) $ lookup "LANGUAGE" o let attendeeOther = toO $ filter f o f (x, _) = x `notElem` [ "CUTYPE", "MEMBER", "ROLE", "PARTSTAT", "RSVP" , "DELEGATED-TO", "DELEGATED-FROM", "SENT-BY" , "CN", "DIR"] return Attendee {..} where g :: (Monad m, Default b) => (a -> m b) -> Maybe a -> m b g = maybe $ return def parseAttendee x = throwError $ "parseAttendee: " ++ show x -- | Parse attachment. 3.8.1.1 parseAttachment :: Content -> ContentParser Attachment parseAttachment (ContentLine _ "ATTACH" o bs) = do fmt <- mapM (parseMime <=< paramOnlyOne) $ lookup "FMTTYPE" o val <- mapM paramOnlyOne $ lookup "VALUE" o case val of Just "BINARY" -> do enc <- mapM paramOnlyOne $ lookup "ENCODING" o case enc of Just "BASE64" -> case B64.decode bs of Left e -> throwError $ "parseAttachment: invalid \ \base64: " ++ e Right v -> return $ BinaryAttachment fmt v (toO $ filter binF o) _ -> throwError $ "parseAttachment: invalid encoding: " ++ show enc Nothing -> do uri <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text) return $ UriAttachment fmt uri (toO $ filter f o) _ -> throwError $ "parseAttachment: invalid value: " ++ show val where binF a@(x, _) = f a && x /= "VALUE" && x /= "ENCODING" f (x, _) = x /= "FMTTYPE" parseAttachment x = throwError $ "parseAttachment: " ++ show x parseDurationProp :: Maybe DTStart -> Content -> ContentParser DurationProp parseDurationProp dts (ContentLine _ "DURATION" o bs) = do val <- parseDuration "DURATION" bs case (dts, val) of (Just DTStartDate {}, DurationDate {..}) | durHour == 0 && durMinute == 0 && durSecond == 0 -> return () (Just DTStartDate {}, DurationWeek {}) -> return () (Just DTStartDate {}, _) -> throwError "DURATION must be in weeks or days when DTSTART \ \has VALUE DATE and not DATE-TIME." _ -> return () return . DurationProp val $ toO o parseDurationProp _ x = throwError $ "parseDurationProp: " ++ show x parseRecurId :: Maybe DTStart -> Content -> ContentParser RecurrenceId parseRecurId dts (ContentLine p "RECURRENCE-ID" o bs) = do range' <- mapM (parseRange . CI.mk <=< paramOnlyOne) $ lookup "RANGE" o recurid <- parseSimpleDateOrDateTime (($ range') . RecurrenceIdDateTime) (($ range') . RecurrenceIdDate) (ContentLine p "RECURRENCE-ID" (filter ((/="RANGE").fst) o) bs) case (dts, recurid) of (Nothing, _) -> return recurid (Just DTStartDate {}, RecurrenceIdDate {}) -> return recurid (Just DTStartDateTime {dtStartDateTimeValue = v}, RecurrenceIdDateTime {recurrenceIdDateTime = r}) -> case (v, r) of -- TODO: Check this. iff confuse me. (UTCDateTime {}, FloatingDateTime {}) -> err dts recurid (UTCDateTime {}, ZonedDateTime {}) -> err dts recurid (FloatingDateTime {}, UTCDateTime {}) -> err dts recurid (ZonedDateTime {}, UTCDateTime {}) -> err dts recurid _ -> return recurid _ -> err dts recurid where err d r = throwError $ "parseRecurId: DTSTART local time mismatch: " ++ show (d, r) parseRecurId _ x = throwError $ "parseRecurId: " ++ show x -- | Parse time transparency. 3.8.2.7 parseTransp :: Content -> ContentParser TimeTransparency parseTransp (ContentLine _ "TRANSP" o x) | CI.mk x == "OPAQUE" = return . Opaque $ toO o | CI.mk x == "TRANSPARENT" = return . Transparent $ toO o parseTransp x = throwError $ "parseTransp: " ++ show x -- | Parse event status. 3.8.1.11 parseEventStatus :: Content -> ContentParser EventStatus parseEventStatus (ContentLine _ "STATUS" o x) | CI.mk x == "TENTATIVE" = return . TentativeEvent $ toO o | CI.mk x == "CONFIRMED" = return . ConfirmedEvent $ toO o | CI.mk x == "CANCELLED" = return . CancelledEvent $ toO o parseEventStatus x = throwError $ "parseEventStatus: " ++ show x -- | Parse todo status. 3.8.1.11 parseTodoStatus :: Content -> ContentParser TodoStatus parseTodoStatus (ContentLine _ "STATUS" o x) | CI.mk x == "NEEDS-ACTION" = return . TodoNeedsAction $ toO o | CI.mk x == "COMPLETED" = return . CompletedTodo $ toO o | CI.mk x == "IN-PROCESS" = return . InProcessTodo $ toO o | CI.mk x == "CANCELLED" = return . CancelledTodo $ toO o parseTodoStatus x = throwError $ "parseTodoStatus: " ++ show x -- | Parse journal status. 3.8.1.11 parseJournalStatus :: Content -> ContentParser JournalStatus parseJournalStatus (ContentLine _ "STATUS" o x) | CI.mk x == "DRAFT" = return . DraftJournal $ toO o | CI.mk x == "FINAL" = return . FinalJournal $ toO o | CI.mk x == "CANCELLED" = return . CancelledJournal $ toO o parseJournalStatus x = throwError $ "parseJournalStatus: " ++ show x -- | Parse organizer. 3.8.4.3 parseOrganizer :: Content -> ContentParser Organizer parseOrganizer (ContentLine _ "ORGANIZER" o bs) = do organizerValue <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text) organizerCN <- mapM paramOnlyOne $ lookup "CN" o organizerDir <- mapM (parseURI . T.unpack <=< paramOnlyOne) $ lookup "DIR" o organizerSentBy <- mapM (parseURI . T.unpack <=< paramOnlyOne) $ lookup "SENT-BY" o organizerLanguage <- mapM (Language . CI.mk .: paramOnlyOne) $ lookup "LANGUAGE" o let f x = x `notElem` ["CN", "DIR", "SENT-BY", "LANGUAGE"] o' = filter (f . fst) o return Organizer { organizerOther = toO o', .. } parseOrganizer x = throwError $ "parseOrganizer: " ++ show x -- | Parse geographic position. 3.8.1.6 parseGeo :: Content -> ContentParser Geo parseGeo (ContentLine _ "GEO" o bs) = do let (lat', long') = B.break (==';') bs lat = maybeRead . stripPlus $ B.unpack lat' :: Maybe Float long = maybeRead . stripPlus . B.unpack $ B.tail long' :: Maybe Float when (B.null long' || isNothing (lat >> long)) . throwError $ "Invalid latitude/longitude: " ++ show bs return $ Geo (fromJust lat) (fromJust long) (toO o) where stripPlus ('+':xs) = xs stripPlus xs = xs parseGeo x = throwError $ "parseGeo: " ++ show x -- | Parse classification. 3.8.1.3 parseClass :: Content -> ContentParser Class parseClass (ContentLine _ "CLASS" o bs) = do iconv <- asks dfBS2IText return . flip Class (toO o) $ case iconv bs of "PUBLIC" -> Public "PRIVATE" -> Private "CONFIDENTIAL" -> Confidential x -> ClassValueX x parseClass x = throwError $ "parseClass: " ++ show x -- | Parse TZName. 3.8.3.1 parseTZName :: Content -> ContentParser TZName parseTZName (ContentLine _ "TZNAME" o bs) = do txt <- valueOnlyOne =<< parseText bs lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o return $ TZName txt lang (toO o) parseTZName x = throwError $ "parseTZName: " ++ show x -- | Parse a VERSION property 3.7.4 parseVersion :: Content -> ContentParser ICalVersion parseVersion (ContentLine _ "VERSION" o bs) = do c <- asks dfBS2Text let (maxver', minver'') = break (==';') . T.unpack $ c bs minver' = drop 1 minver'' parseVer = fst .: listToMaybe . filter ((=="") . snd) . readP_to_S Ver.parseVersion maxver = parseVer maxver' minver = parseVer minver' [maxJ, minJ] = fromJust <$> [maxver, minver] when (isNothing maxver) . throwError $ "parseVersion: error parsing version: " ++ show maxver' if null minver'' then return $ MaxICalVersion maxJ (toO o) else do when (isNothing minver) . throwError $ "parseVersion: error parsing version: " ++ show minver' return $ MinMaxICalVersion maxJ minJ (toO o) parseVersion x = throwError $ "parseVersion: " ++ show x -- | Parse a TZID property. 3.8.3.1 parseTZID :: Content -> ContentParser TZID parseTZID (ContentLine _ "TZID" o bs) = do tzidValue <- asks $ ($ bs) . dfBS2Text let tzidGlobal = (fst <$> T.uncons tzidValue) == Just '/' tzidOther = toO o return TZID {..} parseTZID x = throwError $ "parseTZID: " ++ show x -- | Parse RRule. 3.8.5.3 parseRRule :: Maybe DTStart -> Content -> ContentParser RRule parseRRule Nothing _ = throwError "parseRRule: missing DTSTART." parseRRule (Just dts) (ContentLine _ "RRULE" o bs) = case runParser (parseRecur dts) def "RRULE" bs of Left e -> throwError $ show e Right x -> do y <- x return . RRule y $ toO o parseRRule _ x = throwError $ "parseRRule: " ++ show x -- | Parse Created, 3.8.7.3 parseCreated :: Content -> ContentParser Created parseCreated (ContentLine _ "CREATED" o bs) = do createdValue <- mustBeUTC =<< parseDateTime Nothing bs let createdOther = toO o return Created {..} parseCreated x = throwError $ "parseCreated: " ++ show x -- | Parse Last Modified, 3.8.7.3 parseLastModified :: Content -> ContentParser LastModified parseLastModified (ContentLine _ "LAST-MODIFIED" o bs) = do lastModifiedValue <- mustBeUTC =<< parseDateTime Nothing bs let lastModifiedOther = toO o return LastModified {..} parseLastModified x = throwError $ "parseLastModified: " ++ show x -- | Parse an RDate parseRDate :: Content -> ContentParser RDate parseRDate c@(ContentLine _ "RDATE" o bs) = do typ <- paramOnlyOne . fromMaybe ["DATE-TIME"] $ lookup "VALUE" o case typ of "PERIOD" -> do tzid <- mapM paramOnlyOne $ lookup "TZID" o p <- S.fromList .: mapM (parsePeriod tzid) $ B.split ',' bs return . RDatePeriods p . toO $ filter ((`notElem` ["VALUE", "TZID"]) . fst) o _ -> parseSimpleDatesOrDateTimes RDateDateTimes RDateDates c parseRDate x = throwError $ "parseRDate: " ++ show x -- | Parse a UTC Offset property 3.3.14, 3.8.3.4, and 3.8.3.3 parseUTCOffset :: Content -> ContentParser UTCOffset parseUTCOffset (ContentLine _ n o bs) | n `elem` ["TZOFFSETTO", "TZOFFSETFROM"] = do let str = B.unpack bs (s:rest) = str (t1:t2:m1:m2:sec) = map digitToInt rest (s1:s2:_) = sec sign x = if s == '-' then negate x else x when (length str < 5 || any (not . isDigit) rest || s `notElem` ['+','-'] || length sec `notElem` [0,2]) . throwError $ "parseUTCOffset: " ++ str return . UTCOffset (sign $ ((t1 * 10 + t2) * 60 + (m1 * 10 + m2)) * 60 + if not (null sec) then s1 * 10 + s2 else 0) $ toO o parseUTCOffset x = throwError $ "parseUTCOffset: " ++ show x -- }}}