Skip to content

Commit

Permalink
Display submaps
Browse files Browse the repository at this point in the history
  • Loading branch information
@snoyberg
snoyberg committed Jun 16, 2011
1 parent 8801df9 commit 63e74d1
Show file tree
Hide file tree
Showing 5 changed files with 82 additions and 48 deletions.
34 changes: 20 additions & 14 deletions Handler/Book.hs
View file
Expand Up @@ -28,26 +28,33 @@ $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
Nothing -> return "" -- FIXME
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
Expand All @@ -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
54 changes: 30 additions & 24 deletions Handler/ShowMap.hs
View file
Expand Up @@ -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
Expand Down
8 changes: 6 additions & 2 deletions Model.hs
View file
@@ -1,4 +1,4 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings, TypeSynonymInstances #-}
module Model where

import Yesod.Persist
Expand All @@ -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)

Expand All @@ -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 }
Expand Down
32 changes: 25 additions & 7 deletions Wiki.hs
View file
Expand Up @@ -32,6 +32,7 @@ module Wiki
, fromLabel
, getBlogPost
, getBook
, getMapNode
) where

import Data.Time
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
2 changes: 1 addition & 1 deletion config/routes
View file
Expand Up @@ -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
Expand Down

0 comments on commit 63e74d1

Please sign in to comment.