Merge pull request #327 from poseidon-framework/html

http API

CHANGELOG.md

@@ -1,3 +1,9 @@
+- V 1.6.3.0:
+    - Added an html (website) API to the set of endpoints served by trident `serve`.
+        - The html is build with `blaze-html` and `blaze-markup`.
+        - The javascript for a leaflet map is embedded into the Haskell code with `neat-interpolation`.
+        - The css -- a small class-free stylesheet ("pico css") -- is embedded into trident using `file-embed`.
+    - Slightly changed the way the archive configuration works for `serve` on the command line.
 - V 1.6.2.2:
     - Fixed a small bug that prevented calculation of checksums for genotype data in `rectify`.
 - V 1.6.2.1:

data/README.md

@@ -0,0 +1,3 @@
+# Embedded data files
+
+- pico.classless.blue.min.css: CSS stylesheet from https://picocss.com

poseidon-hs.cabal

@@ -1,5 +1,5 @@
 name:                poseidon-hs
-version:             1.6.2.2
+version:             1.6.3.0
 synopsis:            A package with tools for working with Poseidon genotype data
 description:         The tools in this package read and analyse Poseidon-formatted genotype databases, a modular system for storing genotype data from thousands of individuals.
 license:             MIT
@@ -16,7 +16,8 @@ library
     exposed-modules:    Poseidon.Package, Poseidon.GenotypeData, Poseidon.BibFile, Poseidon.Janno,
                         Poseidon.ColumnTypes, Poseidon.ColumnTypesUtils, Poseidon.MathHelpers,
                         Poseidon.PoseidonVersion, Poseidon.SequencingSource, Poseidon.Chronicle,
-                        Poseidon.EntityTypes, Poseidon.ServerClient, Poseidon.Contributor, Poseidon.Version
+                        Poseidon.EntityTypes, Poseidon.ServerClient, Poseidon.ServerHTML,
+                        Poseidon.ServerStylesheet, Poseidon.Contributor, Poseidon.Version,
                         Poseidon.CLI.List, Poseidon.CLI.Chronicle, Poseidon.CLI.Serve,
                         Poseidon.CLI.Summarise, Poseidon.CLI.Validate, Poseidon.Utils,
                         Poseidon.CLI.Survey, Poseidon.CLI.Forge, Poseidon.CLI.Init,
@@ -32,7 +33,7 @@ library
                         http-conduit, conduit, http-types, zip-archive,
                         unordered-containers, network-uri, optparse-applicative, co-log, regex-tdfa,
                         scientific, country, generics-sop, containers, process, deepseq, template-haskell,
-                        MissingH
+                        blaze-html, blaze-markup, neat-interpolation, file-embed, MissingH
     default-language:   Haskell2010
 
 executable trident

src-executables/Main-trident.hs

@@ -261,7 +261,7 @@ timetravelOptParser = TimetravelOptions <$> parseBasePaths
                                         <*> parseTimetravelChronPath
 
 serveOptParser :: OP.Parser ServeOptions
-serveOptParser = ServeOptions <$> parseArchiveBasePaths
+serveOptParser = ServeOptions <$> parseArchiveConfig
                               <*> parseMaybeZipDir
                               <*> parsePort
                               <*> parseIgnoreChecksums

src/Poseidon/BibFile.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Poseidon.BibFile (dummyBibEntry, readBibTeXFile, writeBibTeXFile, BibTeX, BibEntry(..), parseAuthors, authorAbbrvString) where
+module Poseidon.BibFile (dummyBibEntry, readBibTeXFile, writeBibTeXFile, BibTeX, BibEntry(..), renderBibEntry, parseAuthors, authorAbbrvString) where
 
 import           Poseidon.Utils                     (PoseidonException (..),
                                                      showParsecErr)
@@ -70,15 +70,15 @@ copied the relevant code here and modified it as needed.
 writeBibTeXFile :: FilePath -> BibTeX -> IO ()
 writeBibTeXFile path entries = withFile path WriteMode $ \outH -> do
     forM_ entries $ \bibEntry -> do
-        let entryString = writeEntry bibEntry
+        let entryString = renderBibEntry bibEntry
         hPutStrLn outH entryString
-  where
-    writeEntry :: BibEntry -> String
-    writeEntry (BibEntry entryType bibId items) =
-        let formatItem (name, value_) =
-                "  " ++ name ++ " = {" ++ value_ ++ "},\n"
-        in  "@" ++ entryType ++ "{" ++ bibId ++ ",\n" ++
-            concatMap formatItem items ++ "}\n"
+
+renderBibEntry :: BibEntry -> String
+renderBibEntry (BibEntry entryType bibId items) =
+    let formatItem (name, value_) =
+            "  " ++ name ++ " = {" ++ value_ ++ "},\n"
+    in  "@" ++ entryType ++ "{" ++ bibId ++ ",\n" ++
+        concatMap formatItem items ++ "}\n"
 
 bibFileParser :: Parser [BibEntry]
 bibFileParser = bibCommentParser >> sepEndBy bibEntryParser bibCommentParser

src/Poseidon/CLI/OptparseApplicativeParsers.hs

@@ -10,6 +10,8 @@ import           Poseidon.CLI.List          (ListEntity (..),
                                              RepoLocationSpec (..))
 import           Poseidon.CLI.Rectify       (ChecksumsToRectify (..),
                                              PackageVersionUpdate (..))
+import           Poseidon.CLI.Serve         (ArchiveConfig (..),
+                                             ArchiveSpec (..))
 import           Poseidon.CLI.Validate      (ValidatePlan (..))
 import           Poseidon.Contributor       (ContributorSpec (..),
                                              contributorSpecParser)
@@ -804,24 +806,41 @@ parseCertFile = OP.strOption (
     OP.help "The cert file of the TLS Certificate used for HTTPS."
     )
 
-parseArchiveBasePaths :: OP.Parser [(String, FilePath)]
-parseArchiveBasePaths = OP.some parseArchiveBasePath
+parseArchiveConfig :: OP.Parser (Either ArchiveConfig FilePath)
+parseArchiveConfig = Left <$> parseArchiveConfigCLI <|> Right <$> parseArchiveConfigPath
+
+parseArchiveConfigCLI :: OP.Parser ArchiveConfig
+parseArchiveConfigCLI = ArchiveConfig <$> OP.some parseArchiveSpec
   where
-    parseArchiveBasePath :: OP.Parser (String, FilePath)
-    parseArchiveBasePath = OP.option (OP.eitherReader parseArchiveNameAndPath) (
+    parseArchiveSpec :: OP.Parser ArchiveSpec
+    parseArchiveSpec = OP.option (OP.eitherReader parseArchiveNameAndPath) (
         OP.long "baseDir" <>
         OP.short 'd' <>
         OP.metavar "DSL" <>
         OP.help "A base path, prepended by the corresponding archive name under which \
-                \packages in this path are being served. Example: arch1=/path/to/basepath. Can \
-                \be given multiple times. Multiple paths for the same archive are combined internally. \
+                \packages in this path are being served. Example: arch1=/path1/to/basepath. \
+                \Multiple paths for the same archive can be given separated by comma, e.g. \
+                \Example: arch1=/path1/to/basepath,/path2/to/basepath. \
+                \Can be given multiple times. \
                 \The very first named archive is considered to be the default archive on the server.")
-    parseArchiveNameAndPath :: String -> Either String (String, FilePath)
+    parseArchiveNameAndPath :: String -> Either String ArchiveSpec
     parseArchiveNameAndPath str =
         let parts = splitOn "=" str
         in  case parts of
-                [name, fp] -> return (name, fp)
-                _ -> Left $ "could not parse archive and base directory " ++ str ++ ". Please use format name=path "
+                [name, fp] -> do
+                    let fps = splitOn "," fp
+                    return $ ArchiveSpec name fps Nothing Nothing Nothing
+                _ -> Left $ "could not parse archive and base directory " ++ str ++
+                            ". Please use format name=path1,path2,... "
+
+parseArchiveConfigPath :: OP.Parser FilePath
+parseArchiveConfigPath = OP.strOption (
+    OP.long "archiveConfigFile" <>
+    OP.metavar "FILE" <>
+    OP.help "Path to a .yml config file for the server archive configuration. \
+            \This file must include a list of \"archives:\", each with the fields\
+            \ \"name\", \"paths\", \"description\", \"URL\" and \"dataURL\"."
+    )
 
 parseMaybeArchiveName :: OP.Parser (Maybe String)
 parseMaybeArchiveName = OP.option (Just <$> OP.str) (