summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2017-10-16 15:16:56 +0200
committerLars-Dominik Braun <lars@6xq.net>2017-10-16 15:17:18 +0200
commit25379bbdcc51e0ccd243d3391fa6bc266cd314e2 (patch)
treebdf4fcfbf0a5485ecde15ed2dd410974f2c630a7 /src
parent5703498008563418c4407c1608cd8cac933f96c0 (diff)
downloadcomatose-25379bbdcc51e0ccd243d3391fa6bc266cd314e2.tar.gz
comatose-25379bbdcc51e0ccd243d3391fa6bc266cd314e2.tar.bz2
comatose-25379bbdcc51e0ccd243d3391fa6bc266cd314e2.zip
Split Main.hs
Replace tabs with spaces. No functional changes.
Diffstat (limited to 'src')
-rw-r--r--src/Db.hs129
-rw-r--r--src/Main.hs23
-rw-r--r--src/Render.hs197
-rw-r--r--src/Util.hs7
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
+
+