module Web.Informative where
import Control.Applicative
import Control.Arrow
import Control.Monad
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 qualified Text.Pandoc as P
import Web.Informative.Data
import Yesod
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
convFmt Plain = toHtml
convFmt fmt = preEscapedToMarkup . P.writeHtml P.def . readFmt fmt P.def
convSect Table fmt = convTable fmt
convSect Mapping fmt = convTable fmt
convSect _ fmt = Left . convFmt fmt . T.unpack
convTable :: TextFormat -> T.Text -> Either Html [[Html]]
convTable fmt t = case parseCSV (T.unpack "wikipage") (T.unpack t) of
Left err -> Left $ toHtml $ show err
Right csv -> Right $ map (map (convFmt fmt)) csv
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,
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 textareaField "Content:" (sdContent <$> mdata)
where formats = map (T.pack . show &&& id) [minBound..maxBound]
kinds = map (T.pack . show &&& id) [minBound..maxBound]
getEditR :: T.Text -> Int -> WikiHandler Html
getEditR page rid = do
seg <- liftM getSegment getYesod
pref <- liftM getPrefix getYesod
(msect, mprec, kind, fmt, suggs) <- 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)
Just rel -> do
msect <- get $ wikirelSection rel
case msect of
Nothing -> return (Nothing, Nothing, Error, Plain, suggs)
Just sect ->
return (Just $ convSect (wikisectionKind sect) (wikisectionFormat sect) (wikisectionContent sect), Just $ wikisectionContent sect, wikisectionKind sect, wikisectionFormat sect, suggs)
toParent <- getRouteToParent
authR <- lift getAuthR
loggedIn <- lift isLoggedIn
mmsg <- getMessage
(formw, enctype) <- lift $ generateFormPost $ editSectionForm $ liftM (\t -> SectionData kind fmt $ Textarea t) mprec
form <- lift $ widgetToPageContent formw
lift $ wikiLayout $ do
setTitle $ toHtml page
toWidget $ pageHead form
toWidget $(hamletFile "informative-edit.htm")
toWidget $(cassiusFile "informative.css")
instance (YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => YesodSubDispatch Informative (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesInformative)