module Web.Informative where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Char
import Data.Monoid
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import Database.Persist.Sql
import System.Locale
import Text.Cassius
import Text.CSV
import Text.Hamlet
import Text.Highlighting.Kate
import Text.Highlighting.Kate.Format.HTML
import Text.Highlighting.Kate.Types
import qualified Text.Pandoc as P
import Web.Informative.Data
import Yesod hiding (languages)
import Yesod.Auth
import Yesod.Form
type WikiHandler a = forall master. (YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => HandlerT Informative (HandlerT master IO) a
class (Yesod master, RenderMessage master FormMessage) => YesodWikiAuth master where
getAuthR :: HandlerT master IO (AuthRoute -> Route master)
getUserName :: HandlerT master IO T.Text
isLoggedIn :: HandlerT master IO Bool
wikiLayout :: WidgetT master IO () -> HandlerT master IO Html
share [mkPersist sqlSettings, mkMigrate "migrateWiki"] [persistLowerCase|
Wikipage
title T.Text
segment T.Text
editor T.Text
timestamp UTCTime
UniquePage title segment timestamp
Wikisection
content T.Text
format TextFormat
kind TextKind
Wikirel
page WikipageId
section WikisectionId
index Int
UniqueRel page section
Wikisugg
page T.Text
segment T.Text
index Int
caption T.Text
UniqueSugg page segment
|]
readFmt Markdown = P.readMarkdown
readFmt MediaWiki = P.readMediaWiki
readFmt ReStructuredText = P.readRST
readFmt LaTeX = P.readLaTeX
readFmt Textile = P.readTextile
convFmt :: TextFormat -> String -> Html
convFmt Plain = toHtml
convFmt (Source lg ln) = toHtml . formatHtmlBlock defaultFormatOpts{numberLines=True,startNumber=ln,containerClasses=["sourceCode","source-"<>toClassname lg],codeClasses=["source-"<>toClassname lg]} . highlightAs (T.unpack lg)
convFmt fmt = preEscapedToMarkup . P.writeHtml P.def{P.writerHtml5=True,P.writerHighlight=True,P.writerListings=True} . readFmt fmt P.def{P.readerSmart=True}
convSect Table fmt = convTable fmt
convSect Mapping fmt = convTable fmt
convSect _ fmt = Left . convFmt fmt . remCR . T.unpack
convTable :: TextFormat -> T.Text -> Either Html [[Html]]
convTable fmt t = case parseCSV (T.unpack "wikipage") (remCR $ T.unpack t) of
Left err -> Left $ toHtml $ show err
Right csv -> Right $ map (map (convFmt fmt)) csv
source :: TextFormat -> T.Text -> Int -> TextFormat
source (Source _ _) lg ln = Source lg ln
source fmt _ _ = fmt
fmtNorm :: TextFormat -> TextFormat
fmtNorm (Source _ _) = Source "" 1
fmtNorm fmt = fmt
fmtLang (Source lg _) = lg
fmtLang _ = "haskell"
fmtLine (Source _ ln) = ln
fmtLine _ = 1
toClassname = filter isAlphaNum . T.unpack
remCR = filter (/=chr 13)
getArticleIdR :: Int -> WikiHandler Html
getArticleIdR pageid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(edits,sects',page,suggs) <- lift $ runDB $ do
let pid = Key (PersistInt64 $ fromIntegral pageid) :: WikipageId
wp <- get pid
(sects,page) <- case wp of
Nothing -> return ([(1,Left $ convFmt LaTeX "\\section{404 Not Found} We're sorry, but that article doesn't exist in our database.", Error)],"none")
Just p -> do
rels <- selectList [WikirelPage ==. pid] [Asc WikirelIndex]
sects <- forM rels $ \(Entity (Key (PersistInt64 rid)) r) -> liftM (rid,) $ get $ wikirelSection r
let s' = map (\(rid,Just s) -> (rid,convSect (wikisectionKind s) (wikisectionFormat s) (wikisectionContent s), wikisectionKind s)) sects
return (s', wikipageTitle p)
hs <- selectList [WikipageTitle ==. page, WikipageSegment ==. seg] [Desc WikipageTimestamp, LimitTo 10]
let es = map (\(Entity (Key (PersistInt64 pid)) p) -> (pid, wikipageEditor p, wikipageTimestamp p)) hs
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
return (es,sects,page,suggs)
toParent <- getRouteToParent
mayEdit <- lift $ isAuthorized (toParent $ ArticleR page) True
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
let sects = zip [1..] sects'
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $(hamletFile "informative.htm")
toWidget $(cassiusFile "informative.css")
getArticleR :: T.Text -> WikiHandler Html
getArticleR page = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(edits,sects',suggs) <- lift $ runDB $ do
wp <- selectList [WikipageTitle ==. page, WikipageSegment ==. seg] [Desc WikipageTimestamp, LimitTo 10]
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
case wp of
[] -> return ([], [(1,Left $ convFmt LaTeX "\\section{404 Not Found} We're sorry, but that article doesn't exist in our database.", Error)],suggs)
hs@((Entity pid p):_) -> do
rels <- selectList [WikirelPage ==. pid] [Asc WikirelIndex]
sects <- forM rels $ \(Entity (Key (PersistInt64 rid)) r) -> liftM (rid,) $ get $ wikirelSection r
let s' = map (\(rid,Just s) -> (rid,convSect (wikisectionKind s) (wikisectionFormat s) (wikisectionContent s), wikisectionKind s)) sects
es = map (\(Entity (Key (PersistInt64 pid)) p) -> (pid, wikipageEditor p, wikipageTimestamp p)) hs
return (es, s',suggs)
toParent <- getRouteToParent
mayEdit <- lift $ isAuthorized (toParent $ ArticleR page) True
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
let sects = zip [1..] sects'
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $(hamletFile "informative.htm")
toWidget $(cassiusFile "informative.css")
data SectionData = SectionData {
sdKind :: TextKind,
sdFormat :: TextFormat,
sdLang :: T.Text,
sdFirstLine :: Int,
sdContent :: Textarea
}
editSectionForm :: RenderMessage master FormMessage => Maybe SectionData -> Html -> MForm (HandlerT master IO) (FormResult SectionData, WidgetT master IO ())
editSectionForm mdata = renderDivs $ SectionData
<$> areq (selectFieldList kinds) "Kind:" (sdKind <$> mdata)
<*> areq (selectFieldList formats) "Format:" (sdFormat <$> mdata)
<*> areq textField "Language:" (sdLang <$> mdata)
<*> areq intField "First line:" (sdFirstLine <$> mdata)
<*> areq textareaField "Content:" (sdContent <$> mdata)
where formats :: [(T.Text,TextFormat)]
formats = [("Markdown",Markdown),("MediaWiki",MediaWiki),("ReStructuredText",ReStructuredText),("LaTeX",LaTeX),("Textile",Textile),("Source code",Source "" 1),("Plain text",Plain)]
kinds = map (T.pack . show &&& id) [minBound..maxBound]
getEditR :: Int -> WikiHandler Html
getEditR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(msect, mprec, kind, fmt, suggs, page) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
rel <- get (Key (PersistInt64 $ fromIntegral rid) :: WikirelId)
case rel of
Nothing -> return (Nothing, Nothing, Error, Plain, suggs, "none")
Just rel -> do
msect <- get $ wikirelSection rel
mpage <- get $ wikirelPage rel
case (msect,mpage) of
(Nothing,Nothing) -> return (Nothing, Nothing, Error, Plain, suggs, "none")
(Just sect, Just page) ->
return (Just $ convSect (wikisectionKind sect) (wikisectionFormat sect) (wikisectionContent sect), Just $ wikisectionContent sect, wikisectionKind sect, wikisectionFormat sect, suggs, wikipageTitle page)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
(formw, enctype) <- lift $ generateFormPost $ editSectionForm $ liftM (\t -> SectionData kind (fmtNorm fmt) (fmtLang fmt) (fmtLine fmt) $ Textarea t) mprec
form <- lift $ widgetToPageContent formw
submitR <- return $ toParent $ EditR rid
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
getInsertR :: Int -> WikiHandler Html
getInsertR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(suggs, page) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
rel <- get (Key (PersistInt64 $ fromIntegral rid) :: WikirelId)
case rel of
Nothing -> return (suggs, "none")
Just rel -> do
mpage <- get $ wikirelPage rel
case mpage of
Nothing -> return (suggs, "none")
Just page -> return (suggs, wikipageTitle page)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
(formw, enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData Article MediaWiki "haskell" 1 $ Textarea ""
form <- lift $ widgetToPageContent formw
submitR <- return $ toParent $ InsertR rid
msect <- return (Nothing :: Maybe (Either Html [[Html]]))
kind <- return Article
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
getPrependR :: Int -> WikiHandler Html
getPrependR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(suggs, page) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
rel <- get (Key (PersistInt64 $ fromIntegral rid) :: WikirelId)
case rel of
Nothing -> return (suggs, "none")
Just rel -> do
mpage <- get $ wikirelPage rel
case mpage of
Nothing -> return (suggs, "none")
Just page -> return (suggs, wikipageTitle page)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
(formw, enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData Article MediaWiki "haskell" 1 $ Textarea ""
form <- lift $ widgetToPageContent formw
submitR <- return $ toParent $ PrependR rid
msect <- return (Nothing :: Maybe (Either Html [[Html]]))
kind <- return Article
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
getCreateR :: T.Text -> WikiHandler Html
getCreateR page = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(suggs, exists) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
vs <- selectList [WikipageTitle ==. page] [LimitTo 1]
return (suggs, not $ null vs)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
(formw, enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData Article MediaWiki "haskell" 1 $ Textarea ("= "<>page<>" =\n\nSome text about "<>page<>".")
form <- lift $ widgetToPageContent (if exists then [whamlet|<div .error>Page does already exist.|] else formw)
submitR <- return $ toParent $ CreateR page
msect <- return (Nothing :: Maybe (Either Html [[Html]]))
kind <- return Article
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
postEditR :: Int -> WikiHandler Html
postEditR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
let rid' = Key (PersistInt64 $ fromIntegral rid) :: WikirelId
(msect, mprec, kind, fmt, suggs, page) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
rel <- get rid'
case rel of
Nothing -> return (Nothing, Nothing, Error, Plain, suggs, "none")
Just rel -> do
msect <- get $ wikirelSection rel
mpage <- get $ wikirelPage rel
case (msect,mpage) of
(Nothing,Nothing) -> return (Nothing, Nothing, Error, Plain, suggs, "none")
(Just sect, Just page) ->
return (Just $ convSect (wikisectionKind sect) (wikisectionFormat sect) (wikisectionContent sect), Just $ wikisectionContent sect, wikisectionKind sect, wikisectionFormat sect, suggs, wikipageTitle page)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
user <- lift getUserName
now <- liftIO getCurrentTime
((result, widget),enctype) <- lift $ runFormPost $ editSectionForm $ liftM (\t -> SectionData kind (fmtNorm fmt) (fmtLang fmt) (fmtLine fmt) $ Textarea t) mprec
action <- lift $ runInputPost $ id <$> ireq textField "action"
submitR <- return $ toParent $ EditR rid
case (result,action) of
(FormSuccess (SectionData k f lg ln (Textarea c)),"save") -> do
lift $ runDB $ do
Right sid <- insertBy $ Wikisection c (source f lg ln) k
Right pid <- insertBy $ Wikipage page seg user now
prel <- get rid'
case prel of
Nothing -> return ()
Just prel -> do
rels <- selectList [WikirelPage ==. wikirelPage prel] [Asc WikirelIndex]
let nrels = map (\(Entity ri r) -> Wikirel pid (if ri==rid' then sid else wikirelSection r) (wikirelIndex r)) rels
forM_ nrels insertBy
setMessage $ toHtml ("Page has been edited." :: T.Text)
lift $ redirect $ toParent $ ArticleR page
(FormSuccess (SectionData k f lg ln (Textarea c)),_) -> do
kind <- return k
msect <- return $ Just $ convSect k (source f lg ln) c
mprec <- return $ Just c
(widget,enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData k f lg ln $ Textarea c
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
_ -> do
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
postInsertR :: Int -> WikiHandler Html
postInsertR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
let rid' = Key (PersistInt64 $ fromIntegral rid) :: WikirelId
(suggs, page) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
rel <- get rid'
case rel of
Nothing -> return (suggs, "none")
Just rel -> do
mpage <- get $ wikirelPage rel
case mpage of
Nothing -> return (suggs, "none")
Just page ->
return (suggs, wikipageTitle page)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
user <- lift getUserName
now <- liftIO getCurrentTime
msect <- return (Nothing :: Maybe (Either Html [[Html]]))
((result, widget),enctype) <- lift $ runFormPost $ editSectionForm $ Just $ SectionData Article MediaWiki "haskell" 1 $ Textarea ""
action <- lift $ runInputPost $ id <$> ireq textField "action"
kind <- return Article
submitR <- return $ toParent $ InsertR rid
case (result,action) of
(FormSuccess (SectionData k f lg ln (Textarea c)),"save") -> do
lift $ runDB $ do
Right sid <- insertBy $ Wikisection c (source f lg ln) k
Right pid <- insertBy $ Wikipage page seg user now
prel <- get rid'
case prel of
Nothing -> return ()
Just prel -> do
rels <- selectList [WikirelPage ==. wikirelPage prel] [Asc WikirelIndex]
let nrels1 = map (\(Entity _ r) -> r) $ takeWhile (\(Entity ri _) -> ri /= rid') rels
nrels2 = map (\(Entity _ r) -> r) $ drop (length nrels1) rels
nrels3 = nrels1 ++ [head nrels2] ++ [Wikirel pid sid 0] ++ tail nrels2
nrels = map (\(i,Wikirel _ s _) -> Wikirel pid s i) $ zip [1..] nrels3
forM_ nrels insertBy
setMessage $ toHtml ("Page has been edited." :: T.Text)
lift $ redirect $ toParent $ ArticleR page
(FormSuccess (SectionData k f lg ln (Textarea c)),_) -> do
kind <- return k
msect <- return $ Just $ convSect k (source f lg ln) c
mprec <- return $ Just c
(widget,enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData k f lg ln $ Textarea c
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
_ -> do
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
postPrependR :: Int -> WikiHandler Html
postPrependR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
let rid' = Key (PersistInt64 $ fromIntegral rid) :: WikirelId
(suggs, page) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
rel <- get rid'
case rel of
Nothing -> return (suggs, "none")
Just rel -> do
mpage <- get $ wikirelPage rel
case mpage of
Nothing -> return (suggs, "none")
Just page ->
return (suggs, wikipageTitle page)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
user <- lift getUserName
now <- liftIO getCurrentTime
msect <- return (Nothing :: Maybe (Either Html [[Html]]))
((result, widget),enctype) <- lift $ runFormPost $ editSectionForm $ Just $ SectionData Article MediaWiki "haskell" 1 $ Textarea ""
action <- lift $ runInputPost $ id <$> ireq textField "action"
kind <- return Article
submitR <- return $ toParent $ PrependR rid
case (result,action) of
(FormSuccess (SectionData k f lg ln (Textarea c)),"save") -> do
lift $ runDB $ do
Right sid <- insertBy $ Wikisection c (source f lg ln) k
Right pid <- insertBy $ Wikipage page seg user now
prel <- get rid'
case prel of
Nothing -> return ()
Just prel -> do
rels <- selectList [WikirelPage ==. wikirelPage prel] [Asc WikirelIndex]
let nrels1 = map (\(Entity _ r) -> r) $ takeWhile (\(Entity ri _) -> ri /= rid') rels
nrels2 = map (\(Entity _ r) -> r) $ drop (length nrels1) rels
nrels3 = nrels1 ++ [Wikirel pid sid 0] ++ nrels2
nrels = map (\(i,Wikirel _ s _) -> Wikirel pid s i) $ zip [1..] nrels3
forM_ nrels insertBy
setMessage $ toHtml ("Page has been edited." :: T.Text)
lift $ redirect $ toParent $ ArticleR page
(FormSuccess (SectionData k f lg ln (Textarea c)),_) -> do
kind <- return k
msect <- return $ Just $ convSect k (source f lg ln) c
mprec <- return $ Just c
(widget,enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData k f lg ln $ Textarea c
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
_ -> do
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
postCreateR :: T.Text -> WikiHandler Html
postCreateR page = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(suggs, exists) <- lift $ runDB $ do
suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
vs <- selectList [WikipageTitle ==. page] [LimitTo 1]
return (suggs, not $ null vs)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
user <- lift getUserName
now <- liftIO getCurrentTime
msect <- return (Nothing :: Maybe (Either Html [[Html]]))
((result, widget),enctype) <- lift $ runFormPost $ editSectionForm $ Just $ SectionData Article MediaWiki "haskell" 1 $ Textarea ""
action <- lift $ runInputPost $ id <$> ireq textField "action"
kind <- return Article
submitR <- return $ toParent $ CreateR page
case (exists,result,action) of
(False,FormSuccess (SectionData k f lg ln (Textarea c)),"save") -> do
lift $ runDB $ do
Right sid <- insertBy $ Wikisection c (source f lg ln) k
Right pid <- insertBy $ Wikipage page seg user now
insertBy $ Wikirel pid sid 1
setMessage $ toHtml ("Page has been created." :: T.Text)
lift $ redirect $ toParent $ ArticleR page
(False,FormSuccess (SectionData k f lg ln (Textarea c)),_) -> do
kind <- return k
msect <- return $ Just $ convSect k (source f lg ln) c
mprec <- return $ Just c
(widget,enctype) <- lift $ generateFormPost $ editSectionForm $ Just $ SectionData k f lg ln $ Textarea c
form <- lift $ widgetToPageContent widget
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
_ -> do
form <- lift $ widgetToPageContent (if exists then [whamlet|<div .error>Page does already exist.|] else widget)
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
postDownR :: Int -> WikiHandler Html
postDownR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
user <- lift getUserName
now <- liftIO getCurrentTime
toParent <- getRouteToParent
let rid' = Key (PersistInt64 $ fromIntegral rid) :: WikirelId
page <- lift $ runDB $ do
rel <- get rid'
case rel of
Nothing -> return "none"
Just rel -> do
page <- get $ wikirelPage rel
case page of
Nothing -> return "none"
Just page -> do
Right pid <- insertBy $ Wikipage (wikipageTitle page) seg user now
rels <- selectList [WikirelPage ==. wikirelPage rel] [Asc WikirelIndex]
let swap [Entity _ r] = [r]
swap [] = []
swap (Entity ri1 r1:Entity _ r2:rs)
| ri1 == rid' = r1{wikirelIndex=wikirelIndex r2}:r2{wikirelIndex=wikirelIndex r1}:swap rs
swap (Entity _ r:rs) = r:swap rs
forM (swap rels) $ \r -> insertBy r{wikirelPage=pid}
return $ wikipageTitle page
lift $ redirect $ toParent $ ArticleR page
postUpR :: Int -> WikiHandler Html
postUpR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
user <- lift getUserName
now <- liftIO getCurrentTime
toParent <- getRouteToParent
let rid' = Key (PersistInt64 $ fromIntegral rid) :: WikirelId
page <- lift $ runDB $ do
rel <- get rid'
case rel of
Nothing -> return "none"
Just rel -> do
page <- get $ wikirelPage rel
case page of
Nothing -> return "none"
Just page -> do
Right pid <- insertBy $ Wikipage (wikipageTitle page) seg user now
rels <- selectList [WikirelPage ==. wikirelPage rel] [Asc WikirelIndex]
let swap [Entity _ r] = [r]
swap [] = []
swap (Entity _ r1:Entity ri2 r2:rs)
| ri2 == rid' = r1{wikirelIndex=wikirelIndex r2}:r2{wikirelIndex=wikirelIndex r1}:swap rs
swap (Entity _ r:rs) = r:swap rs
forM (swap rels) $ \r -> insertBy r{wikirelPage=pid}
return $ wikipageTitle page
lift $ redirect $ toParent $ ArticleR page
postDeleteR :: Int -> WikiHandler Html
postDeleteR rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
user <- lift getUserName
now <- liftIO getCurrentTime
toParent <- getRouteToParent
let rid' = Key (PersistInt64 $ fromIntegral rid) :: WikirelId
page <- lift $ runDB $ do
rel <- get rid'
case rel of
Nothing -> return "none"
Just rel -> do
page <- get $ wikirelPage rel
case page of
Nothing -> return "none"
Just page -> do
Right pid <- insertBy $ Wikipage (wikipageTitle page) seg user now
rels <- selectList [WikirelPage ==. wikirelPage rel] [Asc WikirelIndex]
let nrels = map (\(Entity _ r) -> r) $ filter (\(Entity ri _) -> ri /= rid') rels
forM nrels $ \r -> insertBy r{wikirelPage=pid}
return $ wikipageTitle page
lift $ redirect $ toParent $ ArticleR page
instance (YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => YesodSubDispatch Informative (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesInformative)