{-# LANGUAGE OverloadedStrings #-} module Text.ICalendar.Parser.Parameters where import Control.Applicative import Control.Monad (void, when) import Control.Monad.Except 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