- #{bod}
+ #{p ^. body}
This version was last edited at #{tim}
|]
diff --git a/Dixi/Page.hs b/Dixi/Page.hs
--- a/Dixi/Page.hs
+++ b/Dixi/Page.hs
@@ -2,11 +2,14 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
module Dixi.Page where
import Control.Lens
import Data.Data
+import Data.Foldable
import Data.Monoid
import Data.SafeCopy
import Data.Text
@@ -15,7 +18,7 @@
import Dixi.Database.Orphans ()
data Page b = Page { _body :: b, _comment :: Last Text, _time :: Last UTCTime }
- deriving (Functor, Data, Typeable, Show)
+ deriving (Functor, Data, Typeable, Show, Foldable, Traversable)
deriveSafeCopy 0 'base ''Page
diff --git a/Dixi/Pandoc/Wikilinks.hs b/Dixi/Pandoc/Wikilinks.hs
new file mode 100644
--- /dev/null
+++ b/Dixi/Pandoc/Wikilinks.hs
@@ -0,0 +1,47 @@
+module Dixi.Pandoc.Wikilinks (wikilinks) where
+
+import Text.Pandoc
+import Text.Pandoc.Walk
+import Network.URI
+
+wikilinks :: String -> Pandoc -> IO Pandoc
+wikilinks s = return . wikilinks' s
+
+wikilinks' :: String -> Pandoc -> Pandoc
+wikilinks' s = walk (wikify s)
+
+wikify :: String -> Inline -> Inline
+wikify base (Link s ("",t)) = Link s (url, t)
+ where url = base ++ "/" ++ inlinesToURL s
+wikify base (Link s (l,"wikilink")) = Link s (base ++ "/" ++ l, "wikilink")
+wikify _ x = x
+
+-- | Derives a URL from a list of Pandoc Inline elements.
+inlinesToURL :: [Inline] -> String
+inlinesToURL = escapeURIString isUnescapedInURI . inlinesToString
+
+-- | Convert a list of inlines into a string.
+inlinesToString :: [Inline] -> String
+inlinesToString = concatMap go
+ where go x = case x of
+ Str s -> s
+ Emph xs -> concatMap go xs
+ Strong xs -> concatMap go xs
+ Strikeout xs -> concatMap go xs
+ Superscript xs -> concatMap go xs
+ Subscript xs -> concatMap go xs
+ SmallCaps xs -> concatMap go xs
+ Quoted DoubleQuote xs -> '"' : (concatMap go xs ++ "\"")
+ Quoted SingleQuote xs -> '\'' : (concatMap go xs ++ "'")
+ Cite _ xs -> concatMap go xs
+ Code _ s -> s
+ Space -> "_"
+ LineBreak -> "_"
+ Math DisplayMath s -> "$$" ++ s ++ "$$"
+ Math InlineMath s -> "$" ++ s ++ "$"
+ RawInline (Format "tex") s -> s
+ RawInline _ _ -> ""
+ Link xs _ -> concatMap go xs
+ Image xs _ -> concatMap go xs
+ Note _ -> ""
+ Span _ xs -> concatMap go xs
diff --git a/Main.hs b/Main.hs
--- a/Main.hs
+++ b/Main.hs
@@ -13,7 +13,9 @@
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
+import Control.Lens
import Data.Acid
+import Data.Default
import Data.Time
import Data.Text (Text)
import Network.Wai.Handler.Warp
@@ -22,6 +24,7 @@
import System.Environment
import System.Exit
import System.IO
+import Text.Pandoc
import qualified Data.Yaml as Y
import qualified Data.Text as T
@@ -31,7 +34,7 @@
import Dixi.Config
import Dixi.Database
import Dixi.Forms () -- imported for orphans
-import Dixi.Markup () -- imported for orphans
+import Dixi.Markup (writePandocError)
import Dixi.Page
spacesToUScores :: T.Text -> T.Text
@@ -42,7 +45,7 @@
= latest
|: history
where
- latest = latestQ (PP renders) |: latestQ (RP renders)
+ latest = latestQ pp |: latestQ rp
diffPages (Just v1) (Just v2) = do liftIO $ DP renders key v1 v2 <$> query db (GetDiff key (v1, v2))
diffPages _ _ = left err400
@@ -54,23 +57,32 @@
reversion (DR v1 v2 com) = do
_ <- liftIO (getCurrentTime >>= update db . Revert key (v1, v2) com)
- latestQ (PP renders)
- version v = (versionQ (PP renders) v |: versionQ (RP renders) v)
+ latestQ pp
+ version v = (versionQ pp v |: versionQ rp v)
|: updateVersion v
updateVersion v (NB t c) = do _ <- liftIO $ (getCurrentTime >>= update db . Amend key v t c)
- latestQ (PP renders)
+ latestQ pp
- latestQ :: (Key -> Version -> Page Text -> a) -> EitherT ServantErr IO a
- latestQ pp = do liftIO $ uncurry (pp key) <$> query db (GetLatest key)
+ latestQ :: (Key -> Version -> Page Text -> IO a) -> EitherT ServantErr IO a
+ latestQ p = liftIO (uncurry (p key) =<< query db (GetLatest key))
- versionQ :: (Key -> Version -> Page Text -> a) -> Version -> EitherT ServantErr IO a
- versionQ pp v = do liftIO $ pp key v <$> query db (GetVersion key v)
+ versionQ :: (Key -> Version -> Page Text -> IO a) -> Version -> EitherT ServantErr IO a
+ versionQ p v = liftIO (p key v =<< query db (GetVersion key v))
+ pp :: Key -> Version -> Page Text -> IO PrettyPage
+ pp k v p = fmap (PP renders k v) $ flip traverse p $ \b ->
+ case pandocReader renders def (filter (/= '\r') . T.unpack $ b) of
+ Left err -> return $ writePandocError err
+ Right pd -> writeHtml (pandocWriterOptions renders) <$> runEndoIO (pandocProcessors renders) pd
+
+ rp k v p = return (RP renders k v p)
+
renders = configToRenders cfg
server :: AcidState Database -> Config -> Server Dixi
server db cfg = page db cfg
|: page db cfg "Main_Page"
+
main :: IO ()
main = getArgs >>= main'
diff --git a/dixi.cabal b/dixi.cabal
--- a/dixi.cabal
+++ b/dixi.cabal
@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: dixi
-version: 0.3.0.0
+version: 0.5.0.0
synopsis: A wiki implemented with a firm theoretical foundation.
description: This project is a simple wiki developed based on a
firm theoretical foundation.
@@ -45,12 +45,14 @@
, Dixi.Hamlet
, Dixi.Markup
, Dixi.Page
+ , Dixi.Pandoc.Wikilinks
, Dixi.PatchUtils
-- other-extensions:
ghc-options: -Wall
build-depends: base >=4.7 && <4.9
, composition-tree >= 0.2.0.1 && < 0.3, patches-vector >= 0.1.2 && < 0.2
- , pandoc >= 1.15 && < 1.16 , servant >= 0.4 && < 0.5
+ , pandoc >= 1.15 && < 1.16 , pandoc-types >= 1.12 && < 1.13
+ , servant >= 0.4 && < 0.5
, acid-state >= 0.12 && <0.14 , safecopy >= 0.8.3 && < 0.9
, lens >= 4.12 && < 4.14, servant-server >= 0.4 && < 0.5
, blaze-html >= 0.8 && < 0.9 , servant-blaze >= 0.4 && < 0.5, blaze-markup >= 0.7 && <0.8
@@ -69,6 +71,7 @@
, time-locale-compat >= 0.1 && < 0.2
, tz >= 0.0 && < 0.1
, bytestring >= 0.10 && < 0.11
+ , network-uri >= 2.6 && < 2.7
-- hs-source-dirs:
default-language: Haskell2010