Skip to content

Commit

Permalink
draft of a mechanism to handle archive specification primarily for th…
Browse files Browse the repository at this point in the history 
…e html api more flexibly
  • Loading branch information
@nevrome
nevrome committed Feb 6, 2025
1 parent 03d12c5 commit 369dbb8
Show file tree
Hide file tree
Showing 5 changed files with 103 additions and 73 deletions.
2 changes: 1 addition & 1 deletion src-executables/Main-trident.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -261,7 +261,7 @@ timetravelOptParser = TimetravelOptions <$> parseBasePaths
<*> parseTimetravelChronPath

serveOptParser :: OP.Parser ServeOptions
serveOptParser = ServeOptions <$> parseArchiveBasePaths
serveOptParser = ServeOptions <$> parseArchiveConfig
<*> parseMaybeZipDir
<*> parsePort
<*> parseIgnoreChecksums
Expand Down
34 changes: 25 additions & 9 deletions src/Poseidon/CLI/OptparseApplicativeParsers.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,7 @@ import Poseidon.GenotypeData (GenoDataSource (..),
GenotypeDataSpec (..),
GenotypeFileSpec (..),
SNPSetSpec (..))
import Poseidon.CLI.Serve (ArchiveConfig (..), ArchiveSpec (..))
import Poseidon.ServerClient (AddColSpec (..),
ArchiveEndpoint (..))
import Poseidon.Utils (ErrorLength (..), LogMode (..),
Expand Down Expand Up @@ -804,24 +805,39 @@ 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
_ -> 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."
)

parseMaybeArchiveName :: OP.Parser (Maybe String)
parseMaybeArchiveName = OP.option (Just <$> OP.str) (
Expand Down
81 changes: 56 additions & 25 deletions src/Poseidon/CLI/Serve.hs
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Poseidon.CLI.Serve (runServer, runServerMainThread, ServeOptions(..)) where
module Poseidon.CLI.Serve (runServer, runServerMainThread, ServeOptions(..), ArchiveConfig (..), ArchiveSpec (..)) where

import Poseidon.EntityTypes (HasNameAndVersion (..),
PacNameAndVersion,
Expand Down Expand Up @@ -32,9 +32,9 @@ import Codec.Archive.Zip (Archive, addEntryToArchive,
toEntry)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar)
import Control.Monad (foldM, forM, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Data.ByteString.Lazy as B
import Data.List (groupBy, intercalate, nub,
import Data.List (groupBy, intercalate,
sortOn)
import Data.List.Split (splitOn)
import Data.Maybe (isJust, mapMaybe)
Expand Down Expand Up @@ -63,29 +63,54 @@ import Web.Scotty (ActionM, ScottyM, captureParam,
notFound, queryParamMaybe, raw,
redirect, request, scottyApp,
setHeader, text)
import Data.Yaml (FromJSON, parseJSON, (.:?), decodeFileThrow)
import Data.Yaml.Aeson (withObject, (.:))

data ServeOptions = ServeOptions
{ cliArchiveBaseDirs :: [(String, FilePath)]
{ cliArchiveConfig :: Either ArchiveConfig FilePath
, cliZipDir :: Maybe FilePath
, cliPort :: Int
, cliIgnoreChecksums :: Bool
, cliCertFiles :: Maybe (FilePath, [FilePath], FilePath)
}
deriving (Show)

newtype ArchiveConfig = ArchiveConfig [ArchiveSpec] deriving Show

instance FromJSON ArchiveConfig where
parseJSON = withObject "PoseidonYamlStruct" $ \v -> ArchiveConfig
<$> v .: "contributor"

parseArchiveConfigFile :: (MonadIO m) => FilePath -> m ArchiveConfig
parseArchiveConfigFile = decodeFileThrow

data ArchiveSpec = ArchiveSpec
{ _archSpecName :: ArchiveName
, _archSpecPaths :: [FilePath]
, _archSpecDescription :: Maybe String
, _archSpecURL :: Maybe String
} deriving (Show)

instance FromJSON ArchiveSpec where
parseJSON = withObject "contributor" $ \v -> ArchiveSpec
<$> v .: "name"
<*> v .: "paths"
<*> v .:? "description"
<*> v .:? "URL"

type ZipStore = [(PacNameAndVersion, FilePath)] -- maps PackageName+Version to a zipfile-path

type ArchiveName = String

type ArchiveStore a = [(ArchiveName, a)] -- a generic lookup table from an archive name to an item
type ArchiveStore a = [(ArchiveSpec, a)] -- a generic lookup table from an archive name to an item
-- we have two concrete ones: ArchiveStore [PoseidonPackage] and ArchiveStore ZipStore

getArchiveNames :: ArchiveStore a -> [String]
getArchiveNames = map fst
getArchiveSpecs :: ArchiveStore a -> [ArchiveSpec]
getArchiveSpecs = map fst

getArchiveByName :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m a
getArchiveByName name store =
case filter (\(n, _) -> n == name) store of
case filter (\(spec, _) -> _archSpecName spec == name) store of
[] -> fail $ "Archive " <> name <> " does not exist"
[(_,a)] -> pure a
_ -> fail $ "Archive " <> name <> " is ambiguous"
Expand All @@ -105,15 +130,19 @@ runServer (ServeOptions archBaseDirs maybeZipPath port ignoreChecksums certFiles
}

logInfo "Server starting up. Loading packages..."
archiveStore <- readArchiveStore archBaseDirs pacReadOpts
archiveStore <- case archBaseDirs of
Left archiveConfig -> readArchiveStore archiveConfig pacReadOpts
Right path -> do
archiveConfig <- parseArchiveConfigFile path
readArchiveStore archiveConfig pacReadOpts

logInfo $ "Using " ++ (fst . head) archiveStore ++ " as the default archive"
logInfo $ "Using " ++ (_archSpecName . fst . head) archiveStore ++ " as the default archive"

zipArchiveStore <- case maybeZipPath of
Nothing -> return []
Just z -> createZipArchiveStore archiveStore z

let archiveNames = getArchiveNames archiveStore
let archiveSpecs = getArchiveSpecs archiveStore

let runScotty = case certFiles of
Nothing -> scottyHTTP serverReady port
Expand Down Expand Up @@ -201,9 +230,12 @@ runServer (ServeOptions archBaseDirs maybeZipPath port ignoreChecksums certFiles
redirect ("/explorer")
get "/explorer" $ do
logRequest logA
pacsPerArchive <- forM archiveNames $ \n -> do
pacsPerArchive <- forM archiveSpecs $ \spec -> do
let n = _archSpecName spec
d = _archSpecDescription spec
u = _archSpecURL spec
pacs <- selectLatest <$> getArchiveByName n archiveStore
return (n, pacs)
return (n, d, u, pacs)
mainPage pacsPerArchive
-- archive pages
get "/explorer/:archive_name" $ do
Expand Down Expand Up @@ -312,24 +344,23 @@ prepSample sampleName rows = do
[x] -> return x
_ -> fail $ "Sample " <> sampleName <> " exists multiple times"

readArchiveStore :: [(ArchiveName, FilePath)] -> PackageReadOptions -> PoseidonIO (ArchiveStore [PoseidonPackage])
readArchiveStore archBaseDirs pacReadOpts = do
let archiveNames = nub . map fst $ archBaseDirs
forM archiveNames $ \archiveName -> do
logInfo $ "Loading packages for archive " ++ archiveName
let relevantDirs = map snd . filter ((==archiveName) . fst) $ archBaseDirs
readArchiveStore :: ArchiveConfig -> PackageReadOptions -> PoseidonIO (ArchiveStore [PoseidonPackage])
readArchiveStore (ArchiveConfig archiveSpecs) pacReadOpts = do
forM archiveSpecs $ \spec -> do
logInfo $ "Loading packages for archive " ++ _archSpecName spec
let relevantDirs = _archSpecPaths spec
pacs <- readPoseidonPackageCollection pacReadOpts relevantDirs
return (archiveName, pacs)
return (spec, pacs)

createZipArchiveStore :: ArchiveStore [PoseidonPackage] -> FilePath -> PoseidonIO (ArchiveStore ZipStore)
createZipArchiveStore archiveStore zipPath =
forM archiveStore $ \(archiveName, packages) -> do
logInfo $ "Zipping packages in archive " ++ archiveName
(archiveName,) <$> forM packages (\pac -> do
forM archiveStore $ \(spec, packages) -> do
logInfo $ "Zipping packages in archive " ++ _archSpecName spec
(spec,) <$> forM packages (\pac -> do
logInfo "Checking whether zip files are missing or outdated"
liftIO $ createDirectoryIfMissing True (zipPath </> archiveName)
liftIO $ createDirectoryIfMissing True (zipPath </> _archSpecName spec)
let combinedPackageVersionTitle = renderNameWithVersion pac
let fn = zipPath </> archiveName </> combinedPackageVersionTitle <.> "zip"
let fn = zipPath </> _archSpecName spec </> combinedPackageVersionTitle <.> "zip"
zipFileOutdated <- liftIO $ checkZipFileOutdated pac fn
when zipFileOutdated $ do
logInfo ("Zip Archive for package " ++ combinedPackageVersionTitle ++ " missing or outdated. Zipping now")
Expand Down
39 changes: 9 additions & 30 deletions src/Poseidon/ServerHTML.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -183,50 +183,29 @@ footer = H.footer ! A.style "border-top: 1px solid; padding: 1em; border-color:

-- html pages

mainPage :: [(String,[PoseidonPackage])] -> S.ActionM ()
mainPage :: [(String, Maybe String, Maybe String,[PoseidonPackage])] -> S.ActionM ()
mainPage pacsPerArchive = do
urlPath <- pathInfo <$> S.request
S.html $ renderMarkup $ explorerPage urlPath $ do
H.h1 "Archives"
H.ul $ forM_ pacsPerArchive $ \(archiveName, pacs) -> do
H.ul $ forM_ pacsPerArchive $ \(archiveName, maybeDescription, maybeURL, pacs) -> do
let nrPackages = length pacs
H.article $ do
H.header $ do
H.a ! A.href ("/explorer/" <> H.toValue archiveName) $
H.toMarkup archiveName
-- normal archive
H.toMarkup $ show nrPackages <> " packages"
-- cover special cases for the main archive explorer website
case archiveName of
"community-archive" -> do
-- archives with more infoFullDesc
case (maybeDescription,maybeURL) of
(Just desc, Just url)-> do
H.br
H.br
H.p $ H.toMarkup (
"Poseidon Community Archive (PCA) with per-paper packages and \
\genotype data as published." :: String)
H.p $ H.toMarkup desc
H.footer $ H.p $ H.a
! A.href "https://github.com/poseidon-framework/community-archive"
! A.href (H.stringValue url)
! A.style "float: right; font-size: 0.8em;" $
H.toMarkup ("The PCA on GitHub" :: String)
"minotaur-archive" -> do
H.br
H.br
H.p $ H.toMarkup (
"Poseidon Minotaur Archive (PMA) with per-paper packages and \
\genotype data reprocessed by the Minotaur workflow." :: String)
H.footer $ H.p $ H.a
! A.href "https://github.com/poseidon-framework/minotaur-archive"
! A.style "float: right; font-size: 0.8em;" $
H.toMarkup ("The PMA on GitHub" :: String)
"aadr-archive" -> do
H.br
H.br
H.p $ H.toMarkup (
"Poseidon AADR Archive (PAA) with a structurally unified version of the \
\AADR dataset repackaged in the Poseidon package format." :: String)
H.footer $ H.p $ H.a
! A.href "https://github.com/poseidon-framework/aadr-archive"
! A.style "float: right; font-size: 0.8em;" $
H.toMarkup ("The PAA on GitHub" :: String)
H.toMarkup ("Source archive" :: String)
_ -> return ()

archivePage ::
Expand Down
20 changes: 12 additions & 8 deletions test/PoseidonGoldenTests/GoldenTestsRunCommands.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ import Poseidon.CLI.List (ListEntity (..), ListOptions (..),
import Poseidon.CLI.Rectify (ChecksumsToRectify (..),
PackageVersionUpdate (..),
RectifyOptions (..), runRectify)
import Poseidon.CLI.Serve (ServeOptions (..), runServer)
import Poseidon.CLI.Serve (ServeOptions (..), runServer, ArchiveConfig (..), ArchiveSpec (..))
import Poseidon.CLI.Summarise (SummariseOptions (..),
runSummarise)
import Poseidon.CLI.Survey (SurveyOptions (..), runSurvey)
Expand Down Expand Up @@ -1199,13 +1199,17 @@ testPipelineChronicleAndTimetravel testDir checkFilePath = do
-- delete .git directory in chronicle to clean up in the end
removeDirectoryRecursive (testDir </> "chronicle" </> ".git")

archives :: [(String, FilePath)]
archives = [
("testArchive1", "test/testDat/testPackages/ancient/Lamnidis_2018")
, ("testArchive1", "test/testDat/testPackages/ancient/Lamnidis_2018_newVersion")
, ("testArchive2", "test/testDat/testPackages/ancient/Schiffels_2016")
, ("testArchive1", "test/testDat/testPackages/ancient/Wang_2020")
, ("testArchive2", "test/testDat/testPackages/ancient/Schmid_2028")
archives :: Either ArchiveConfig FilePath
archives = Left $ ArchiveConfig [
ArchiveSpec "testArchive1" [
"test/testDat/testPackages/ancient/Lamnidis_2018"
, "test/testDat/testPackages/ancient/Lamnidis_2018_newVersion"
, "test/testDat/testPackages/ancient/Wang_2020"
] Nothing Nothing
, ArchiveSpec "testArchive1" [
"test/testDat/testPackages/ancient/Schiffels_2016"
, "test/testDat/testPackages/ancient/Schmid_2028"
] Nothing Nothing
]

-- Note: We here use our test server (no SSL and different port). The reason is that
Expand Down

0 comments on commit 369dbb8

Please sign in to comment.