| 1 |
{-# LANGUAGE ViewPatterns #-}
|
| 2 |
{-# LANGUAGE LambdaCase #-}
|
| 3 |
{-# LANGUAGE RecordWildCards #-}
|
| 4 |
|
| 5 |
module Main where
|
| 6 |
|
| 7 |
import Control.Monad (zipWithM_)
|
| 8 |
import Data.ByteString.Lazy.Char8 (pack)
|
| 9 |
import Data.Digest.Pure.SHA
|
| 10 |
import Data.Monoid ((<>))
|
| 11 |
import Data.Time.Clock.POSIX (getPOSIXTime)
|
| 12 |
import Network.HostName
|
| 13 |
import Network.HTTP
|
| 14 |
import System.Directory
|
| 15 |
import System.Environment
|
| 16 |
import System.Exit (die)
|
| 17 |
import System.FilePath ((</>))
|
| 18 |
import System.Posix.Process (getProcessID)
|
| 19 |
import Text.Atom.Feed.Import (elementFeed)
|
| 20 |
import Text.Atom.Feed
|
| 21 |
import Text.XML.Light.Input (parseXMLDoc)
|
| 22 |
|
| 23 |
usage :: String
|
| 24 |
usage = "Usage: lektor-rss [feed url]"
|
| 25 |
|
| 26 |
lektorSetup :: IO ()
|
| 27 |
lektorSetup = do
|
| 28 |
dir <- getEnv "LEKTORDIR"
|
| 29 |
setCurrentDirectory dir
|
| 30 |
mapM_ (createDirectoryIfMissing True)
|
| 31 |
[ "src", "tmp", "new", "cur" ]
|
| 32 |
|
| 33 |
main :: IO ()
|
| 34 |
main = do
|
| 35 |
lektorSetup
|
| 36 |
getArgs >>= \case
|
| 37 |
[] -> putStrLn usage
|
| 38 |
(url:_) -> do
|
| 39 |
simpleHTTP (getRequest url) >>= \case
|
| 40 |
Left err -> die "Unable to fetch document"
|
| 41 |
Right r -> makeEntries url (rspBody r)
|
| 42 |
|
| 43 |
makeEntries :: String -> String -> IO ()
|
| 44 |
makeEntries url s = case parseXMLDoc s of
|
| 45 |
Nothing -> die "Unale to parse XML document"
|
| 46 |
Just xml -> case elementFeed xml of
|
| 47 |
Just atom -> buildLektorDir url atom
|
| 48 |
Nothing -> die "XML document not an Atom feed"
|
| 49 |
|
| 50 |
contentAsString :: TextContent -> String
|
| 51 |
contentAsString (TextString s) = s
|
| 52 |
contentAsString _ = error "..."
|
| 53 |
|
| 54 |
buildLektorDir :: String -> Feed -> IO ()
|
| 55 |
buildLektorDir url feed = do
|
| 56 |
let hash = showDigest (sha1 (pack url))
|
| 57 |
mapM_ (createDirectoryIfMissing True)
|
| 58 |
[ "src" </> hash
|
| 59 |
, "tmp" </> hash
|
| 60 |
, "new" </> hash
|
| 61 |
, "cur" </> hash
|
| 62 |
]
|
| 63 |
writeFile ("src" </> hash </> "name")
|
| 64 |
(contentAsString (feedTitle feed))
|
| 65 |
writeFile ("src" </> hash </> "id") url
|
| 66 |
zipWithM_ (buildLektorEntry hash) [0..] (reverse (feedEntries feed))
|
| 67 |
|
| 68 |
buildLektorEntry :: String -> Int -> Entry -> IO ()
|
| 69 |
buildLektorEntry hash n (Entry { .. }) = do
|
| 70 |
t <- fmap (floor . realToFrac) getPOSIXTime
|
| 71 |
p <- getProcessID
|
| 72 |
h <- getHostName
|
| 73 |
let dirId = show t <> ".P" <> show p <> "Q" <> show n <> "." <> h
|
| 74 |
let tmpDir = "tmp" </> hash </> dirId
|
| 75 |
createDirectoryIfMissing True tmpDir
|
| 76 |
writeFile (tmpDir </> "title") (contentAsString entryTitle)
|
| 77 |
writeFile (tmpDir </> "id") entryId
|
| 78 |
writeFile (tmpDir </> "content") $ case entryContent of
|
| 79 |
Just (TextContent s) -> s
|
| 80 |
Just (HTMLContent s) -> s
|
| 81 |
_ -> "[unsupported content]"
|
| 82 |
writeFile (tmpDir </> "type") $ case entryContent of
|
| 83 |
Just (HTMLContent s) -> "text/html"
|
| 84 |
_ -> "text/plain"
|
| 85 |
renameDirectory tmpDir ("new" </> hash </> dirId)
|