gdritter repos lektor / 43a191f
Switched error-handling to ExceptT Getty Ritter 8 years ago
3 changed file(s) with 29 addition(s) and 33 deletion(s). Collapse all Expand all
+1
-2
lektor-rss/lektor-rss.cabal less more
1414 main-is: Main.hs
1515 default-language: Haskell2010
1616 ghc-options: -Wall
17 build-depends: base >= 4 && < 5, feed, HTTP, SHA, xml, bytestring, directory, filepath, hostname, time, unix, random
18
17 build-depends: base >= 4 && < 5, feed, HTTP, SHA, xml, bytestring, directory, filepath, hostname, time, unix, random, errors, transformers
1918 source-repository head
2019 type: git
2120 -- Location:
+10
-0
lektor-rss/src/Lektor.hs less more
88 , writeAll
99 , writeFeed
1010 , writeEntry
11 , writeSetup
1112 ) where
1213
1314 import Data.ByteString.Lazy.Char8 (pack)
1718 import Data.Time.Clock.POSIX (getPOSIXTime)
1819 import Network.HostName (getHostName)
1920 import System.Directory
21 import System.Environment (getEnv)
2022 import System.FilePath ((</>))
2123 import System.Posix.Files (createSymbolicLink)
2224 import System.Posix.Process (getProcessID)
5860 mkEntry entryId entryTitle entryContent =
5961 Entry entryId entryTitle entryContent Nothing Nothing Nothing
6062
63 writeSetup :: IO ()
64 writeSetup = do
65 dir <- getEnv "LEKTORDIR"
66 setCurrentDirectory dir
67 mapM_ (createDirectoryIfMissing True)
68 [ "src", "tmp", "new", "cur" ]
69
6170 writeAll :: (Feed, [Entry]) -> IO ()
6271 writeAll (feed, entries) = do
72 writeSetup
6373 writeFeed feed
6474 mapM_ (writeEntry feed) entries
6575
+18
-31
lektor-rss/src/Main.hs less more
44
55 module Main where
66
7 import Atom
78 import qualified Lektor as L
8 import qualified Atom as A
99
10 import Network.HTTP
11 import System.Directory
12 import System.Environment
13 import Text.Atom.Feed.Import (elementFeed)
14 import Text.XML.Light.Input (parseXMLDoc)
15
16 die :: String -> a
17 die = error
10 import Control.Error (ExceptT(..), headErr, fmapLT, runScript, (??))
11 import Control.Monad.Trans.Class (lift)
12 import Network.HTTP (simpleHTTP, getRequest, rspBody)
13 import System.Environment (getArgs)
14 import Text.Atom.Feed.Import (elementFeed)
15 import Text.XML.Light.Input (parseXMLDoc)
1816
1917 usage :: String
2018 usage = "Usage: lektor-rss [feed url]"
2119
22 lektorSetup :: IO ()
23 lektorSetup = do
24 dir <- getEnv "LEKTORDIR"
25 setCurrentDirectory dir
26 mapM_ (createDirectoryIfMissing True)
27 [ "src", "tmp", "new", "cur" ]
28
2920 main :: IO ()
30 main = do
31 lektorSetup
32 getArgs >>= \case
33 [] -> putStrLn usage
34 (url:_) -> do
35 simpleHTTP (getRequest url) >>= \case
36 Left _ -> die "Unable to fetch document"
37 Right r -> writeAsAtom (rspBody r)
38
39 writeAsAtom :: String -> IO ()
40 writeAsAtom s = case parseXMLDoc s of
41 Nothing -> die "Unable to parse XML document"
42 Just xml -> case elementFeed xml of
43 Nothing -> die "XML document not an Atom feed"
44 Just atom -> L.writeAll (A.atomToLektor atom)
21 main = runScript $ do
22 -- check the args for the url
23 url <- ExceptT (fmap (headErr usage) getArgs)
24 -- GET the resource
25 resp <- fmapLT show (ExceptT (simpleHTTP (getRequest url)))
26 -- parse the XML
27 xml <- parseXMLDoc (rspBody resp) ?? "Unable to parse XML document"
28 -- decode the Atom format
29 atom <- elementFeed xml ?? "XML document not an Atom feed"
30 -- write the Lektor dir
31 lift (L.writeAll (atomToLektor atom))