dixi 0.3.0.0 → 0.5.0.0
raw patch · 7 files changed
+148/−23 lines, 7 filesdep +network-uridep +pandoc-types
Dependencies added: network-uri, pandoc-types
Files
- Dixi/API.hs +2/−1
- Dixi/Config.hs +64/−5
- Dixi/Markup.hs +5/−5
- Dixi/Page.hs +4/−1
- Dixi/Pandoc/Wikilinks.hs +47/−0
- Main.hs +21/−9
- dixi.cabal +5/−2
Dixi/API.hs view
@@ -14,6 +14,7 @@ import Data.Proxy import Servant.API import Servant.HTML.Blaze+import Text.Hamlet (Html) import Dixi.Config import Dixi.Common@@ -28,7 +29,7 @@ (|:) = (:<|>) -data PrettyPage = PP Renders Key Version (Page Text)+data PrettyPage = PP Renders Key Version (Page Html) data RawPage = RP Renders Key Version (Page Text) data DiffPage = DP Renders Key Version Version (Page (Hunks Char)) data History = H Renders Key [Page PatchSummary]
Dixi/Config.hs view
@@ -5,18 +5,27 @@ , Renders (..) , defaultConfig , configToRenders+ , EndoIO (..) ) where +import Control.Monad ((<=<)) import Data.Aeson-import Data.Maybe (fromMaybe)-import Data.Monoid (Last (..))+import Data.Default+import Data.Maybe (fromMaybe, catMaybes)+import Data.Monoid (Last (..), Monoid (..)) import Data.Time (UTCTime, formatTime) import Data.Time.Locale.Compat import Data.Time.Zones.All (toTZName, fromTZName, tzByLabel, TZLabel (..)) import Data.Time.Zones (utcToLocalTimeTZ) import GHC.Generics+import Text.Pandoc hiding (Format, readers)+import Text.Pandoc.Error import qualified Data.ByteString.Char8 as B +import Dixi.Pandoc.Wikilinks++newtype Format = Format String deriving (Generic, Show)+ data TimeConfig = TimeConfig { timezone :: String , format :: String@@ -25,22 +34,72 @@ { port :: Int , storage :: FilePath , time :: TimeConfig+ , readerFormat :: Format+ , url :: String+ , processors :: [String] } deriving (Generic, Show) instance FromJSON Config where instance ToJSON Config where instance FromJSON TimeConfig where instance ToJSON TimeConfig where+instance FromJSON Format where+instance ToJSON Format where +type PureReader = ReaderOptions -> String -> Either PandocError Pandoc++newtype EndoIO x = EndoIO { runEndoIO :: x -> IO x }++instance Monoid (EndoIO a) where+ mempty = EndoIO return+ EndoIO a `mappend` EndoIO b = EndoIO (a <=< b)+ data Renders = Renders- { renderTime :: Last UTCTime -> String }+ { renderTime :: Last UTCTime -> String+ , pandocReader :: PureReader+ , pandocWriterOptions :: WriterOptions+ , pandocProcessors :: EndoIO Pandoc+ } defaultConfig :: Config-defaultConfig = Config 8000 "state" (TimeConfig (B.unpack $ toTZName Etc__UTC) "%T, %F")+defaultConfig = Config 8000 "state"+ (TimeConfig (B.unpack $ toTZName Etc__UTC) "%T, %F")+ (Format "org")+ ("http://localhost:8000")+ ["wikilinks"] +readers :: [(String, PureReader)]+readers = [ ("native" , const readNative)+ ,("json" , readJSON )+ ,("commonmark" , readCommonMark)+ ,("rst" , readRST)+ ,("markdown" , readMarkdown)+ ,("mediawiki" , readMediaWiki)+ ,("docbook" , readDocBook)+ ,("opml" , readOPML)+ ,("org" , readOrg)+ ,("textile" , readTextile) + ,("html" , readHtml)+ ,("latex" , readLaTeX)+ ,("haddock" , readHaddock)+ ,("twiki" , readTWiki)+ ,("t2t" , readTxt2TagsNoMacros)+ ] +allProcessors :: Config -> [(String, EndoIO Pandoc)]+allProcessors Config {..}+ = [("wikilinks", EndoIO $ wikilinks url)+ ]+ configToRenders :: Config -> Renders-configToRenders Config {..} = Renders {..}+configToRenders cfg@(Config {..}) = Renders {..} where renderTime (Last Nothing) = "(never)" renderTime (Last (Just t)) = let label = fromMaybe Etc__UTC (fromTZName $ B.pack $ timezone time) in formatTime defaultTimeLocale (format time) $ utcToLocalTimeTZ (tzByLabel label) t+ pandocReader | Format f <- readerFormat + = case lookup f readers of+ Just r -> r+ Nothing -> readOrg+ pandocWriterOptions = def { writerSourceURL = Just url }++ pandocProcessors = mconcat $ catMaybes $ map (flip lookup $ allProcessors cfg) processors
Dixi/Markup.hs view
@@ -23,7 +23,6 @@ import Text.Blaze import Text.Cassius import Text.Hamlet (shamlet, Html)-import Text.Pandoc import Text.Pandoc.Error import qualified Data.Text as T@@ -39,6 +38,7 @@ link = safeLink dixi + renderTitle :: Text -> Text renderTitle = T.pack . map (\c -> if c == '_' then ' ' else c) . T.unpack @@ -293,19 +293,19 @@ toMarkup (ParseFailure s) = [shamlet| <b> Parse Failure: </b> #{s}|] toMarkup (ParsecError _ e) = [shamlet| <b> Parse Error: </b> #{show e} |] +writePandocError :: PandocError -> Html+writePandocError err = [shamlet|#{err}|]+ instance ToMarkup PrettyPage where toMarkup (PP (Renders {..}) k v p) = let com = p ^. comment . traverse tim = renderTime $ p ^. time- bod = case readOrg def (filter (/= '\r') . T.unpack $ p ^. body) of- Left err -> [shamlet|#{err}|]- Right pd -> writeHtml def pd in outerMatter (renderTitle k) [shamlet| #{versionHeader k v com} <div .body>- #{bod}+ #{p ^. body} <div .timestamp> This version was last edited at #{tim} |]
Dixi/Page.hs view
@@ -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
+ Dixi/Pandoc/Wikilinks.hs view
@@ -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
Main.hs view
@@ -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'
dixi.cabal view
@@ -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