{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Applicative ( (<$>), (<*>), (<|>) )
import Control.Arrow ( first )
import Control.Monad ( replicateM, guard, when )
import Control.Monad.IO.Class ( liftIO )
import Control.Monad.Random ( getRandomR )
import Data.Char ( toLower )
import Data.Foldable ( mapM_, forM_ )
import Data.Maybe ( fromJust, fromMaybe )
import Data.Time.Clock ( getCurrentTime, addUTCTime )
import Data.Time.Clock.POSIX ( getPOSIXTime
, posixSecondsToUTCTime )
import Data.Time.Format ( formatTime )
import Data.Function ( on )
import Data.List ( sortBy, groupBy )
import Network.URI ( URI(uriFragment)
, relativeTo
, parseURI
, parseRelativeReference
)
import Prelude hiding ( mapM_ )
import Snap.Iteratee ( enumBS )
import Snap.Types
import Snap.Util.FileServe ( fileServe )
import System.Environment ( getArgs )
import System.Exit ( exitFailure, exitSuccess )
import System.FilePath ( (</>) )
import System.Locale ( defaultTimeLocale )
import Text.XHtmlCombinators
import Text.XHtmlCombinators.Escape ( escape, escapeAttr )
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Text.JSON as JSON
import qualified Text.XHtmlCombinators.Attributes as A
import qualified Text.XML.Light.Output as XML
import qualified Text.Atom.Feed.Export as Atom
import qualified Report as Report
import Config ( parseArgs, unUsage, Usage, Action(..) )
import qualified Config.Command.Run as Run
import qualified Config.Command.Scan as Scan
import Analyze ( analyze )
import Privilege ( tryDropPrivilege )
import Server
import State.Types
import qualified State.Logger as L
import Paths_doc_review ( getDataFileName )
import Feed ( commentFeed )
showUsage :: Usage -> IO ()
showUsage = putStr . unUsage 78
main :: IO ()
main = do
args <- getArgs
case parseArgs args of
Left usg ->
do showUsage usg
exitFailure
Right (Help usg) ->
do showUsage usg
exitSuccess
Right (Report cfg) ->
putStr . Report.genReport cfg =<< Report.analyzeFiles cfg
Right (RunServer cfg) ->
do st <- maybe return L.wrap (Run.cfgLogTo cfg) =<< Run.cfgStore cfg
when (Run.cfgScanOnStart cfg) $ scanDir cfg st
runServer cfg st
Right (Scan cfg) ->
let cDir = Scan.contentDir cfg
showChapter (mChId, cIds) =
maybe "(unnamed)" (showString "Chapter: " . T.unpack . chapterId) mChId:
map (showString " " . showCommentId) cIds
showCommentId = (T.unpack . commentId)
showFile (fn, chs) = [ ""
, replicate 50 '='
, "Analysis of " ++ show fn
, replicate 50 '-'
, ""
] ++ concatMap showChapter chs
dupes =
filter ((> 1) . length) .
groupBy ((==) `on` getCId) .
sortBy (compare `on` getCId) .
recs
where
recs fs = do
(fn, chs) <- fs
(mChId, cIds) <- chs
cId <- cIds
[(fn, mChId, cId)]
getCId (_, _, cId) = cId
showDupes files = case map (map getCId) $ dupes files of
[] -> ["No duplicate comment ids"]
ds -> "Duplicate comment ids found:":
concatMap showDupeSet ds
where
showDupeSet = map (showString " " . show)
in case Scan.store cfg of
Just mk -> loadChapters cDir =<< mk
Nothing ->
do files <- analyze cDir
putStr $ unlines $ concatMap showFile files
putStr $ unlines $ []:showDupes files
-- |Scan the content directory for chapter HTML files and update the
-- database to include all of the chapter mappings
loadChapters :: FilePath -> State -> IO ()
loadChapters chapterDir st = do
chapters <- analyze chapterDir
storeChapters chapters st
storeChapters :: [(String, [(Maybe ChapterId, [CommentId])])]
-> State -> IO ()
storeChapters files st = do
forM_ files $ \(fn, chapters) -> do
let uri = parseRelativeReference fn
forM_ chapters $ \(mChId, cIds) ->
maybe (return ()) (\chId -> addChapter st chId cIds uri) mChId
runServer :: Run.Config -> State -> IO ()
runServer cfg st = do
static <- case Run.cfgStaticDir cfg of
Nothing -> getDataFileName "static"
Just s -> return s
let hostBS = E.encodeUtf8 $ T.pack $ Run.cfgHostName cfg
sCfg = emptyServerConfig
{ hostname = hostBS
, accessLog = Just $ Run.cfgLogDir cfg </> "access.log"
, errorLog = Just $ Run.cfgLogDir cfg </> "error.log"
, port = Run.cfgPort cfg
}
dropPriv <- maybe (return (return ())) tryDropPrivilege $ Run.cfgRunAs cfg
let dropPrivAct = liftIO dropPriv >> pass
server sCfg $ dropPrivAct <|> trackSession (app static cfg st)
scanDir :: Run.Config -> State -> IO ()
scanDir = loadChapters . Run.cfgContentDir
app :: FilePath -> Run.Config -> State -> SessionId -> Snap ()
app static cfg st sessionId =
dir "comments"
(route [ ("single/:id", getCommentHandler st sessionId)
, ("chapter/:chapid/count/", getCountsHandler st)
, ("chapter/:chapid/feed", getChapterFeedHandler sessionId st)
, ("submit/:id", submitHandler st sessionId)
]) <|>
fileServe (Run.cfgContentDir cfg) <|>
fileServe static <|>
maybe pass (ifTop . relativeRedirect) (Run.cfgDefaultPage cfg)
-- |Redirect to the supplied URI (relative to the current request's
-- URI)
relativeRedirect :: URI -> Snap ()
relativeRedirect d = do
u <- baseURL
-- relativeTo's implementation always returns Just
redirect $ B.pack $ show $ fromJust $ d `relativeTo` u
-- |The base URL for this request (taking into account the protocol,
-- the host, and the port)
baseURL :: Snap URI
baseURL =
withRequest $ \req -> do
let host = B.unpack $ rqServerName req
rport = rqServerPort req
defaultPort | rqIsSecure req = 443
| otherwise = 80
proto | rqIsSecure req = "https"
| otherwise = "http"
authStr | rport == defaultPort || rport == 0 = host
| otherwise = host ++ ':':show rport
case parseURI $ proto ++ "://" ++ authStr of
Nothing -> finishWith $ badRequest $
T.concat ["Bad host header: ", T.pack host]
Just u -> return u
newSessionId :: IO SessionId
newSessionId = SessionId . B.pack <$> replicateM 24 selectRandomSessionChar
where
selectRandomSessionChar =
B.index sessionChars <$> getRandomR (0, B.length sessionChars - 1)
sessionChars :: B.ByteString
sessionChars = B.pack $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "."
trackSession :: (SessionId -> Snap a) -> Snap a
trackSession act = do
let sessionCookieName = "doc-review-session"
cookies <- rqCookies <$> getRequest
sessionId <-
case [c | c <- cookies, cookieName c == sessionCookieName ] of
[] -> liftIO newSessionId
(c:_) -> return $ SessionId $ cookieValue c
res <- act sessionId
-- Expires in 1000000 seconds
expiry <- addUTCTime 1000000 <$> liftIO getCurrentTime
let newCookie =
Cookie { cookieName = sessionCookieName
, cookieValue = let SessionId sid = sessionId
in sid
, cookieExpires = Just expiry
, cookieDomain = Nothing
, cookiePath = Just "/"
}
modifyResponse $ addCookie newCookie
return res
--------------------------------------------------
-- Handlers
getChapterFeedHandler :: SessionId -> State -> Snap ()
getChapterFeedHandler sId st = do
Just chapId <- mkChapterId <$> requireParam "chapid"
makeAbsolute <- flip relativeTo <$> baseURL
chapURL <- liftIO $ getChapterURI st chapId
case chapURL >>= makeAbsolute of
Nothing -> do
modifyResponse $ setResponseStatus 404 "Not Found"
. addHeader "content-type" "text/plain"
mapM_ writeBS [ "Chapter not found: "
, E.encodeUtf8 $ chapterId chapId
]
finishWith =<< getResponse
Just u -> do
limit <- fromMaybe 10 <$> getLimitParam "limit"
cs <- liftIO $ take limit <$> getChapterComments st chapId
fmt <- fromMaybe AtomFeed <$> getFormatParam "format"
case fmt of
AtomFeed ->
do modifyResponse $ addHeader "content-type" "application/atom+xml"
writeText $ T.pack $ XML.showTopElement $
Atom.xmlFeed $ commentFeed chapId cs u
WebPage ->
do modifyResponse $ addHeader "content-type" "text/html"
writeText $ render $ chronoView sId chapId cs u
getParamM :: (B.ByteString -> Maybe a) -> B.ByteString -> Snap (Maybe a)
getParamM f name = (f =<<) <$> getParam name
getLimitParam :: B.ByteString -- ^Parameter name
-> Snap (Maybe Int)
getLimitParam = getParamM $ \lim ->
case reads $ B.unpack lim of
[(n, [])] -> Just n
_ -> Nothing -- log something here
-- because of the bad parse?
data Format = AtomFeed | WebPage
getFormatParam :: B.ByteString -> Snap (Maybe Format)
getFormatParam = getParamM $ (`lookup` fs) . B.map toLower
where fs = [ ("atom", AtomFeed), ("html", WebPage) ]
getCountsHandler :: State -> Snap ()
getCountsHandler st = do
chapId <- mkChapterId <$> requireParam "chapid"
counts <- liftIO $ getCounts st chapId
modifyResponse $ addHeader "content-type" "text/json"
writeText $ T.pack $ JSON.encode $ countsJSON counts
countsJSON :: [(CommentId, Int)] -> JSON.JSValue
countsJSON = JSON.showJSON . JSON.toJSObject .
map (first (T.unpack . commentId))
getCommentHandler :: State -> SessionId -> Snap ()
getCommentHandler st sessionId = do
mcid <- mkCommentId <$> requireParam "id"
case mcid of
Nothing -> finishWith $ badRequest "Bad comment id"
Just cid -> respondComments cid st sessionId
submitHandler :: State -> SessionId -> Snap ()
submitHandler st sessionId = do
mcid <- mkCommentId <$> requireParam "id"
case mcid of
Nothing -> finishWith $ badRequest "Bad comment id"
Just cid ->
do comment <- Comment <$> requireParam "name"
<*> requireParam "comment"
<*> getParamUtf8 "email"
<*> liftIO getPOSIXTime
<*> return sessionId
chap <- (mkChapterId =<<) <$> getParamUtf8 "chapid"
liftIO $ addComment st cid chap comment
respondComments cid st sessionId
--------------------------------------------------
-- Snap helpers
respondComments :: CommentId -> State -> SessionId -> Snap ()
respondComments cid st sessionId = do
cs <- liftIO $ findComments st cid
si <- liftIO $ getLastInfo st sessionId
modifyResponse $ addHeader "content-type" "text/html"
writeText $ render $ (getMarkup cid cs si sessionId :: XHtml FlowContent)
badRequest :: T.Text -> Response
badRequest msg = setResponseBody (enumBS $ E.encodeUtf8 msg) $
setResponseStatus 400 "Bad request" $
emptyResponse
requireParam :: T.Text -> Snap T.Text
requireParam argName =
getParamUtf8 argName >>=
maybe (finishWith $ badRequest missing) return
where
missing = T.concat ["Missing parameter ", argName]
getParamUtf8 :: T.Text -> Snap (Maybe T.Text)
getParamUtf8 argName = fmap E.decodeUtf8 <$> getParam (E.encodeUtf8 argName)
--------------------------------------------------
-- Rendering comments
chronoView :: SessionId -> ChapterId -> [(CommentId, Comment)] -> URI -> XHtml Page
chronoView sId chId cs u =
html True $ do
head_ $ do
title $ pageTitle
link' [ A.type_ "text/css"
, A.href $ escape "/styles.css"
, A.rel "stylesheet" ]
body $ div' [ A.id_ "content" ] $
do div' [ A.class_ "navheader" ] $ h1 $ text pageTitle
div' [ A.class_ "chapter" ] $ do
p $ do
text $ escape $ T.concat
[ "This is a chronological listing of comments on "
, chapterId chId
, ". Click on each comment's link to view the "
, "comment in context. You can also view them "
, "inline using the links "
]
a' [ A.href $ escapeAttr $ T.pack $ show u ] $ text $
escape $ "within the document itself"
text $ escape "."
forM_ cs $ \(cId, c) ->
commentMarkup sId cId (Just u) c
where
pageTitle = escape $ T.concat [ "Chronological view of comments on "
, chapterId chId
]
getMarkup :: Block a => CommentId -> [Comment] -> Maybe SessionInfo
-> SessionId -> XHtml a
getMarkup cId cs si sid = do
div' [ A.id_ $ T.concat ["toggle_", commentId cId], A.class_ "toggle" ] $
a' [ A.class_ "commenttoggle"
, A.attr "onclick" $
T.concat ["return toggleComment('", commentId cId, "')"]
, A.href "show/hide comments"
] $ text $ case length cs of
0 -> "No comments"
1 -> "1 comment"
n -> T.concat [T.pack (show n), " comments"]
case cs of
[] -> do
div' [A.class_ "comment"] $
text "Be the first to comment on this paragraph!"
return ()
_ -> mapM_ (commentMarkup sid cId Nothing) cs
newCommentForm cId si
div_ $ span' [ A.class_ "comment_error" ] $ empty
newCommentForm :: Block a => CommentId -> Maybe SessionInfo -> XHtml a
newCommentForm cId msi =
form' (addId "/comments/submit/") [ idAttr "form_"
, A.class_ "comment"
, A.method "post"
] $
table $ tbody $ do
tr $ do
th $ label' [forAttr "comment_"] $ text "Comment:"
td $ textarea' 10 40 [A.name "comment", idAttr "comment_"] ""
tr $ do
th $ label' [forAttr "name_"] $ text "Name:"
td $ input' [ A.name "name"
, A.type_ "text"
, idAttr "name_"
, nameValue
]
tr $ do
th $ label' [forAttr "email_"] $ text "E-Mail Address: "
td $ do
input' [ A.name "email"
, A.type_ "text"
, idAttr "email_"
, emailValue
]
text " (optional, will not be displayed)"
tr $ do
td empty
td $ input' [A.name "submit", A.type_ "submit"]
where
nameValue = A.value $ maybe "" (escapeAttr . siName) msi
emailValue = A.value $ maybe "" escapeAttr $ siEmail =<< msi
forAttr t = A.for (addId t)
idAttr t = A.id_ (addId t)
addId t = T.concat [t, commentId cId]
commentMarkup :: Block a => SessionId -> CommentId -> Maybe URI -> Comment
-> XHtml a
commentMarkup sid cId mURI c =
div' [A.class_ topCls] $ do
div' [A.class_ "username"] $ maybeLink $
do text $ escape $ name
text " "
span' [A.class_ "date"] $ text $ escape $ fmtTime $ cDate c
div' [A.class_ "comment-text"] $ text $ escape $ cComment c
where
maybeLink = maybe span_ (toAnchor . addFrag) mURI
toAnchor u = a' [ A.href $ escapeAttr $ T.pack $ show u ]
addFrag u = u { uriFragment = '#':T.unpack (commentId cId) }
isMine = sid == cSession c
name | isMine = T.concat [ cName c, " (you)" ]
| otherwise = cName c
topCls = T.unwords $ ["comment"] ++ (guard isMine >> return "mine")
fmtTime = T.pack .
formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" .
posixSecondsToUTCTime