Skip to content

Commit

Permalink
remaining necessary changes
Browse files Browse the repository at this point in the history
  • Loading branch information
@nevrome
nevrome committed Feb 7, 2025
1 parent 369dbb8 commit 2e8b6f9
Show file tree
Hide file tree
Showing 4 changed files with 55 additions and 34 deletions.
5 changes: 3 additions & 2 deletions src/Poseidon/CLI/OptparseApplicativeParsers.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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 (..),
Expand Down Expand Up @@ -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,... "

Expand Down
54 changes: 34 additions & 20 deletions src/Poseidon/CLI/Serve.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,17 +32,19 @@ 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 (..))
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)
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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

Expand All @@ -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
Expand Down Expand Up @@ -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"
Expand All @@ -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
Expand All @@ -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"
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
22 changes: 13 additions & 9 deletions src/Poseidon/ServerHTML.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
8 changes: 5 additions & 3 deletions test/PoseidonGoldenTests/GoldenTestsRunCommands.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 2e8b6f9

Please sign in to comment.