----------------------------------------------------------------------------- -- | -- Module : HtmlPages -- Copyright : (c) Eric Mertens 2007 -- License : BSD3-style (see LICENSE) -- -- Maintainer : emertens@gmail.com -- Stability : unstable -- Portability : portable, Haskell 98. -- ----------------------------------------------------------------------------- -- -- The HPaste page templates. -- module HtmlPages(newPastePage, annotatePastePage, listEntriesPage, displayPastePage, diffPage, adminIndexPage, adminDeletePage) where import Data.Char import Data.Int import qualified Data.ByteString.Char8 as B import Data.List import Language.Haskell.HsColour.CSS import Text.XHtml.Strict import Text.Printf import PasteState import DiffHtml (htmlDiff) srcurl :: String srcurl = "http://www.scannedinavian.com/~eric/hpaste/" ircurl :: String ircurl = "http://haskell.org/haskellwiki/IRC_channel" happsurl :: String happsurl = "http://happs.org" stylesheet :: String stylesheet = "/static/hpaste.css" ------------------------------------------------------------------------ -- -- Markup -- -- | Create a standard header mkheader :: String -> Html mkheader titl = header << (thetitle << (titl ++ " - hpaste") +++ thelink ! [rel "stylesheet", thetype "text/css", href stylesheet] << noHtml +++ script ! [thetype "text/javascript", src "/static/hi.js"] << noHtml +++ meta ! [httpequiv "Content-Type" ,content "text/html;charset=utf-8"]) newPastePage :: String -> Html newPastePage nick = naPastePage "/new" nick "" annotatePastePage :: Int -> String -> String -> Html annotatePastePage entryId nick startingText = naPastePage ("/annotate/" ++ show entryId) nick startingText ------------------------------------------------------------------------ -- -- new paste page -- naPastePage :: String -> String -> String -> Html naPastePage target nick startingText = mkheader "new" +++ body << thediv ! [theclass "wrapper"] << (hpasteH1Header +++ thediv ! [theclass "topnav"] << hotlink "/" << "recent" +++ p ! [theclass "notice"] << "Notice: hpaste is for small pastes and truncates after 5K" +++ gui target << (-- Text field: label ! [thefor "content"] << textarea ! [rows "24", cols "80" ,identifier "content", name "content"] << startingText +++ thediv << ( -- the nick form label ! [thefor "nick"] << ("author:" +++ input ! [name "nick", identifier "nick" ,thetype "text", value nick] ) +++ -- whether to remember this label ! [thefor "remember"] << ("remember me:" +++ input ! (if null nick then id else (checked :)) [thetype "checkbox", name "remember" ,value "remember", identifier "remember" ,theclass "checkbox"] ) +++ -- paste title label ! [thefor "title"] << ("title:" +++ textfield "title" ) +++ -- whether to inform people on irc label ! [thefor "announce"] << ("announce:" +++ input ! [thetype "checkbox", name "announce" ,value "true", identifier "announce" ,theclass "checkbox", checked] ) +++ input ! [thetype "image", alt "save" ,theclass "submit" ,src "/static/save.jpg"] ) )+++ p ! [theclass "footer"] << disclaimer ) -- -- All paste/statistics page -- listEntriesPage :: [(Int, [Entry])] -> Int64 -> Int -> Bool -> Html listEntriesPage xs t' offset moreEntries = mkheader "recent" +++ body << thediv ! [theclass "wrapper"] << (listEntriesHeader +++ table ! [theclass "pastes"] << (listEntriesTableHeader +++ concatHtml [tr ! [strAttr "onclick" (printf "location.href='/%d'" entryId) ,theclass "pastes"] << ( td << hotlink ("/" ++ show entryId) << "view" +++ td << entryNick x +++ td << formatShortTime t' (entryTime x) +++ td << entryTitle x +++ td << show (length xs')) | (entryId,(x:xs')) <- xs] ) +++ thediv ! [theclass "pager"] << ((if offset > 0 then toHtml $ hotlink (printf "/?offset=%d" (offset-1)) << "newer" else toHtml "newer") +++ " " +++ (if moreEntries then toHtml $ hotlink (printf "?offset=%d" (offset+1)) << "older" else toHtml "older") ) +++ p ! [theclass "footer"] << disclaimer ) hpasteH1Header :: Html hpasteH1Header = h1 << hotlink "/" << (spaceHtml +++ thespan << "hpaste") -- these two headers are constant and are used on every view -- of the main list view page listEntriesHeader :: Html listEntriesHeader = hpasteH1Header +++ thediv ! [theclass "topnav"] << (hotlink "/" << "recent" +++ " | " +++ hotlink "/new" << "new") listEntriesTableHeader :: Html listEntriesTableHeader = tr << (th << "link" +++ th << "author" +++ th << "age" +++ th << "title" +++ th << "revisions") -- disclaimer text disclaimer :: Html disclaimer = "Powered by " +++ hotlink happsurl << "HAppS" +++ ". " +++ "Copyright (c) 2007 glguy @ " +++ hotlink ircurl << "#haskell" +++ ". " +++ "Source via " +++ hotlink srcurl << "darcs" +++ "." -- -- The 'view' page -- note this uncompresses and unpacks the page -- displayPastePage :: Int -> [Entry] -> Int64 -> Bool -> Html displayPastePage _ [] _ _ = mkheader "paste deleted" +++ body << thediv ! [theclass "wrapper"] << (hpasteH1Header +++ p << "This paste has been deleted") displayPastePage entryId xs t' number = mkheader (entryTitle (head xs)) +++ body << thediv ! [theclass "wrapper"] << (hpasteH1Header +++ thediv ! [theclass "topnav"] << (hotlink "/" << "recent" +++ " | " +++ hotlink ("/annotate/" ++ show entryId) << "annotate" +++ " | " +++ hotlink "/new" << "new" ) +++ [ hr +++ thediv ! [theclass "pasteEntry", identifier ('a' : show n)] << (unordList [thespan ! [theclass "nickLabel"] << entryNick x ,thespan ! [theclass "entryLabel"] << entryTitle x ,thespan ! [theclass "entryTime"] << formatTime t' (entryTime x) ] ! [theclass "pasteHeader"] +++ unordList [toHtml $ hotlink (printf "/%d/%d/plain" entryId n) << "raw" ,toHtml (hotlink ("#a" ++ show n) << "link") ,toHtml $ hotlink (printf "/annotate/%d?oldId=%d" entryId n) << "annotate" ] ! [theclass "pasteLinks"] ) +++ ( let s = entryContent x in formatContent (B.unpack s)) | (n,x) <- zip [(0::Int)..] xs] +++ thediv ! [theclass "pasteforms"] << ( form ! [action ("/" ++ show entryId), method "get"] << fieldset ! [theclass "left"] << (label ! [thefor "lines"] << ("number lines:" +++ input ! [thetype "checkbox", name "lines" ,value "true", identifier "lines" ,theclass "checkbox"] ! [flag | (True,flag) <- [(number,checked)]] ) +++ button ! [thetype "submit"] << "format" ) +++ diffForm +++ thediv ! [theclass "clear"] << spaceHtml) ) where diffForm | null (tail xs) = noHtml | otherwise = form ! [action (printf "/%d/diff" entryId) ,method "get"] << fieldset ! [theclass "right"] << (label ! [thefor "old"] << ("old: " +++ entrySelectbox "old") +++ label ! [thefor "new"] << ("new: " +++ entrySelectbox "new") +++ button ! [thetype "submit"] << "diff" ) entrySelectbox n = select ! [name n, identifier n] << [option ! [value (show n')] << longName n' e' | (n',e') <- zip [0..] xs] where longName :: Int -> Entry -> String longName line entry = printf "%d: %s" line (entryTitle entry) addLineNums = primHtml . ("
"++) . unlines
        . zipWith (printf "%4d  %s") [(1::Int)..]
        . lines . drop 5

      formatContent x
        | number    = addLineNums colored
        | otherwise = primHtml colored
        where colored = hscolour False True x

--
-- The diff page
--
diffPage :: Int -> Entry -> Entry -> Html
diffPage entryId xs ys =
    mkheader "diff" +++
    body << thediv ! [theclass "wrapper"]
    << (hpasteH1Header +++
        thediv ! [theclass "topnav"]
        << (hotlink "/" << "recent" +++ " | " +++
            hotlink "/new" << "new" +++ " | " +++
            hotlink ("/" ++ show entryId) << "normal"
           ) +++
        hr +++
        thediv ! [theclass "pasteEntry"]
        << (unordList [toHtml $ thespan ! [theclass "fromLabel"] << "Old:"
                      ,toHtml $ ' ' : entryTitle xs
                      ,toHtml $ thespan ! [theclass "toLabel"] << "New:"
                      ,toHtml $ ' ' : entryTitle ys
                      ] ! [theclass "pasteHeader"] +++
            unordList [hotlink "#" << "link"] ! [theclass "pasteLinks"]
           ) +++
        pre
        << htmlDiff (entryToScrubbed xs) (entryToScrubbed ys)
       )
  where
    entryToScrubbed x =
        let s = entryContent x
        in B.pack . scrub . hscolour False True . B.unpack $ s
    scrub = lastN 6 . drop 5
    lastN n as = zipWith const as (drop n as)

------------------------------------------------------------------------

formatShortTime :: Int64 -> Int64 -> String
formatShortTime to from
  | delta < 60    = shows delta "s"
  | delta < 3600  = shows (div delta 60) "m"
  | delta < 86400 = shows (div delta 3600) "h"
  | otherwise     = shows (div delta 86400) "d"
  where delta = to - from

formatTime :: Int64 -> Int64 -> String
formatTime to from
  | delta < 60    = shows delta " seconds ago"
  | delta < 120   = "1 minute ago"
  | delta < 3600  = shows (div delta 60) " minutes ago"
  | delta < 7200  = "1 hour ago"
  | delta < 86400 = shows (div delta 3600) " hours ago"
  | delta < 172800 = "1 day ago"
  | otherwise = shows (div delta 86400) " days ago"
  where delta = to - from

-----------------------------------------------------------------------

adminIndexPage :: Html
adminIndexPage =
  header << thetitle << "Admin Functions" +++
  body
  << (h1 << "Admin Functions" +++
      unordList [hotlink "/admin/delete" << "Delete an entry by ID"]
      )

---------------------------------------------------------------------

adminDeletePage :: String -> Html
adminDeletePage status = 
  header << thetitle << "Deletion Form" +++
  body
  << (h1 << "Admin Section - Delete" +++
      p << hotlink "/admin/" << "Back to Admin Functions" +++
      p << status +++
      gui "/admin/delete"
      << (label ! [thefor "pasteId"]
          << ("Entry Id: " +++
              textfield "pasteId"
             ) +++
          submit "Delete" "Delete"
        )
     )