dixi 0.5.1.1 → 0.6
raw patch · 14 files changed
+835/−333 lines, 14 filesdep +aeson-prettydep +attoparsecdep +dixidep ~base
Dependencies added: aeson-pretty, attoparsec, dixi, filepath, heredoc, servant-docs, transformers-compat
Dependency ranges changed: base
Files
- Dixi/API.hs +95/−12
- Dixi/Common.hs +6/−0
- Dixi/Config.hs +106/−52
- Dixi/Database.hs +43/−22
- Dixi/Database/Orphans.hs +2/−2
- Dixi/Forms.hs +11/−3
- Dixi/Markup.hs +164/−119
- Dixi/Page.hs +4/−1
- Dixi/PatchUtils.hs +1/−1
- Dixi/Server.hs +89/−0
- Main.hs +0/−111
- api-docs/Docs.hs +159/−0
- dixi.cabal +55/−10
- main/Main.hs +100/−0
Dixi/API.hs view
@@ -1,24 +1,38 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-} module Dixi.API where +import Control.Lens hiding ((.=))+import Data.Aeson+import Data.Aeson.Types+import Data.Foldable import Data.Text (Text)-import Data.Patch+import Data.Patch (Hunks, HunkStatus (..)) import Data.Proxy+import Data.Vector (Vector) import Servant.API import Servant.HTML.Blaze+import Text.Blaze.Html.Renderer.Text import Text.Hamlet (Html) +#ifdef OLDBASE+import Control.Applicative+#endif+ import Dixi.Config import Dixi.Common import Dixi.Page import Dixi.PatchUtils ++ type a :| b = a :<|> b infixr 8 :| infixr 8 |:@@ -35,18 +49,87 @@ data NewBody = NB Text (Maybe Text) data RevReq = DR Version Version (Maybe Text) -type HistoryAPI = Get '[HTML] History+type HistoryAPI = Get '[HTML, JSON] History :| Capture "version" Version :> VersionAPI- :| "diff" :> QueryParam "from" Version :> QueryParam "to" Version :> Get '[HTML] DiffPage- :| "revert" :> ReqBody '[FormUrlEncoded] RevReq :> Post '[HTML] PrettyPage+ :| "diff" :> QueryParam "from" Version :> QueryParam "to" Version :> Get '[HTML, JSON] DiffPage+ :| "revert" :> ReqBody '[FormUrlEncoded, JSON] RevReq :> Post '[HTML, JSON] PrettyPage type VersionAPI = PageViewAPI- :| ReqBody '[FormUrlEncoded] NewBody :> Post '[HTML] PrettyPage+ :| ReqBody '[FormUrlEncoded, JSON] NewBody :> Post '[HTML, JSON] PrettyPage type PageAPI = PageViewAPI :| "history" :> HistoryAPI-type PageViewAPI = Get '[HTML] PrettyPage- :| "raw" :> Get '[HTML] RawPage+type PageViewAPI = Get '[HTML, JSON] PrettyPage+ :| "raw" :> Get '[HTML, JSON] RawPage type Dixi = Capture "page" Key :> PageAPI :| PageAPI+++instance FromJSON RevReq where+ parseJSON (Object o) = DR <$> o .: "from" <*> o .: "to" <*> o .:? "comment"+ parseJSON wat = typeMismatch "Revert" wat++instance ToJSON RevReq where+ toJSON (DR v1 v2 Nothing) = object ["from" .= v1, "to" .= v2]+ toJSON (DR v1 v2 (Just c)) = object ["from" .= v1, "to" .= v2, "comment" .= c]++instance FromJSON NewBody where+ parseJSON (Object o) = NB <$> o .: "content" <*> o .:? "comment"+ parseJSON wat = typeMismatch "NewBody" wat++instance ToJSON NewBody where+ toJSON (NB cn Nothing) = object ["content" .= cn ]+ toJSON (NB cn (Just c)) = object ["content" .= cn, "comment" .= c ]+++instance ToJSON DiffPage where+ toJSON (DP (Renders {..}) k v1 v2 p)+ = object [ "title" .= k+ , "versions" .= object [ "from" .= v1 , "to" .= v2 ]+ , "diff" .= map (uncurry hunkToJSON) (p ^. body)+ ]+ where+ hunkToJSON :: Vector Char -> HunkStatus -> Value + hunkToJSON v s = object [ "text" .= toList v+ , "status" .= case s of Inserted -> '+'+ Deleted -> '-'+ Replaced -> '~'+ Unchanged -> ' '+ ]+instance ToJSON RawPage where+ toJSON (RP (Renders {..}) k v p)+ = let tim = renderTime $ p ^. time+ com = p ^. comment . traverse+ in object [ "title" .= k+ , "version" .= v+ , "time" .= tim+ , "comment" .= com+ , "content" .= (p ^. body)+ ]+++instance ToJSON PrettyPage where+ toJSON (PP (Renders {..}) k v p)+ = let tim = renderTime $ p ^. time+ com = p ^. comment . traverse+ in object [ "title" .= k+ , "version" .= v+ , "time" .= tim+ , "comment" .= com+ , "content" .= renderHtml (p ^. body)+ ]++instance ToJSON History where+ toJSON (H (Renders {..}) k cs) = object [ "title" .= k , "history" .= zipWith versionToJSON [1 :: Version ..] cs]+ where+ versionToJSON v p = let+ tim = renderTime $ p ^. time+ com = p ^. comment . traverse+ (a,b,c) = p ^. body+ in object [ "version" .= v+ , "time" .= tim+ , "comment" .= com+ , "changes" .= object [ "insertions" .= a , "deletions" .= b, "modifications" .= c]+ ]+ dixi :: Proxy Dixi dixi = Proxy
Dixi/Common.hs view
@@ -1,6 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-} module Dixi.Common where import Data.Text+import Data.Typeable type Key = Text type Version = Int++data DixiError = VersionNotFound Key Version+ | PatchNotApplicable Key+ deriving (Show, Typeable)
Dixi/Config.hs view
@@ -1,51 +1,72 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-} -module Dixi.Config ( Config (Config, port, storage)+module Dixi.Config ( Config (Config, port, storage, static, stylesheet) , Renders (..) , defaultConfig , configToRenders+ , defaultRenders , EndoIO (..) ) where import Control.Monad ((<=<)) import Data.Aeson+import Data.Aeson.Types+import Data.Char (toLower) import Data.Default-import Data.Maybe (catMaybes)-import Data.Monoid (Last (..), Monoid (..))+import Data.Maybe (mapMaybe, fromMaybe)+import Data.Monoid import Data.Time (UTCTime, formatTime) import Data.Time.Locale.Compat import Data.Time.LocalTime.TimeZone.Olson import Data.Time.LocalTime.TimeZone.Series import GHC.Generics-import Text.Pandoc hiding (Format, readers)-import Text.Pandoc.Error+import Text.Hamlet +import qualified Text.Pandoc as P+import qualified Text.Pandoc.Error as P+ import Dixi.Pandoc.Wikilinks -newtype Format = Format String deriving (Generic, Show)+newtype Format = Format String+ deriving (Generic, Show) data TimeConfig = TimeConfig- { timezone :: String- , format :: String- } deriving (Generic, Show)+ { timezone :: String+ , format :: String+ } deriving (Generic, Show)++++data MathMethod = Plain | LatexMathML | MathML | MathJax | Katex deriving (Generic, Show)+ data Config = Config- { port :: Int- , storage :: FilePath- , time :: TimeConfig+ { port :: Int+ , storage :: FilePath+ , static :: Maybe FilePath+ , stylesheet :: FilePath+ , time :: TimeConfig , readerFormat :: Format- , url :: String- , processors :: [String]+ , url :: String+ , processors :: [String]+ , math :: MathMethod } 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+instance FromJSON Config where+ parseJSON = genericParseJSON (defaultOptions {omitNothingFields = True})+instance ToJSON Config where+ toJSON = genericToJSON (defaultOptions {omitNothingFields = True})+instance FromJSON TimeConfig where -- generic+instance ToJSON TimeConfig where -- generic+instance FromJSON Format where -- generic+instance ToJSON Format where -- generic+instance FromJSON MathMethod where+ parseJSON = genericParseJSON (defaultOptions { constructorTagModifier = map toLower})+instance ToJSON MathMethod where+ toJSON = genericToJSON (defaultOptions { constructorTagModifier = map toLower }) -type PureReader = ReaderOptions -> String -> Either PandocError Pandoc+type PureReader = P.ReaderOptions -> String -> Either P.PandocError P.Pandoc newtype EndoIO x = EndoIO { runEndoIO :: x -> IO x } @@ -56,50 +77,83 @@ data Renders = Renders { renderTime :: Last UTCTime -> String , pandocReader :: PureReader- , pandocWriterOptions :: WriterOptions- , pandocProcessors :: EndoIO Pandoc+ , pandocWriterOptions :: P.WriterOptions+ , pandocProcessors :: EndoIO P.Pandoc+ , headerBlock :: Html } +defaultRenders :: Renders+defaultRenders = Renders renderTime P.readOrg def mempty+ [shamlet|<link rel="stylesheet" href="/static/stylesheet.css">|]+ where renderTime (Last Nothing) = "(never)"+ renderTime (Last (Just t)) = show t+ defaultConfig :: Config-defaultConfig = Config 8000 "state"+defaultConfig = Config 8000 "state" (Just "static") "style.css" (TimeConfig "Etc/UTC" "%T, %F") (Format "org")- ("http://localhost:8000")+ "http://localhost:8000" ["wikilinks"]+ Katex 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)- ]+readers = [ ("native" , const P.readNative)+ , ("json" , P.readJSON )+ , ("commonmark" , P.readCommonMark)+ , ("rst" , P.readRST)+ , ("markdown" , P.readMarkdown)+ , ("mediawiki" , P.readMediaWiki)+ , ("docbook" , P.readDocBook)+ , ("opml" , P.readOPML)+ , ("org" , P.readOrg)+ , ("textile" , P.readTextile)+ , ("html" , P.readHtml)+ , ("latex" , P.readLaTeX)+ , ("haddock" , P.readHaddock)+ , ("twiki" , P.readTWiki)+ , ("t2t" , P.readTxt2TagsNoMacros)+ ] -allProcessors :: Config -> [(String, EndoIO Pandoc)]+allProcessors :: Config -> [(String, EndoIO P.Pandoc)] allProcessors Config {..}- = [("wikilinks", EndoIO $ wikilinks url)+ = [ ("wikilinks", EndoIO $ wikilinks url) ] +convertMathMethod :: MathMethod -> P.HTMLMathMethod+convertMathMethod Plain = P.PlainMath+convertMathMethod LatexMathML = P.LaTeXMathML Nothing+convertMathMethod MathML = P.MathML Nothing+convertMathMethod MathJax = P.MathJax ""+convertMathMethod Katex = P.KaTeX "" ""++headerForMathMethod :: MathMethod -> Html+headerForMathMethod Plain = [shamlet||]+headerForMathMethod LatexMathML = [shamlet|+ <script type="text/javascript" src="http://math.etsu.edu/LaTeXMathML/LaTeXMathML.js">+ <link rel="stylesheet" type="text/css" href="http://math.etsu.edu/LaTeXMathML/LaTeXMathML.standardarticle.css">+ |]+headerForMathMethod MathML = [shamlet||]+headerForMathMethod Katex = [shamlet|+ <link rel="stylesheet" href="//cdnjs.cloudflare.com/ajax/libs/KaTeX/0.5.1/katex.min.css">+ <script src="//cdnjs.cloudflare.com/ajax/libs/KaTeX/0.5.1/katex.min.js">+ <script src="//code.jquery.com/jquery-1.11.2.min.js"></script>+ <script> $(function () { $(".math").each(function (x) { katex.render($(this).text(), this); }); });+ |]+headerForMathMethod MathJax = [shamlet|+ <script type="text/javascript" src="https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML">+ |]+ configToRenders :: Config -> IO Renders configToRenders cfg@(Config {..}) = do olsonData <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ timezone time) let renderTime (Last Nothing) = "(never)" renderTime (Last (Just t)) = formatTime defaultTimeLocale (format time) $ utcToLocalTime' olsonData 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- return $ Renders {..}+ pandocReader | Format f <- readerFormat = fromMaybe P.readOrg (lookup f readers)+ pandocWriterOptions = def { P.writerSourceURL = Just url, P.writerHTMLMathMethod = convertMathMethod math }+ pandocProcessors = mconcat $ mapMaybe (flip lookup $ allProcessors cfg) processors+ stylesheetUrl = url ++ "/static/" ++ stylesheet+ headerBlock = [shamlet|+ <link rel="stylesheet" href="#{stylesheetUrl}">+ #{headerForMathMethod math}+ |]+ return Renders {..}
Dixi/Database.hs view
@@ -2,8 +2,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS -fno-warn-orphans #-} module Dixi.Database ( Database , emptyDB+ , DixiError (..) , Amend (..) , GetDiff (..) , GetHistory (..)@@ -12,13 +15,13 @@ , Revert (..) ) where -import Control.Applicative import Control.Lens+import Control.Monad.Trans.Except+import Control.Monad import Data.Acid import Data.Compositions.Snoc (Compositions) import Data.Foldable import Data.Map (Map)-import Data.Maybe import Data.Monoid import Data.Patch (Patch) import Data.SafeCopy hiding (Version)@@ -26,6 +29,10 @@ import Data.Time import Data.Typeable +#ifdef OLDBASE+import Control.Applicative+#endif+ import qualified Data.Compositions.Snoc as C import qualified Data.Patch as P import qualified Data.Text as T@@ -39,57 +46,71 @@ data Database = DB { _db :: Map Key (Compositions (Page (Patch Char)))} deriving (Typeable) + emptyDB :: Database emptyDB = DB mempty deriveSafeCopy 0 'base ''Database +deriveSafeCopy 0 'base ''DixiError+ makeLenses ''Database + getLatest :: Key -> Query Database (Version, Page Text) getLatest k = do- b <- (view (db . ix k))+ b <- view (db . ix k) return (C.length b, patchToText <$> C.composed b) -getVersion :: Key -> Version -> Query Database (Page Text)-getVersion k v = do+getVersion :: Key -> Version -> Query Database (Either DixiError (Page Text))+getVersion k v = runExceptT $ do b <- view (db . ix k)+ when (C.length b < v) $ throwE $ VersionNotFound k v return $ patchToText <$> C.composed (C.take v b) getHistory :: Key -> Query Database [Page PatchSummary] getHistory k = view (db . ix k . to (fmap (fmap patchSummary) . toList)) -getDiff :: Key -> (Version, Version) -> Query Database (Page (P.Hunks Char))+{-# ANN module "HLint: ignore Reduce duplication" #-}+getDiff :: Key -> (Version, Version) -> Query Database (Either DixiError (Page (P.Hunks Char))) getDiff k (v1 , v2) | v1 > v2 = getDiff k (v2, v1)- | otherwise = do+ | otherwise = runExceptT $ do b <- view (db . ix k)+ let latest = C.length b+ when (latest < v1) $ throwE $ VersionNotFound k v1+ when (latest < v2) $ throwE $ VersionNotFound k v2 let y = patchToVector (C.composed (C.take v1 b) ^. body)- return $ fmap (\z -> P.hunks z y) (C.dropComposed v1 (C.take v2 b)) + return $ fmap (`P.hunks` y) (C.dropComposed v1 (C.take v2 b)) -amendPatch :: Key -> Version -> Patch Char -> Maybe Text -> UTCTime -> Update Database (Version)-amendPatch k v q com tim = do- (db . at k) %= \mb ->- let b = fromMaybe mempty mb- p = C.dropComposed v b ^. body- r = snd $ P.transformWith P.theirs p q- in Just (C.snoc b (Page r (Last com) (Last $ Just tim)))- C.length <$> use (db . ix k)+amendPatch :: Key -> Version -> Patch Char -> Maybe Text -> UTCTime -> Update Database (Either DixiError Version)+amendPatch k v q com tim = runExceptT $ do+ b <- use (db . ix k)+ let latest = C.length b+ when (latest < v) $ throwE $ VersionNotFound k v+ let p = C.dropComposed v b ^. body+ r = snd $ P.transformWith P.theirs p q+ (db . at k) .= Just (C.snoc b (Page r (Last com) (Last $ Just tim)))+ return (latest + 1) -amend :: Key -> Version -> Text -> Maybe Text -> UTCTime -> Update Database (Version)-amend k v new com tim = do+amend :: Key -> Version -> Text -> Maybe Text -> UTCTime -> Update Database (Either DixiError Version)+amend k v new com tim = runExceptT $ do b <- use (db . ix k)+ when (C.length b < v) $ throwE $ VersionNotFound k v let n = V.fromList (T.unpack new) o = C.composed (C.take v b) ^. body . to patchToVector q = P.diff o n- amendPatch k v q com tim+ ExceptT $ amendPatch k v q com tim -revert :: Key -> (Version, Version) -> Maybe Text -> UTCTime -> Update Database Version+revert :: Key -> (Version, Version) -> Maybe Text -> UTCTime -> Update Database (Either DixiError Version) revert k (v1,v2) com tim | v2 < v1 = revert k (v2, v1) com tim-revert k (v1,v2) com tim = do+revert k (v1,v2) com tim = runExceptT $ do b <- use (db . ix k)+ let latest = C.length b+ when (latest < v1) $ throwE $ VersionNotFound k v1+ when (latest < v2) $ throwE $ VersionNotFound k v2 let p = C.dropComposed v1 (C.take v2 b) ^. body- amendPatch k (max v1 v2) (P.inverse p) com tim+ ExceptT $ amendPatch k (max v1 v2) (P.inverse p) com tim makeAcidic ''Database ['getLatest, 'getVersion, 'getHistory, 'getDiff, 'amend, 'revert]
Dixi/Database/Orphans.hs view
@@ -12,12 +12,12 @@ import Data.Compositions.Internal as C import Data.Compositions.Snoc.Internal as S import Data.Data-import Data.Foldable import Data.Monoid import Data.Patch.Internal import Data.SafeCopy-import Data.Traversable #ifdef OLDBASE+import Data.Foldable+import Data.Traversable import Data.Orphans() #endif
Dixi/Forms.hs view
@@ -1,18 +1,26 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS -fno-warn-orphans #-} module Dixi.Forms where -import Control.Applicative import Servant.API import Text.Read +#ifdef OLDBASE+import Control.Applicative+#endif+ import qualified Data.Text as T import Dixi.API instance FromFormUrlEncoded NewBody where- fromFormUrlEncoded x = NB <$> maybe (Left "error") Right (lookup "body" x) <*> pure (lookup "comment" x)-+ fromFormUrlEncoded x = NB <$> maybe (Left "error") Right (lookup "content" x) <*> pure (lookup "comment" x)+instance ToFormUrlEncoded NewBody where+ toFormUrlEncoded (NB t c) = ("content", T.pack $ show t) : maybe [] (pure . ("comment",)) c+instance ToFormUrlEncoded RevReq where+ toFormUrlEncoded (DR v1 v2 c) = [("from", T.pack $ show v1), ("to", T.pack $ show v2)] ++ maybe [] (pure . ("comment",)) c instance FromFormUrlEncoded RevReq where fromFormUrlEncoded x = DR <$> maybe (Left "error") Right (lookup "from" x >>= readMaybe . T.unpack) <*> maybe (Left "error") Right (lookup "to" x >>= readMaybe . T.unpack)
Dixi/Markup.hs view
@@ -6,26 +6,29 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS -fno-warn-orphans #-} module Dixi.Markup where import Control.Lens-import Data.Foldable (toList)-import Data.Maybe (fromMaybe)+import Data.Foldable (toList)+import Data.Maybe (fromMaybe) import Data.Monoid-import Data.Patch (Hunks, HunkStatus(..))+import Data.Patch (Hunks, HunkStatus(..)) import Data.Proxy-import Data.Text (Text)+import Data.Text (Text) import Servant.API import Servant.HTML.Blaze import Text.Blaze-import Text.Cassius-import Text.Hamlet (shamlet, Html)+import Text.Blaze.Renderer.Utf8 (renderMarkup)+import Text.Hamlet (shamlet, Html)+import Text.Heredoc+import Text.Lucius import Text.Pandoc.Error -import qualified Data.Text as T+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.ByteString.Lazy as B import Dixi.API import Dixi.Common@@ -44,135 +47,42 @@ prettyUrl :: Proxy ( Capture "page" Key :> "history" :> Capture "version" Version- :> Get '[HTML] PrettyPage+ :> Get '[HTML, JSON] PrettyPage ) prettyUrl = Proxy -latestUrl :: Proxy (Capture "page" Key :> Get '[HTML] PrettyPage)+latestUrl :: Proxy (Capture "page" Key :> Get '[HTML, JSON] PrettyPage) latestUrl = Proxy rawUrl :: Proxy ( Capture "page" Key :> "history" :> Capture "version" Version- :> "raw" :> Get '[HTML] RawPage+ :> "raw" :> Get '[HTML, JSON] RawPage ) rawUrl = Proxy amendUrl :: Proxy ( Capture "page" Key :> "history" :> Capture "version" Version- :> ReqBody '[FormUrlEncoded] NewBody- :> Post '[HTML] PrettyPage+ :> ReqBody '[FormUrlEncoded, JSON] NewBody+ :> Post '[HTML, JSON] PrettyPage ) amendUrl = Proxy -diffUrl :: Proxy (Capture "page" Key :> "history" :> "diff" :> Get '[HTML] DiffPage)+diffUrl :: Proxy (Capture "page" Key :> "history" :> "diff" :> Get '[HTML, JSON] DiffPage) diffUrl = Proxy-historyUrl :: Proxy (Capture "page" Key :> "history" :> Get '[HTML] History)+historyUrl :: Proxy (Capture "page" Key :> "history" :> Get '[HTML, JSON] History) historyUrl = Proxy-revertUrl :: Proxy (Capture "page" Key :> "history" :> "revert" :> ReqBody '[FormUrlEncoded] RevReq :> Post '[HTML] PrettyPage)+revertUrl :: Proxy (Capture "page" Key :> "history" :> "revert" :> ReqBody '[FormUrlEncoded, JSON] RevReq :> Post '[HTML, JSON] PrettyPage) revertUrl = Proxy -stylesheet :: Css-stylesheet = [cassius|- div.body- margin: 1em- table.history- border: 0px- td- border: 0px- button- width: 100%- padding: 4px- tr- border: 0px- .hist-version- text-align:right- .histh-comment- text-align:left- .histh-version- padding-right:5px- .hist-fromto- text-align:center- body- font-family: PT Serif, Palatino, Georgia, Times, serif- margin: 0px- .toolbar- background: #BBBBAA- border-top: 1px solid #888877- border-bottom: 1px solid #EEEEDD- a:hover- background: #F1F1D9- border: 1px outset #F1F1D9- a:active- background: #F1F1D9- border: 1px inset #F1F1D9- a- background: #DCDCCB- border: 1px outset #F1F1D9- text-decoration: none- color: black- padding: 2px- margin-top: 2px- margin-bottom: 2px- margin-left: 2px- .header- background: #FFFFDD- font-size: 1.5em- font-weight: bold- padding-left: 0.5em- padding-top: 0.5em- padding-bottom: 0.5em- .subtitle- float:right- font-size: 0.8em- margin-right: 0.5em- color: gray- position: relative- top: -2.5em- .addition-sum- background: #B5F386- padding: 3px- border-radius: 6px 0px 0px 6px- margin-top:1px;- margin-bottom:1px;- .subtraction-sum- background: #EC8160- padding: 3px- margin-top:1px;- margin-bottom:1px;- .replacement-sum- background: #F3E686- padding: 3px- border-radius: 0px 6px 6px 0px- margin-top:1px;- margin-bottom:1px;- .hunk- white-space: pre- font-family:monospace- border-radius: 4px;- .hunk-inserted- background: #B5F386- .hunk-deleted- background: #EC8160- text-decoration: line-through;- .hunk-replaced- background: #F3E686- .timestamp- color: #444444- font-size: small- div.timestamp- margin-left: 0.5em- margin-top: 2em-|] undefined--outerMatter :: Text -> Html -> Html-outerMatter title bod = [shamlet|+outerMatter :: Html -> Text -> Html -> Html+outerMatter ss title bod = [shamlet| $doctype 5 <html> <head> <link href="http://fonts.googleapis.com/css?family=PT+Serif:400,700" rel="stylesheet" type="text/css"> <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/font-awesome/4.4.0/css/font-awesome.min.css">- <style> #{renderCss stylesheet}+ #{ss} <title> #{title} <body> <div .header> #{title}@@ -188,6 +98,23 @@ guardText x y | y == "" = x | otherwise = y ++dixiError :: Html -> DixiError -> B.ByteString+dixiError header (VersionNotFound k v) = renderMarkup $ outerMatter header (renderTitle k)+ [shamlet|+ #{pageHeader k "Error"}+ <div .body>+ <h1> Error+ <span.error> Version #{v} not found!+ |]+dixiError header (PatchNotApplicable k) = renderMarkup $ outerMatter header (renderTitle k)+ [shamlet|+ #{pageHeader k "Error"}+ <div .body>+ <h1> Internal Error+ <span.error> Patch not Applicable!+ |]+ instance ToMarkup URI where toMarkup u = [shamlet|#{show u}|] @@ -200,7 +127,7 @@ instance ToMarkup DiffPage where- toMarkup (DP (Renders {..}) k v1 v2 p) = outerMatter (renderTitle k) $ [shamlet| + toMarkup (DP (Renders {..}) k v1 v2 p) = outerMatter headerBlock (renderTitle k) $ [shamlet| #{pageHeader k vString} <div .body> <div>@@ -227,11 +154,11 @@ styleFor Replaced = "hunk-replaced" styleFor Unchanged = "hunk-unchanged" vString :: Text- vString = ("diff " <> T.pack (show v1) <> " - " <> T.pack (show v2))+ vString = "diff " <> T.pack (show v1) <> " - " <> T.pack (show v2) instance ToMarkup History where- toMarkup (H (Renders {..}) k []) = outerMatter (renderTitle k) $ pageHeader k "history"- toMarkup (H (Renders {..}) k ps) = outerMatter (renderTitle k) $ [shamlet| + toMarkup (H (Renders {..}) k []) = outerMatter headerBlock (renderTitle k) $ pageHeader k "history"+ toMarkup (H (Renders {..}) k ps) = outerMatter headerBlock (renderTitle k) $ [shamlet| #{pageHeader k "history"} <div .body> <form method="GET" action="/#{link diffUrl k}">@@ -301,7 +228,7 @@ = let com = p ^. comment . traverse tim = renderTime $ p ^. time- in outerMatter (renderTitle k)+ in outerMatter headerBlock (renderTitle k) [shamlet| #{versionHeader k v com} <div .body>@@ -314,13 +241,131 @@ = let com = p ^. comment . traverse bod = p ^. body- in outerMatter (renderTitle k)+ in outerMatter headerBlock (renderTitle k) [shamlet| #{versionHeader k v com} <div .body> <form method="POST" action="/#{link amendUrl k v}">- <textarea name="body" cols=80 rows=24 style="font-family:monospace">#{bod}+ <textarea name="content" cols=80 rows=24 style="font-family:monospace">#{bod} <br> <input type="text" name="comment" value="no comment"> <input type="submit"> |]++defaultStylesheet :: L.Text+Right defaultStylesheet = luciusRT [here|+ div.body {+ margin: 1em;+ }+ table.history {+ border: 0px;+ td {+ border: 0px;+ button {+ width: 100%;+ padding: 4px;+ }+ }+ tr {+ border: 0px;+ }+ }+ .hist-version {+ text-align:right;+ }+ .histh-comment {+ text-align:left;+ }+ .histh-version {+ padding-right:5px;+ }+ .hist-fromto {+ text-align:center;+ }+ body {+ font-family: PT Serif, Palatino, Georgia, Times, serif;+ margin: 0px;+ }+ .toolbar {+ background: #BBBBAA;+ border-top: 1px solid #888877;+ border-bottom: 1px solid #EEEEDD;+ a:hover {+ background: #F1F1D9;+ border: 1px outset #F1F1D9;+ }+ a:active {+ background: #F1F1D9;+ border: 1px inset #F1F1D9;+ }+ a {+ background: #DCDCCB;+ border: 1px outset #F1F1D9;+ text-decoration: none;+ color: black;+ padding: 2px;+ margin-top: 2px;+ margin-bottom: 2px;+ margin-left: 2px;+ }+ }+ .header {+ background: #FFFFDD;+ font-size: 1.5em;+ font-weight: bold;+ padding-left: 0.5em;+ padding-top: 0.5em;+ padding-bottom: 0.5em;+ }+ .subtitle {+ float:right;+ font-size: 0.8em;+ margin-right: 0.5em;+ color: gray;+ position: relative;+ top: -2.5em;+ }+ .addition-sum {+ background: #B5F386;+ padding: 3px;+ border-radius: 6px 0px 0px 6px;+ margin-top:1px;+ margin-bottom:1px;+ }+ .subtraction-sum {+ background: #EC8160;+ padding: 3px;+ margin-top:1px;+ margin-bottom:1px;+ }+ .replacement-sum {+ background: #F3E686;+ padding: 3px;+ border-radius: 0px 6px 6px 0px;+ margin-top:1px;+ margin-bottom:1px;+ }+ .hunk {+ white-space: pre;+ font-family:monospace;+ border-radius: 4px;+ }+ .hunk-inserted {+ background: #B5F386;+ }+ .hunk-deleted {+ background: #EC8160;+ text-decoration: line-through;;+ }+ .hunk-replaced {+ background: #F3E686;+ }+ .timestamp {+ color: #444444;+ font-size: small;+ }+ div.timestamp {+ margin-left: 0.5em;+ margin-top: 2em;+ }+|] []
Dixi/Page.hs view
@@ -5,15 +5,18 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE CPP #-} module Dixi.Page where import Control.Lens import Data.Data-import Data.Foldable import Data.Monoid import Data.SafeCopy import Data.Text import Data.Time+#ifdef OLDBASE+import Data.Foldable+#endif import Dixi.Database.Orphans ()
Dixi/PatchUtils.hs view
@@ -11,7 +11,7 @@ type PatchSummary = (Int, Int, Int) -patchSummary :: (Patch a) -> PatchSummary+patchSummary :: Patch a -> PatchSummary patchSummary p | (Sum a, Sum b, Sum c) <- mconcat (map toCounts $ P.toList p) = (a,b,c) where toCounts (P.Insert {}) = (Sum 1, Sum 0, Sum 0) toCounts (P.Delete {}) = (Sum 0, Sum 1, Sum 0)
+ Dixi/Server.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}++module Dixi.Server where++import Control.Monad.IO.Class+import Control.Monad.Trans.Either+import Data.Acid+import Data.Default+import Data.Time+import Data.Text (Text)+import Data.Traversable+import Servant+import Text.Pandoc+#ifdef OLDBASE+import Control.Applicative+#endif++import qualified Data.Text as T++import Dixi.API+import Dixi.Common+import Dixi.Config+import Dixi.Database+import Dixi.Forms () -- imported for orphans+import Dixi.Markup (writePandocError, dixiError)+import Dixi.Page++spacesToUScores :: T.Text -> T.Text+spacesToUScores = T.pack . map (\x -> if x == ' ' then '_' else x) . T.unpack++page :: AcidState Database -> Renders -> Key -> Server PageAPI+page db renders (spacesToUScores -> key)+ = latest+ |: history+ where+ latest = latestQ pp |: latestQ rp++ diffPages (Just v1) (Just v2) = liftIO (query db (GetDiff key (v1, v2)))+ >>= \case Left e -> handle e+ Right x -> return $ DP renders key v1 v2 x+ diffPages _ _ = left err400++ history = liftIO (H renders key <$> query db (GetHistory key))+ |: version+ |: diffPages+ |: reversion++ reversion (DR v1 v2 com) = do+ _ <- liftIO (getCurrentTime >>= update db . Revert key (v1, v2) com)+ 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++ 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 -> IO a) -> Version -> EitherT ServantErr IO a+ versionQ p v = liftIO (query db (GetVersion key v))+ >>= \case Left e -> handle e+ Right x -> liftIO (p key v x)+++ pp :: Key -> Version -> Page Text -> IO PrettyPage+ pp k v p = fmap (PP renders k v) $ for 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)++ handle :: DixiError -> EitherT ServantErr IO a+ handle e = left err404 { errBody = dixiError (headerBlock renders) e }+++server :: AcidState Database -> Renders -> Server Dixi+server db cfg = page db cfg+ |: page db cfg "Main_Page"+
− Main.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE ConstraintKinds #-}--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-import Servant-import System.Directory-import System.Environment-import System.Exit-import System.IO-import Text.Pandoc--import qualified Data.Yaml as Y-import qualified Data.Text as T--import Dixi.API-import Dixi.Common-import Dixi.Config-import Dixi.Database-import Dixi.Forms () -- imported for orphans-import Dixi.Markup (writePandocError) -import Dixi.Page--spacesToUScores :: T.Text -> T.Text-spacesToUScores = T.pack . map (\x -> if x == ' ' then '_' else x) . T.unpack--page :: AcidState Database -> Renders -> Key -> Server PageAPI-page db renders (spacesToUScores -> key)- = latest- |: history- where- 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-- history = do liftIO $ H renders key <$> query db (GetHistory key)- |: version- |: diffPages- |: reversion-- reversion (DR v1 v2 com) = do- _ <- liftIO (getCurrentTime >>= update db . Revert key (v1, v2) com)- 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-- 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 -> 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)---server :: AcidState Database -> Renders -> Server Dixi-server db cfg = page db cfg- |: page db cfg "Main_Page"---main :: IO ()-main = getArgs >>= main'- where- main' [] = main' ["config.yml"]- main' [x] = do- c <- doesFileExist x- if c then Y.decodeFileEither x >>= main''- else do- putStrLn "Configuration file not found, would you like to [c]reate one, [r]un with default configuration or e[x]it?"- hSetBuffering stdin NoBuffering- getChar >>= \i -> case i of- _ | i `elem` ['c','C'] -> Y.encodeFile x defaultConfig >> main'' (Right defaultConfig)- _ | i `elem` ['r','R'] -> main'' (Right defaultConfig)- _ | otherwise -> exitFailure- main' _ = do- p <- getProgName- hPutStrLn stderr $ "usage:\n " ++ p ++ " [/path/to/config.yml]"- exitFailure- main'' (Left e) = do- hPutStrLn stderr $ Y.prettyPrintParseException e- exitFailure- main'' (Right cfg@(Config {..})) = do- db <- openLocalStateFrom storage emptyDB- createCheckpoint db- createArchive db- run port . serve dixi . server db =<< configToRenders cfg
+ api-docs/Docs.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+import Data.Proxy+import Data.Patch(HunkStatus (..))+import Dixi.API+import Dixi.Forms()+import Dixi.Markup()+import Servant.Docs+import Servant.API+import Servant.HTML.Blaze+import System.Environment+import Data.Text (Text)+import Dixi.Config+import Dixi.Page+import Data.Time+import Dixi.Common+import Data.Monoid+import Control.Lens+import qualified Data.Vector as V+import Text.Hamlet+import Data.Aeson.Parser+import Data.Attoparsec.ByteString.Lazy+import Data.Aeson.Encode.Pretty+import qualified Data.ByteString.Lazy as LBS+instance ToSample RevReq RevReq where+ toSample _ = Just $ DR 5 7 (Just "Revert changes 5-6, 6-7")++instance ToSample RawPage RawPage where+ toSample _ = Just $ RP defaultRenders "Page_Title" 3 $ Page "Some page content, in input format (e.g org mode)"+ (Last (Just "An optional comment"))+ (Last (Just (UTCTime (ModifiedJulianDay 0) 0)))+instance ToSample PrettyPage PrettyPage where+ toSample _ = Just $ PP defaultRenders "Page_Title" 3 $ Page [shamlet|Some page content, in <b>HTML</b> from Pandoc.|]+ (Last (Just "An optional comment"))+ (Last (Just (UTCTime (ModifiedJulianDay 0) 0)))+instance ToSample NewBody NewBody where+ toSample _ = Just $ NB "Some new content, in input format (e.g org mode)" (Just "An optional comment")++instance ToSample History History where+ toSample _ = Just $ H defaultRenders "Page_Title"+ [ Page (4, 9, 14) (Last (Just "Change 1")) (Last (Just (UTCTime (ModifiedJulianDay 0) 0)))+ , Page (12, 3, 1) (Last (Just "Change 2")) (Last (Just (UTCTime (ModifiedJulianDay 1) 0)))+ , Page (12, 0, 0) (Last (Just "Change 3")) (Last (Just (UTCTime (ModifiedJulianDay 2) 0)))+ ]++instance ToSample DiffPage DiffPage where+ toSample _ = Just $ DP defaultRenders "Page_Title" 5 7+ (Page [ (V.fromList "This is the ", Unchanged)+ , (V.fromList "new", Replaced)+ , (V.fromList "ginal", Deleted)+ , (V.fromList " document.", Unchanged)+ ]+ (Last (Just "An optional comment"))+ (Last (Just (UTCTime (ModifiedJulianDay 0) 0))))++instance ToParam (QueryParam "from" Int) where+ toParam _ = DocQueryParam "from" [] "Version to diff from, starting from 0 to N-1" Normal+instance ToParam (QueryParam "to" Int) where+ toParam _ = DocQueryParam "to" [] "Version to diff to, from 1 to N" Normal+instance ToCapture (Capture "page" Text) where+ toCapture _ = DocCapture "page" "Title of the page, using underscores for spaces."+instance ToCapture (Capture "version" Int) where+ toCapture _ = DocCapture "version" "A page version to examine. All pages have a zeroth version, which is empty."++main :: IO ()+main = do+ filename <- fmap (\x -> if null x then "docs.md" else head x) getArgs+ writeFile filename (markdown $ postprocess $ docsWith intro extra dixi)++postprocess :: API -> API+postprocess = over (apiEndpoints . traverse . rqbody) (filter ((== contentType (Proxy :: Proxy JSON)) . view _1) . fmap (over _2 prettify))+ . over (apiEndpoints . traverse . response . respBody) (filter ((== contentType (Proxy :: Proxy JSON)) . view _2) . fmap (over _3 prettify))++++diffNote, revertNote, historyNote, amendNote :: String -> [DocNote]+diffNote page = [ DocNote "Description" [ "Compute the diff between two versions of " ++ page ++ "."+ , "If the `from` version is greater than the `to` version, they are swapped."+ ]+ , DocNote "Reponse details" ["Each diff hunk uses a single character string to " +++ "indicate the type of change, where " +++ "`+` is used for additions, `-` for deletions, and `~` for replacements."]+ ]++revertNote page = [ DocNote "Description" [ "Apply a new patch which reverts any still-extant changes made in a certain version range of " ++ page ++ "."+ , "If the `from` version is greater than the `to` version they are swapped."+ ]+ , DocNote "Response details" ["The response is just the most recent version of the page, " +++ "with the revert patch applied."]+ ]+historyNote page = [ DocNote "Description" [ "Returns the complete version history of " ++ page+ ++ ", with patch summaries, times, and change comments."]]+amendNote page = [ DocNote "Description" [ "Submit a new version to be applied to the " ++ page ++ ", based on the given version."+ , "The change will be transformed and applied to the latest version."+ ]+ ]+prettyNote, rawNote :: String -> String -> [DocNote]+prettyNote version page = [ DocNote "Description" [ "Returns the " ++ version ++ " of the " ++ page+ ++ ", in HTML format as processed by Pandoc."]]+rawNote version page = [ DocNote "Description" [ "Returns the " ++ version ++ " of the " ++ page+ ++ ", in the input format (e.g org mode, markdown)."]]++intro :: [DocIntro]+intro = [ DocIntro "Dixi API Documentation"+ ["What follows is the documentation for the JSON API of `dixi`."+ ,"Unlike other wikis `dixi` supports editing of any version of a page, and the changes will be propagated through to the latest version in a way that makes sense."+ ,"It is also able to revert changes (or the composition of several changes) from deep in a document's history and preserve every other change."+ ]+ , DocIntro "Structure"+ ["In general, there are two of each API action, one applying to a particular, specified page and one applying to the page entitled `Main_Page`"+ ,"The behaviour of these actions is identical, except for the page to which they apply."]+ ]++prettify :: LBS.ByteString -> LBS.ByteString+prettify x = go (parse json x)+ where+ go (Done _ r) = encodePretty r+ go _ = error "Error, cannot parse json value! Something is seriously wrong here."++extra :: ExtraInfo Dixi+extra = mconcat+ [ extraInfo (Proxy :: Proxy (Capture "page" Key :> "history" :> "diff" :> QueryParam "from" Version :> QueryParam "to" Version :> Get '[HTML,JSON] DiffPage)) $+ defAction & notes <>~ diffNote "the given page"+ , extraInfo (Proxy :: Proxy ("history" :> "revert" :> ReqBody '[FormUrlEncoded, JSON] RevReq :> Post '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ revertNote "the `Main_Page`"+ , extraInfo (Proxy :: Proxy ("history" :> "diff" :> QueryParam "from" Version :> QueryParam "to" Version :> Get '[HTML,JSON] DiffPage)) $+ defAction & notes <>~ diffNote "the `Main_Page`"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> "history" :> "revert" :> ReqBody '[FormUrlEncoded, JSON] RevReq :> Post '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ revertNote "the given page"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> "history" :> Get '[HTML, JSON] History)) $+ defAction & notes <>~ historyNote "the given page"+ , extraInfo (Proxy :: Proxy ("history" :> Get '[HTML, JSON] History)) $+ defAction & notes <>~ historyNote "the page entitled `Main_Page`"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> "history" :> Capture "version" Version :> Get '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ prettyNote "given version" "given page"+ , extraInfo (Proxy :: Proxy ("history" :> Capture "version" Version :> Get '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ prettyNote "given version" "page entitled `Main_Page`"+ , extraInfo (Proxy :: Proxy (Get '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ prettyNote "latest version" "page entitled `Main_Page`"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> Get '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ prettyNote "latest version" "given page"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> "history" :> Capture "version" Version :> "raw" :> Get '[HTML, JSON] RawPage)) $+ defAction & notes <>~ rawNote "given version" "given page"+ , extraInfo (Proxy :: Proxy ("history" :> Capture "version" Version :> "raw" :> Get '[HTML, JSON] RawPage)) $+ defAction & notes <>~ rawNote "given version" "page entitled `Main_Page`"+ , extraInfo (Proxy :: Proxy ("raw" :> Get '[HTML, JSON] RawPage)) $+ defAction & notes <>~ rawNote "latest version" "page entitled `Main_Page`"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> "raw" :> Get '[HTML, JSON] RawPage)) $+ defAction & notes <>~ rawNote "latest version" "given page"+ , extraInfo (Proxy :: Proxy (Capture "page" Key :> "history" :> Capture "version" Version :> ReqBody '[FormUrlEncoded, JSON] NewBody :> Post '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ amendNote "given page"+ , extraInfo (Proxy :: Proxy ("history" :> Capture "version" Version :> ReqBody '[FormUrlEncoded, JSON] NewBody :> Post '[HTML, JSON] PrettyPage)) $+ defAction & notes <>~ amendNote "`Main_Page`"+ ]
dixi.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: dixi-version: 0.5.1.1+version: 0.6 synopsis: A wiki implemented with a firm theoretical foundation. description: This project is a simple wiki developed based on a firm theoretical foundation.@@ -19,7 +19,7 @@ preserve every other change. . Right now the wiki doesn't support many bells and whistles,- such as administrator control, configurability, or user accounts,+ such as administrator control, or user accounts, but they're coming. license: BSD3 license-file: LICENSE@@ -38,9 +38,8 @@ description: if building with older base versions default: False -executable dixi- main-is: Main.hs- other-modules: Dixi.API+library+ exposed-modules: Dixi.API , Dixi.Common , Dixi.Config , Dixi.Database@@ -51,36 +50,82 @@ , Dixi.Page , Dixi.Pandoc.Wikilinks , Dixi.PatchUtils- -- other-extensions: + , Dixi.Server ghc-options: -Wall if flag(old-base) build-depends: base >= 4.7 && < 4.8, base-orphans >= 0.4 && < 0.5+ , transformers-compat >= 0.4 && < 0.5 cpp-options: -DOLDBASE else build-depends: base >= 4.8 && < 4.9 build-depends: composition-tree >= 0.2.0.1 && < 0.3, patches-vector >= 0.1.2 && < 0.2 , pandoc >= 1.15 && < 1.16 , pandoc-types >= 1.12 && < 1.13 , servant >= 0.4 && < 0.5+ , servant-server >= 0.4 && < 0.5 , acid-state >= 0.12 && <0.14 , safecopy >= 0.8.3 && < 0.9- , lens >= 4.7 && < 4.14, servant-server >= 0.4 && < 0.5+ , lens >= 4.7 && < 4.14 , blaze-html >= 0.8 && < 0.9 , servant-blaze >= 0.4 && < 0.5, blaze-markup >= 0.7 && <0.8 , shakespeare >= 2.0 && < 2.1 , containers >= 0.5 && < 0.6 , text >= 1.2 && < 1.3 , vector >= 0.10 && <0.12 , transformers >= 0.3 && < 0.5- , warp >= 3.0 && <3.2 , data-default >= 0.5 && <0.6 , either >= 4.3 && <4.5 , template-haskell- , yaml >= 0.8 && < 0.9 , aeson >= 0.8 && < 0.11- , directory >= 1.0 && < 1.3 , time >= 1.4 && < 1.6 , time-locale-compat >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 , network-uri >= 2.6 && < 2.7 , timezone-olson >= 0.1 && < 0.2 , timezone-series >= 0.1 && < 0.2+ , heredoc >= 0.2 && <0.3+ default-language: Haskell2010 +executable dixi+ hs-source-dirs: main + main-is: Main.hs+ -- other-extensions: + ghc-options: -Wall++ build-depends: dixi++ if flag(old-base)+ build-depends: base >= 4.7 && < 4.8, base-orphans >= 0.4 && < 0.5+ cpp-options: -DOLDBASE+ else+ build-depends: base >= 4.8 && < 4.9+ build-depends: warp >= 3.0 && <3.2+ , servant-server >= 0.4 && < 0.5+ , directory >= 1.0 && < 1.3+ , yaml >= 0.8 && < 0.9+ , acid-state >= 0.12 && <0.14+ , text >= 1.2 && < 1.3+ , filepath >= 1.3 && < 1.5+ -- hs-source-dirs: + default-language: Haskell2010++test-suite api-docs+ hs-source-dirs: api-docs+ type: exitcode-stdio-1.0+ main-is: Docs.hs + if flag(old-base)+ build-depends: base >= 4.7 && < 4.8, base-orphans >= 0.4 && < 0.5+ cpp-options: -DOLDBASE+ else+ build-depends: base >= 4.8 && < 4.9+ build-depends: dixi, servant-docs >= 0.4 && < 0.5+ , text >= 1.2 && < 1.3+ , servant >= 0.4 && < 0.5+ , time >= 1.4 && < 1.6+ , lens >= 4.7 && < 4.14+ , aeson-pretty >= 0.7 && < 0.8+ , aeson >= 0.8 && < 0.11+ , attoparsec >= 0.12 && < 0.14+ , bytestring >= 0.10 && < 0.11+ , shakespeare >= 2.0 && < 2.1+ , vector >= 0.10 && <0.12+ , patches-vector >= 0.1.2 && < 0.2+ , servant-blaze >= 0.4 && <0.5 default-language: Haskell2010
+ main/Main.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++import Control.Exception(bracket)+import Control.Monad+import Data.Acid+import Network.Wai.Handler.Warp+import Servant+import System.Directory+import System.FilePath+import System.Environment+import System.Exit+import System.IO++import qualified Data.Yaml as Y+import qualified Data.Text.Lazy.IO as L++import Dixi.API+import Dixi.Config+import Dixi.Database+import Dixi.Forms () -- imported for orphans+import Dixi.Server+import Dixi.Markup (defaultStylesheet)++getChar' :: IO Char+getChar' =+ bracket (hGetBuffering stdin)+ (hSetBuffering stdin)+ $ const $ do+ hSetBuffering stdin NoBuffering+ bracket (hGetEcho stdin)+ (hSetEcho stdin)+ $ const $ hSetEcho stdin False >> getChar++handleStatics, handleStylesheet :: FilePath -> IO ()++handleStatics fn = do+ c <- doesDirectoryExist fn+ unless c $ do+ putStrLn "Statics directory not found, would you like to [c]reate it, or e[x]it?"+ getChar' >>= \i -> case i of+ _ | i `elem` ("cC" :: String) -> createDirectory fn+ | otherwise -> exitFailure++handleStylesheet fn = do+ c <- doesFileExist fn+ unless c $ do+ putStrLn "Stylesheet file not found, would you like to [c]reate one, or e[x]it?"+ getChar' >>= \i -> case i of+ _ | i `elem` ("cC" :: String) -> L.writeFile fn defaultStylesheet+ | otherwise -> exitFailure++handleConfig :: FilePath -> IO (Either Y.ParseException Config)+handleConfig fn = do+ c <- doesFileExist fn+ if c then Y.decodeFileEither fn+ else do+ putStrLn "Configuration file not found, would you like to [c]reate one, [r]un with default configuration or e[x]it?"+ getChar' >>= \i -> case i of+ _ | i `elem` ("cC" :: String) -> Y.encodeFile fn defaultConfig >> return (Right defaultConfig)+ | i `elem` ("rR" :: String) -> return (Right defaultConfig)+ | otherwise -> exitFailure+++dixiWithStatic :: Proxy (Dixi :| "static" :> Raw)+dixiWithStatic = Proxy++main :: IO ()+main = getArgs >>= main'+ where+ main' [] = main' ["config.yaml"]+ main' [x] = handleConfig x >>= main''+ main' _ = do+ p <- getProgName+ hPutStrLn stderr $ "usage:\n " ++ p ++ " [/path/to/config.yaml]"+ exitFailure+ main'' (Left e) = do+ hPutStrLn stderr $ Y.prettyPrintParseException e+ exitFailure+ main'' (Right cfg@(Config {..})) = do+ case static of+ Just st -> do+ handleStatics st+ handleStylesheet (st </> stylesheet)+ Nothing -> return ()+ db <- openLocalStateFrom storage emptyDB+ createCheckpoint db+ createArchive db+ rs <- configToRenders cfg+ putStrLn "Starting dixi"+ run port $ case static of+ Just st -> serve dixiWithStatic $ server db rs |: serveDirectory st+ Nothing -> serve dixi $ server db rs