diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008, Tupil +Copyright (c) 2012, Tingtun AS All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Tupil nor the names of other + * 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. diff --git a/Text/ICalendar.hs b/Text/ICalendar.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar.hs @@ -0,0 +1,9 @@ +module Text.ICalendar + ( module Text.ICalendar.Types + , module Text.ICalendar.Parser + , module Text.ICalendar.Printer + ) where + +import Text.ICalendar.Types +import Text.ICalendar.Parser +import Text.ICalendar.Printer diff --git a/Text/ICalendar/Parser.hs b/Text/ICalendar/Parser.hs --- a/Text/ICalendar/Parser.hs +++ b/Text/ICalendar/Parser.hs @@ -1,368 +1,55 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -{-| - -Parser for the iCalendar format (version 2.0, RFC2445). - -Features: - - * Unfolds folded lines (see RFC) - - * Supports all IANA iCalendar tokens - -/Warning!/ This is version 0.0, important things are missing - - * Property and parameter values are not parsed, but kept as in the file. - - * There are no restrictions on the properties components can have. - - * Line unfolding causes error messages to report the wrong line. - -This package is meant to grow to a full-fledged data definition, printer and -parser for the iCalendar format. But that will probably take some time. So, -if you've come here because you need this, please e-mail me (Eelco Lempsink). - --} - -module Text.ICalendar.Parser - ( - -- * Tokens from RFC2445 - ComponentName(..) - , PropertyName(..) - , ParamName(..) - , ParamValue(..) - -- * Data definitions - , Property - , Value - , ICalendar(..) - , Component(..) - , Param(..) - -- * Parser - , parser +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Text.ICalendar.Parser + ( parseICal + , parseICalFile + , DecodingFunctions(..) ) where ------------------------------------------------------------- --- Imports ------------------------------------------------------------- - -import Data.Char +import Prelude +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 Control.Applicative -import Control.Monad (MonadPlus(..), ap) --- Hide Parsec's definitions of some Applicative functions. -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) +import Text.Parsec.Prim hiding (many, (<|>)) +import Text.Parsec.Pos +import Text.Parsec.ByteString.Lazy () +import Text.Parsec.Text.Lazy () ------------------------------------------------------------- --- Tokens, as defined in RFC2445. ------------------------------------------------------------- +import Text.ICalendar.Types +import Text.ICalendar.Parser.Common +import Text.ICalendar.Parser.Content +import Text.ICalendar.Parser.Components --- | Calendar Component names (4.6) -data ComponentName = - VEVENT -- ^ Event Component (4.6.1) - | VTODO -- ^ To-do Component (4.6.2) - | VJOURNAL -- ^ Journal Component (4.6.3) - | VFREEBUSY -- ^ Free/Busy Component (4.6.4) - | VTIMEZONE -- ^ Time Zone Component (4.6.5) - | X_c String -- ^ Non-standard/Experimental Component - -- Time Zone subcomponents - | STANDARD -- ^ Standard Time Sub-component (4.6.5) - | DAYLIGHT -- ^ Daylight Saving Time Sub-component (4.6.5) - -- Event and To-do subcomponent - | VALARM -- ^ Alarm Sub-component (4.6.6) - deriving (Eq, Show) --- | Property names for Calendar Properties (4.7) and Component Properties (4.8) -data PropertyName = - -- Calendar properties (4.7) - CALSCALE -- ^ Calendar Scale (4.7.1) - | METHOD -- ^ Method (4.7.2) - | PRODID -- ^ Product Identifier (4.7.3) - | VERSION -- ^ Version (4.7.4) - - -- Component properties (4.8.1) - | ATTACH -- ^ Attachment (4.8.1.1) - | CATEGORIES -- ^ Categories (4.8.1.2) - | CLASS -- ^ Classification (4.8.1.3) - | COMMENT -- ^ Comment (4.8.1.4) - | DESCRIPTION -- ^ Description (4.8.1.5) - | GEO -- ^ Geographic Position (4.8.1.6) - | LOCATION -- ^ Location (4.8.1.7) - | PERCENT_COMPLETE -- ^ Percent Complete (4.8.1.8) - | PRIORITY -- ^ Priority (4.8.1.9) - | RESOURCES -- ^ Resources (4.8.1.10) - | STATUS -- ^ Status (4.8.1.11) - | SUMMARY -- ^ Summary (4.8.1.12) - - -- Date and Time Component properties (4.8.2) - | COMPLETED -- ^ Date/Time Completed (4.8.2.1) - | DTEND -- ^ Date/Time End (4.8.2.2) - | DUE -- ^ Date/Time Due (4.8.2.3) - | DTSTART -- ^ Date/Time Start (4.8.2.4) - | DURATION -- ^ Duration (4.8.2.5) - | FREEBUSY -- ^ Free/Busy Time (4.8.2.6) - | TRANSP -- ^ Time Transparency (4.8.2.7) - - -- Time Zone Component properties (4.8.3) - | TZID -- ^ Time Zone Identifier (4.8.3.1) - | TZNAME -- ^ Time Zone Name (4.8.3.2) - | TZOFFSETFROM -- ^ Time Zone Offset From (4.8.3.3) - | TZOFFSETTO -- ^ Time Zone Offset To (4.8.3.4) - | TZURL -- ^ Time Zone URL (4.8.3.5) - - -- Relationship Component properties (4.8.4) - | ATTENDEE -- ^ Attendee (4.8.4.1) - | CONTACT -- ^ Contact (4.8.4.2) - | ORGANIZER -- ^ Organizer (4.8.4.3) - | RECURRENCE_ID -- ^ Recurrence ID (4.8.4.4) - | RELATED_TO -- ^ Related To (4.8.4.5) - | URL -- ^ Uniform Resource Locator (4.8.4.6) - | UID -- ^ Unique Identfier (4.8.4.7) - - -- Recurrence Component properties (4.8.5) - | EXDATE -- ^ Exception Date/Times (4.8.5.1) - | EXRULE -- ^ Exception Rule (4.8.5.2) - | RDATE -- ^ Recurrence Date/Times (4.8.5.3) - | RRULE -- ^ Recurrence Rule (4.8.5.4) - - -- Alarm Component properties (4.8.6) - | ACTION -- ^ Action (4.8.6.1) - | REPEAT -- ^ Repeat Count (4.8.6.2) - | TRIGGER -- ^ Trigger (4.8.6.3) - - -- Change Management Component properties (4.8.7) - | CREATED -- ^ Date/Time Created (4.8.7.1) - | DTSTAMP -- ^ Date/Time Stamp (4.8.7.2) - | LAST_MODIFIED -- ^ Last Modified (4.8.7.3) - | SEQUENCE -- ^ Sequence Number (4.8.7.4) - - -- Miscellaneous Component properties (4.8.8) - | X_ String -- ^ Non-standard Properties (4.8.8.1) - | REQUEST_STATUS -- ^ Request Status (4.8.8.2) - deriving (Eq, Show) - --- | Parameter names (4.2) -data ParamName = ALTREP -- ^ Alternate Text Represenation (4.2.1) - | CN -- ^ Common Name (4.2.2) - | CUTYPE -- ^ Calendar User Type (4.2.3) - | DELEGATED_FROM -- ^ Delegators (4.2.4) - | DELEGATED_TO -- ^ Delegatees (4.2.5) - | DIR -- ^ Directory Entry Reference (4.2.6) - | ENCODING -- ^ Inline Encoding (4.2.7) - | FMTYPE -- ^ Format Type (4.2.8) - | FBTYPE -- ^ Free/Busy Time Type (4.2.9) - | LANGUAGE -- ^ Language (4.2.10) - | MEMBER -- ^ Group or List Membership (4.2.11) - | PARTSTAT -- ^ Participation Status (4.2.12) - | RANGE -- ^ Recurrence Identfier Range (4.2.13) - | RELATED -- ^ Alarm Trigger Relationship (4.2.14) - | RELTYPE -- ^ Relationship Type (4.2.15) - | ROLE -- ^ Participation Role (4.2.16) - | RSVP -- ^ RSVP Expectation (4.2.17) - | SENT_BY -- ^ Sent By (4.2.18) - | TZIDp -- ^ Time Zone Identifier (4.2.19) - | VALUE -- ^ Value Data Types (4.2.20) - | X_p String -- ^ Non-standard Parameter (4.2.21) - deriving (Eq, Show) - -data ParamValue = Paramtext String - | QuotedString String - deriving (Eq, Show) - ------------------------------------------------------------- --- Parsed datastructers and helper functions ------------------------------------------------------------- - -type Value = String -type Property = (PropertyName, [Param], Value) - --- | iCalendar data -data ICalendar = ICalendar { calendarProperties :: [Property] - , components :: [Component] - } deriving (Eq, Show) - -mkICalendar = ICalendar [] [] - -addCalendarProperty prop calendar = calendar { calendarProperties = prop : calendarProperties calendar } -addComponent comp calendar = calendar { components = comp : components calendar } - --- | Component data -data Component = Component { cName :: ComponentName - , properties :: [Property] - , subcomponents :: [Component] - } deriving (Eq, Show) - -mkComponent name = Component name [] [] - -addProperty prop component = component { properties = prop : properties component } -addSubcomponent comp component = component { subcomponents = comp : subcomponents component } - --- | Parameter data -data Param = Param { pName :: ParamName - , pValues :: [ParamValue] - } deriving (Eq, Show) - ------------------------------------------------------------- --- Parser helpers ------------------------------------------------------------- - --- | Case insensitive string matching. Also wrapped in a 'try' so the matching --- will fail as a whole and not mid-string. -ciString = try . sequence . (map (\c -> char (toUpper c) <|> char (toLower c))) - -crlf = string "\r\n" - --- | Parses any character except controls and double quotation marks -pQsafeChar = oneOf $ wsp ++ map chr (0x21 : [0x23..0x7e]) ++ nonUsAscii - --- | Parses any character except controls, double quotation marks, ";", ":", "," -pSafeChar = oneOf $ wsp ++ map chr (0x21 : [0x23..0x2b] ++ [0x2d..0x39] ++ [0x3c..0x7e]) ++ nonUsAscii - --- | Parses any textual character -pValueChar = oneOf $ wsp ++ map chr [0x21..0x7e] ++ nonUsAscii - --- | Non US-ASCII characters -nonUsAscii = map chr [0x80..0xF8] - --- | Linear white space -wsp = " \t" - ------------------------------------------------------------- --- Scanner, creating a tokenstream ------------------------------------------------------------- - --- TODO folding the lines should keep the original positions --- | Parses a "String" to an "ICalendar". Will unfold folded lines, so error messages might be off. -parser = do input <- getInput - setInput (foldLines input) - pICalendar - --- | Remove crlf's followed by space or tab, this is called "line folding". -foldLines [] = [] -foldLines ('\r':'\n':' ' :lines) = foldLines lines -foldLines ('\r':'\n':'\t':lines) = foldLines lines -foldLines (l:lines) = l : foldLines lines - -pICalendar = pBegin <* pVCalendar - *> pCalendarPropertiesAndComponents - <* eof - -pVCalendar = ciString "VCALENDAR" <* crlf - -pCalendarPropertiesAndComponents = - addCalendarProperty <$> pProperty <*> pCalendarPropertiesAndComponents - <|> addComponent <$> pComponent <*> pCalendarPropertiesAndComponents - <|> mkICalendar <$ pEnd <* pVCalendar - -pComponent = do component <- pComponentBegin - pPropertiesAndSubcomponents component - -pComponentBegin = mkComponent <$ pBegin <*> pComponentName - -pPropertiesAndSubcomponents component = - addProperty <$> pProperty <*> pPropertiesAndSubcomponents component - <|> addSubcomponent <$> pComponent <*> pPropertiesAndSubcomponents component - <|> component <$ pComponentEnd component - -pProperty = (,,) <$> pPropertyName <*> many pParam <*> pValue - -pParam = Param <$ char ';' <*> pParamName <*> sepBy pParamValue (char ',') - --- NOTE: pQuotedString has to go first, because the value may be empty -pParamValue = pQuotedString <|> pParamtext -pParamtext = Paramtext <$> many pSafeChar -pQuotedString = QuotedString <$ char '"' <*> many pQsafeChar <* char '"' - -pValue = char ':' *> many pValueChar <* crlf - --- TODO: This will disappear once every component has its own parser -pComponentEnd c = do pEnd - component <- pComponentName - if component == cName c - then return component - else unexpected $ "END:" ++ show (cName c) - -pBegin = ciString "BEGIN:" -pEnd = ciString "END:" +-- | Parse a ByteString containing iCalendar data. +-- Returns either an error, or a tuple of the result and a list of warnings. +parseICal :: DecodingFunctions + -> FilePath + -> ByteString + -> Either String ([VCalendar], [String]) +parseICal 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) -pComponentName = ( VEVENT <$ ciString "VEVENT" - <|> VTODO <$ ciString "VTODO" - <|> VJOURNAL <$ ciString "VJOURNAL" - <|> VFREEBUSY <$ ciString "VFREEBUSY" - <|> VTIMEZONE <$ ciString "VTIMEZONE" - <|> X_c <$ ciString "X-" <*> many1 (alphaNum <|> char '-') - <|> STANDARD <$ ciString "STANDARD" - <|> DAYLIGHT <$ ciString "DAYLIGHT" - <|> VALARM <$ ciString "VALARM" - ) <* crlf - -pPropertyName = CALSCALE <$ ciString "CALSCALE" - <|> METHOD <$ ciString "METHOD" - <|> PRODID <$ ciString "PRODID" - <|> VERSION <$ ciString "VERSION" - <|> ATTACH <$ ciString "ATTACH" - <|> CATEGORIES <$ ciString "CATEGORIES" - <|> CLASS <$ ciString "CLASS" - <|> COMMENT <$ ciString "COMMENT" - <|> DESCRIPTION <$ ciString "DESCRIPTION" - <|> GEO <$ ciString "GEO" - <|> LOCATION <$ ciString "LOCATION" - <|> PERCENT_COMPLETE <$ ciString "PERCENT-COMPLETE" - <|> PRIORITY <$ ciString "PRIORITY" - <|> RESOURCES <$ ciString "RESOURCES" - <|> STATUS <$ ciString "STATUS" - <|> SUMMARY <$ ciString "SUMMARY" - <|> COMPLETED <$ ciString "COMPLETED" - <|> DTEND <$ ciString "DTEND" - <|> DUE <$ ciString "DUE" - <|> DTSTART <$ ciString "DTSTART" - <|> DURATION <$ ciString "DURATION" - <|> FREEBUSY <$ ciString "FREEBUSY" - <|> TRANSP <$ ciString "TRANSP" - <|> TZID <$ ciString "TZID" - <|> TZNAME <$ ciString "TZNAME" - <|> TZOFFSETFROM <$ ciString "TZOFFSETFROM" - <|> TZOFFSETTO <$ ciString "TZOFFSETTO" - <|> TZURL <$ ciString "TZURL" - <|> ATTENDEE <$ ciString "ATTENDEE" - <|> CONTACT <$ ciString "CONTACT" - <|> ORGANIZER <$ ciString "ORGANIZER" - <|> RECURRENCE_ID <$ ciString "RECURRENCE-ID" - <|> RELATED_TO <$ ciString "RELATED-TO" - <|> URL <$ ciString "URL" - <|> UID <$ ciString "UID" - <|> EXDATE <$ ciString "EXDATE" - <|> EXRULE <$ ciString "EXRULE" - <|> RDATE <$ ciString "RDATE" - <|> RRULE <$ ciString "RRULE" - <|> ACTION <$ ciString "ACTION" - <|> REPEAT <$ ciString "REPEAT" - <|> TRIGGER <$ ciString "TRIGGER" - <|> CREATED <$ ciString "CREATED" - <|> DTSTAMP <$ ciString "DTSTAMP" - <|> LAST_MODIFIED <$ ciString "LAST-MODIFIED" - <|> SEQUENCE <$ ciString "SEQUENCE" - <|> X_ <$ ciString "X-" <*> many1 (alphaNum <|> char '-') - <|> REQUEST_STATUS <$ ciString "REQUEST-STATUS" +-- | Parse an iCalendar file. +parseICalFile :: DecodingFunctions + -> FilePath + -> IO (Either String ([VCalendar], [String])) +parseICalFile s f = parseICal s f <$> B.readFile f -pParamName = ( ALTREP <$ ciString "ALTREP" - <|> CN <$ ciString "CN" - <|> CUTYPE <$ ciString "CUTYPE" - <|> DELEGATED_FROM <$ ciString "DELEGATED-FROM" - <|> DELEGATED_TO <$ ciString "DELEGATED-TO" - <|> DIR <$ ciString "DIR" - <|> ENCODING <$ ciString "ENCODING" - <|> FMTYPE <$ ciString "FMTYPE" - <|> FBTYPE <$ ciString "FBTYPE" - <|> LANGUAGE <$ ciString "LANGUAGE" - <|> MEMBER <$ ciString "MEMBER" - <|> PARTSTAT <$ ciString "PARTSTAT" - <|> RANGE <$ ciString "RANGE" - <|> RELATED <$ ciString "RELATED" - <|> RELTYPE <$ ciString "RELTYPE" - <|> ROLE <$ ciString "ROLE" - <|> RSVP <$ ciString "RSVP" - <|> SENT_BY <$ ciString "SENT-BY" - <|> TZIDp <$ ciString "TZID" - <|> VALUE <$ ciString "VALUE" - <|> X_p <$ ciString "X-" <*> many1 (alphaNum <|> char '-') - ) <* char '=' +runCP :: DecodingFunctions -> ContentParser a + -> (Either String a, (SourcePos, [Content]), [String]) +runCP s = ((flip .) . flip) runRWS s (undefined, undefined) . runErrorT diff --git a/Text/ICalendar/Parser/Common.hs b/Text/ICalendar/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Parser/Common.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Text.ICalendar.Parser.Common where + +import Prelude hiding (mapM) +import Control.Applicative +import Control.Arrow (second) +import Control.Monad.Error hiding (mapM) +import Control.Monad.RWS ( RWS, MonadWriter(tell) , MonadState(get, put), asks + , modify ) +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy.Builder as Bu +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 ( UTCTime(UTCTime), LocalTime(LocalTime), Day + , TimeOfDay()) +import qualified Data.Time as Time +import Data.Traversable (mapM) +import qualified Network.URI as URI +import qualified System.Locale as L + +import qualified Text.Parsec as P +import Text.Parsec.Prim hiding ((<|>)) +import Text.Parsec.Combinator hiding (optional) + +import Text.ICalendar.Types + +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 = sepBy text (P.char ',') + text = do x <- P.satisfy isTSafe' + case x of + '\\' -> do y <- P.anyChar + case y of + '\\' -> nxt '\\' + ';' -> nxt ';' + ',' -> nxt ',' + z | z `elem` "nN" -> nxt '\n' + _ -> fail $ "unexpected " ++ show x + y -> nxt y + -- isTSafe + 0x22, 0x3A + isTSafe' c = let n = ord c + in n == 9 || (n >= 0x20 && 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 L.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 L.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' valueOnlyOne + +-- | 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 .: diff --git a/Text/ICalendar/Parser/Components.hs b/Text/ICalendar/Parser/Components.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Parser/Components.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Text.ICalendar.Parser.Components where + +import Control.Applicative +import Control.Monad.Error hiding (mapM) +import Control.Monad.RWS ( MonadState(get), tell ) +import qualified Data.CaseInsensitive as CI +import Data.List (partition) +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S + +import Text.ICalendar.Types +import Text.ICalendar.Parser.Common +import Text.ICalendar.Parser.Properties + +-- | 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 <- optCompN "VTIMEZONE" parseVTimeZone + vcEvents <- optCompN "VEVENT" (parseVEvent vcMethod) + vcTodos <- optCompN "VTODO" parseVTodo + vcJournals <- optCompN "VJOURNAL" parseVJournal + vcFreeBusys <- optCompN "VFREEBUSY" parseVFreeBusy + vcOtherComps <- otherComponents + vcOther <- otherProperties + return VCalendar {..} +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" $ parseSimpleDateTime ((Just .) . Created) + 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" . parseSimpleDateTime $ + (Just .) . Created + 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" . parseSimpleDateTime $ + (Just .) . Created + 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 + diff --git a/Text/ICalendar/Parser/Content.hs b/Text/ICalendar/Parser/Content.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Parser/Content.hs @@ -0,0 +1,113 @@ +{-# 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.Prim hiding (many, (<|>)) +import Text.Parsec.Combinator hiding (optional) +import Text.Parsec.ByteString.Lazy () +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` "\";:," +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" diff --git a/Text/ICalendar/Parser/Parameters.hs b/Text/ICalendar/Parser/Parameters.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Parser/Parameters.hs @@ -0,0 +1,208 @@ +{-# 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.Prim hiding ((<|>)) +import Text.Parsec.Perm +import Text.Parsec.Combinator hiding (optional) + +import Text.ICalendar.Types +import Text.ICalendar.Parser.Common + +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.unpack 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" -> 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" -> PeriodDuration dateTime + <$> parseDuration "period" x + _ -> PeriodDates dateTime <$> parseDateTime tzid x diff --git a/Text/ICalendar/Parser/Properties.hs b/Text/ICalendar/Parser/Properties.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Parser/Properties.hs @@ -0,0 +1,383 @@ +{-# 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 + +-- }}} diff --git a/Text/ICalendar/Printer.hs b/Text/ICalendar/Printer.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Printer.hs @@ -0,0 +1,958 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +module Text.ICalendar.Printer + ( EncodingFunctions(..) + , printICal + ) where + +import Prelude hiding (mapM_) +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Monad hiding (mapM_, forM_) +import Control.Monad.RWS ( RWS, runRWS, MonadWriter(tell) + , MonadState(get, put), asks, modify) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Builder (Builder) +import qualified Data.ByteString.Lazy.Builder as Bu +import qualified Data.CaseInsensitive as CI +import Data.Char (ord, toUpper) +import Data.Default +import Data.Foldable (mapM_, forM_) +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 qualified System.Locale as L +import Text.Printf (printf) + +import Codec.MIME.Type (showMIMEType, MIMEType) +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 + +printICal :: EncodingFunctions -> VCalendar -> ByteString +printICal r v = (\(_, _, x) -> Bu.toLazyByteString x) $ + runRWS (printVCalendar v) r 0 + +-- {{{ 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" $ toParam createdOther <> toParam createdValue + printValue 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 recurrenceIdOther + toParam RecurrenceIdDateTime {..} = toParam recurrenceIdDateTime <> + toParam recurrenceIdOther + +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.pack $ 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", [(NoQuotes, 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 L.defaultTimeLocale + +-- }}} diff --git a/Text/ICalendar/Types.hs b/Text/ICalendar/Types.hs new file mode 100644 --- /dev/null +++ b/Text/ICalendar/Types.hs @@ -0,0 +1,806 @@ +{-# 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.Set (Set) +import Data.Text.Lazy (Text) +import Data.Time +import Data.Typeable (Typeable) +import Data.Version (Version(..)) +import Network.URI (URI) + +-- | 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 :: Set VTimeZone + , vcEvents :: Set VEvent + , vcTodos :: Set VTodo + , vcJournals :: Set VJournal + , vcFreeBusys :: Set VFreeBusy + , vcOtherComps :: Set VOther + } deriving (Show, Eq, Ord, Typeable) + +instance Default VCalendar where + def = VCalendar (ProdId "-//haskell.org/NONSGML iCalendar-0.1//EN" def) + (MaxICalVersion (Version [2,0] []) def) + def Nothing def def def def def def def + +-- | 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 :: Range -- ^ 'def' = 'ThisAndFuture' + , recurrenceIdOther :: OtherParams + } + | RecurrenceIdDateTime + { recurrenceIdDateTime :: DateTime + , recurrenceIdRange :: Range -- ^ 'def' = 'ThisAndFuture' + , recurrenceIdOther :: OtherParams + } deriving (Show, Eq, Ord, Typeable) + +-- | Recurrence Identifier Range. 3.2.13 +data Range = ThisAndFuture | ThisAndPrior + deriving (Show, Eq, Ord, Typeable) + +instance Default Range where + def = ThisAndFuture + +-- | 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 :: DateTime + , 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) diff --git a/iCalendar.cabal b/iCalendar.cabal --- a/iCalendar.cabal +++ b/iCalendar.cabal @@ -1,42 +1,38 @@ -Name: iCalendar -Version: 0.0.1 -Synopsis: Parser for iCalendar format (RFC2445) - -Description: Parser for the iCalendar format (version 2.0, RFC2445). - . - Features: - . - * Unfolds folded lines (see RFC) - . - * Supports all IANA iCalendar tokens - . - /Warning!/ This is version 0.0, important things are missing - . - * Property and parameter values are not parsed, but kept as in the file. - . - * There are no restrictions on the properties components can have. - . - * Line unfolding causes error messages to report the wrong line. - . - This package is meant to grow to a full-fledged data definition, printer and - parser for the iCalendar format. But that will probably take some time. So, - if you've come here because you need this, please e-mail me (Eelco Lempsink). - -Category: Text -License: BSD3 -License-file: LICENSE -Copyright: (c) Tupil -Author: Eelco Lempsink -Maintainer: Clint Adams -Build-Type: Simple -Cabal-Version: >=1.10 - -Library - build-depends: base >= 4 && < 5 - , parsec >=3 && <4 - exposed-modules: Text.ICalendar.Parser - default-language: Haskell98 +name: iCalendar +version: 0.1 +synopsis: iCalendar data types, parser, and printer. +description: Data definitions, parsing and printing of the iCalendar + format (RFC5545). +homepage: http://github.com/tingtun/iCalendar +bug-reports: http://github.com/tingtun/iCalendar/issues +license: BSD3 +license-file: LICENSE +author: Christian Rødli Amble +maintainer: cra+code@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://git.debian.org/users/clint/iCalendar-Haskell.git + type: git + location: git://github.com/tingtun/iCalendar.git + +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 + build-depends: base ==4.*, time ==1.4.*, data-default >=0.3 + , case-insensitive ==0.4.*, network ==2.4.* + , bytestring >=0.10 && < 0.11, parsec ==3.1.* + , text, containers >= 0.4 && < 0.6, mime ==0.3.* + , mtl ==2.1.*, old-locale, base64-bytestring ==1.0.* + ghc-options: -Wall