diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Done (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Done nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ical.cabal b/ical.cabal new file mode 100644 --- /dev/null +++ b/ical.cabal @@ -0,0 +1,51 @@ +name: ical +version: 0.0.0 +synopsis: iCalendar format parser and org-mode converter. +description: Please see README.md +homepage: http://github.com/chrisdone/ical#readme +license: BSD3 +license-file: LICENSE +author: Chris Done +maintainer: chrisdone@gmail.com +copyright: 2015 Chris Done +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: ICal, ICal.Types, ICal.Org, ICal.Tokenizer, ICal.Parser + build-depends: aeson >= 0.8.0.2 + , attoparsec >= 0.12.1.6 + , base >= 4.7 && < 5 + , containers >= 0.5.6.2 + , either >= 4.4.1 + , mtl >= 2.2.1 + , text >= 1.2.1.3 + , time >= 1.5.0.1 + , transformers >= 0.4.2.0 + default-language: Haskell2010 + +executable ical-org + hs-source-dirs: src/main + ghc-options: -Wall + main-is: Org.hs + build-depends: base >= 4.7 && < 5 + , ical + , time + default-language: Haskell2010 + +test-suite ical-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , ical + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/chrisdone/ical diff --git a/src/ICal.hs b/src/ICal.hs new file mode 100644 --- /dev/null +++ b/src/ICal.hs @@ -0,0 +1,14 @@ +-- | Basic parser for ICalendar format. + +module ICal + (-- * Top-level functions + tokenizeObjectFromFile + ,tokenizeObjectFromText + ,tokenizeAesonFromText + -- * Types + ,Object(..) + ,Line(..)) + where + +import ICal.Types +import ICal.Tokenizer diff --git a/src/ICal/Org.hs b/src/ICal/Org.hs new file mode 100644 --- /dev/null +++ b/src/ICal/Org.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | Export to Org mode for Emacs. + +module ICal.Org + (-- * Handy export functions + exportFromToFile + ,parseFromObject + -- * Conversions + ,documentParser + ,buildDocument + -- * Types + ,Event (..) + ) + where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Identity +import Data.Ord +import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as LT +import qualified Data.Text.Lazy.IO as LT +import Data.Time +import ICal +import ICal.Parser +import ICal.Types + +-- | An Org mode section. +data Event = + Event {eventTitle :: !Text -- ^ Title of the section. + ,eventStart :: !UTCTime -- ^ Date starts. + ,eventDescription :: !(Maybe Text) -- ^ Contents of the section. + ,eventEnd :: !(Maybe UTCTime) -- ^ Date ends. + ,eventCreated :: !UTCTime -- ^ Date created. + } + deriving (Show) + +-- | Handy exporting function. +exportFromToFile :: Day -> FilePath -> FilePath -> IO () +exportFromToFile base from to = + do obj <- tokenizeObjectFromFile from + today <- getCurrentTime + case parseFromObject obj of + Left er -> error (show er) + Right es -> + LT.writeFile to + (LT.toLazyText (buildDocument base today es)) + +-- | Parse an iCalendar object into an Org mode document. +parseFromObject :: Object -> Either ParseError [Event] +parseFromObject s = runIdentity (parseEither s documentParser) + +-- | Build an org-mode document. +buildDocument :: Day -> UTCTime -> [Event] -> Builder +buildDocument base today = + mconcat . + map build . + dropWhile (\e -> + utctDay (fromMaybe (eventStart e) + (eventEnd e)) < + base) . + sortBy (comparing eventStart) + where build event = + mconcat ["* " <> todo <> LT.fromText (eventTitle event) + ,"\n" + ," SCHEDULED: <" <> formatDate (eventStart event) <> ">" + ,if fromMaybe (eventStart event) + (eventEnd event) > + today + then "" + else "\n - State \"DONE\" from \"TODO\" [" <> + formatDate + (fromMaybe (eventStart event) + (eventEnd event)) <> + "]\n" + ,"\n"] + where formatDate = + LT.fromText . + T.pack . formatTime defaultTimeLocale "%Y-%m-%d" + todo = + if fromMaybe (eventStart event) + (eventEnd event) > + today + then "TODO " + else "DONE " + +-- | Parse an org-mode document from the object. +documentParser :: Parser Identity Object [Event] +documentParser = + begin "VCALENDAR" + (do version <- property "VERSION" + unless (version == "2.0") + (parseError (GeneralProblem "Expected document version 2.0.")) + scale <- property "CALSCALE" + unless (scale == "GREGORIAN") + (parseError (GeneralProblem "Need time gregorian scale.")) + timezones <- fmap M.fromList (objects "VTIMEZONE" timeZoneParser) + events <- objects "VEVENT" (eventParser timezones) + return events) + +-- | Parse a time zone. +timeZoneParser :: Parser Identity [Object] (Text,TimeZone) +timeZoneParser = + do key <- property "TZID" + return (key,utc) + +-- | Parse an event. +eventParser :: Map Text TimeZone -> Parser Identity [Object] Event +eventParser timezones = + do start <- property "DTSTART" >>= utcTimeParser timezones + end <- optional (property "DTEND" >>= utcTimeParser timezones) + created <- property "CREATED" >>= utcTimeParser timezones + description <- optional (property "DESCRIPTION") + summary <- property "SUMMARY" + return (Event {eventTitle = summary + ,eventStart = start + ,eventEnd = end + ,eventDescription = description + ,eventCreated = created}) + +-- | Parse a time field into a UTCTime. +utcTimeParser :: Map Text TimeZone -> Text -> Parser Identity s UTCTime +utcTimeParser timezones s = + case T.stripPrefix "VALUE=DATE:" s of + Just s' -> + case justdate s' of + Nothing -> + parseError (GeneralProblem ("Unable to parse date from " <> s')) + Just t -> return t + Nothing -> + case T.stripPrefix "TZID=" s of + Just tzPlusDate -> + case T.break (== ':') tzPlusDate of + (tz,T.drop 1 -> date) -> + case datetime "" date of + Just t -> return t + Nothing -> + parseError (GeneralProblem ("Couldn't parse: " <> date)) + Nothing -> + case datetime "Z" s of + Just t -> return t + Nothing -> + parseError (GeneralProblem ("Invalid date property: " <> s)) + where datetime z s' = + parseTimeM True + defaultTimeLocale + ("%Y%m%dT%H%M%S" ++ z) + (T.unpack s') + justdate s' = + fmap (\d -> UTCTime d 0) + (parseTimeM True + defaultTimeLocale + "%Y%m%d" + (T.unpack s')) diff --git a/src/ICal/Parser.hs b/src/ICal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/ICal/Parser.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + +-- | The basic parser. + +module ICal.Parser + (-- * Types + Parser + ,ParseError(..) + -- * Handy starter functions + ,parseEither + -- * Combinators + ,begin + ,object + ,objects + ,property + ,properties + -- * Parser library + ,local + ,parseError + ,getState + ,putState) + where + +import Control.Applicative +import Control.Monad.State.Strict +import Control.Monad.Trans.Either +import Data.List +import Data.Maybe +import Data.Text (Text) +import ICal.Types + +-- | A parse error. +data ParseError + = ExpectedObject !Text + | ExpectedProperty !Text + | GeneralProblem !Text + deriving (Show) + +-- | Parse some iCalendar thing. +parseEither + :: Monad m + => s -> Parser m s a -> m (Either ParseError a) +parseEither s p = + evalStateT (runEitherT (runParser p)) + s + +-- | Parser type. +newtype Parser m s a = + Parser {runParser :: EitherT ParseError (StateT s m) a} + deriving (Monad,Applicative,Functor) + +-- | Left branch failing resets the state. +instance Monad m => Alternative (Parser m s) where + Parser x <|> Parser y = + Parser (do s <- get + r <- + EitherT (do r <- runEitherT x + return (Right r)) + case r of + Left{} -> do put s + y + Right ok -> return ok) + empty = parseError (GeneralProblem "empty parser") + +-- | Lookup a property. +property :: Monad m + => Text -- ^ Key + -> Parser m [Object] Text -- ^ The value of that property. +property !key = + do os <- getState + case listToMaybe + (mapMaybe (\case + Property name value + | name == key -> Just value + _ -> Nothing) + os) of + Nothing -> parseError (ExpectedProperty key) + Just x -> return x + +-- | Get all values of a property. +properties :: Monad m + => Text -- ^ Key + -> Parser m [Object] [Text] -- ^ The values of that property. +properties !key = + do os <- getState + return (mapMaybe (\case + Property name value + | name == key -> Just value + _ -> Nothing) + os) + +-- | Lookup an object with this name in the current object's children, +-- then run with that object as the context. +object :: Monad m => Text -> Parser m [Object] a -> Parser m [Object] a +object !name m = + do os <- getState + case find (\case + Object name' _ -> name' == name + _ -> False) os of + Just (Object _ children) -> + local children m + _ -> parseError (ExpectedObject name) + +-- | Lookup objects with this name in the current object's children, +-- then run with that object as the context. +objects :: Monad m => Text -> Parser m [Object] a -> Parser m [Object] [a] +objects !name m = + do os <- getState + case mapMaybe (\case + Object name' children + | name' == name -> Just children + _ -> Nothing) + os of + cs -> mapM (\children -> local children m) cs + +-- | Require the given object name to exist and run in that context. +begin :: Monad m => Text -> Parser m [Object] a -> Parser m Object a +begin !name m = + do o <- getState + case o of + Object name' children -> + if name' == name + then local children m + else parseError (ExpectedObject name) + _ -> parseError (ExpectedObject name) + +-- | Use a local state of a different type. +local :: Monad m + => t -> Parser m t a -> Parser m s a +local temp m = + Parser (EitherT (StateT (\orig -> + do (result,_new) <- + runStateT (runEitherT (runParser m)) temp + return (result,orig)))) + +-- | Throw a parse error. +parseError :: Monad m => ParseError -> Parser m o a +parseError = Parser . left + +-- | Get the current state. +getState :: Monad m => Parser m s s +getState = Parser get + +-- | Put a new state. +putState :: Monad m => s -> Parser m s () +putState = Parser . put diff --git a/src/ICal/Tokenizer.hs b/src/ICal/Tokenizer.hs new file mode 100644 --- /dev/null +++ b/src/ICal/Tokenizer.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + +-- | The basic tokenizer. + +module ICal.Tokenizer + (-- * Top-level functions + tokenizeObjectFromFile + ,tokenizeObjectFromText + ,tokenizeAesonFromText + -- * Raw tokenizers + ,objectTokenizer + ,linesTokenizer + ,lineTokenizer) + where + +import Control.Monad.Fix +import Data.Aeson (FromJSON(..),toJSON,fromJSON,Result(..)) +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as P +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import ICal.Types + +-- | Tokenizer a complete document from a .ics file. +tokenizeObjectFromFile :: FilePath -> IO Object +tokenizeObjectFromFile fp = + fmap tokenizeObjectFromText (T.readFile fp) >>= + \case + Left err -> error err + Right ok -> return ok + +-- | Tokenizer a complete document. +tokenizeObjectFromText :: Text -> Either String Object +tokenizeObjectFromText t = + do ls <- P.parseOnly linesTokenizer t + (object,remainder) <- objectTokenizer ls + if null remainder + then return object + else Left ("Unexpected extraneous input: " ++ show remainder) + +-- | Tokenize an Aeson instance from the document. +tokenizeAesonFromText :: FromJSON a => Text -> Either String a +tokenizeAesonFromText t = + do doc <- tokenizeObjectFromText t + case fromJSON (toJSON doc) of + Error e -> Left e + Success a -> Right a + +-- | Tokenize a list of lines into an object. +objectTokenizer :: [Line] -> Either String (Object,[Line]) +objectTokenizer [] = Left "Unexpected end of input." +objectTokenizer (Begin name:linesInAndAfterObject) = + do (values,linesAfterObject) <- + fix (\loop -> + \case + [] -> return ([],[]) + nextLineSet@(next:linesAfterObject) -> + case next of + End{} -> return ([],linesAfterObject) + _ -> + do (x,linesAfterChildObject) <- objectTokenizer nextLineSet + (xs,linesAfterRestOfChildren) <- + loop linesAfterChildObject + return (x : xs,linesAfterRestOfChildren)) + linesInAndAfterObject + return (Object name values,linesAfterObject) +objectTokenizer (Pair key value:linesAfterPair) = + return (Property key value,linesAfterPair) +objectTokenizer (End name:_) = + Left ("Unexpected end of object: " ++ show name) + +-- | Tokenize lines of iCalendar format. +linesTokenizer :: Parser [Line] +linesTokenizer = P.many1 lineTokenizer + +-- | Tokenize a single line. +lineTokenizer :: Parser Line +lineTokenizer = + do (key,value) <- propertyTokenizer + case key of + "BEGIN" -> return (Begin value) + "END" -> return (End value) + _ -> return (Pair key value) + +-- | Tokenize a (possibly-mult-line) property. +propertyTokenizer :: Parser (Text,Text) +propertyTokenizer = + do key <- P.takeWhile1 (not . propertySeparator) + _ <- P.satisfy propertySeparator + fmap ((key,) . T.concat) + (fix (\loop -> + do value <- P.takeTill newline + _ <- P.takeWhile1 newline + mnext <- P.peekChar + case mnext of + Just ' ' -> + do _ <- P.anyChar + rest <- loop + return (value : rest) + _ -> return [value])) + where propertySeparator c = c == ':' || c == ';' + newline c = c == '\r' || c == '\n' diff --git a/src/ICal/Types.hs b/src/ICal/Types.hs new file mode 100644 --- /dev/null +++ b/src/ICal/Types.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | All iCalendar types. + +module ICal.Types where + +import Data.Text (Text) +import Data.Aeson (ToJSON(..),object,(.=)) + +-- | Tree for representing iCal file. +data Object + = Property !Text -- name + !Text -- value + | Object !Text -- name + ![Object] -- values + deriving (Show) + +instance ToJSON Object where + toJSON (Object name values) = object ["name" .= name,"values" .= values] + toJSON (Property key value) = object ["key" .= key,"value" .= value] + +-- | An iCalendar line. +data Line + = Begin !Text -- object name + | End !Text -- object name + | Pair !Text -- name + !Text -- value + deriving (Show) diff --git a/src/main/Org.hs b/src/main/Org.hs new file mode 100644 --- /dev/null +++ b/src/main/Org.hs @@ -0,0 +1,23 @@ +-- | Export .org file from an iCalendar file. + +import Data.List +import Data.Maybe +import Data.Time +import ICal.Org +import System.Environment + +-- | Export .org file from an iCalendar file. +main :: IO () +main = + do args <- getArgs + let files = filter (not . isPrefixOf "--") args + opts = filter (isPrefixOf "--") args + case files of + [ics,org] -> + do let base = + fromMaybe (fromGregorian 1970 01 01) + (do dateString <- + listToMaybe (mapMaybe (stripPrefix "--base=") opts) + parseTimeM True defaultTimeLocale "%Y-%m-%d" dateString) + exportFromToFile base ics org + _ -> error "expected [--base=YYYY-MM-DD (default: 1970-01-01)]" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"