informative 0.1.0.3 → 0.1.0.4

raw patch · 7 files changed

+550/−33 lines, 7 filesdep +highlighting-katePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: highlighting-kate

API changes (from Hackage documentation)

Files

• Web/Informative.hs +433/−14
• Web/Informative/Data.hs +8/−2
• informative-edit.htm +2/−5
• informative-test.hs +1/−1
• informative.cabal +3/−3
• informative.css +85/−3
• informative.htm +18/−5

@@ -5,6 +5,8 @@ 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@@ -13,9 +15,12 @@ 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+import Yesod hiding (languages) import Yesod.Auth import Yesod.Form @@ -55,15 +60,30 @@ readFmt MediaWiki = P.readMediaWiki readFmt ReStructuredText = P.readRST readFmt LaTeX = P.readLaTeX+readFmt Textile = P.readTextile+convFmt :: TextFormat -> String -> Html convFmt Plain = toHtml-convFmt fmt = preEscapedToMarkup . P.writeHtml P.def . readFmt fmt P.def+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 . T.unpack+convSect _ fmt = Left . convFmt fmt . remCR . T.unpack convTable :: TextFormat -> T.Text -> Either Html [[Html]]-convTable fmt t = case parseCSV (T.unpack "wikipage") (T.unpack t) of+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@@ -123,6 +143,8 @@ data SectionData = SectionData {   sdKind :: TextKind,   sdFormat :: TextFormat,+  sdLang :: T.Text,+  sdFirstLine :: Int,   sdContent :: Textarea   } @@ -130,36 +152,433 @@ 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 = map (T.pack . show &&& id) [minBound..maxBound]+  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 :: T.Text -> Int -> WikiHandler Html-getEditR page rid = do+getEditR :: Int -> WikiHandler Html+getEditR rid = do   seg <- liftM getSegment getYesod   pref <- liftM getPrefix getYesod-  (msect, mprec, kind, fmt, suggs) <- lift $ runDB $ do+  (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)+      Nothing -> return (Nothing, Nothing, Error, Plain, suggs, "none")       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)+        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 fmt $ Textarea t) mprec+  (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)

@@ -10,10 +10,16 @@ mkYesodSubData "Informative" [parseRoutes|  /article/#Text ArticleR GET  /articleid/#Int ArticleIdR GET- /edit/#Text/#Int EditR GET+ /edit/#Int EditR GET POST+ /insert/#Int InsertR GET POST+ /prepend/#Int PrependR GET POST+ /down/#Int DownR POST+ /up/#Int UpR POST+ /delete/#Int DeleteR POST+ /create/#Text CreateR GET POST |] -data TextFormat = Markdown | MediaWiki | ReStructuredText | LaTeX | Plain deriving (Eq,Ord,Show,Read, Enum, Bounded)+data TextFormat = Markdown | MediaWiki | ReStructuredText | LaTeX | Textile | Source Text Int | Plain deriving (Eq,Ord,Show,Read) derivePersistField "TextFormat"  data TextKind = Article | Table | Mapping | Hint | Error deriving (Eq, Ord, Show, Read, Enum, Bounded)

@@ -23,7 +23,7 @@       $of (Left c, Hint)         <div .hint>           #{c}-      $of (Left c, Error)+      $of (Left c, _)         <div .error>           #{c}       $of (Right [], _)@@ -46,12 +46,9 @@               <tr>                 $forall c <- cols                   <td>#{c}-  $nothing-    <div .hint>-      You are creating a new section.   <div .content>     <p>-      <form method=post action=@{toParent $ EditR page rid} enctype=#{enctype}>+      <form method=post action=@{submitR} enctype=#{enctype}>         ^{pageBody form}         <button type="submit" name="action" value="save">Save         <button type="submit" name="action" value="preview" default>Preview

@@ -22,7 +22,7 @@ instance Yesod Master where   authRoute _ = Just $ AuthR LoginR   isAuthorized (SubsiteR _) True = mayWrite-  isAuthorized (SubsiteR (EditR _ _)) _ = mayWrite+  isAuthorized (SubsiteR (EditR _)) _ = mayWrite   isAuthorized _ _ = return Authorized  mayWrite = do

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.0.3+version:             0.1.0.4  -- A short (one-line) description of the package. synopsis:            A yesod subsite serving a wiki.@@ -59,7 +59,7 @@   -- other-extensions:          -- Other library packages from which modules are imported.-  build-depends:       base >=4.6 && <4.8, yesod >=1.2 && <1.3, text >=1.1 && <1.2, persistent-postgresql >=1.3 && <1.4, monad-logger >=0.3 && <0.4, persistent >=1.3 && <1.4, pandoc >=1.10, shakespeare >=2.0 && <2.1, time >=1.4 && <1.5, old-locale >= 1.0, csv >=0.1 && <0.2, yesod-auth >=1.3 && <1.4, http-conduit >=2.1 && <2.2, yesod-core >=1.2 && <1.3, yesod-form >=1.3 && <1.4+  build-depends:       base >=4.6 && <4.8, yesod >=1.2 && <1.3, text >=1.1 && <1.2, persistent-postgresql >=1.3 && <1.4, monad-logger >=0.3 && <0.4, persistent >=1.3 && <1.4, pandoc >=1.10, shakespeare >=2.0 && <2.1, time >=1.4 && <1.5, old-locale >= 1.0, csv >=0.1 && <0.2, yesod-auth >=1.3 && <1.4, http-conduit >=2.1 && <2.2, yesod-core >=1.2 && <1.3, yesod-form >=1.3 && <1.4, highlighting-kate >=0.5 && <0.6      -- Directories containing source files.   -- hs-source-dirs:      @@ -68,6 +68,6 @@   default-language:    Haskell2010    executable informative-test-  build-depends:       base >=4.6 && <4.8, yesod >=1.2 && <1.3, text >=1.1 && <1.2, persistent-postgresql >=1.3 && <1.4, monad-logger >=0.3 && <0.4, persistent >=1.3 && <1.4, pandoc >=1.10, shakespeare >=2.0 && <2.1, time >=1.4 && <1.5, old-locale >= 1.0, csv >=0.1 && <0.2, yesod-auth >=1.3 && <1.4, http-conduit >=2.1 && <2.2, yesod-core >=1.2 && <1.3, yesod-form >=1.3 && <1.4+  build-depends:       base >=4.6 && <4.8, yesod >=1.2 && <1.3, text >=1.1 && <1.2, persistent-postgresql >=1.3 && <1.4, monad-logger >=0.3 && <0.4, persistent >=1.3 && <1.4, pandoc >=1.10, shakespeare >=2.0 && <2.1, time >=1.4 && <1.5, old-locale >= 1.0, csv >=0.1 && <0.2, yesod-auth >=1.3 && <1.4, http-conduit >=2.1 && <2.2, yesod-core >=1.2 && <1.3, yesod-form >=1.3 && <1.4, highlighting-kate >=0.5 && <0.6   main-is:             informative-test.hs   default-language:    Haskell2010

@@ -131,16 +131,18 @@ div.table table p, div.mapping table p   margin: 0px; -div#content a+div#content a, div#content button.linkbutton   color: black;   text-decoration: none;+  border: none;+  background: none;  div#content div.content a:before, div#content div.table a:before, div#content div.mapping a:before   color: navy;   content: '->';   font-size: 11px; -div#content a:hover+div#content a:hover, div#content button.linkbutton:hover   text-decoration: underline;  div#content div.edit@@ -150,9 +152,21 @@   font-style: italic;   margin-top: -0.3cm; -div#content div.edit a+div#content div.edit a, div#content div.edit button.linkbutton   color: navy;+  display: inline;+  font-style: italic;+  font-size: 13px;+  margin: 0px;+  padding: 0px;+  cursor: pointer; +div#content div.edit form+  display: inline;+  margin: 0px;+  padding: 0px;+  border: none;+ textarea   width: 100em;   height: 30em;@@ -160,3 +174,71 @@ label   width: 10em;   float: left;++span.kw+  font-weight: bold+  +span.dt+  color: teal++span.dv, span.bn, span.fl, span.ch, span.st+  color: navy++span.co+  color: green++code.sourceCode+  display: block;+  border: 1px solid navy;+  background-color: #dddddd;+  padding: 4px;+  margin-right: 3px;++code.cs, code.source-cs+  background-color: #ffdddd+  color: purple+  border: 1px solid maroon;++code.cs span.co, code.cs span.dv, code.cs span.fl, code.cs span.ch, code.cs span.st, code.cs span.dt, code.source-cs span.co, code.source-cs span.dv, code.source-cs span.fl, code.source-cs span.ch, code.source-cs span.st, code.source-cs span.dt+  color: maroon++code.cs span.co:after, code.source-cs span.co:after+  content: '/\* I\'m a barbie girl in a barbie world \\o/ \*/';++code.php code.source-php+  background-color: #ffddff+  color: maroon+  border: 1px solid purple;++code.php span.co, code.php span.dv, code.php span.fl, code.php span.ch, code.php span.st, code.php span.dt, code.source-php span.co, code.source-php span.dv, code.source-php span.fl, code.source-php span.ch, code.source-php span.st, code.source-php span.dt+  color: purple++pre.haskell:before, pre.source-haskell:before+  content: 'Haskell';+  display: inline;+  border: 1px solid navy;+  padding: 2px;+  background-color: navy;+  color: yellow;+  border-bottom: none+  padding-bottom: 0px;++pre.php:before, pre.source-php:before+  content: 'PHP';+  display: inline;+  border: 1px solid purple;+  padding: 2px;+  background-color: purple;+  color: white;+  border-bottom: none+  padding-bottom: 0px;++pre.cs:before, pre.source-cs:before+  content: 'C#';+  display: inline;+  border: 1px solid maroon;+  padding: 2px;+  background-color: maroon;+  color: white;+  border-bottom: none+  padding-bottom: 0px;

@@ -15,6 +15,11 @@   $maybe msg <- mmsg     <div .hint>       #{msg}+  $if not (null sects)+    $with (idx, (rid, sect, kind)) <- head sects+      $if ((mayEdit == Authorized) && (rid >= 0))+        <div .edit>+          <a href=@{toParent $ PrependR $ fromIntegral rid}>insert   $forall (idx, (rid, sect, kind)) <- sects     $case (sect, kind)       $of (Left c, Article)@@ -23,7 +28,7 @@       $of (Left c, Hint)         <div .hint>           #{c}-      $of (Left c, Error)+      $of (Left c, _)         <div .error>           #{c}       $of (Right [], _)@@ -46,14 +51,22 @@               <tr>                 $forall c <- cols                   <td>#{c}+    $if ((mayEdit == Authorized) && (rid < 0))+      <div .edit>+        <a href=@{toParent $ CreateR page}>create     $if ((mayEdit == Authorized) && (rid >= 0))       <div .edit>         $if idx > 1-          <a href=@{toParent $ EditR page $ fromIntegral rid}>up+          <form method=post action=@{toParent $ UpR $ fromIntegral rid}>+            <button .linkbutton>up         $if idx < length sects-          <a href=@{toParent $ EditR page $ fromIntegral rid}>down-        <a href=@{toParent $ EditR page $ fromIntegral rid}>insert-        <a href=@{toParent $ EditR page $ fromIntegral rid}>edit+          <form method=post action=@{toParent $ DownR $ fromIntegral rid}>+            <button .linkbutton>down+        $if length sects > 1+          <form method=post action=@{toParent $ DeleteR $ fromIntegral rid}>+            <button .linkbutton>delete+        <a href=@{toParent $ InsertR $ fromIntegral rid}>insert+        <a href=@{toParent $ EditR $ fromIntegral rid}>edit   <div .table>     <table>       <thead>