diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Db.hs | 129 | ||||
| -rw-r--r-- | src/Main.hs | 23 | ||||
| -rw-r--r-- | src/Render.hs | 197 | ||||
| -rw-r--r-- | src/Util.hs | 7 |
4 files changed, 356 insertions, 0 deletions
diff --git a/src/Db.hs b/src/Db.hs new file mode 100644 index 0000000..8f6fdba --- /dev/null +++ b/src/Db.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} +module Db where + +import System.FilePath ((<.>), splitExtension) +import Data.List (nub, sort, sortBy, isPrefixOf) +import Control.Monad +import Data.Yaml +import Text.Parsec.Error +import Text.ParserCombinators.Parsec.Prim +import Text.BibTeX.Parse +import Text.BibTeX.Entry as E +import qualified Data.Aeson as A +import qualified Data.Map as M + +import Util + +-- |A MAC protocol/algorithm +data Protocol = Protocol { + -- |Short protocol name, usually its abbreviation + pname :: String + -- |Long protocol name + , plongname :: Maybe String + -- |Free-text protocol description + , pdescription :: Maybe String + -- |List of publication references describing this protocol + , pref :: [String] + -- |Feature references of this protocol + , pfeatures :: M.Map String (Maybe String) + -- |List of references to other protocols, usually from the paper’s + -- “related work” section + , prelated :: [String] + -- |Relevance of this protocol, calculated (pun intended) + , prank :: Float + } deriving Show + +-- |A MAC protocol feature +data Feature = Feature { + -- |Referenceable name + fname :: String + -- |Its description + , fdescription :: Maybe String + } deriving Show + +-- |The whole database +data Database = Database { + -- |Key-value pair for each protocol + dalgos :: M.Map String Protocol + -- |Global list of available features + , dfeatures :: M.Map String Feature + -- |Global list of available publications + , dpublications :: [T] + } deriving Show + +instance FromJSON Protocol where + parseJSON (Object v) = Protocol + <$> v .: "name" + <*> v .:? "longname" + <*> v .:? "description" + <*> v .:? "ref" .!= [] + <*> v .:? "features" .!= M.empty + <*> v .:? "related" .!= [] + <*> return 0 + parseJSON _ = mzero + +instance FromJSON Feature where + parseJSON (Object v) = Feature + <$> v .: "name" + <*> v .:? "description" + parseJSON _ = mzero + +instance FromJSON Database where + parseJSON (Object v) = Database + <$> v .: "algos" + <*> v .: "features" + <*> pure [] + parseJSON _ = mzero + +-- |Find publication with identifier `ident` +findPublication db ident = safeHead $ filter (\x -> ident == E.identifier x) $ dpublications db + +-- |Get a list of all publications referenced by proto @p@ +protoPublications db p = map (findPublication db) (pref p) + +-- |Find all referenced features’ names +referencedFeatures db = nub $ sort $ concat $ map (M.keys . pfeatures) $ M.elems $ dalgos db + +-- |Get all features at `level`, starting with 0 +getFeaturesByLevel db level = M.filterWithKey (\k v -> countDots k == level) $ dfeatures db + where + countDots = length . filter ((==) '.') + +-- |Get features by `base` feature +getFeaturesByBase db base = M.filterWithKey (\k v -> (base ++ ".") `isPrefixOf` k) $ dfeatures db + +-- |Read protocol and bib database from file +readDb :: String -> IO Database +readDb f = do + yamlres <- decodeFileEither f + --print yamlres + let + (Right yamldb) = yamlres + (basename, _) = splitExtension f + bibres <- parseFromFile file (basename <.> "bib") + --print bibres + let (Right bibdb) = bibres + return $ calcRank $ yamldb { dpublications = bibdb } + +-- |Protocol rank/popularity, uses the pagerank algorithm +calcRank db = + let + initalgos = M.mapWithKey initial $ dalgos db + n = fromIntegral $ M.size $ dalgos db + d = 0.85 + initial ident p = p { prank = 1.0/n } + -- Get all incoming references + pincoming algos ident = filter (\(_, x) -> ident `elem` prelated x) $ M.toList algos + -- Calculate new rank for p + modify algos ident p = p { prank = (1-d)/n + d*sum (map inrank (pincoming algos ident)) } + -- Incoming rank for p + inrank (_, p) = prank p / fromIntegral (length (prelated p)) + absdiff :: M.Map String Protocol -> (String, Protocol) -> Float + absdiff b (ident, p) = abs (prank (b M.! ident) - prank p) + rankdiff :: M.Map String Protocol -> M.Map String Protocol -> Float + rankdiff a b = 1/n * M.foldlWithKey (\x ident p -> x + absdiff b (ident, p)) 0 a + iterateUntil fiter fcmp a = let b = fiter a in if fcmp a b then iterateUntil fiter fcmp b else b + run algos = M.mapWithKey (modify algos) algos + stop prevalgos algos = rankdiff prevalgos algos > 0.00001 + in db { dalgos = (iterateUntil run stop initalgos) } + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..1521382 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,23 @@ +module Main (main) where + +import Text.ParserCombinators.Parsec.Prim +import Text.BibTeX.Parse +import System.Directory (copyFile) + +import Render (render) +import Db (readDb) + +import Paths_comatose + +-- |Read attributions from bibtex file +readAttributions = getDataFileName "data/attribution.bib" >>= parseFromFile file + +copyDataFile source dest = getDataFileName source >>= (\x -> copyFile x dest) + +main = do + db <- getDataFileName "data/db.yaml" >>= readDb + (Right attribution) <- readAttributions + render "_build/index.html" db attribution + copyDataFile "data/style.css" "_build/style.css" + copyDataFile "data/script.js" "_build/script.js" + diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 index 0000000..d48a567 --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE OverloadedStrings #-} +module Render (render) where + +import Control.Applicative +import Control.Monad +import Data.Monoid +import Data.List (nub, sort, sortBy, isPrefixOf) +import Data.Function (on) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Text.BibTeX.Entry as E +import qualified Data.Map as M +import Text.Parsec.Error +import Text.ParserCombinators.Parsec.Prim +import Text.Printf (printf) +import qualified Data.ByteString.Lazy as BS +import Network.URI (isReserved, escapeURIString) +import Lucid + +import Util +import Db + +maybeToHtml = maybe mempty toHtml + +scholarSearch q = "http://scholar.google.com/scholar?q=" ++ escapeURIString isReserved q + +resolveDoi :: String -> String +resolveDoi q = "http://doi.org/" ++ q + +-- |List of protocol features +protofeatures :: Database -> Protocol -> Html () +protofeatures _ p | (M.size $ pfeatures p) == 0 = mempty +protofeatures db p = do + dt_ "Features" + dd_ $ ul_ [class_ "features list-inline"] $ forM_ (sort $ M.keys $ pfeatures p) (\x -> li_ [data_ "id" (T.pack x), class_ "list-inline-item"] $ toHtml $ maybe ("" :: String) fname $ M.lookup x (dfeatures db)) + +-- |List of protocol publications +protopapers :: [T] -> Html () +protopapers pubs | length pubs == 0 = mempty +protopapers pubs = do + dt_ "Published in" + dd_ [class_ "ref"] $ if length pubs == 1 + then p_ $ bibentry $ head pubs + else ol_ $ forM_ pubs (li_ . bibentry) + +-- |Protocol description +protodesc :: Protocol -> Html () +protodesc Protocol { pdescription = Nothing } = mempty +protodesc Protocol { pdescription = Just desc } = p_ $ toHtml desc + +protorelated :: Database -> Protocol -> Html () +protorelated _ p | null $ prelated p = mempty +protorelated db p = + let + algos = dalgos db + lookup k = M.lookup k algos >>= \y -> return (k, y) + rel = catMaybes $ map lookup $ prelated p + in do + dt_ "Related" + dd_ [class_ "related"] $ ul_ [class_ "list-inline"] $ forM_ rel $ + \(ident, x) -> li_ [class_ "list-inline-item"] $ a_ [href_ (T.pack $ '#':ident)] $ toHtml $ pname x + +-- |One protocol +protoentry :: Database -> (String, Protocol) -> Html () +protoentry db (ident, p) = + let + pubs = catMaybes $ protoPublications db p + firstpub = safeHead pubs + field key = firstpub >>= (return . E.fields) >>= lookup key + in + section_ [ + id_ $ T.pack ident + , class_ "protocol" + , data_ "rank" (T.pack $ show $ prank p) + ] $ do + h3_ [class_ "name"] $ do + a_ [href_ (T.pack $ '#':ident), title_ "permalink"] $ toHtml $ pname p + " " + maybe "" (small_ [class_ "longname"] . toHtml) $ plongname p + protodesc p + dl_ $ do + protopapers pubs + protofeatures db p + protorelated db p + +extcss url = link_ [rel_ "stylesheet", type_ "text/css", href_ url] + +extjs :: T.Text -> Html () +extjs url = script_ [type_ "text/javascript", charset_ "utf8", src_ url] ("" :: T.Text) + +-- | Try very hard to find an appropriate URL for the bibentry, DOIs are prefered +bibentryurl bib = safeHead $ catMaybes [doi, url] + where + fields = E.fields bib + doi = lookup "doi" fields >>= return . resolveDoi + url = lookup "url" fields + +-- | Format bibliography/references item +bibentry :: E.T -> Html () +bibentry bib = do + let + fields = E.fields bib + htmlLookup k = maybeToHtml $ lookup k fields + maybe + (span_ [class_ "title"] $ htmlLookup "title") + (\x -> a_ [href_ $ T.pack $ x, class_ "title"] $ htmlLookup "title") + (bibentryurl bib) + ", " + span_ [class_ "author"] $ htmlLookup "author" + ", " + span_ [class_ "year"] $ htmlLookup "year" + +-- | References section +references :: [E.T] -> Html () +references attrib = section_ $ do + h2_ "References" + ol_ $ forM_ attrib (li_ . bibentry) + +-- | What is this?! +introduction :: Database -> Html () +introduction db = + let + algocount = M.size $ dalgos db + pubyears = catMaybes $ map (lookup "year" . E.fields) $ dpublications db + firstyear = foldr min (head pubyears) (tail pubyears) + lastyear = foldr max (head pubyears) (tail pubyears) + in section_ [class_ "container"] $ do + h1_ [class_ "display-3"] "comatose" + p_ $ do + "The comprehensive MAC taxonomy database (comatose) is a collection of " + toHtml $ show algocount + " wireless media/medium access protocols published between " + toHtml firstyear + " and " + toHtml lastyear + "." + +-- |List of protocol features +features :: Database -> Html () +features db = + section_ [id_ "features"] $ do + h2_ "Features" + p_ "This section presents so-called “features” that are assigned to each protocol." + forM_ (M.toList $ getFeaturesByLevel db 0) $ \(baseident, basefeature) -> do + let featureanchor = "feature-" ++ baseident in do + h3_ [id_ $ T.pack featureanchor] $ a_ [href_ $ T.pack $ '#':featureanchor] $ toHtml $ fname basefeature + maybe mempty (p_ . toHtml) $ fdescription basefeature + dl_ $ forM_ (M.toList $ getFeaturesByBase db baseident) $ \(ident, feature) -> do + dt_ [class_ "form-inline"] $ let i = T.pack ("filter-feature-" ++ ident) in do + input_ [type_ "checkbox", id_ i, class_ "filter-feature", value_ (T.pack ident)] + " " + label_ [for_ i] $ toHtml $ fname feature + maybe mempty (dd_ . toHtml) $ fdescription feature + +-- | The list of protocols +protocols :: Database -> Html () +protocols db = section_ [id_ "protocols"] $ do + h2_ "Protocols" + forM_ (M.toList $ dalgos db) (protoentry db) + +-- |Page template +page db attrib = doctypehtml_ $ do + head_ $ do + title_ "comatose" + meta_ [charset_ "utf-8"] + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1, shrink-to-fit=no"] + extjs "https://code.jquery.com/jquery-3.2.1.min.js" + extcss "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-beta/css/bootstrap.min.css" + extjs "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-beta/js/bootstrap.min.js" + extcss "style.css" + body_ $ do + nav_ [class_ "navbar navbar-expand-md navbar-dark bg-dark fixed-top"] $ do + div_ [class_ "collapse navbar-collapse"] $ do + span_ [class_ "navbar-brand"] "comatose" + ul_ [class_ "navbar-nav mr-auto"] $ do + li_ [class_ "nav-item" ] $ a_ [class_ "nav-link", href_ "#features"] "Features" + li_ [class_ "nav-item" ] $ a_ [class_ "nav-link", href_ "#protocols"] "Protocols" + form_ [id_ "protosort", class_ "form-inline my-2 my-lg-0"] $ do + input_ [id_ "filter", type_ "search", class_ "form-control mr-sm-2", placeholder_ "Filter by name"] + " " + label_ [for_ "sort"] "Sort by" + " " + select_ [id_ "sort", class_ "form-control"] $ do + option_ [value_ "name"] "Name" + option_ [value_ "year"] "Year" + option_ [value_ "rank"] "Rank" + div_ [class_ "jumbotron" ] $ introduction db + div_ [class_ "container"] $ do + features db + protocols db + references (sortBy (compare `on` lookup "year" . E.fields) attrib) + extjs "script.js" + +-- |Render page +render f db attribution = renderToFile f (page db attribution) + diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 index 0000000..15ca593 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,7 @@ +module Util (safeHead) where + +-- |Safe head function +safeHead [] = Nothing +safeHead (x:_) = Just x + + |