diff --git a/Web/Informative.hs b/Web/Informative.hs --- a/Web/Informative.hs +++ b/Web/Informative.hs @@ -2,6 +2,8 @@ module Web.Informative where +import Control.Applicative +import Control.Arrow import Control.Monad import qualified Data.Text as T import Data.Time.Clock @@ -15,8 +17,9 @@ import Web.Informative.Data import Yesod import Yesod.Auth +import Yesod.Form -type WikiHandler a = forall master. (Yesod master, YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => HandlerT Informative (HandlerT master IO) a +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) @@ -40,6 +43,12 @@ 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 @@ -60,7 +69,7 @@ getArticleIdR pageid = do seg <- liftM getSegment getYesod pref <- liftM getPrefix getYesod - (edits,sects',page) <- lift $ runDB $ do + (edits,sects',page,suggs) <- lift $ runDB $ do let pid = Key (PersistInt64 $ fromIntegral pageid) :: WikipageId wp <- get pid (sects,page) <- case wp of @@ -72,7 +81,8 @@ 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 - return (es,sects,page) + suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex] + return (es,sects,page,suggs) toParent <- getRouteToParent mayEdit <- lift $ isAuthorized (toParent $ ArticleR page) True authR <- lift getAuthR @@ -88,16 +98,17 @@ getArticleR page = do seg <- liftM getSegment getYesod pref <- liftM getPrefix getYesod - (edits,sects') <- lift $ runDB $ do + (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)]) + [] -> 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') + return (es, s',suggs) toParent <- getRouteToParent mayEdit <- lift $ isAuthorized (toParent $ ArticleR page) True authR <- lift getAuthR @@ -109,9 +120,46 @@ 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 sect = do - lift $ defaultLayout [whamlet| Woohoo, we are editing this!|] +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 $(cassiusFileReload "informative.css") instance (YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => YesodSubDispatch Informative (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesInformative) diff --git a/Web/Informative/Data.hs b/Web/Informative/Data.hs --- a/Web/Informative/Data.hs +++ b/Web/Informative/Data.hs @@ -13,8 +13,8 @@ /edit/#Text/#Int EditR GET |] -data TextFormat = Markdown | MediaWiki | ReStructuredText | LaTeX | Plain deriving (Eq,Ord,Show,Read) +data TextFormat = Markdown | MediaWiki | ReStructuredText | LaTeX | Plain deriving (Eq,Ord,Show,Read, Enum, Bounded) derivePersistField "TextFormat" -data TextKind = Article | Table | Mapping | Hint | Error deriving (Eq, Ord, Show, Read) +data TextKind = Article | Table | Mapping | Hint | Error deriving (Eq, Ord, Show, Read, Enum, Bounded) derivePersistField "TextKind" diff --git a/informative-edit.htm b/informative-edit.htm new file mode 100644 --- /dev/null +++ b/informative-edit.htm @@ -0,0 +1,57 @@ +

#{page} +
+