{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE FlexibleContexts  #-}
module Text.ICalendar.Parser.Properties where

import           Control.Applicative
import           Control.Monad                (when, (<=<))
import           Control.Monad.Except         hiding (mapM)
import           Control.Monad.RWS            (asks)
import qualified Data.ByteString.Base64.Lazy  as B64
import qualified Data.ByteString.Lazy.Char8   as B
import           Data.CaseInsensitive         (CI)
import qualified Data.CaseInsensitive         as CI
import           Data.Char
import           Data.Default
import           Data.Maybe
import qualified Data.Set                     as S
import           Data.Text.Lazy               (Text)
import qualified Data.Text.Lazy               as T
import           Data.Traversable             (mapM)
import qualified Data.Version                 as Ver
import           Prelude                      hiding (mapM)
import           Text.ParserCombinators.ReadP (readP_to_S)

import Text.Parsec.Prim hiding ((<|>))

import Text.ICalendar.Parser.Common
import Text.ICalendar.Parser.Parameters
import Text.ICalendar.Types

parseFreeBusy :: Content -> ContentParser FreeBusy
parseFreeBusy (ContentLine _ "FREEBUSY" o bs) = do
    typ <- maybe (return def) (parseFBType . CI.mk .: paramOnlyOne) $
                     lookup "FBTYPE" o
    periods <- S.fromList .: mapM parseUTCPeriod $ B.split ',' bs
    return $ FreeBusy typ periods (toO $ filter ((/="FBTYPE").fst) o)
parseFreeBusy x = throwError $ "parseFreeBusy: " ++ show x

parseXDurationOpt :: CI Text
                  -> (DateTime -> OtherParams -> a)
                  -> (Date     -> OtherParams -> a)
                  -> Maybe DTStart
                  -> ContentParser (Maybe (Either a DurationProp))
parseXDurationOpt w a b dts = do
    dte <- optLine1 w $ Just .: parseSimpleDateOrDateTime a b
    dur <- optLine1 "DURATION" $ Just .: parseDurationProp dts
    case (dte, dur) of
         (Nothing, Nothing) -> return Nothing
         (Just x, Nothing) -> return . Just $ Left x
         (Nothing, Just x) -> return . Just $ Right x
         _ -> throwError "Either DTEND or DURATION can be specified, but not \
                         \both."

-- | Parse trigger. 3.8.6.3
parseTrigger :: Content -> ContentParser Trigger
parseTrigger (ContentLine _ "TRIGGER" o bs) = do
    value <- paramOnlyOne . fromMaybe ["DURATION"] $ lookup "VALUE" o
    case value of
         "DURATION" -> do
            rel <- maybe (return def)
                         (parseAlarmTriggerRelationship . CI.mk
                               <=< paramOnlyOne) $ lookup "RELATED" o
            let o' = filter (\(x,_) -> x /= "VALUE" && x /= "RELATED") o
            val <- parseDuration "TRIGGER" bs
            return $ TriggerDuration val rel (toO o')
         "DATE-TIME" -> do val <- mustBeUTC =<< parseDateTime Nothing bs
                           let o' = filter (\(x, _) -> x /= "VALUE") o
                           return $ TriggerDateTime val (toO o')
         x -> throwError $ "parseTrigger: invalid value: " ++ show x
parseTrigger x = throwError $ "parseTrigger: " ++ show x


-- | Parse related to. 3.8.4.5
parseRelatedTo :: Content -> ContentParser RelatedTo
parseRelatedTo (ContentLine _ "RELATED-TO" o bs) = do
    val <- valueOnlyOne =<< parseText bs
    typ <- maybe (return def) (parseRelationshipType . CI.mk .: paramOnlyOne) $
                lookup "RELTYPE" o
    return $ RelatedTo val typ (toO $ filter (\(x,_) -> x /= "RELTYPE") o)
parseRelatedTo x = throwError $ "parseRelatedTo: " ++ show x


-- | Parse request status. 3.8.8.3
parseRequestStatus :: Content -> ContentParser RequestStatus
parseRequestStatus (ContentLine _ "REQUEST-STATUS" o bs) = do
    let (statcode', rest) = B.break (==';') bs
        statcode :: Maybe [Int]
        statcode = mapM (maybeRead . B.unpack) $ B.split '.' statcode'
    when (isNothing statcode) .
        throwError $ "parseRequestStatus: invalid code: " ++ show bs
    when (B.null rest) .
        throwError $ "parseRequestStatus: missing statdesc: " ++ show bs
    (statdesc, rest') <- (\(a,b) -> (,b) <$> valueOnlyOne a)
                                   <=< parseText' $ B.tail rest
    statext <- if B.null rest'
                  then return Nothing
                  else do when (B.head rest' /= ';') .
                              throwError $ "parseRequestStatus: bad desc: " ++
                                               show bs
                          Just <$> (valueOnlyOne =<< parseText (B.tail rest'))
    lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o
    let o' = filter (\(x, _) -> x `notElem` ["LANGUAGE"]) o
    return $ RequestStatus (fromJust statcode) statdesc lang statext (toO o')
parseRequestStatus x = throwError $ "parseRequestStatus: " ++ show x

-- | Parse exception date-times. 3.8.5.1
parseExDate :: Content -> ContentParser ExDate
parseExDate (ContentLine _ "EXDATE" o bs) = do
    (typ, tzid, o') <- typTzIdO o
    let bs' = B.split ',' bs
    case typ of
         "DATE-TIME" -> do xs <- mapM (parseDateTime tzid) bs'
                           return . ExDateTimes (S.fromList xs) $ toO o'
         "DATE" -> do xs <- mapM parseDate bs'
                      return . ExDates (S.fromList xs) $ toO o'
         _ -> throwError $ "Invalid type: " ++ show typ
parseExDate x = throwError $ "parseExDate: " ++ show x

-- | Parse categories. 3.8.1.2
parseCategories :: Content -> ContentParser Categories
parseCategories (ContentLine _ "CATEGORIES" o bs) = do
    vals <- parseText bs
    lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o
    let o' = filter (\(x, _) -> x `notElem` ["LANGUAGE"]) o
    return $ Categories (S.fromList vals) lang (toO o')
parseCategories x = throwError $ "parseCategories: " ++ show x

-- | Parse attendee. 3.8.4.1
parseAttendee :: Content -> ContentParser Attendee
parseAttendee (ContentLine _ "ATTENDEE" o bs) = do
    attendeeValue <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text)
    attendeeCUType <- g (parseCUType . CI.mk .: paramOnlyOne) $
                        lookup "CUTYPE" o
    attendeeMember <- g (S.fromList .: mapM (parseURI . T.unpack)) $
                        lookup "MEMBER" o
    attendeeRole <- g (parseRole . CI.mk .: paramOnlyOne) $ lookup "ROLE" o
    attendeePartStat <- g (parsePartStat . CI.mk .: paramOnlyOne) $
                        lookup "PARTSTAT" o
    attendeeRSVP <- maybe (return False) (parseBool . CI.mk <=< paramOnlyOne) $
                        lookup "RSVP" o
    attendeeDelTo <- g (S.fromList .: mapM (parseURI . T.unpack)) $
                        lookup "DELEGATED-TO" o
    attendeeDelFrom <- g (S.fromList .: mapM (parseURI . T.unpack)) $
                        lookup "DELEGATED-FROM" o
    attendeeSentBy <- mapM (parseURI . T.unpack <=< paramOnlyOne) $
                        lookup "SENT-BY" o
    attendeeCN <- mapM paramOnlyOne $ lookup "CN" o
    attendeeDir <- mapM (parseURI . T.unpack <=< paramOnlyOne) $
                        lookup "DIR" o
    attendeeLanguage <- mapM (Language . CI.mk .: paramOnlyOne) $
                        lookup "LANGUAGE" o
    let attendeeOther = toO $ filter f o
        f (x, _) = x `notElem` [ "CUTYPE", "MEMBER", "ROLE", "PARTSTAT", "RSVP"
                               , "DELEGATED-TO", "DELEGATED-FROM", "SENT-BY"
                               , "CN", "DIR"]
    return Attendee {..}
  where g :: (Monad m, Default b) => (a -> m b) -> Maybe a -> m b
        g = maybe $ return def
parseAttendee x = throwError $ "parseAttendee: " ++ show x


-- | Parse attachment. 3.8.1.1
parseAttachment :: Content -> ContentParser Attachment
parseAttachment (ContentLine _ "ATTACH" o bs) = do
    fmt <- mapM (parseMime <=< paramOnlyOne) $ lookup "FMTTYPE" o
    val <- mapM paramOnlyOne $ lookup "VALUE" o
    case val of
         Just "BINARY" -> do
             enc <- mapM paramOnlyOne $ lookup "ENCODING" o
             case enc of
                  Just "BASE64" ->
                      case B64.decode bs of
                           Left e -> throwError $ "parseAttachment: invalid \
                                                  \base64: " ++ e
                           Right v -> return $ BinaryAttachment fmt v
                                                  (toO $ filter binF o)
                  _ -> throwError $ "parseAttachment: invalid encoding: " ++
                                        show enc
         Nothing -> do uri <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text)
                       return $ UriAttachment fmt uri (toO $ filter f o)
         _ -> throwError $ "parseAttachment: invalid value: " ++ show val
  where binF a@(x, _) = f a && x /= "VALUE" && x /= "ENCODING"
        f (x, _) = x /= "FMTTYPE"
parseAttachment x = throwError $ "parseAttachment: " ++ show x

parseDurationProp :: Maybe DTStart -> Content -> ContentParser DurationProp
parseDurationProp dts (ContentLine _ "DURATION" o bs) = do
    val <- parseDuration "DURATION" bs
    case (dts, val) of
         (Just DTStartDate {}, DurationDate {..})
            | durHour == 0 && durMinute == 0 && durSecond == 0 -> return ()
         (Just DTStartDate {}, DurationWeek {}) -> return ()
         (Just DTStartDate {}, _) ->
             throwError "DURATION must be in weeks or days when DTSTART \
                        \has VALUE DATE and not DATE-TIME."
         _ -> return ()
    return . DurationProp val $ toO o
parseDurationProp _ x = throwError $ "parseDurationProp: " ++ show x

parseRecurId :: Maybe DTStart -> Content -> ContentParser RecurrenceId
parseRecurId dts (ContentLine p "RECURRENCE-ID" o bs) = do
    range' <- mapM (parseRange . CI.mk <=< paramOnlyOne) $ lookup "RANGE" o
    recurid <- parseSimpleDateOrDateTime
            (($ range') . RecurrenceIdDateTime)
            (($ range') . RecurrenceIdDate)
            (ContentLine p "RECURRENCE-ID" (filter ((/="RANGE").fst) o) bs)
    case (dts, recurid) of
         (Nothing, _) -> return recurid
         (Just DTStartDate {}, RecurrenceIdDate {}) ->
             return recurid
         (Just DTStartDateTime {dtStartDateTimeValue = v},
          RecurrenceIdDateTime {recurrenceIdDateTime = r}) ->
               case (v, r) of -- TODO: Check this. iff confuse me.
                    (UTCDateTime {}, FloatingDateTime {}) -> err dts recurid
                    (UTCDateTime {}, ZonedDateTime {})    -> err dts recurid
                    (FloatingDateTime {}, UTCDateTime {}) -> err dts recurid
                    (ZonedDateTime {}, UTCDateTime {})    -> err dts recurid
                    _ -> return recurid
         _ -> err dts recurid
  where err d r = throwError $ "parseRecurId: DTSTART local time mismatch: " ++
                                show (d, r)
parseRecurId _ x = throwError $ "parseRecurId: " ++ show x

-- | Parse time transparency. 3.8.2.7
parseTransp :: Content -> ContentParser TimeTransparency
parseTransp (ContentLine _ "TRANSP" o x)
    | CI.mk x == "OPAQUE" = return . Opaque $ toO o
    | CI.mk x == "TRANSPARENT" = return . Transparent $ toO o
parseTransp x = throwError $ "parseTransp: " ++ show x

-- | Parse event status. 3.8.1.11
parseEventStatus :: Content -> ContentParser EventStatus
parseEventStatus (ContentLine _ "STATUS" o x)
    | CI.mk x == "TENTATIVE" = return . TentativeEvent $ toO o
    | CI.mk x == "CONFIRMED" = return . ConfirmedEvent $ toO o
    | CI.mk x == "CANCELLED" = return . CancelledEvent $ toO o
parseEventStatus x = throwError $ "parseEventStatus: " ++ show x

-- | Parse todo status. 3.8.1.11
parseTodoStatus :: Content -> ContentParser TodoStatus
parseTodoStatus (ContentLine _ "STATUS" o x)
    | CI.mk x == "NEEDS-ACTION" = return . TodoNeedsAction $ toO o
    | CI.mk x == "COMPLETED"    = return . CompletedTodo   $ toO o
    | CI.mk x == "IN-PROCESS"   = return . InProcessTodo   $ toO o
    | CI.mk x == "CANCELLED"    = return . CancelledTodo   $ toO o
parseTodoStatus x = throwError $ "parseTodoStatus: " ++ show x

-- | Parse journal status. 3.8.1.11
parseJournalStatus :: Content -> ContentParser JournalStatus
parseJournalStatus (ContentLine _ "STATUS" o x)
    | CI.mk x == "DRAFT"     = return . DraftJournal     $ toO o
    | CI.mk x == "FINAL"     = return . FinalJournal     $ toO o
    | CI.mk x == "CANCELLED" = return . CancelledJournal $ toO o
parseJournalStatus x = throwError $ "parseJournalStatus: " ++ show x

-- | Parse organizer. 3.8.4.3
parseOrganizer :: Content -> ContentParser Organizer
parseOrganizer (ContentLine _ "ORGANIZER" o bs) = do
    organizerValue <- parseURI =<< asks (T.unpack . ($ bs) . dfBS2Text)
    organizerCN <- mapM paramOnlyOne $ lookup "CN" o
    organizerDir <- mapM (parseURI . T.unpack <=< paramOnlyOne) $ lookup "DIR" o
    organizerSentBy <- mapM (parseURI . T.unpack <=< paramOnlyOne) $
        lookup "SENT-BY" o
    organizerLanguage <- mapM (Language . CI.mk .: paramOnlyOne) $
        lookup "LANGUAGE" o
    let f x = x `notElem` ["CN", "DIR", "SENT-BY", "LANGUAGE"]
        o' = filter (f . fst) o
    return Organizer { organizerOther = toO o', .. }
parseOrganizer x = throwError $ "parseOrganizer: " ++ show x

-- | Parse geographic position. 3.8.1.6
parseGeo :: Content -> ContentParser Geo
parseGeo (ContentLine _ "GEO" o bs) = do
    let (lat', long') = B.break (==';') bs
        lat = maybeRead . stripPlus $ B.unpack lat' :: Maybe Float
        long = maybeRead . stripPlus . B.unpack $ B.tail long' :: Maybe Float
    when (B.null long' || isNothing (lat >> long)) .
        throwError $ "Invalid latitude/longitude: " ++ show bs
    return $ Geo (fromJust lat) (fromJust long) (toO o)
  where stripPlus ('+':xs) = xs
        stripPlus xs = xs
parseGeo x = throwError $ "parseGeo: " ++ show x

-- | Parse classification. 3.8.1.3
parseClass :: Content -> ContentParser Class
parseClass (ContentLine _ "CLASS" o bs) = do
    iconv <- asks dfBS2IText
    return . flip Class (toO o) $
        case iconv bs of
             "PUBLIC" -> Public
             "PRIVATE" -> Private
             "CONFIDENTIAL" -> Confidential
             x -> ClassValueX x
parseClass x = throwError $ "parseClass: " ++ show x

-- | Parse TZName. 3.8.3.1
parseTZName :: Content -> ContentParser TZName
parseTZName (ContentLine _ "TZNAME" o bs) = do
    txt <- valueOnlyOne =<< parseText bs
    lang <- mapM paramOnlyOne $ Language . CI.mk .: lookup "LANGUAGE" o
    return $ TZName txt lang (toO o)
parseTZName x = throwError $ "parseTZName: " ++ show x


-- | Parse a VERSION property 3.7.4
parseVersion :: Content -> ContentParser ICalVersion
parseVersion (ContentLine _ "VERSION" o bs) = do
    c <- asks dfBS2Text
    let (maxver', minver'') = break (==';') . T.unpack $ c bs
        minver' = drop 1 minver''
        parseVer = fst .: listToMaybe . filter ((=="") . snd)
                                       . readP_to_S Ver.parseVersion
        maxver = parseVer maxver'
        minver = parseVer minver'
        [maxJ, minJ] = fromJust <$> [maxver, minver]
    when (isNothing maxver) .
        throwError $ "parseVersion: error parsing version: " ++ show maxver'
    if null minver''
       then return $ MaxICalVersion maxJ (toO o)
       else do when (isNothing minver) .
                    throwError $ "parseVersion: error parsing version: "
                                   ++ show minver'
               return $ MinMaxICalVersion maxJ minJ (toO o)
parseVersion x = throwError $ "parseVersion: " ++ show x

-- | Parse a TZID property. 3.8.3.1
parseTZID :: Content -> ContentParser TZID
parseTZID (ContentLine _ "TZID" o bs) = do
    tzidValue <- asks $ ($ bs) . dfBS2Text
    let tzidGlobal = (fst <$> T.uncons tzidValue) == Just '/'
        tzidOther = toO o
    return TZID {..}
parseTZID x = throwError $ "parseTZID: " ++ show x

-- | Parse RRule. 3.8.5.3
parseRRule :: Maybe DTStart -> Content -> ContentParser RRule
parseRRule Nothing _ = throwError "parseRRule: missing DTSTART."
parseRRule (Just dts) (ContentLine _ "RRULE" o bs) =
    case runParser (parseRecur dts) def "RRULE" bs of
         Left e -> throwError $ show e
         Right x -> do y <- x
                       return . RRule y $ toO o
parseRRule _ x = throwError $ "parseRRule: " ++ show x

-- | Parse Created, 3.8.7.3
parseCreated :: Content -> ContentParser Created
parseCreated (ContentLine _ "CREATED" o bs) = do
    createdValue <- mustBeUTC =<< parseDateTime Nothing bs
    let createdOther = toO o
    return Created {..}
parseCreated x = throwError $ "parseCreated: " ++ show x

-- | Parse Last Modified, 3.8.7.3
parseLastModified :: Content -> ContentParser LastModified
parseLastModified (ContentLine _ "LAST-MODIFIED" o bs) = do
    lastModifiedValue <- mustBeUTC =<< parseDateTime Nothing bs
    let lastModifiedOther = toO o
    return LastModified {..}
parseLastModified x = throwError $ "parseLastModified: " ++ show x

-- | Parse an RDate
parseRDate :: Content -> ContentParser RDate
parseRDate c@(ContentLine _ "RDATE" o bs) = do
    typ <- paramOnlyOne . fromMaybe ["DATE-TIME"] $ lookup "VALUE" o
    case typ of
         "PERIOD" -> do
             tzid <- mapM paramOnlyOne $ lookup "TZID" o
             p <- S.fromList .: mapM (parsePeriod tzid) $ B.split ',' bs
             return . RDatePeriods p . toO $
                filter ((`notElem` ["VALUE", "TZID"]) . fst) o
         _ -> parseSimpleDatesOrDateTimes RDateDateTimes RDateDates c
parseRDate x = throwError $ "parseRDate: " ++ show x

-- | Parse a UTC Offset property 3.3.14, 3.8.3.4, and 3.8.3.3
parseUTCOffset :: Content -> ContentParser UTCOffset
parseUTCOffset (ContentLine _ n o bs)
        | n `elem` ["TZOFFSETTO", "TZOFFSETFROM"] = do
    let str = B.unpack bs
        (s:rest) = str
        (t1:t2:m1:m2:sec) = map digitToInt rest
        (s1:s2:_) = sec
        sign x = if s == '-' then negate x else x
    when (length str < 5 || any (not . isDigit) rest || s `notElem` ['+','-']
                         || length sec `notElem` [0,2]) .
        throwError $ "parseUTCOffset: " ++ str
    return . UTCOffset (sign $ ((t1 * 10 + t2) * 60 + (m1 * 10 + m2)) * 60 +
                                if not (null sec) then s1 * 10 + s2 else 0)
                       $ toO o
parseUTCOffset x = throwError $ "parseUTCOffset: " ++ show x

-- }}}