{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} module Text.ICalendar.Parser.Properties where import Prelude hiding (mapM) 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 Text.ParserCombinators.ReadP (readP_to_S) import Text.Parsec.Prim hiding ((<|>)) import Text.ICalendar.Types import Text.ICalendar.Parser.Common import Text.ICalendar.Parser.Parameters 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' <- maybe (return def) (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 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 -- }}}