Commit 1ecceeb46ecea423e9a320015d85281518bf3b23 - lektor

Finished Atom example Getty Ritter 10 years ago

4 changed file(s) with 34 addition(s) and 66 deletion(s). Collapse all Expand all

-1

lektor-rss/lektor-rss.cabal less more

14	14	main-is: Main.hs
15	15	default-language: Haskell2010
16	16	ghc-options: -Wall
17		build-depends: base >= 4 && < 5, feed, HTTP, SHA, xml, bytestring, directory, filepath, hostname, time, unix
	17	build-depends: base >= 4 && < 5, feed, HTTP, SHA, xml, bytestring, directory, filepath, hostname, time, unix, random
18	18
19	19	source-repository head
20	20	type: git

-2

lektor-rss/src/Atom.hs less more

27	27	, L.entryTitle = toString entryTitle
28	28	, L.entryContent = maybe "" entryToString entryContent
29	29	, L.entryAuthor = toPeople entryAuthors
30		, L.entryPubdate = undefined
31		, L.entryType = undefined
	30	, L.entryPubdate = Just entryUpdated
	31	, L.entryType = fmap entryToType entryContent
32	32	}
33	33
34	34	toString :: TextContent -> String

43	43	entryToString (MixedContent _ _) = "[unimplemented]"
44	44	entryToString (ExternalContent _ _) = "[unimplemented]"
45	45
	46	entryToType :: EntryContent -> String
	47	entryToType HTMLContent {} = "text/html"
	48	entryToType XHTMLContent {} = "text/xhtml"
	49	entryToType _ = "text/plain"
	50
46	51	toPeople :: [Person] -> Maybe String
47	52	toPeople [] = Nothing
48	53	toPeople xs = Just (unlines (map toPerson xs))

+19

-9

lektor-rss/src/Lektor.hs less more

1	1	{-# LANGUAGE RecordWildCards #-}
2		{-# LANGUAGE ScopedTypeVariables #-}
3	2
4	3	module Lektor
5	4	( Feed(..)
6	5	, Entry(..)
7	6	, mkFeed
8	7	, mkEntry
	8	, writeAll
9	9	, writeFeed
10	10	, writeEntry
11	11	) where

20	20	import System.FilePath ((</>))
21	21	import System.Posix.Files (createSymbolicLink)
22	22	import System.Posix.Process (getProcessID)
	23	import System.Random (randomIO)
23	24
24	25	mkdirP :: FilePath -> IO ()
25	26	mkdirP = createDirectoryIfMissing True

57	58	mkEntry entryId entryTitle entryContent =
58	59	Entry entryId entryTitle entryContent Nothing Nothing Nothing
59	60
	61	writeAll :: (Feed, [Entry]) -> IO ()
	62	writeAll (feed, entries) = do
	63	writeFeed feed
	64	mapM_ (writeEntry feed) entries
	65
60	66	writeFeed :: Feed -> IO ()
61	67	writeFeed Feed { .. } = do
62	68	let dir = "src" </> hash feedId

69	75	writeFileMb (dir </> "copyright") feedCopy
70	76	writeFileMb (dir </> "author") feedAuthor
71	77
72		writeEntry :: Entry -> Feed -> IO ()
73		writeEntry (Entry { .. }) (Feed { feedId = feedId }) = do
	78	writeEntry :: Feed -> Entry -> IO ()
	79	writeEntry (Feed { feedId = feedId }) (Entry { .. }) = do
74	80	let feedHash = hash feedId
75	81	uniq <- mkUniq
76	82	let dir = "tmp" </> feedHash </> uniq
	83	cwd <- getCurrentDirectory
77	84	mkdirP dir
78	85	mkdirP ("new" </> hash feedId)
79	86	writeFile (dir </> "id") entryId

82	89	writeFileMb (dir </> "author") entryAuthor
83	90	writeFileMb (dir </> "pubdate") entryPubdate
84	91	writeFileMb (dir </> "type") entryType
85		createSymbolicLink (~~dir </> "feed") ("src" </> feedHash~~)
	92	createSymbolicLink (cwd </> "src" </> feedHash) (dir </> "feed")
86	93	renameDirectory dir ("new" </> feedHash </> uniq)
	94
	95	integer :: Integer -> Integer
	96	integer = id
87	97
88	98	mkUniq :: IO String
89	99	mkUniq = do
90		(t :: Integer, r') <- properFraction `fmap` getPOSIXTime
91		let r = filter isDigit (show r')
92		~~let m = ""~~
	100	(t, m') <- properFraction `fmap` getPOSIXTime
	101	let m = filter isDigit (show m')
	102	r <- abs `fmap` randomIO
93	103	p <- getProcessID
94	104	h <- getHostName
95		let uniq = "P" <> show p <> "R" <> r <> "M" <> m
96		return (show t <> "." <> uniq <> "." <> h)
	105	let uniq = "P" <> show p <> "R" <> show (integer r) <> "M" <> m
	106	return (show (integer t) <> "." <> uniq <> "." <> h)

-54

lektor-rss/src/Main.hs less more

5	5	module Main where
6	6
7	7	import qualified Lektor as L
8
9	8	import qualified Atom as A
10	9
11		import Control.Monad (zipWithM_)
12		import Data.ByteString.Lazy.Char8 (pack)
13		import Data.Digest.Pure.SHA
14		import Data.Monoid ((<>))
15		import Data.Time.Clock.POSIX (getPOSIXTime)
16		import Network.HostName
17	10	import Network.HTTP
18	11	import System.Directory
19	12	import System.Environment
20		-- import System.Exit (die)
21		import System.FilePath ((</>))
22		import System.Posix.Process (getProcessID)
23	13	import Text.Atom.Feed.Import (elementFeed)
24		import Text.Atom.Feed
25	14	import Text.XML.Light.Input (parseXMLDoc)
26	15
	16	die :: String -> a
27	17	die = error
28	18
29	19	usage :: String

43	33	[] -> putStrLn usage
44	34	(url:_) -> do
45	35	simpleHTTP (getRequest url) >>= \case
46		Left err -> die "Unable to fetch document"
47		Right r -> makeEntries url (rspBody r)
	36	Left _ -> die "Unable to fetch document"
	37	Right r -> writeAsAtom (rspBody r)
48	38
49		makeEntries :: String -> String -> IO ()
50		makeEntries url s = case parseXMLDoc s of
51		Nothing -> die "Unale to parse XML document"
	39	writeAsAtom :: String -> IO ()
	40	writeAsAtom s = case parseXMLDoc s of
	41	Nothing -> die "Unable to parse XML document"
52	42	Just xml -> case elementFeed xml of
53		Just atom -> buildLektorDir url atom
54	43	Nothing -> die "XML document not an Atom feed"
55
56		contentAsString :: TextContent -> String
57		contentAsString (TextString s) = s
58		contentAsString _ = error "..."
59
60		buildLektorDir :: String -> Feed -> IO ()
61		buildLektorDir url feed = do
62		let hash = showDigest (sha1 (pack url))
63		mapM_ (createDirectoryIfMissing True)
64		[ "src" </> hash
65		, "tmp" </> hash
66		, "new" </> hash
67		, "cur" </> hash
68		]
69		writeFile ("src" </> hash </> "name")
70		(contentAsString (feedTitle feed))
71		writeFile ("src" </> hash </> "id") url
72		zipWithM_ (buildLektorEntry hash) [0..] (reverse (feedEntries feed))
73
74		buildLektorEntry :: String -> Int -> Entry -> IO ()
75		buildLektorEntry hash n (Entry { .. }) = do
76		t <- fmap (floor . realToFrac) getPOSIXTime
77		p <- getProcessID
78		h <- getHostName
79		let dirId = show t <> ".P" <> show p <> "Q" <> show n <> "." <> h
80		let tmpDir = "tmp" </> hash </> dirId
81		createDirectoryIfMissing True tmpDir
82		writeFile (tmpDir </> "title") (contentAsString entryTitle)
83		writeFile (tmpDir </> "id") entryId
84		writeFile (tmpDir </> "content") $ case entryContent of
85		Just (TextContent s) -> s
86		Just (HTMLContent s) -> s
87		_ -> "[unsupported content]"
88		writeFile (tmpDir </> "type") $ case entryContent of
89		Just (HTMLContent s) -> "text/html"
90		_ -> "text/plain"
91		~~renameDirectory tmpDir ("new" </> hash </> dirId~~)
	44	Just atom -> L.writeAll (A.atomToLektor atom)