{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

module Poseidon.ServerHTML (mainPage, archivePage, packageVersionPage, samplePage, MapMarker(..)) where

import           Poseidon.EntityTypes
import           Poseidon.Janno
import           Poseidon.Package

import           Control.Monad               (forM_)
import qualified Control.Monad               as OP
import           Data.Aeson                  (defaultOptions, encode,
                                              genericToEncoding)
import           Data.Aeson.Types            (ToJSON (..))
import qualified Data.ByteString.Lazy.Char8  as C
import           Data.Csv                    (ToNamedRecord (..))
import qualified Data.HashMap.Strict         as HM
import           Data.List                   (foldl')
import           Data.Maybe                  (fromMaybe)
import qualified Data.Text                   as T
import qualified Data.Text.Encoding          as T
import           Data.Version                (Version, showVersion)
import           GHC.Generics
import           NeatInterpolation
import           Network.Wai                 (Request (..))
import           Paths_poseidon_hs           (version)
import qualified Text.Blaze.Html5            as H
import           Text.Blaze.Html5            ((!))
import qualified Text.Blaze.Html5.Attributes as A
import           Text.Blaze.Renderer.Text
import qualified Web.Scotty                  as S

-- helper functions and types

renderMaybeVersion :: Maybe Version -> String
renderMaybeVersion :: Maybe Version -> String
renderMaybeVersion Maybe Version
Nothing  = (String
"" :: String)
renderMaybeVersion (Just Version
v) = Version -> String
showVersion Version
v

data MapMarker = MapMarker {
      MapMarker -> Double
mmLat            :: Double
    , MapMarker -> Double
mmLon            :: Double
    , MapMarker -> String
mmPoseidonID     :: String
    , MapMarker -> String
mmPackageName    :: String
    , MapMarker -> Maybe String
mmPackageVersion :: Maybe String
    , MapMarker -> String
mmArchiveName    :: String
    , MapMarker -> Maybe String
mmLocation       :: Maybe String
    , MapMarker -> Maybe String
mmAge            :: Maybe String
    } deriving ((forall x. MapMarker -> Rep MapMarker x)
-> (forall x. Rep MapMarker x -> MapMarker) -> Generic MapMarker
forall x. Rep MapMarker x -> MapMarker
forall x. MapMarker -> Rep MapMarker x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MapMarker -> Rep MapMarker x
from :: forall x. MapMarker -> Rep MapMarker x
$cto :: forall x. Rep MapMarker x -> MapMarker
to :: forall x. Rep MapMarker x -> MapMarker
Generic, Int -> MapMarker -> ShowS
[MapMarker] -> ShowS
MapMarker -> String
(Int -> MapMarker -> ShowS)
-> (MapMarker -> String)
-> ([MapMarker] -> ShowS)
-> Show MapMarker
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MapMarker -> ShowS
showsPrec :: Int -> MapMarker -> ShowS
$cshow :: MapMarker -> String
show :: MapMarker -> String
$cshowList :: [MapMarker] -> ShowS
showList :: [MapMarker] -> ShowS
Show)

instance ToJSON MapMarker where
    toEncoding :: MapMarker -> Encoding
toEncoding = Options -> MapMarker -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

dataToJSON :: ToJSON a => a -> T.Text
dataToJSON :: forall a. ToJSON a => a -> Text
dataToJSON = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C.unpack (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

-- javascript (leaflet map)

mapJS :: T.Text -> T.Text -> T.Text
mapJS :: Text -> Text -> Text
mapJS Text
nrLoaded Text
mapMarkers = [text|
  window.onload = function() {
    // basic map
    var mymap = L.map('mapid').setView([35, 10], 1);
    L.tileLayer('https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png', {
        maxZoom: 19,
        attribution: 'Map data <a href="https://www.openstreetmap.org/">OpenStreetMap</a> contributors'
    }).addTo(mymap);
    // add legend
    const nrLoaded = $nrLoaded;
    var legend = L.control({position: 'bottomright'});
    legend.onAdd = function (map) {
        var div = L.DomUtil.create('div', 'info legend');
        div.innerHTML = nrLoaded[0] + ' samples loaded<br>' + nrLoaded[1] + ' lat/lon missing<br>';
        return div;
    };
    legend.addTo(mymap);
    // markers
    var markers = L.markerClusterGroup();
    const mapMarkers = $mapMarkers;
    for (var i = 0; i<mapMarkers.length; i++) {
        const s = mapMarkers[i];
        // prepare popup message
        const packageLink = '<a href="/explorer/' + s.mmArchiveName + '/' + s.mmPackageName + '/' + s.mmPackageVersion + '/' + s.mmPoseidonID + '" style="text-decoration: underline; cursor: pointer;">Open sample</a>';
        const popupContentLines = [];
        popupContentLines.push('<b>Poseidon ID:</b> ' + s.mmPoseidonID);
        popupContentLines.push('<b>Package:</b> ' + s.mmPackageName);
        popupContentLines.push('<b>Package version:</b> ' + s.mmPackageVersion);
        popupContentLines.push('<b>Archive:</b> ' + s.mmArchiveName);
        popupContentLines.push('<b>Location:</b> ' + s.mmLocation);
        popupContentLines.push('<b>Age BC/AD:</b> ' + s.mmAge);
        popupContentLines.push('<b>' + packageLink + '</b>');
        const popupContent = popupContentLines.join("<br>");
        // create a marker with a popup
        L.marker([s.mmLat, s.mmLon]).bindPopup(popupContent).addTo(markers);
    }
    mymap.addLayer(markers);
  }
|]

-- css (specific additions to the stylesheet)

mapCSS :: T.Text
mapCSS :: Text
mapCSS = [text|
  /* overwrite some pico styling for the map */
  #mapid,
  #mapid * {
    padding: 0;
    --pico-border-width: 0rem !important;
    --pico-background-color: transparent !important;
  }
  /* legend */
  .legend {
    padding: 6px 8px !important;
    font: 14px/16px Arial, Helvetica, sans-serif;
    background: rgba(255,255,255,0.8);
    box-shadow: 0 0 15px rgba(0,0,0,0.2);
    border-radius: 5px;
    color: #777;
  }
  .leaflet-popup-content-wrapper {
    padding: 6px 8px !important;
  }
|]

-- html template

explorerPage :: [T.Text] -> H.Html -> H.Html
explorerPage :: [Text] -> Html -> Html
explorerPage [Text]
urlPath Html
content = do
    Html
H.docType
    Html -> Html
H.html (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html
header
      Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.main (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html
navBar
          [Text] -> Html
breadcrumb [Text]
urlPath
          Html
content
          Html
footer

header :: H.Markup
header :: Html
header = Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    -- load classless pico CSS
    Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"/styles.css"
    Html -> Html
H.style (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToHtml Text
mapCSS
    -- leaflet (js must be after css)
    Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet"
           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css"
           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"https://unpkg.com/leaflet@1.9.4/dist/leaflet.css"
           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
H.customAttribute Tag
"integrity" AttributeValue
"sha256-p4NxAoJBhIIN+hmNHrzRCf9tD/miZyoHS5obTRR9BMY="
           Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
H.customAttribute Tag
"crossorigin" AttributeValue
""
    Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src AttributeValue
"https://unpkg.com/leaflet@1.9.4/dist/leaflet.js"
             (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
H.customAttribute Tag
"integrity" AttributeValue
"sha256-20nQCchB9co0qIjJZRGuk2/Z9VM+kNiyxNV1lvTlZBo="
             (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
H.customAttribute Tag
"crossorigin" AttributeValue
""
             (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
    -- leaflet markercluster
    Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"https://unpkg.com/leaflet.markercluster@1.5.3/dist/MarkerCluster.css"
    Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"https://unpkg.com/leaflet.markercluster@1.5.3/dist/MarkerCluster.Default.css"
    Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src AttributeValue
"https://unpkg.com/leaflet.markercluster@1.5.3/dist/leaflet.markercluster.js" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""

navBar :: H.Html
navBar :: Html
navBar = Html -> Html
H.nav (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
  Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.strong Html
"Poseidon data explorer"
  Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"https://www.poseidon-adna.org" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Poseidon?"

breadcrumb :: [T.Text] -> H.Html
breadcrumb :: [Text] -> Html
breadcrumb [Text]
segments =
  Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"font-size: 0.7em;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    ((Text, Text) -> Html) -> [(Text, Text)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text, Text) -> Html
forall {a}. ToMarkup a => (a, Text) -> Html
toLi ([(Text, Text)] -> Html) -> [(Text, Text)] -> Html
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
segments [Text]
paths
  where
    paths :: [Text]
paths = [Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
tail ((Text -> Text -> Text) -> Text -> [Text] -> [Text]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\Text
acc Text
seg -> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
seg) Text
"" [Text]
segments)
    toLi :: (a, Text) -> Html
toLi (a
seg, Text
path) = do
        Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
path) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ a -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup a
seg
        Text -> Html
H.text Text
" / "

footer :: H.Html
footer :: Html
footer = Html -> Html
H.footer (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"border-top: 1px solid; padding: 1em; border-color: #727B8A;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"float: left; font-size: 0.7em;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
       Html
"trident v" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Version -> String
showVersion Version
version)
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"float: right; font-size: 0.7em;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
       Html
"Built with "
       Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"https://picocss.com" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"pico CSS"

-- html pages

mainPage :: [(String, Maybe String, Maybe String,[PoseidonPackage])] -> S.ActionM ()
mainPage :: [(String, Maybe String, Maybe String, [PoseidonPackage])]
-> ActionM ()
mainPage [(String, Maybe String, Maybe String, [PoseidonPackage])]
pacsPerArchive = do
  [Text]
urlPath <- Request -> [Text]
pathInfo (Request -> [Text]) -> ActionT IO Request -> ActionT IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT IO Request
S.request
  Text -> ActionM ()
S.html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
renderMarkup (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Html -> Html
explorerPage [Text]
urlPath (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.h1 Html
"Archives"
    Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [(String, Maybe String, Maybe String, [PoseidonPackage])]
-> ((String, Maybe String, Maybe String, [PoseidonPackage])
    -> Html)
-> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, Maybe String, Maybe String, [PoseidonPackage])]
pacsPerArchive (((String, Maybe String, Maybe String, [PoseidonPackage]) -> Html)
 -> Html)
-> ((String, Maybe String, Maybe String, [PoseidonPackage])
    -> Html)
-> Html
forall a b. (a -> b) -> a -> b
$ \(String
archiveName, Maybe String
maybeDescription, Maybe String
maybeURL, [PoseidonPackage]
pacs) -> do
      let nrPackages :: Int
nrPackages = [PoseidonPackage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PoseidonPackage]
pacs
      Html -> Html
H.article (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.header (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/explorer/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
            String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
archiveName
        -- normal archive
        String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
nrPackages String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" packages"
        -- archives with more info
        case (Maybe String
maybeDescription,Maybe String
maybeURL) of
          (Just String
desc, Just String
url) -> do
            Html
H.br
            Html
H.br
            Html -> Html
H.p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
desc
            Html -> Html
H.footer (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
H.stringValue String
url)
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"float: right; font-size: 0.8em;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
"Source archive" :: String)
          (Maybe String, Maybe String)
_ -> () -> Html
forall a. a -> MarkupM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

archivePage ::
     String
  -> Maybe String
  -> Bool
  -> [MapMarker]
  -> [PoseidonPackage]
  -> S.ActionM ()
archivePage :: String
-> Maybe String
-> Bool
-> [MapMarker]
-> [PoseidonPackage]
-> ActionM ()
archivePage String
archiveName Maybe String
maybeArchiveSpecURL Bool
archiveZip [MapMarker]
mapMarkers [PoseidonPackage]
pacs = do
  [Text]
urlPath <- Request -> [Text]
pathInfo (Request -> [Text]) -> ActionT IO Request -> ActionT IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT IO Request
S.request
  let nrSamplesTotal :: Int
nrSamplesTotal = (Int -> PoseidonPackage -> Int) -> Int -> [PoseidonPackage] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
i PoseidonPackage
p -> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [JannoRow] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (JannoRows -> [JannoRow]
getJannoRows (JannoRows -> [JannoRow]) -> JannoRows -> [JannoRow]
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> JannoRows
posPacJanno PoseidonPackage
p)) Int
0 [PoseidonPackage]
pacs
  Text -> ActionM ()
S.html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
renderMarkup (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Html -> Html
explorerPage [Text]
urlPath (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/javascript" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToHtml (Text -> Text -> Text
mapJS ((Int, Int) -> Text
forall a. ToJSON a => a -> Text
dataToJSON ([MapMarker] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MapMarker]
mapMarkers, Int
nrSamplesTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
- [MapMarker] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MapMarker]
mapMarkers)) ([MapMarker] -> Text
forall a. ToJSON a => a -> Text
dataToJSON [MapMarker]
mapMarkers))
    Html -> Html
H.h1 (String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"Archive: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
archiveName)
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"mapid" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"height: 350px;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
    Html -> Html
H.table (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"Package"
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"# Samples"
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"Source"
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
".zip Archive"
      [PoseidonPackage] -> (PoseidonPackage -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [PoseidonPackage]
pacs ((PoseidonPackage -> Html) -> Html)
-> (PoseidonPackage -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \PoseidonPackage
pac -> do
        let pacName :: String
pacName = PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
pac
            nrSamples :: Int
nrSamples = [JannoRow] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JannoRow] -> Int) -> [JannoRow] -> Int
forall a b. (a -> b) -> a -> b
$ JannoRows -> [JannoRow]
getJannoRows (JannoRows -> [JannoRow]) -> JannoRows -> [JannoRow]
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> JannoRows
posPacJanno PoseidonPackage
pac
        Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          -- normal archive
          Html -> Html
H.td (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/explorer/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<>  String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
pacName)
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
nrSamples
          -- archives with more info
          case Maybe String
maybeArchiveSpecURL of
            Just String
url -> Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
H.stringValue String
url AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
"GitHub" :: String)
            Maybe String
Nothing  -> Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
H.string String
"n/a"
          if Bool
archiveZip
          then Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/zip_file/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"?archive=" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
"Download" :: String)
          else Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
H.string String
"n/a"

packageVersionPage ::
     String -> String -> Maybe Version
  -> Bool
  -> [MapMarker]
  -> String
  -> PoseidonPackage -> [PoseidonPackage] -> [JannoRow]
  -> S.ActionM ()
packageVersionPage :: String
-> String
-> Maybe Version
-> Bool
-> [MapMarker]
-> String
-> PoseidonPackage
-> [PoseidonPackage]
-> [JannoRow]
-> ActionM ()
packageVersionPage
  String
archiveName String
pacName Maybe Version
pacVersion
  Bool
archiveZip
  [MapMarker]
mapMarkers
  String
bib
  PoseidonPackage
oneVersion [PoseidonPackage]
allVersions [JannoRow]
samples = do
  [Text]
urlPath <- Request -> [Text]
pathInfo (Request -> [Text]) -> ActionT IO Request -> ActionT IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT IO Request
S.request
  let nrSamples :: Int
nrSamples = [JannoRow] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JannoRow] -> Int) -> [JannoRow] -> Int
forall a b. (a -> b) -> a -> b
$ JannoRows -> [JannoRow]
getJannoRows (JannoRows -> [JannoRow]) -> JannoRows -> [JannoRow]
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> JannoRows
posPacJanno PoseidonPackage
oneVersion
  Text -> ActionM ()
S.html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
renderMarkup (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Html -> Html
explorerPage [Text]
urlPath (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/javascript" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToHtml (Text -> Text -> Text
mapJS ((Int, Int) -> Text
forall a. ToJSON a => a -> Text
dataToJSON ([MapMarker] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MapMarker]
mapMarkers, Int
nrSamples Int -> Int -> Int
forall a. Num a => a -> a -> a
- [MapMarker] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MapMarker]
mapMarkers)) ([MapMarker] -> Text
forall a. ToJSON a => a -> Text
dataToJSON [MapMarker]
mapMarkers))
    case Maybe Version
pacVersion of
      Maybe Version
Nothing -> Html -> Html
H.h1 (String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"Package: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pacName)
      Just Version
v -> Html -> Html
H.h1 (String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"Package: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pacName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
v)
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"mapid" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"height: 350px;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
    Html
H.br
    -- description
    Html -> Html
H.article (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.b Html
"Description: "
      String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"unknown" (PoseidonPackage -> Maybe String
posPacDescription PoseidonPackage
oneVersion)
      Html
H.br
      Html -> Html
H.b Html
"Version: "
      String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Maybe Version -> String
renderMaybeVersion (Maybe Version -> String) -> Maybe Version -> String
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
oneVersion
      Html
H.br
      Html -> Html
H.b Html
"Last modified: "
      String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String -> (Day -> String) -> Maybe Day -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"unknown" Day -> String
forall a. Show a => a -> String
show (PoseidonPackage -> Maybe Day
posPacLastModified PoseidonPackage
oneVersion)
      Html
H.br
      Html -> Html
H.b Html
"Number of samples: "
      String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
nrSamples
    -- versions and bibliography
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"float: left; width: 70%;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.details (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.summary Html
"Package versions"
        Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          [PoseidonPackage] -> (PoseidonPackage -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [PoseidonPackage]
allVersions ((PoseidonPackage -> Html) -> Html)
-> (PoseidonPackage -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \PoseidonPackage
pac -> Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.div (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
            let v :: Maybe Version
v = PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
pac
            Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/explorer/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Maybe Version -> String
renderMaybeVersion Maybe Version
v)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Maybe Version -> String
renderMaybeVersion Maybe Version
v
            Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
OP.when Bool
archiveZip (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
              String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
" | " :: String)
              Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/zip_file/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"?package_version=" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Maybe Version -> String
renderMaybeVersion Maybe Version
v) AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"&archive=" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
"Download" :: String)
      Html -> Html
H.details (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.summary Html
"Bibliography (in bibtex format)"
        Html -> Html
H.textarea (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rows AttributeValue
"15" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
bib
    -- download button
    Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
OP.when Bool
archiveZip (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"float: right; text-align: right;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        case Maybe Version
pacVersion of
          Maybe Version
Nothing -> do
            Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/zip_file/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"?archive=" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
"Download" :: String)
          Just Version
v -> do
            Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"/zip_file/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"?package_version=" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Version -> String
showVersion Version
v) AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"&archive=" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String
"Download" :: String)
    -- sample table
    Html -> Html
H.table (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"PoseidonID"
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"Genetic_Sex"
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"Group_Name"
      [JannoRow] -> (JannoRow -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JannoRow]
samples ((JannoRow -> Html) -> Html) -> (JannoRow -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \JannoRow
jannoRow -> do
        let link :: AttributeValue
link = AttributeValue
"/explorer/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
archiveName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
pacName AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Maybe Version -> String
renderMaybeVersion Maybe Version
pacVersion) AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"/" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (JannoRow -> String
jPoseidonID JannoRow
jannoRow)
        Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
link (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ JannoRow -> String
jPoseidonID JannoRow
jannoRow
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ GeneticSex -> String
forall a. Show a => a -> String
show (GeneticSex -> String) -> GeneticSex -> String
forall a b. (a -> b) -> a -> b
$ JannoRow -> GeneticSex
jGeneticSex JannoRow
jannoRow
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (GroupName -> Text) -> [GroupName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(GroupName Text
t) -> Text
t) ([GroupName] -> [Text]) -> [GroupName] -> [Text]
forall a b. (a -> b) -> a -> b
$ ListColumn GroupName -> [GroupName]
forall a. ListColumn a -> [a]
getListColumn (ListColumn GroupName -> [GroupName])
-> ListColumn GroupName -> [GroupName]
forall a b. (a -> b) -> a -> b
$ JannoRow -> ListColumn GroupName
jGroupName JannoRow
jannoRow

samplePage ::
     Maybe MapMarker
  -> JannoRow
  -> S.ActionM ()
samplePage :: Maybe MapMarker -> JannoRow -> ActionM ()
samplePage Maybe MapMarker
maybeMapMarker JannoRow
row = do
  [Text]
urlPath <- Request -> [Text]
pathInfo (Request -> [Text]) -> ActionT IO Request -> ActionT IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT IO Request
S.request
  let hashMap :: NamedRecord
hashMap = JannoRow -> NamedRecord
forall a. ToNamedRecord a => a -> NamedRecord
toNamedRecord JannoRow
row
  Text -> ActionM ()
S.html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
renderMarkup (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Html -> Html
explorerPage [Text]
urlPath (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      case Maybe MapMarker
maybeMapMarker of
        Just MapMarker
mapMarker -> Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/javascript" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToHtml (Text -> Text -> Text
mapJS ((Int, Int) -> Text
forall a. ToJSON a => a -> Text
dataToJSON ((Int
1,Int
0) :: (Int,Int))) ([MapMarker] -> Text
forall a. ToJSON a => a -> Text
dataToJSON [MapMarker
mapMarker]))
        Maybe MapMarker
Nothing -> () -> Html
forall a. a -> MarkupM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Html -> Html
H.h1 (String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"Sample: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> JannoRow -> String
jPoseidonID JannoRow
row)
    case Maybe MapMarker
maybeMapMarker of
      Just MapMarker
_  -> Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"mapid" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
"height: 350px;" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
      Maybe MapMarker
Nothing -> () -> Html
forall a. a -> MarkupM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Html -> Html
H.table (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"Property"
        Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.b Html
"Value"
      Vector Name -> (Name -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([JannoRow] -> Vector Name
makeHeaderWithAdditionalColumns [JannoRow
row]) ((Name -> Html) -> Html) -> (Name -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \Name
key -> do
        Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Name -> Text
T.decodeUtf8Lenient Name
key
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Name -> Text
T.decodeUtf8Lenient (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Name -> NamedRecord -> Name
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.findWithDefault Name
"" Name
key NamedRecord
hashMap