{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Paste views. module Hpaste.View.Paste (pasteFormlet ,page ,pasteLink ,pasteRawLink) where import Hpaste.Types import Hpaste.View.Highlight (highlightPaste) import Hpaste.View.Hlint (viewHints) import Hpaste.View.Html import Hpaste.View.Layout import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad import Data.ByteString.UTF8 (toString) import Data.List (find,nub) import qualified Data.Map as M import Data.Maybe import Data.Monoid.Operator ((++)) import Data.Text (Text,pack) import qualified Data.Text as T import Data.Text.Lazy (fromStrict) import Data.Time.Show (showDateTime) import Data.Traversable hiding (forM) import Prelude hiding ((++)) import Safe (readMay) import Text.Blaze.Html5 as H hiding (map) import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Html5.Extra import Text.Blaze.Extra import Text.Formlet -- | Render the page page. page :: PastePage -> Markup page PastePage{ppPaste=p@Paste{..},..} = layoutPage $ Page { pageTitle = pasteTitle , pageBody = do viewPaste (if ppRevision then [] else ppRevisions) [] ppChans ppLangs (p,case ppRevisionsHints of (hints:_) -> hints; _ -> ppHints) viewAnnotations (p : ppAnnotations) ppChans ppLangs (zip ppAnnotations ppAnnotationHints) , pageName = "paste" } -- | A formlet for paste submission / annotateing. pasteFormlet :: PasteFormlet -> (Formlet PasteSubmit,Markup) pasteFormlet pf@PasteFormlet{..} = let form = postForm ! A.action (toValue action) $ do when pfSubmitted $ when (not (null pfErrors)) $ H.div ! aClass "errors" $ mapM_ (p . toMarkup) pfErrors formletHtml (pasteSubmit pf) pfParams p $ do submitI "public" "Create Public Paste" " " submitI "private" "Create Secret Paste" in (pasteSubmit pf,form) where action = case pfAnnotatePaste of Just Paste{..} -> "/annotate/" ++ show (fromMaybe pasteId pasteParent) where pasteParent = case pasteType of AnnotationOf pid -> Just pid _ -> Nothing Nothing -> case pfEditPaste of Just Paste{..} -> "/edit/" ++ show pasteId Nothing -> "/new" -- | Make a submit (captioned) button. submitI :: Text -> Text -> Markup submitI name caption = H.input ! A.type_ "submit" ! A.name (toValue name) ! A.value (toValue caption) -- | The paste submitting formlet itself. pasteSubmit :: PasteFormlet -> Formlet PasteSubmit pasteSubmit pf@PasteFormlet{..} = PasteSubmit <$> pure (getPasteId pf) <*> pure (case pfAnnotatePaste of Just pid -> AnnotationOf (pasteId pid) _ -> case pfEditPaste of Just pid -> RevisionOf (pasteId pid) _ -> NormalPaste) <*> req (textInput "title" "Title" (annotateTitle <|> editTitle)) <*> defaulting "Anonymous Coward" (textInput "author" "Author" Nothing) <*> parse (traverse lookupLang) (opt (dropInput languages "language" "Language" (snd defChan))) <*> parse (traverse lookupChan) (opt (dropInput channels "channel" "Channel" (fst defChan))) <*> req (areaInput "paste" "Paste" pfContent) <*> opt (wrap (H.div ! aClass "spam") (textInput "email" "Email" Nothing)) where defaulting def = fmap swap where swap "" = def swap x = x channels = options channelName channelName pfChannels languages = options languageName languageTitle pfLanguages lookupLang slug = findOption ((==slug).languageName) pfLanguages languageId lookupChan slug = findOption ((==slug).channelName) pfChannels channelId defChan = maybe (fromMaybe "" (annotateChan <|> editChan) ,fromMaybe "haskell" (annotateLanguage <|> editLanguage)) (channelName &&& trim.channelName) (pfDefChan >>= findChan) findChan name = find ((==name).trim.channelName) pfChannels trim = T.dropWhile (=='#') annotateTitle = ((++ " (annotation)") . pasteTitle) <$> pfAnnotatePaste annotateLanguage = join (fmap pasteLanguage pfAnnotatePaste) >>= findLangById annotateChan = join (fmap pasteChannel pfAnnotatePaste) >>= findChanById editTitle = Nothing editLanguage = join (fmap pasteLanguage pfEditPaste) >>= findLangById editChan = join (fmap pasteChannel pfEditPaste) >>= findChanById findChanById id = channelName <$> find ((==id).channelId) pfChannels findLangById id = languageName <$> find ((==id).languageId) pfLanguages -- | Get the paste id. getPasteId :: PasteFormlet -> Maybe PasteId getPasteId PasteFormlet{..} = M.lookup "id" pfParams >>= readMay . concat . map toString >>= return . PasteId -- | View the paste's annotations. viewAnnotations :: [Paste] -> [Channel] -> [Language] -> [(Paste,[Hint])] -> Markup viewAnnotations pastes chans langs annotations = do mapM_ (viewPaste [] pastes chans langs) annotations -- | View a paste's details and content. viewPaste :: [Paste] -> [Paste] -> [Channel] -> [Language] -> (Paste,[Hint]) -> Markup viewPaste revisions annotations chans langs (paste@Paste{..},hints) = do pasteDetails revisions annotations chans langs paste pasteContent revisions langs paste viewHints hints -- | List the details of the page in a dark section. pasteDetails :: [Paste] -> [Paste] -> [Channel] -> [Language] -> Paste -> Markup pasteDetails revisions annotations chans langs paste = darkNoTitleSection $ do pasteNav annotations paste h2 $ toMarkup $ fromStrict (pasteTitle paste) ul ! aClass "paste-specs" $ do detail "Paste" $ do pasteLink paste $ "#" ++ show (pasteId paste) " " linkToParent paste detail "Author(s)" $ do let authors | null revisions = map pasteAuthor [paste] | otherwise = map pasteAuthor revisions htmlCommasAnd $ flip map (nub authors) $ \author -> linkAuthor author detail "Language" $ showLanguage langs (pasteLanguage paste) detail "Channel" $ showChannel (Just paste) chans (pasteChannel paste) detail "Created" $ showDateTime (pasteDate paste) detail "Raw" $ pasteRawLink paste $ ("View raw link" :: Text) unless (length revisions < 2) $ detail "Revisions" $ do br ul !. "revisions" $ listRevisions paste revisions clear where detail title content = do li $ do strong (title ++ ":"); toMarkup content -- | Link to an author. linkAuthor :: Text -> Markup linkAuthor author = href ("/browse?author=" ++ author) $ toMarkup author -- | Link to annotation/revision parents. linkToParent :: Paste -> Markup linkToParent paste = do case pasteType paste of NormalPaste -> return () AnnotationOf pid -> do "(an annotation of "; pidLink pid; ")" RevisionOf pid -> do "(a revision of "; pidLink pid; ")" -- | List the revisions of a paste. listRevisions :: Paste -> [Paste] -> Markup listRevisions _ [] = return () listRevisions p [x] = revisionDetails p x listRevisions p (x:y:xs) = do revisionDetails y x listRevisions p (y:xs) -- | List the details of a revision. revisionDetails :: Paste -> Paste -> Markup revisionDetails paste revision = li $ do toMarkup $ showDateTime (pasteDate revision) " " revisionLink revision $ do "#"; toMarkup (show (pasteId revision)) unless (pasteId paste == pasteId revision) $ do " " href ("/diff/" ++ show (pasteId paste) ++ "/" ++ show (pasteId revision)) $ ("(diff)" :: Markup) ": " toMarkup (pasteTitle revision) " (" linkAuthor (pasteAuthor revision) ")" -- | Individual paste navigation. pasteNav :: [Paste] -> Paste -> Markup pasteNav pastes paste = H.div ! aClass "paste-nav" $ do diffLink href ("/edit/" ++ pack (show pid) ++ "") ("Edit" :: Text) " - " href ("/annotate/" ++ pack (show pid) ++ "") ("Annotate" :: Text) " - " href ("/report/" ++ pack (show pid) ++ "") ("Report/Delete" :: Text) where pid = pasteId paste pairs = zip (drop 1 pastes) pastes parent = fmap snd $ find ((==pid).pasteId.fst) $ pairs diffLink = do case listToMaybe pastes of Nothing -> return () Just Paste{pasteId=parentId} -> do href ("/diff/" ++ show parentId ++ "/" ++ show pid) ("Diff original" :: Text) case parent of Nothing -> return () Just Paste{pasteId=prevId} -> do when (pasteType paste /= AnnotationOf prevId) $ do " / " href ("/diff/" ++ show prevId ++ "/" ++ show pid) ("prev" :: Text) case listToMaybe pastes of Nothing -> return (); Just{} -> " - " -- | Show the paste content with highlighting. pasteContent :: [Paste] -> [Language] -> Paste -> Markup pasteContent revisions langs paste = case revisions of (rev:_) -> lightNoTitleSection $ highlightPaste langs rev _ -> lightNoTitleSection $ highlightPaste langs paste -- | The href link to a paste. pasteLink :: ToMarkup html => Paste -> html -> Markup pasteLink Paste{..} inner = href ("/" ++ show pasteId) inner -- | The href link to a paste pid. pidLink :: PasteId -> Markup pidLink pid = href ("/" ++ show pid) $ toMarkup $ "#" ++ show pid -- | The href link to a paste. revisionLink :: ToMarkup html => Paste -> html -> Markup revisionLink Paste{..} inner = href ("/revision/" ++ show pasteId) inner -- | The href link to a paste, raw content. pasteRawLink :: ToMarkup html => Paste -> html -> Markup pasteRawLink Paste{..} inner = href ("/raw/" ++ show pasteId) inner