dixi (empty) → 0.1.0.0
raw patch · 14 files changed
+792/−0 lines, 14 filesdep +acid-statedep +aesondep +basesetup-changed
Dependencies added: acid-state, aeson, base, blaze-html, blaze-markup, composition-tree, containers, data-default, directory, either, lens, pandoc, patches-vector, safecopy, servant, servant-blaze, servant-server, shakespeare, template-haskell, text, transformers, vector, warp, yaml
Files
- Dixi/API.hs +51/−0
- Dixi/Common.hs +6/−0
- Dixi/Config.hs +17/−0
- Dixi/Database.hs +95/−0
- Dixi/Database/Orphans.hs +36/−0
- Dixi/Forms.hs +19/−0
- Dixi/Hamlet.hs +7/−0
- Dixi/Markup.hs +313/−0
- Dixi/Page.hs +25/−0
- Dixi/PatchUtils.hs +24/−0
- LICENSE +30/−0
- Main.hs +97/−0
- Setup.hs +2/−0
- dixi.cabal +70/−0
+ Dixi/API.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ConstraintKinds #-}+module Dixi.API where++import Data.Text (Text)+import Data.Patch+import Data.Proxy+import Servant.API+import Servant.HTML.Blaze++import Dixi.Common+import Dixi.Page+import Dixi.PatchUtils++type a :| b = a :<|> b+infixr 8 :|+infixr 8 |:++(|:) :: a -> b -> a :| b+(|:) = (:<|>)++data PrettyPage = PP Key Version (Page Text)+data RawPage = RP Key Version (Page Text)+data DiffPage = DP Key Version Version (Page (Hunks Char))+data History = H Key [Page PatchSummary]++data NewBody = NB Text (Maybe Text)+data RevReq = DR Version Version (Maybe Text)++type HistoryAPI = Get '[HTML] History+ :| Capture "version" Version :> VersionAPI+ :| "diff" :> QueryParam "from" Version :> QueryParam "to" Version :> Get '[HTML] DiffPage+ :| "revert" :> ReqBody '[FormUrlEncoded] RevReq :> Post '[HTML] PrettyPage+type VersionAPI = PageViewAPI+ :| ReqBody '[FormUrlEncoded] NewBody :> Post '[HTML] PrettyPage+type PageAPI = PageViewAPI+ :| "history" :> HistoryAPI+type PageViewAPI = Get '[HTML] PrettyPage+ :| "raw" :> Get '[HTML] RawPage+type Dixi = Capture "page" Key :> PageAPI+ :| PageAPI++dixi :: Proxy Dixi+dixi = Proxy
+ Dixi/Common.hs view
@@ -0,0 +1,6 @@+module Dixi.Common where++import Data.Text++type Key = Text+type Version = Int
+ Dixi/Config.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}++module Dixi.Config where++import Data.Aeson+import GHC.Generics++data Config = Config+ { port :: Int+ , storage :: FilePath+ } deriving (Generic, Show)++instance FromJSON Config where+instance ToJSON Config where++defaultConfig :: Config+defaultConfig = Config 8000 "state"
+ Dixi/Database.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+module Dixi.Database+ ( Database , emptyDB+ , Amend (..)+ , GetDiff (..)+ , GetHistory (..)+ , GetLatest (..)+ , GetVersion (..)+ , Revert (..)+ ) where++import Control.Applicative+import Control.Lens+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)+import Data.Text (Text)+import Data.Typeable++import qualified Data.Compositions.Snoc as C+import qualified Data.Patch as P+import qualified Data.Text as T+import qualified Data.Vector as V++import Dixi.Common+import Dixi.Database.Orphans ()+import Dixi.Page+import Dixi.PatchUtils++data Database = DB { _db :: Map Key (Compositions (Page (Patch Char)))}+ deriving (Typeable)++emptyDB :: Database+emptyDB = DB mempty++deriveSafeCopy 0 'base ''Database++makeLenses ''Database++getLatest :: Key -> Query Database (Version, Page Text)+getLatest k = do+ b <- (view (db . ix k))+ return (C.length b, patchToText <$> C.composed b)++getVersion :: Key -> Version -> Query Database (Page Text)+getVersion k v = do+ b <- view (db . ix k)+ 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))+getDiff k (v1 , v2) | v1 > v2 = getDiff k (v2, v1)+ | otherwise = do+ b <- view (db . ix k)+ let y = patchToVector (C.composed (C.take v1 b) ^. body)+ return $ fmap (\z -> P.hunks z y) (C.dropComposed v1 (C.take v2 b)) ++amendPatch :: Key -> Version -> Patch Char -> Maybe Text -> Update Database (Version)+amendPatch k v q com = 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)))+ C.length <$> use (db . ix k)++amend :: Key -> Version -> Text -> Maybe Text -> Update Database (Version)+amend k v new com = do+ b <- use (db . ix k)+ 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+++revert :: Key -> (Version, Version) -> Maybe Text -> Update Database Version+revert k (v1,v2) com | v2 < v1 = revert k (v2, v1) com+revert k (v1,v2) com = do+ b <- use (db . ix k)+ let p = C.dropComposed v1 (C.take v2 b) ^. body+ amendPatch k (max v1 v2) (P.inverse p) com++makeAcidic ''Database ['getLatest, 'getVersion, 'getHistory, 'getDiff, 'amend, 'revert]++
+ Dixi/Database/Orphans.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# OPTIONS -fno-warn-orphans #-}+module Dixi.Database.Orphans where++import Control.Lens ()+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++deriveSafeCopy 0 'base ''Node+deriveSafeCopy 0 'base ''C.Compositions+deriveSafeCopy 0 'base ''Flip+deriveSafeCopy 0 'base ''S.Compositions+deriveSafeCopy 0 'base ''Edit+deriveSafeCopy 0 'base ''Patch+deriveSafeCopy 0 'base ''Last+deriveSafeCopy 0 'base ''HunkStatus++deriving instance Foldable (Last)+deriving instance Traversable (Last)++deriving instance Typeable (Patch)+deriving instance Typeable (HunkStatus)++deriving instance Data a => (Data (Last a))+
+ Dixi/Forms.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}+module Dixi.Forms where++import Control.Applicative+import Servant.API+import Text.Read++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)++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)+ <*> pure (lookup "comment" x)
+ Dixi/Hamlet.hs view
@@ -0,0 +1,7 @@+module Dixi.Hamlet where++import Text.Hamlet+import Language.Haskell.TH.Quote++hml :: QuasiQuoter+hml = hamletWithSettings htmlRules (defaultHamletSettings { hamletNewlines = NoNewlines})
+ Dixi/Markup.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# 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.Monoid+import Data.Patch (Hunks, HunkStatus(..))+import Data.Proxy+import Data.Text (Text)+import Servant.API+import Servant.HTML.Blaze+import Text.Blaze+import Text.Cassius+import Text.Hamlet (shamlet, Html)+import Text.Pandoc+import Text.Pandoc.Error++import qualified Data.Text as T++import Dixi.API+import Dixi.Common+import Dixi.Page+import Dixi.Hamlet+import Dixi.PatchUtils++link :: (IsElem endpoint Dixi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint+link = safeLink dixi++renderTitle :: Text -> Text+renderTitle = T.pack . map (\c -> if c == '_' then ' ' else c) . T.unpack++prettyUrl :: Proxy ( Capture "page" Key :> "history"+ :> Capture "version" Version+ :> Get '[HTML] PrettyPage+ )+prettyUrl = Proxy++latestUrl :: Proxy (Capture "page" Key :> Get '[HTML] PrettyPage)+latestUrl = Proxy++rawUrl :: Proxy ( Capture "page" Key :> "history"+ :> Capture "version" Version+ :> "raw" :> Get '[HTML] RawPage+ )+rawUrl = Proxy+++amendUrl :: Proxy ( Capture "page" Key :> "history"+ :> Capture "version" Version+ :> ReqBody '[FormUrlEncoded] NewBody+ :> Post '[HTML] PrettyPage+ )+amendUrl = Proxy++diffUrl :: Proxy (Capture "page" Key :> "history" :> "diff" :> Get '[HTML] DiffPage)+diffUrl = Proxy+historyUrl :: Proxy (Capture "page" Key :> "history" :> Get '[HTML] History)+historyUrl = Proxy+revertUrl :: Proxy (Capture "page" Key :> "history" :> "revert" :> ReqBody '[FormUrlEncoded] RevReq :> Post '[HTML] 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++|] undefined++outerMatter :: Text -> Html -> Html+outerMatter 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}+ <title> #{title}+ <body>+ <div .header> #{title}+ #{bod}+|]++++unlast :: a -> Last a -> a+unlast d (Last x) = fromMaybe d x++guardText :: Text -> Text -> Text+guardText x y | y == "" = x+ | otherwise = y++instance ToMarkup URI where+ toMarkup u = [shamlet|#{show u}|]++instance ToMarkup PatchSummary where+ toMarkup (i,d,r) = [hml|+ <span .fa .fa-plus-square-o .addition-sum> #{show i}+ <span .fa .fa-minus-square-o .subtraction-sum> #{show d}+ <span .fa .fa-pencil-square-o .replacement-sum> #{show r}+|]+++instance ToMarkup DiffPage where+ toMarkup (DP k v1 v2 p) = outerMatter (renderTitle k) $ [shamlet| + #{pageHeader k vString}+ <div .body>+ <div>+ #{renderHunks d}+ <br>+ <hr>+ <form method="POST" action="/#{link revertUrl k}">+ <input type="hidden" name="from" value="#{show v1}">+ <input type="hidden" name="to" value="#{show v2}">+ <input type="text" name="comment" value="revert #{show v1} - #{show v2}">+ <button type="submit">+ <span .fa .fa-undo> Revert+ |]+ where+ d = p ^. body+ renderHunks :: Hunks Char -> Html+ renderHunks ps = [hml|+ $forall (x, s) <- ps+ <span class="hunk #{styleFor s}">#{toList x}+ |]+ styleFor :: HunkStatus -> String+ styleFor Inserted = "hunk-inserted"+ styleFor Deleted = "hunk-deleted"+ styleFor Replaced = "hunk-replaced"+ styleFor Unchanged = "hunk-unchanged"+ vString :: Text+ vString = ("diff " <> T.pack (show v1) <> " - " <> T.pack (show v2))++instance ToMarkup History where+ toMarkup (H k []) = outerMatter (renderTitle k) $ pageHeader k "history"+ toMarkup (H k ps) = outerMatter (renderTitle k) $ [shamlet| + #{pageHeader k "history"}+ <div .body>+ <form method="GET" action="/#{link diffUrl k}">+ <table .history>+ <tr>+ <th .histh-version> Version+ <th .histh-fromto> From/To+ <th .histh-changes> Changes+ <th .histh-comment> Comment+ $forall (v, p) <- ps'+ <tr>+ <td .hist-version>+ #{show v}.+ <td .hist-fromto>+ <input type="radio" checked style="position:relative; top:1em;" name="from" value="#{show (v - 1)}">+ <input type="radio" checked name="to" value="#{show v}">+ <td>+ #{(p ^. body)}+ <td>+ <a .histlink href="/#{link prettyUrl k v}">#{guardText "no comment" (unlast "no comment" (p ^. comment))}+ <tr>+ <td> + <tr>+ <td>+ <td>+ <button type="submit">+ <span .fa .fa-files-o>+ \ Diff+ <td>+ <td>+ <small> (to revert a change, view the diff first)+ |]+ where ps' = reverse $ zip [1..] ps++versionHeader :: Key -> Version -> Text -> Html+versionHeader k v com = [shamlet| + <div .subtitle>+ version #{v} (#{com'})+ <div .toolbar>+ <a href="/#{link rawUrl k v}" .fa .fa-edit> edit+ <a href="/#{link prettyUrl k v}" .fa .fa-eye> view+ <a href="/#{link historyUrl k}" .fa .fa-history> history+ <a href="/#{link latestUrl k}" .fa .fa-fast-forward> latest+ |]+ where com' = if com == "" then "no comment" else com+pageHeader :: Key -> Text -> Html+pageHeader k com = [shamlet| + <div .subtitle>+ #{com}+ <div .toolbar>+ <a href="/#{link historyUrl k}" .fa .fa-history> history+ <a href="/#{link latestUrl k}" .fa .fa-fast-forward> latest+ |]++instance ToMarkup PandocError where+ toMarkup (ParseFailure s) = [shamlet| <b> Parse Failure: </b> #{s}|]+ toMarkup (ParsecError _ e) = [shamlet| <b> Parse Error: </b> #{show e} |]++instance ToMarkup PrettyPage where+ toMarkup (PP k v p)+ = let+ com = p ^. comment . traverse+ 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}+ |]++instance ToMarkup RawPage where+ toMarkup (RP k v p )+ = let+ com = p ^. comment . traverse+ bod = p ^. body+ in outerMatter (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}+ <br>+ <input type="text" name="comment" value="no comment">+ <input type="submit">+ |]
+ Dixi/Page.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+module Dixi.Page where++import Control.Lens+import Data.Data+import Data.Monoid+import Data.SafeCopy+import Data.Text++import Dixi.Database.Orphans ()++data Page b = Page { _body :: b, _comment :: Last Text }+ deriving (Functor, Data, Typeable, Show)++deriveSafeCopy 0 'base ''Page++makeLenses ''Page++instance Monoid b => Monoid (Page b) where+ mempty = Page mempty mempty+ mappend (Page a a') (Page b b') = Page (a <> b) (a' <> b')
+ Dixi/PatchUtils.hs view
@@ -0,0 +1,24 @@+module Dixi.PatchUtils where++import Data.Foldable+import Data.Monoid+import Data.Patch (Patch)+import Data.Text (Text)+import Data.Vector (Vector)++import qualified Data.Patch as P+import qualified Data.Text as T++type PatchSummary = (Int, Int, Int)++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)+ toCounts (P.Replace {}) = (Sum 0, Sum 0, Sum 1)++patchToText :: Patch Char -> Text+patchToText = T.pack . toList . patchToVector++patchToVector :: Patch Char -> Vector Char+patchToVector = flip P.apply mempty
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Liam O'Connor++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Liam O'Connor nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,97 @@+{-# 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 Data.Acid+import Data.Text (Text)+import Network.Wai.Handler.Warp+import Servant+import System.Directory+import System.Environment+import System.Exit+import System.IO++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 () -- imported for orphans+import Dixi.Page++spacesToUScores :: T.Text -> T.Text+spacesToUScores = T.pack . map (\x -> if x == ' ' then '_' else x) . T.unpack++page :: AcidState Database -> Key -> Server PageAPI+page db (spacesToUScores -> key)+ = latest+ |: history+ where+ latest = latestQ PP |: latestQ RP++ diffPages (Just v1) (Just v2) = do liftIO $ DP key v1 v2 <$> query db (GetDiff key (v1, v2))+ diffPages _ _ = left err400++ history = do liftIO $ H key <$> query db (GetHistory key)+ |: version+ |: diffPages+ |: reversion++ reversion (DR v1 v2 com) = do+ _ <- liftIO $ 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 $ update db $ Amend key v t c+ latestQ PP++ latestQ :: (Key -> Version -> Page Text -> a) -> EitherT ServantErr IO a+ latestQ pp = do liftIO $ uncurry (pp 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)++server :: AcidState Database -> Server Dixi+server db = page db+ |: page db "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 (Config {..})) = do+ db <- openLocalStateFrom storage emptyDB+ createCheckpoint db+ createArchive db+ run port $ serve dixi $ server db
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dixi.cabal view
@@ -0,0 +1,70 @@+-- Initial dixi.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/++name: dixi+version: 0.1.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.+ .+ Documents are not stored directly, but as a composition+ tree of patches to an initial empty document. As our+ patches support operational transform, edits can be+ made to any version of each document and they are+ transformed to be applied to the latest version.+ .+ This also makes it easy to use the group structure of+ patches to be able to revert changes (or the composition+ of several changes) from deep in a document's history and+ preserve every other change.+ .+ Right now the wiki doesn't support many bells and whistles,+ such as administrator control, configurability, or user accounts,+ but they're coming.+license: BSD3+license-file: LICENSE+author: Liam O'Connor+maintainer: liamoc@cse.unsw.edu.au+copyright: Liam O'Connor, 2015+category: Web+build-type: Simple+cabal-version: >=1.10+homepage: https://github.com/liamoc/dixi+source-repository head+ type: git+ location: https://github.com/liamoc/dixi++executable dixi+ main-is: Main.hs+ other-modules: Dixi.API+ , Dixi.Common+ , Dixi.Config+ , Dixi.Database+ , Dixi.Database.Orphans+ , Dixi.Forms+ , Dixi.Hamlet+ , Dixi.Markup+ , Dixi.Page+ , 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+ , 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+ , shakespeare >= 2.0 && < 2.1+ , containers >= 0.5 && < 0.6 , text >= 1.2 && < 1.3+ , vector >= 0.10 && <0.12+ , transformers >= 0.4 && < 0.5+ , warp >= 3.1 && <3.2+ , data-default >= 0.5 && <0.6+ , either >= 4.4 && <4.5+ , template-haskell+ , yaml >= 0.8 && < 0.9+ , aeson >= 0.8 && < 0.11+ , directory >= 1.0 && < 1.3++ -- hs-source-dirs: + default-language: Haskell2010