rezoom-0.0.2: Rezoom/Builder.hs

module Rezoom.Builder (
    build
    ) where
    import Text.XHtml.Strict
    import Text.JSON
    import Rezoom.JSON
    import Data.Digest.OpenSSL.MD5 (md5sum)
    import qualified Data.Map as M
    import qualified Data.ByteString.Char8 as B
    import Data.Maybe
    import Data.Char (toLower)
    import Data.Ord (comparing)
    import Data.List
    import Data.DateTime
    import Paths_rezoom
    import System.IO

    eStr = extractString
    
    type Opts = M.Map String String
    
    instance Eq Html where
        x == y = showHtml x == showHtml y
    
    build :: Opts -> Either String JSValue -> IO String
    build opts val = fmap (renderHtml) $ build_ opts val
    
    build_ :: Opts -> Either String JSValue -> IO Html
    build_ _ (Left err) = buildErr err
    build_ opts (Right v) = case v $$ "repositories" of 
        Nothing -> error "Unknown username."
        Just repos -> do
            filename <- getDataFileName "Rezoom/rezoom.css"
            fileContents <- readFile filename
            return $ buildHeader fileContents +++ body <<
                        thediv ! [identifier "container"] <<
                            thediv ! [identifier "container-inner"] <<
                                (header_ opts +++
                                 (subsection "Skills" ["langs"] $ skillList knownRepos) +++
                                 sectionize knownRepos)
            where
                knownRepos = sortBy (comparing ($$! "language")) $ 
                                filter (hasKey "language") $
                                    extractList repos
            
    sectionize :: [JSValue] -> [Html]
    sectionize = map (\e -> (<<) (thediv ! (secAttrs $ langname e))
            [sectionHeader $ langname e,
            thediv ! [theclass "subsection"] << ulist << projectList e]
        ) . groupBy (\x y -> x $$! "language" == y $$! "language")
        where
            langname e = eStr $ (head e) $$! "language"
            secAttrs str = let lower = map toLower str in
                [theclass $ "section lang-" ++ lower ++ " lang",
        	     identifier $ lower]
    
    sectionHeader :: String -> Html
    sectionHeader js = h3 ! [theclass "side"] << js

    projectList :: [JSValue] -> [Html]
    projectList vals = map (\e -> li ! [theclass "project"] <<
        (projectHeader e +++
         (thediv ! [theclass "description"] << 
             (eStr $ e $$! "description")))
        ) $ reverse $ sortBy (comparing ($$! "pushed_at")) vals
                    
    header_ :: Opts -> Html
    header_ opts = thediv ! [identifier "header"] <<
                    [gravatar opts,
                     headerName opts,
                     h4 << ulist << linkList opts]
                 
    projectHeader :: JSValue -> Html
    projectHeader js = h3 <<
        (anchor ! [href $ eStr $ js $$! "url"] << (eStr $ js $$! "name") +++
         " " +++
         thespan ! [theclass "pushed"] << ("↑ " ++ ctsr))
         where
             create_time = fromJust $ parseDateTime "%Y/%m/%d %T %Z" $ eStr $ js $$! "pushed_at"
             ctsr = formatDateTime "%b %d, %Y" create_time
    
    gravatar :: Opts -> Html
    gravatar opts = case M.lookup "email" opts of
        Just email -> thediv ! [identifier "avatar"] <<
                        image ! [src $ "http://www.gravatar.com/avatar/" ++ hash ++ "?size=96"]
                      where
                          hash = md5sum $ B.pack $ map toLower email
        Nothing -> thediv << ""
        
    headerName :: Opts -> Html
    headerName opts = h2 << (case M.lookup "realname" opts of
        Just name -> name +++ bold << "/" +++ unamelink
        Nothing -> unamelink)
            where
                username = fromJust $ M.lookup "username" opts
                unamelink = anchor ! [href $ "http://github.com/" ++ username] << username
                
    subsection :: String -> [String] -> Html -> Html
    subsection secname classes cont = thediv ! [theclass $ intercalate " " ("section":classes)] <<
        [h3 ! [theclass "side"] << secname,
         thediv ! [theclass "subsection"] << cont]
        
    linkList :: Opts -> [Html]
    linkList opts = map (\r -> li << anchor ! [href $ fromJust $ M.lookup r opts] << r
        ) $ filter (not . isNothing . flip M.lookup opts) ["email", "facebook", "twitter"]
    
    skillList :: [JSValue] -> Html
    skillList list = (<<) ulist $ nub $ map
        (\e -> let val = eStr $ e $$! "language" in 
            li << anchor ! [href $ map (toLower) ('#':val)] << val) list
    
    format_ :: String -> [String] -> String
    format_ [] args = []
    format_ str [] = str
    format_ (x:xs) args = case x of
        '%' -> head args ++ format_ xs (tail args)
        y -> y:format_ xs args
    
    buildErr :: String -> IO Html
    buildErr str = return $ (<<) body $ "Error: " ++ str
    
    buildHeader :: String -> Html
    buildHeader str = header << style ! [thetype "text/css"] << str