Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

First draft of a markdown tag

  • Loading branch information...
commit fc7f542c559dd8e9dea0fa8572d54bd82e1aa37a 1 parent 46e85c0
@gregorycollins gregorycollins authored
Showing with 109 additions and 15 deletions.
  1. +9 −4 snap-website.cabal
  2. +89 −11 src/Main.hs
  3. +11 −0 templates/tutorials/heist.tpl
View
13 snap-website.cabal
@@ -17,13 +17,18 @@ Executable snap-website
Build-depends:
base >= 4,
- haskell98,
- transformers,
bytestring,
+ directory,
+ filepath,
+ haskell98,
+ heist,
+ hexpat,
+ MonadCatchIO-transformers >= 0.2 && < 0.3,
+ monads-fd,
+ process,
snap-core,
snap-server,
- heist,
- filepath
+ transformers
ghc-prof-options: -prof -auto-all
View
100 src/Main.hs
@@ -1,51 +1,129 @@
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
-import System
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
+import Data.Maybe
import Control.Applicative
import Control.Concurrent
-import Control.Exception
+import Control.Exception (throwIO, SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import Control.Monad.Reader.Class
import Control.Monad.Trans
-import System.Exit
+import Data.Typeable
import Snap.Http.Server
import Snap.Types
import Snap.Util.FileServe
import Snap.Util.GZip
+import System
+import System.Directory
+import System.Exit
+import System.Process
import Text.Templating.Heist
+import Text.XML.Expat.Tree
-renderTmpl :: MVar (TemplateState IO)
+
+renderTmpl :: MVar (TemplateState Snap)
-> ByteString
-> Snap ()
renderTmpl tsMVar n = do
ts <- liftIO $ readMVar tsMVar
- maybe pass writeBS =<< liftIO (renderTemplate ts n)
+ maybe pass writeBS =<< renderTemplate ts n
+
-templateServe :: MVar (TemplateState IO)
+templateServe :: MVar (TemplateState Snap)
-> Snap ()
templateServe tsMVar =
ifTop (renderTmpl tsMVar "index") <|>
path "admin/reload" (reloadTemplates tsMVar) <|>
(renderTmpl tsMVar . B.pack =<< getSafePath)
-reloadTemplates :: MVar (TemplateState IO)
+
+reloadTemplates :: MVar (TemplateState Snap)
-> Snap ()
reloadTemplates tsMVar = do
- liftIO $ modifyMVar_ tsMVar (const $ loadTemplates "templates")
+ liftIO $ modifyMVar_ tsMVar $ const $
+ liftM bindMarkdownTag $ loadTemplates "templates"
-site :: MVar (TemplateState IO) -> Snap ()
+site :: MVar (TemplateState Snap) -> Snap ()
site tsMVar = withCompression $ h1 <|> h2 tsMVar
h1 :: Snap ()
h1 = fileServe "static"
-h2 :: MVar (TemplateState IO) -> Snap ()
+h2 :: MVar (TemplateState Snap) -> Snap ()
h2 m = templateServe m
+bindMarkdownTag :: TemplateState Snap -> TemplateState Snap
+bindMarkdownTag = bindSplice "markdown" markdownSplice
+
+
+data PandocMissingException = PandocMissingException
+ deriving (Typeable)
+
+instance Show PandocMissingException where
+ show PandocMissingException =
+ "Cannot find the \"pandoc\" executable; is it on your $PATH?"
+
+instance Exception PandocMissingException
+
+
+data MarkdownException = MarkdownException String
+ deriving (Typeable)
+
+instance Show MarkdownException where
+ show (MarkdownException e) =
+ "Markdown error: pandoc replied:\n\n" ++ e
+
+instance Exception MarkdownException
+
+
+pandoc :: FilePath -> ByteString -> IO ByteString
+pandoc pandocPath s = do
+ -- using the crummy string functions for convenience here
+ let s' = B.unpack s
+ (ex, sout, serr) <- readProcessWithExitCode pandocPath args s'
+
+ when (isFail ex) $ throw $ MarkdownException serr
+ return $ B.pack sout
+
+ where
+ isFail ExitSuccess = False
+ isFail _ = True
+ args = [ "-S", "--no-wrap" ]
+
+
+markdownSplice :: Splice Snap
+markdownSplice = do
+ pdMD <- liftIO $ findExecutable "pandoc"
+
+ liftIO $ B.putStrLn $ B.concat ["pandoc?", B.pack (show pdMD)]
+
+ when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException
+
+ tree <- ask
+ let txt = textContent tree
+
+ liftIO $ B.putStrLn "got text"
+ liftIO $ B.putStrLn txt
+
+ markup <- liftIO $ pandoc (fromJust pdMD) txt
+
+ liftIO $ B.putStrLn "got markup"
+ liftIO $ B.putStrLn markup
+
+ let ee = parse' heistExpatOptions markup
+ case ee of
+ (Left e) -> liftIO $ throw $ MarkdownException $
+ "Error parsing markdown output: " ++ show e
+ (Right n) -> return [n]
+
+
-- FIXME: remove
killMe :: ThreadId -> Snap ()
killMe t = liftIO (exitSuccess >> killThread t)
@@ -58,7 +136,7 @@ main = do
port:_ -> return $ read port
ts <- loadTemplates "templates"
- tsMVar <- newMVar ts
+ tsMVar <- newMVar $ bindMarkdownTag ts
(try $ httpServe "*" port "achilles"
(Just "access.log")
(Just "error.log")
View
11 templates/tutorials/heist.tpl
@@ -1,4 +1,15 @@
<apply template="page">
+
+ <markdown><![CDATA[
+
+FIXME: replace document below with original *markdown*-formatted text
+
+## TESTING 1-2-3
+This should be a [link](http://google.com)
+
+ ]]>
+ </markdown>
+
<div id="TOC"
><ul
><li
Please sign in to comment.
Something went wrong with that request. Please try again.