-- Calendar plugin for Gitit. -- Portions of code are borrowed from -- http://moonpatio.com/repos/LIBS/Language/lhc/tests/9_nofib/spectral/calendar/Calendar.hs -- The plugin converts a code block like this: -- -- ~~~{.cal file="path"} -- whatever -- ~~~ -- -- into a current month calendar appearing on the page. The `file' attribute is mandatory, -- and should point to an existing file (may be part of the Wiki). -- String template attributes may be used: -- * $U$ for the name of the logged in user -- * $P$ for the "path" name of the current page's URI -- * $W$ for the repository base (if calendar file is a Wiki page or uploaded file) -- * $S$ for the static directory (if calendar file is a static file outside the Wiki hierarchy). -- * $M$ for the number of the month shown (1 - 12) -- * $Y$ for the number of the year shown module Cal (plugin) where import Data.Time import Data.Maybe import Data.Either import Text.XHtml import qualified Data.Map as M import Data.Tuple.All import Data.ByteString.Lazy.UTF8 (toString) import System.Process import System.Exit import Network.Gitit.Interface import Text.StringTemplate hiding (toString) import BrownPLT.JavaScript.Syntax import BrownPLT.JavaScript.PrettyPrint import Happstack.Server.HTTP.Types -- Information about the months in a year: monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31] where feb | leap year = 29 | otherwise = 28 leap year = if year`mod`100 == 0 then year`mod`400 == 0 else year`mod`4 == 0 monthNames = ["January","February","March","April", "May","June","July","August", "September","October","November","December"] dayNames = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"] jan1st year = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7 where last = year - 1 firstDays year = take 12 (map (`mod`7) (scanl (+) (jan1st year) (monthLengths year))) -- Producing the information necessary for one month: dates fd ml = map (date ml) [1-fd..42-fd] where date ml d | d<1 || ml [(Int, String, CalDay)] monList (year, month, today) = zip3 wkns wkds days where dts = dates fdm ndm fdm = (firstDays year) !! (month - 1) ndm = (monthLengths year) !! (month - 1) days = map (day . fromIntegral) dts day 0 = Noday day n | n == today = Today n day n = Anyday n wkds = cycle dayNames wkns = concatMap (replicate 7) [1 .. ] -- Get local day from the current time getLocalDay :: IO (Integer, Int, Int) getLocalDay = do tz <- getCurrentTimeZone ut <- getCurrentTime let lt = utcToLocalTime tz ut return $ toGregorian $ localDay lt -- Plugin itself plugin :: Plugin plugin = mkPageTransformM transformBlock transformBlock :: Block -> PluginM Block transformBlock (CodeBlock (_, classes, namevals) contents) | "cal" `elem` classes && isJust (lookup "file" namevals) = do req <- askRequest let inps = rqInputs req yrmo = zip (map fst inps) (map (toString . inputValue . snd) inps) ld'@(yr', mn', dy') <- liftIO $ getLocalDay let mbyr = mbNumber "yr" yrmo mbmn = mbNumber "mo" yrmo yr = fromMaybe yr' mbyr mn = fromMaybe mn' mbmn dy = if yr == yr' && mn == mn' then dy' else -1 ld = (yr, mn, dy) mbu <- askUser let u = case mbu of Nothing -> "not_logged_in" Just u' -> uUsername u' cfg <- askConfig let monname = monthNames !! (mn - 1) calpath = fromJust $ lookup "file" namevals calfile = render . setAttribute "S" (staticDir cfg) . setAttribute "W" (repositoryPath cfg) . setAttribute "P" (rqUri req) . setAttribute "Y" (show yr) . setAttribute "M" (show mn) . setAttribute "U" u $ ((newSTMP calpath) :: (StringTemplate String)) let past = "--past=-1" future = "--future=40" now = "--now=" ++ show yr ++ " " ++ take 3 monname ++ " 1" prog = "when" cal <- liftIO $ do (ec, out, err) <- readProcessWithExitCode prog [ past ,future ,now ,"--nopaging" ,"--nostyled_output" ,"--calendar=" ++ calfile] "" case ec of ExitSuccess -> return $ Right out _ -> return $ Left err doNotCache let mlst = monList ld (ny, nm) = ymNext (yr, mn) (py, pm) = ymPrev (yr, mn) tcap = Strong [ Link [Str "<<"] (rqUri req ++ "?mo=" ++ show pm ++ "&yr=" ++ show py, "Previous Month") ,Space ,Str $ monname ++ " " ++ show yr ,Space ,Link [Str ">>"] (rqUri req ++ "?mo=" ++ show nm ++ "&yr=" ++ show ny, "Next Month")] algn = replicate 7 AlignLeft rlwd = replicate 7 (1 / 7) hdrs = map (\d -> [Header 1 [Str d], mkhtml $ thediv ! [identifier d] << noHtml]) dayNames mnn = take 3 $ monthNames !! (mn - 1) mkhtml = RawHtml . showHtmlFragment cell (_, _, Noday) = [Plain [Str ""]] cell (wkn, wkd, (Today n)) = [mkhtml $ thediv ! [mkon "mouseover" yr mnn n ,mkon "mouseout" 0 0 0 ,mkid yr mnn n ,cellsty True] << primHtml (show n)] cell (wkn, wkd, (Anyday n)) = [mkhtml $ thediv ! [mkon "mouseover" yr mnn n ,mkon "mouseout" 0 0 0 ,mkid yr mnn n ,cellsty False] << primHtml (show n)] week wkn = filter ((== wkn) . sel1) mlst row wkn | all ((== Noday) . sel3) (week wkn) = [] row wkn = map cell $ week wkn rows = filter (not . null) $ map row [1 .. 6] tblc = Table [tcap] algn rlwd hdrs rows cellsty f = thestyle $ "font-size: 24pt; text-align: center; padding: 3px; width: 3em;" ++ if f then " font-weight: bold; border: 1px solid red;" else "" jp = JP { jsUser = u ,jsPath = rqUri req ,jsYear = show yr ,jsMonth = show mn} calres = case cal of Left e -> [mkhtml $ script ! [thetype "text/javascript"] << primHtml (mkjs jp "") ,Plain [Str $ "[" ++ calfile ++ "] Error: " ++ e]] Right r -> [mkhtml $ script ! [thetype "text/javascript"] << primHtml (mkjs jp r)] mkon e yr mnn n = strAttr ("on" ++ e) $ "javascript:calpic(" ++ show u ++ ", " ++ show yr ++ ", " ++ show mnn ++ ", " ++ show n ++ ");" mkid yr mnn n = identifier $ show yr ++ mnn ++ show n topdiv = mkhtml $ thediv ! [identifier "topdiv", thestyle "width:100%"] << noHtml botdiv = mkhtml $ thediv ! [identifier "botdiv", thestyle "width:100%"] << noHtml return $ BlockQuote $ [topdiv, tblc, botdiv] ++ calres transformBlock x = return x -- Calculate next and previous month-year pair. ymNext :: (Integer, Int) -> (Integer, Int) ymNext (y, 12) = (y + 1, 1) ymNext (y, m) = (y, m + 1) ymPrev :: (Integer, Int) -> (Integer, Int) ymPrev (y, 1) = (y - 1, 12) ymPrev (y, m) = (y, m - 1) -- Lookup a numeric value in a String-String pair list. Returns Nothing if -- either lookup fails, or numeric conversion is not possible. mbNumber :: (Read a, Integral a) => String -> [(String, String)] -> Maybe a mbNumber k t = do v <- lookup k t let r = readsPrec 0 v case r of [] -> Nothing (m:ms) -> Just (fst m) -- Parameter block for the Javascript generator. data JSPARM = JP { jsUser :: String ,jsPath :: String ,jsYear :: String ,jsMonth :: String} -- Transform the response from `when' into a Javascript object with dates being -- property names. The input string is a multi-string (separated with newlines) -- formatted as follows: -- -- Sun 2009 Aug 9 * Sunday!!! -- -- that is, the first token should be removed, next three tokens put together and -- form a Javascript object property name, the rest of the line should be stored in an -- object. If the fifth token starts with an asterisk, this is a message, otherwise -- it is expected to be a picture file path (the same template rules as with calendar file -- path apply). mkjs :: JSPARM -- Javascript parameters -> String -- output from the calendar script -> String -- Javascript generated mkjs jp = z where z = show . stmt . mkobjv . mkmap . drop 1 . concatMap (mkpair . drop 1 . words) . lines mkpair ss | length ss < 4 = [] mkpair (y:m:d:rs) = [(y ++ m ++ d, appst $ unwords rs)] appst s = render . setAttribute "S" "_static" . setAttribute "W" "" . setAttribute "Y" (jsYear jp) . setAttribute "M" (jsMonth jp) . setAttribute "P" (jsPath jp) . setAttribute "U" (jsUser jp) $ ((newSTMP s) :: (StringTemplate String)) mkmap = foldl insmap M.empty insmap m (k, v) = M.insertWith (++) k [v] m mkobjv m = VarDeclStmt () [VarDecl () (Id () "calendar") $ Just $ ObjectLit () $ map mkpl $ M.toList m] mkpl (k, v) = (PropString () k, ArrayLit () $ map (StringLit ()) v)