path: root/Main.hs

{-# LANGUAGE OverloadedStrings #-}

import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Yaml
import Data.List (nub, sort, sortBy)
import Data.Function (on)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Aeson as A
import Text.BibTeX.Parse
import Text.BibTeX.Entry as E
import qualified Data.Map as M
import Text.Parsec.Error
import Text.ParserCombinators.Parsec.Prim
import qualified Data.ByteString.Lazy as BS
import System.FilePath ((<.>), splitExtension)
import System.Directory (copyFile)
import Network.URI (isReserved, escapeURIString)
import Lucid

import Paths_comatose

data Protocol = Protocol {
	  pname :: String
	, plongname :: Maybe String
	, pdescription :: Maybe String
	, pref :: [String]
	, pfeatures :: M.Map String (Maybe String)
	} deriving Show

data Database = Database {
	  dalgos :: M.Map String Protocol
	, dfeatures :: M.Map String Feature
	, dpublications :: [T]
	} deriving Show

data Feature = Feature {
	  fname :: String
	, fdescription :: Maybe String
	} deriving Show

type FeatureList = M.Map String Feature

instance FromJSON Protocol where
	parseJSON (Object v) = Protocol
		<$> v .: "name"
		<*> v .:? "longname"
		<*> v .:? "description"
		<*> v .:? "ref" .!= []
		<*> v .:? "features" .!= M.empty
	parseJSON _          = mzero

instance FromJSON Database where
	parseJSON (Object v) = Database
		<$> v .: "algos"
		<*> v .: "features"
		<*> pure []
	parseJSON _          = mzero

instance FromJSON Feature where
	parseJSON (Object v) = Feature
		<$> v .: "name"
		<*> v .:? "description"
	parseJSON _          = mzero

safeHead [] = Nothing
safeHead (x:_) = Just x

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

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 yamldb { dpublications = bibdb }

maybeToHtml = maybe (toHtml ("" :: String)) toHtml

head' [] = Nothing
head' (x:_) = Just x

scholarSearch q = "http://scholar.google.com/scholar?q=" ++ escapeURIString isReserved q
resolveDoi q = "http://doi.org/" ++ q

protofeatures :: Database -> Protocol -> Html ()
protofeatures _ p | (M.size $ pfeatures p) == 0 = mempty
protofeatures db p = do
	dt_ "Features"
	dd_ $ ul_ [class_ "features"] $ forM_ (sort $ M.keys $ pfeatures p) (\x -> li_ $ toHtml $ maybe ("" :: String) fname $ M.lookup x (dfeatures db))

protopapers :: [T] -> Html ()
protopapers pubs | length pubs == 0 = mempty
protopapers pubs = do
	dt_ "Published in"
	dd_ $ if length pubs == 1
		then p_ $ bibentry $ head pubs
		else ol_ $ forM_ pubs (li_ . bibentry)

protoentry :: Database -> (String, Protocol) -> Html ()
protoentry db (ident, p) =
	let
		pubs = catMaybes $ protoPublications db p
		firstpub = head' pubs
		field key = firstpub >>= (return . E.fields) >>= lookup key
	in
		section_ [
			id_ $ T.pack ident
			, class_ "protocol"
			, data_ "name" (T.pack $ pname p)
			, data_ "longname" (maybe "" T.pack $ plongname p)
			, data_ "author" (maybe "" T.pack $ field "author")
			, data_ "year" (maybe "" T.pack $ field "year")
			] $ do
			h3_ $ do
				toHtml $ pname p
				" "
				maybe "" (small_ . toHtml) $ plongname p
				" "
				small_ $ a_ [href_ (T.pack $ '#':ident), title_ "permalink", class_ "permalink"] "¶"
			dl_ $ do
				protopapers pubs
				protofeatures 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
	a_ [href_ $ T.pack $ maybe "" id $ bibentryurl bib] $ maybeToHtml $ lookup "title" fields
	", "
	maybeToHtml $ lookup "author" fields
	", "
	maybeToHtml $ lookup "year" fields

-- | 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_ $ do
		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
			"."

-- | The list of protocols
protocols :: Database -> Html ()
protocols db = section_ [id_ "protocols"] $ do
	h2_ "Protocols"
	div_ [id_ "protosort", class_ "form-inline"] $ do
		label_ [for_ "filter"] "Filter"
		" "
		input_ [id_ "filter", type_ "text", class_ "form-control"]
		" "
		label_ [for_ "sort"] "Sort by"
		" "
		select_ [id_ "sort", class_ "form-control"] $ do
			option_ [value_ "name"] "Name"
			option_ [value_ "year"] "Year"
	forM_ (M.toList $ dalgos db) (protoentry db)

page db attrib = doctypehtml_ $ do
	head_ $ do
		title_ "comatose"
		meta_ [charset_ "utf-8"]
		extjs "https://code.jquery.com/jquery-1.11.2.min.js"
		extcss "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.4/css/bootstrap.min.css"
		extcss "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.4/css/bootstrap-theme.min.css"
		extjs "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.4/js/bootstrap.min.js"
		extcss "style.css"
	body_ $ do
		div_ [class_ "container"] $ do
			div_ [class_ "page-header"] $ do
				h1_ "comatose"
			introduction db
			protocols db
			references (sortBy (compare `on` lookup "year" . E.fields) attrib)
		extjs "script.js"

render f db attribution = renderToFile f (page db attribution)

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"