First pass at Atom feed fetching

lektor-rss/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2015, Getty Ritter
+
+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 Getty Ritter 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.

lektor-rss/lektor-rss.cabal

@@ -0,0 +1,21 @@
+name:                   lektor-rss
+version:                0.0.0
+author:                 Getty Ritter<gettylefou@gmail.com>
+maintainer:             Getty Ritter<gettylefou@gmail.com>
+license:                BSD3
+license-file:           LICENSE
+-- synopsis:
+-- description:
+cabal-version:          >= 1.10
+build-type:             Simple
+
+executable lektor-rss
+  hs-source-dirs:       src
+  main-is:              Main.hs
+  default-language:     Haskell2010
+  ghc-options:          -Wall
+  build-depends:        base >= 4 && < 5, feed, HTTP, SHA, xml, bytestring, directory, filepath, hostname, time, unix
+
+source-repository head
+  type:                 git
+--  Location:

lektor-rss/src/Main.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Control.Monad (zipWithM_)
+import Data.ByteString.Lazy.Char8 (pack)
+import Data.Digest.Pure.SHA
+import Data.Monoid ((<>))
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Network.HostName
+import Network.HTTP
+import System.Directory
+import System.Environment
+import System.Exit (die)
+import System.FilePath ((</>))
+import System.Posix.Process (getProcessID)
+import Text.Atom.Feed.Import (elementFeed)
+import Text.Atom.Feed
+import Text.XML.Light.Input (parseXMLDoc)
+
+usage :: String
+usage = "Usage: lektor-rss [feed url]"
+
+lektorSetup :: IO ()
+lektorSetup = do
+  dir <- getEnv "LEKTORDIR"
+  setCurrentDirectory dir
+  mapM_ (createDirectoryIfMissing True)
+    [ "src", "tmp", "new", "cur" ]
+
+main :: IO ()
+main = do
+  lektorSetup
+  getArgs >>= \case
+    []      -> putStrLn usage
+    (url:_) -> do
+      simpleHTTP (getRequest url) >>= \case
+        Left err -> die "Unable to fetch document"
+        Right r  -> makeEntries url (rspBody r)
+
+makeEntries :: String -> String -> IO ()
+makeEntries url s = case parseXMLDoc s of
+  Nothing -> die "Unale to parse XML document"
+  Just xml -> case elementFeed xml of
+    Just atom -> buildLektorDir url atom
+    Nothing   -> die "XML document not an Atom feed"
+
+contentAsString :: TextContent -> String
+contentAsString (TextString s) = s
+contentAsString _ = error "..."
+
+buildLektorDir :: String -> Feed -> IO ()
+buildLektorDir url feed = do
+  let hash = showDigest (sha1 (pack url))
+  mapM_ (createDirectoryIfMissing True)
+    [ "src" </> hash
+    , "tmp" </> hash
+    , "new" </> hash
+    , "cur" </> hash
+    ]
+  writeFile ("src" </> hash </> "name")
+    (contentAsString (feedTitle feed))
+  writeFile ("src" </> hash </> "id") url
+  zipWithM_ (buildLektorEntry hash) [0..] (reverse (feedEntries feed))
+
+buildLektorEntry :: String -> Int -> Entry -> IO ()
+buildLektorEntry hash n (Entry { .. }) = do
+  t <- fmap (floor . realToFrac) getPOSIXTime
+  p <- getProcessID
+  h <- getHostName
+  let dirId  = show t <> ".P" <> show p <> "Q" <> show n <> "." <> h
+  let tmpDir = "tmp" </> hash </> dirId
+  createDirectoryIfMissing True tmpDir
+  writeFile (tmpDir </> "title") (contentAsString entryTitle)
+  writeFile (tmpDir </> "id") entryId
+  writeFile (tmpDir </> "content") $ case entryContent of
+    Just (TextContent s) -> s
+    Just (HTMLContent s) -> s
+    _                    -> "[unsupported content]"
+  writeFile (tmpDir </> "type") $ case entryContent of
+    Just (HTMLContent s) -> "text/html"
+    _                    -> "text/plain"
+  renameDirectory tmpDir ("new" </> hash </> dirId)