diff --git a/Handler/Book.hs b/Handler/Book.hs index 7346e47..e0e7ad9 100644 --- a/Handler/Book.hs +++ b/Handler/Book.hs @@ -28,12 +28,17 @@ $if not $ null tocs ^{showTOC $ tocChildren toc} |] -loadTOC :: Int -> (MapNodeSlug -> WikiRoute) -> TMapId -> Handler [TOC] -loadTOC depth0 toRoute tmid = - runDB $ selectList [TMapNodeMapEq tmid, TMapNodeParentEq Nothing] [TMapNodePositionAsc] 0 0 >>= mapM (go depth0) +loadTOC :: Int -> ([MapNodeSlug] -> WikiRoute) -> TMapId -> Handler [TOC] +loadTOC depth0 toRoute = + runDB . go' id depth0 where - go depth (mnid, mn) = do - let link = Just $ toRoute $ tMapNodeSlug mn + go' front depth tmid = selectList [TMapNodeMapEq tmid, TMapNodeParentEq Nothing] [TMapNodePositionAsc] 0 0 >>= (fmap concat . mapM (go front depth)) + go front depth (_, TMapNode + { tMapNodeCmap = Just submap + , tMapNodeSlug = slug + }) = go' (front . (:) slug) depth submap + go front depth (mnid, mn) = do + let link = Just $ toRoute $ front [tMapNodeSlug mn] title <- case tMapNodeCtopic mn of Just tid -> topicTitle <$> get404 tid @@ -41,13 +46,15 @@ loadTOC depth0 toRoute tmid = children <- if depth <= 1 then return [] - else selectList [TMapNodeParentEq $ Just mnid] [TMapNodePositionAsc] 0 0 >>= mapM (go $ depth - 1) - return $ TOC link title children + else selectList [TMapNodeParentEq $ Just mnid] [TMapNodePositionAsc] 0 0 >>= mapM (go front $ depth - 1) + return [TOC link title $ concat children] getBookR :: Handler RepHtml getBookR = do - book <- getBook - tocs <- loadTOC (bookChunking book) BookChapterR (bookMap book) + book <- runDB getBook + let toRoute [] = error "in getBookR: toRoute received an empty list" + toRoute (x:xs) = BookChapterR x xs + tocs <- loadTOC (bookChunking book) toRoute (bookMap book) tm <- runDB $ get404 $ bookMap book mtopic <- case bookTopic book of @@ -57,16 +64,15 @@ getBookR = do return $ map (\y -> (tid, y)) x defaultLayout $(hamletFile "book") -getBookChapterR :: MapNodeSlug -> Handler RepHtml -getBookChapterR mnslug = do +getBookChapterR :: MapNodeSlug -> MapNodeSlugs -> Handler RepHtml +getBookChapterR mnslug mnslugs = do -- FIXME show TOC for shallow chapters - book <- getBook (mn, tree) <- runDB $ do - (mnid, mn) <- getBy404 $ UniqueMapNode (bookMap book) mnslug + (mnid, mn) <- getMapNode mnslug mnslugs tree <- loadTreeNode (mnid, mn) return (mn, tree) defaultLayout $ do addLucius $(luciusFile "book") addLucius $(luciusFile "show-map") - addHamlet $ showTree 2 [tree] + addHamlet $ showTree 2 tree comments diff --git a/Handler/ShowMap.hs b/Handler/ShowMap.hs index fc39a52..df21c18 100644 --- a/Handler/ShowMap.hs +++ b/Handler/ShowMap.hs @@ -40,32 +40,38 @@ $forall tree <- trees incr i = i + 1 loadTree :: TMapId -> Handler [Tree] -loadTree tmid = - runDB $ selectList [TMapNodeMapEq tmid, TMapNodeParentEq Nothing] [TMapNodePositionAsc] 0 0 >>= mapM loadTreeNode +loadTree = runDB . loadTree' -loadTreeNode :: (TMapNodeId, TMapNode) -> SqlPersist (GGHandler sub Wiki IO) Tree +loadTree' :: TMapId -> SqlPersist (GGHandler sub Wiki IO) [Tree] +loadTree' tmid = + selectList [TMapNodeMapEq tmid, TMapNodeParentEq Nothing] [TMapNodePositionAsc] 0 0 >>= (fmap concat . mapM loadTreeNode) + +loadTreeNode :: (TMapNodeId, TMapNode) -> SqlPersist (GGHandler sub Wiki IO) [Tree] loadTreeNode (tmnid, tmn) = do - c <- selectList [TMapNodeParentEq $ Just tmnid] [] 0 0 >>= mapM loadTreeNode - title <- - case tMapNodeCtopic tmn of - Nothing -> return "" - Just tid -> do - t <- get404 tid - return $ topicTitle t - content <- - case tMapNodeCtopic tmn of - Nothing -> return Nothing - Just tid -> do - x <- selectList [TopicContentTopicEq tid] [TopicContentChangedDesc] 1 0 - case x of - (_, y):_ -> return $ Just y - [] -> return Nothing - return Tree - { treeTopicId = tMapNodeCtopic tmn - , treeTitle = title - , treeChildren = c - , treeContent = content - } + case tMapNodeCmap tmn of + Nothing -> do + c <- selectList [TMapNodeParentEq $ Just tmnid] [] 0 0 >>= mapM loadTreeNode + title <- + case tMapNodeCtopic tmn of + Nothing -> return "" + Just tid -> do + t <- get404 tid + return $ topicTitle t + content <- + case tMapNodeCtopic tmn of + Nothing -> return Nothing + Just tid -> do + x <- selectList [TopicContentTopicEq tid] [TopicContentChangedDesc] 1 0 + case x of + (_, y):_ -> return $ Just y + [] -> return Nothing + return [Tree + { treeTopicId = tMapNodeCtopic tmn + , treeTitle = title + , treeChildren = concat c + , treeContent = content + }] + Just tmid -> loadTree' tmid getShowMapR :: TMapId -> Handler RepHtml getShowMapR tmid = do diff --git a/Model.hs b/Model.hs index ab16480..39454be 100644 --- a/Model.hs +++ b/Model.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings, TypeSynonymInstances #-} module Model where import Yesod.Persist @@ -8,7 +8,7 @@ import Data.Text (Text, pack) import Data.Time (UTCTime) import Text.Hamlet (Html) import Yesod.Form (Textarea) -import Yesod.Core (SinglePiece (..)) +import Yesod.Core (SinglePiece (..), MultiPiece (..)) import Data.ByteString (ByteString) import Data.ByteString.Base64 (decodeLenient) @@ -18,6 +18,10 @@ derivePersistField "TopicFormat" newtype MapNodeSlug = MapNodeSlug { unMapNodeSlug :: Text } deriving (Read, Eq, Show, PersistField, SinglePiece, Ord) +type MapNodeSlugs = [MapNodeSlug] +instance MultiPiece MapNodeSlugs where + toMultiPiece = map unMapNodeSlug + fromMultiPiece = fmap (map MapNodeSlug) . fromMultiPiece newtype BlogSlug = BlogSlug Text deriving (Read, Eq, Show, PersistField, SinglePiece, Ord) newtype UserHandle = UserHandle { unUserHandle :: Text } diff --git a/Wiki.hs b/Wiki.hs index ed218cd..9a3404e 100644 --- a/Wiki.hs +++ b/Wiki.hs @@ -32,6 +32,7 @@ module Wiki , fromLabel , getBlogPost , getBook + , getMapNode ) where import Data.Time @@ -155,6 +156,9 @@ instance Yesod Wiki where clientSessionDuration _ = 60 * 24 * 7 * 2 -- 2 weeks + maximumContentLength _ (Just UploadDitamapR) = 1000 * 1000 * 5 + maximumContentLength _ _ = 1000 * 1000 * 1 + -- How to run database actions. instance YesodPersist Wiki where type YesodDB Wiki = SqlPersist @@ -220,12 +224,11 @@ instance YesodBreadcrumbs Wiki where tm <- runDB $ get404 $ blogMap blog return (MsgBlogPostTitle $ tMapTitle tm, Just RootR) breadcrumb BookR = do - book <- getBook + book <- runDB getBook tm <- runDB $ get404 $ bookMap book return (MsgBookTitle $ tMapTitle tm, Just RootR) - breadcrumb (BookChapterR mnslug) = do - book <- getBook - (_, mn) <- runDB $ getBy404 $ UniqueMapNode (bookMap book) mnslug + breadcrumb (BookChapterR mnslug mnslugs) = do + (_, mn) <- runDB $ getMapNode mnslug mnslugs title <- case tMapNodeCtopic mn of Just tid -> runDB $ topicTitle <$> get404 tid @@ -296,9 +299,24 @@ getBlogPost :: Int -> Month -> BlogSlug -> GHandler sub Wiki Blog getBlogPost year month slug = runDB $ fmap snd $ getBy404 $ UniqueBlogSlug year month slug -getBook :: GHandler sub Wiki Book +getBook :: SqlPersist (GGHandler s Wiki IO) Book getBook = do - x <- runDB $ selectList [] [] 1 0 + x <- selectList [] [] 1 0 case x of - [] -> notFound + [] -> lift notFound (_, y):_ -> return y + +getMapNode :: MapNodeSlug -> MapNodeSlugs -> SqlPersist (GGHandler s Wiki IO) (TMapNodeId, TMapNode) +getMapNode mnslug mnslugs = do + book <- getBook + (mnid, mn) <- go' (bookMap book) mnslug + go mnid mn mnslugs + where + go' tmid slug = getBy404 $ UniqueMapNode tmid slug + go mnid mn [] = return (mnid, mn) + go _ mn (x:xs) = + case tMapNodeCmap mn of + Nothing -> lift notFound -- FIXME more debug info? + Just tmid -> do + (mnid', mn') <- go' tmid x + go mnid' mn' xs diff --git a/config/routes b/config/routes index 5efba66..d9872c2 100644 --- a/config/routes +++ b/config/routes @@ -45,7 +45,7 @@ /blog/#Int/#Month/#BlogSlug BlogPostR GET /book BookR GET -/book/#MapNodeSlug BookChapterR GET +/book/#MapNodeSlug/*MapNodeSlugs BookChapterR GET /comments/count CommentCountR GET /comments CommentsR GET POST