From 2e8b6f929a81dba5e269a7688ff2ea0f5f34709e Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Fri, 7 Feb 2025 11:37:05 +0100 Subject: [PATCH] remaining necessary changes --- .../CLI/OptparseApplicativeParsers.hs | 5 +- src/Poseidon/CLI/Serve.hs | 54 ++++++++++++------- src/Poseidon/ServerHTML.hs | 22 ++++---- .../GoldenTestsRunCommands.hs | 8 +-- 4 files changed, 55 insertions(+), 34 deletions(-) diff --git a/src/Poseidon/CLI/OptparseApplicativeParsers.hs b/src/Poseidon/CLI/OptparseApplicativeParsers.hs index 4e06263ce..7dc0790f4 100644 --- a/src/Poseidon/CLI/OptparseApplicativeParsers.hs +++ b/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) @@ -21,7 +23,6 @@ import Poseidon.GenotypeData (GenoDataSource (..), GenotypeDataSpec (..), GenotypeFileSpec (..), SNPSetSpec (..)) -import Poseidon.CLI.Serve (ArchiveConfig (..), ArchiveSpec (..)) import Poseidon.ServerClient (AddColSpec (..), ArchiveEndpoint (..)) import Poseidon.Utils (ErrorLength (..), LogMode (..), @@ -828,7 +829,7 @@ parseArchiveConfigCLI = ArchiveConfig <$> OP.some parseArchiveSpec in case parts of [name, fp] -> do let fps = splitOn "," fp - return $ ArchiveSpec name fps Nothing Nothing + return $ ArchiveSpec name fps Nothing Nothing Nothing False _ -> Left $ "could not parse archive and base directory " ++ str ++ ". Please use format name=path1,path2,... " diff --git a/src/Poseidon/CLI/Serve.hs b/src/Poseidon/CLI/Serve.hs index e2534448e..a2a32d1cc 100644 --- a/src/Poseidon/CLI/Serve.hs +++ b/src/Poseidon/CLI/Serve.hs @@ -32,10 +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, MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString.Lazy as B -import Data.List (groupBy, intercalate, - sortOn) +import Data.List (groupBy, intercalate, sortOn) import Data.List.Split (splitOn) import Data.Maybe (isJust, mapMaybe) import Data.Ord (Down (..)) @@ -43,6 +42,9 @@ import Data.Text.Lazy (pack) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Version (Version, parseVersion, showVersion) +import Data.Yaml (FromJSON, decodeFileThrow, + parseJSON, (.:?)) +import Data.Yaml.Aeson (withObject, (.:)) import Network.Wai (pathInfo, queryString) import Network.Wai.Handler.Warp (defaultSettings, runSettings, setBeforeMainLoop, setPort) @@ -63,8 +65,6 @@ 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 { cliArchiveConfig :: Either ArchiveConfig FilePath @@ -79,16 +79,18 @@ newtype ArchiveConfig = ArchiveConfig [ArchiveSpec] deriving Show instance FromJSON ArchiveConfig where parseJSON = withObject "PoseidonYamlStruct" $ \v -> ArchiveConfig - <$> v .: "contributor" + <$> v .: "archives" parseArchiveConfigFile :: (MonadIO m) => FilePath -> m ArchiveConfig parseArchiveConfigFile = decodeFileThrow data ArchiveSpec = ArchiveSpec - { _archSpecName :: ArchiveName - , _archSpecPaths :: [FilePath] + { _archSpecName :: ArchiveName + , _archSpecPaths :: [FilePath] , _archSpecDescription :: Maybe String - , _archSpecURL :: Maybe String + , _archSpecURL :: Maybe String + , _archSpecDataURL :: Maybe String + , _archSpecZip :: Bool } deriving (Show) instance FromJSON ArchiveSpec where @@ -97,6 +99,8 @@ instance FromJSON ArchiveSpec where <*> v .: "paths" <*> v .:? "description" <*> v .:? "URL" + <*> v .:? "dataURL" + <*> v .: "zip" type ZipStore = [(PacNameAndVersion, FilePath)] -- maps PackageName+Version to a zipfile-path @@ -108,8 +112,15 @@ type ArchiveStore a = [(ArchiveSpec, a)] -- a generic lookup table from an archi getArchiveSpecs :: ArchiveStore a -> [ArchiveSpec] getArchiveSpecs = map fst -getArchiveByName :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m a -getArchiveByName name store = +getArchiveSpecByName :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m ArchiveSpec +getArchiveSpecByName name store = + case filter (\(spec, _) -> _archSpecName spec == name) store of + [] -> fail $ "Archive " <> name <> " does not exist" + [(spec,_)] -> pure spec + _ -> fail $ "Archive " <> name <> " is ambiguous" + +getArchiveContentByName :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m a +getArchiveContentByName name store = case filter (\(spec, _) -> _archSpecName spec == name) store of [] -> fail $ "Archive " <> name <> " does not exist" [(_,a)] -> pure a @@ -227,23 +238,26 @@ runServer (ServeOptions archBaseDirs maybeZipPath port ignoreChecksums certFiles raw stylesBS -- landing page get "/" $ do - redirect ("/explorer") + redirect "/explorer" get "/explorer" $ do logRequest logA pacsPerArchive <- forM archiveSpecs $ \spec -> do let n = _archSpecName spec d = _archSpecDescription spec u = _archSpecURL spec - pacs <- selectLatest <$> getArchiveByName n archiveStore + pacs <- selectLatest <$> getArchiveContentByName n archiveStore return (n, d, u, pacs) mainPage pacsPerArchive -- archive pages get "/explorer/:archive_name" $ do logRequest logA archiveName <- captureParam "archive_name" - latestPacs <- selectLatest <$> getArchiveByName archiveName archiveStore + spec <- getArchiveSpecByName archiveName archiveStore + let maybeArchiveDataURL = _archSpecDataURL spec + archiveZip = _archSpecZip spec + latestPacs <- selectLatest <$> getArchiveContentByName archiveName archiveStore let mapMarkers = concatMap (prepMappable archiveName) latestPacs - archivePage archiveName mapMarkers latestPacs + archivePage archiveName maybeArchiveDataURL archiveZip mapMarkers latestPacs -- per package pages get "/explorer/:archive_name/:package_name" $ do archive_name <- captureParam "archive_name" @@ -257,7 +271,7 @@ runServer (ServeOptions archBaseDirs maybeZipPath port ignoreChecksums certFiles pacVersionWL <- case parsePackageVersionString pacVersionString of Nothing -> fail $ "Could not parse package version string " ++ pacVersionString Just v -> return v - allPacs <- getArchiveByName archiveName archiveStore + allPacs <- getArchiveContentByName archiveName archiveStore allVersions <- prepPacVersions pacName allPacs oneVersion <- prepPacVersion pacVersionWL allVersions let mapMarkers = prepMappable archiveName oneVersion @@ -269,7 +283,7 @@ runServer (ServeOptions archBaseDirs maybeZipPath port ignoreChecksums certFiles get "/explorer/:archive_name/:package_name/:package_version/:sample" $ do logRequest logA archiveName <- captureParam "archive_name" - allPacs <- getArchiveByName archiveName archiveStore + allPacs <- getArchiveContentByName archiveName archiveStore pacName <- captureParam "package_name" allVersions <- prepPacVersions pacName allPacs pacVersionString <- captureParam "package_version" @@ -330,9 +344,9 @@ prepPacVersion pacVersion pacs = do case pacVersion of Latest -> return $ head $ selectLatest pacs NumericalVersion v -> case filter (\pac -> getPacVersion pac == Just v) pacs of - [] -> fail $ "Package version " <> (show pacVersion) <> " does not exist" + [] -> fail $ "Package version " <> show pacVersion <> " does not exist" [x] -> return x - _ -> fail $ "Package version " <> (show pacVersion) <> " exists multiple times" + _ -> fail $ "Package version " <> show pacVersion <> " exists multiple times" prepSamples :: PoseidonPackage -> ActionM [JannoRow] prepSamples pac = return $ getJannoRowsFromPac pac @@ -492,4 +506,4 @@ getItemFromArchiveStore store = do maybeArchiveName <- queryParamMaybe "archive" case maybeArchiveName of Nothing -> return . snd . head $ store - Just name -> getArchiveByName name store + Just name -> getArchiveContentByName name store diff --git a/src/Poseidon/ServerHTML.hs b/src/Poseidon/ServerHTML.hs index b20781bdc..2085da7fd 100644 --- a/src/Poseidon/ServerHTML.hs +++ b/src/Poseidon/ServerHTML.hs @@ -196,9 +196,9 @@ mainPage pacsPerArchive = do H.toMarkup archiveName -- normal archive H.toMarkup $ show nrPackages <> " packages" - -- archives with more infoFullDesc - case (maybeDescription,maybeURL) of - (Just desc, Just url)-> do + -- archives with more info + case (maybeDescription,maybeURL) of + (Just desc, Just url) -> do H.br H.br H.p $ H.toMarkup desc @@ -210,10 +210,12 @@ mainPage pacsPerArchive = do archivePage :: String + -> Maybe String + -> Bool -> [MapMarker] -> [PoseidonPackage] -> S.ActionM () -archivePage archiveName mapMarkers pacs = do +archivePage archiveName maybeArchiveSpecURL archiveZip mapMarkers pacs = do urlPath <- pathInfo <$> S.request let nrSamplesTotal = foldl' (\i p -> i + length (getJannoRows $ posPacJanno p)) 0 pacs S.html $ renderMarkup $ explorerPage urlPath $ do @@ -231,13 +233,15 @@ archivePage archiveName mapMarkers pacs = do let pacName = getPacName pac nrSamples = length $ getJannoRows $ posPacJanno pac H.tr $ do + -- normal archive H.td (H.a ! A.href ("/explorer/" <> H.toValue archiveName <> "/" <> H.toValue pacName) $ H.toMarkup pacName) H.td $ H.toMarkup $ show nrSamples - OP.when (archiveName `elem` ["community-archive", "minotaur-archive", "aadr-archive"]) $ do - H.td $ H.a ! A.href ("https://www.github.com/poseidon-framework/" <> H.toValue archiveName <> "/tree/main/" <> H.toValue pacName) - $ H.toMarkup ("GitHub" :: String) - H.td $ H.a ! A.href ("/zip_file/" <> H.toValue pacName) - $ H.toMarkup ("Download" :: String) + -- archives with more info + case maybeArchiveSpecURL of + Just url -> H.td $ H.a ! A.href (H.stringValue url <> "/" <> H.toValue pacName) $ H.toMarkup ("GitHub" :: String) + Nothing -> return () + OP.when archiveZip $ + H.td $ H.a ! A.href ("/zip_file/" <> H.toValue pacName) $ H.toMarkup ("Download" :: String) packageVersionPage :: String -> String -> Maybe Version diff --git a/test/PoseidonGoldenTests/GoldenTestsRunCommands.hs b/test/PoseidonGoldenTests/GoldenTestsRunCommands.hs index 8ddfaaf4f..af252066d 100644 --- a/test/PoseidonGoldenTests/GoldenTestsRunCommands.hs +++ b/test/PoseidonGoldenTests/GoldenTestsRunCommands.hs @@ -20,7 +20,9 @@ import Poseidon.CLI.List (ListEntity (..), ListOptions (..), import Poseidon.CLI.Rectify (ChecksumsToRectify (..), PackageVersionUpdate (..), RectifyOptions (..), runRectify) -import Poseidon.CLI.Serve (ServeOptions (..), runServer, ArchiveConfig (..), ArchiveSpec (..)) +import Poseidon.CLI.Serve (ArchiveConfig (..), + ArchiveSpec (..), + ServeOptions (..), runServer) import Poseidon.CLI.Summarise (SummariseOptions (..), runSummarise) import Poseidon.CLI.Survey (SurveyOptions (..), runSurvey) @@ -1205,11 +1207,11 @@ archives = Left $ ArchiveConfig [ "test/testDat/testPackages/ancient/Lamnidis_2018" , "test/testDat/testPackages/ancient/Lamnidis_2018_newVersion" , "test/testDat/testPackages/ancient/Wang_2020" - ] Nothing Nothing + ] Nothing Nothing Nothing False , ArchiveSpec "testArchive1" [ "test/testDat/testPackages/ancient/Schiffels_2016" , "test/testDat/testPackages/ancient/Schmid_2028" - ] Nothing Nothing + ] Nothing Nothing Nothing False ] -- Note: We here use our test server (no SSL and different port). The reason is that