{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

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

import           Poseidon.EntityTypes         (HasNameAndVersion (..),
                                               PacNameAndVersion (PacNameAndVersion),
                                               renderNameWithVersion)
import           Poseidon.GenotypeData        (GenotypeDataSpec (..),
                                               GenotypeFileSpec (..))
import           Poseidon.Janno               (JannoRow (..), getJannoRows)
import           Poseidon.Package             (PackageReadOptions (..),
                                               PoseidonPackage (..),
                                               defaultPackageReadOptions,
                                               getAllGroupInfo,
                                               getBibliographyInfo,
                                               getExtendedIndividualInfo,
                                               getJannoRowsFromPac,
                                               packagesToPackageInfos,
                                               readPoseidonPackageCollection)
import           Poseidon.PoseidonVersion     (minimalRequiredClientVersion)
import           Poseidon.ServerClient        (AddColSpec (..),
                                               ApiReturnData (..),
                                               ServerApiReturnType (..))
import           Poseidon.ServerHTML
import           Poseidon.ServerStylesheet    (stylesBS)
import           Poseidon.Utils               (LogA, PoseidonIO, envLogAction,
                                               logDebug, logInfo, logWithEnv)

import           Codec.Archive.Zip            (Archive, addEntryToArchive,
                                               emptyArchive, fromArchive,
                                               toEntry)
import           Control.Concurrent.MVar      (MVar, newEmptyMVar, putMVar)
import           Control.Monad                (foldM, forM, when)
import           Control.Monad.IO.Class       (MonadIO, liftIO)
import qualified Data.ByteString.Lazy         as B
import           Data.List                    (foldl', 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                    (Day)
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)
import           Network.Wai.Handler.WarpTLS  (runTLS, tlsSettings,
                                               tlsSettingsChain)
import           Network.Wai.Middleware.Cors  (simpleCors)
import           Paths_poseidon_hs            (version)
import           Poseidon.BibFile             (renderBibEntry)
import           Poseidon.ColumnTypesJanno    (JannoLatitude (..),
                                               JannoLongitude (..))
import           System.Directory             (createDirectoryIfMissing,
                                               doesFileExist,
                                               getModificationTime)
import           System.FilePath              ((<.>), (</>))
import           Text.ParserCombinators.ReadP (readP_to_S)
import           Web.Scotty                   (ActionM, ScottyM, captureParam,
                                               file, get, json, middleware,
                                               notFound, queryParamMaybe, raw,
                                               redirect, request, scottyApp,
                                               setHeader, text)

-- CLI options and routines
data ServeOptions = ServeOptions
    { ServeOptions -> Either ArchiveConfig String
cliArchiveConfig   :: Either ArchiveConfig FilePath
    , ServeOptions -> Maybe String
cliZipDir          :: Maybe FilePath
    , ServeOptions -> Int
cliPort            :: Int
    , ServeOptions -> Bool
cliIgnoreChecksums :: Bool
    , ServeOptions -> Maybe (String, [String], String)
cliCertFiles       :: Maybe (FilePath, [FilePath], FilePath)
    }
    deriving (Int -> ServeOptions -> ShowS
[ServeOptions] -> ShowS
ServeOptions -> String
(Int -> ServeOptions -> ShowS)
-> (ServeOptions -> String)
-> ([ServeOptions] -> ShowS)
-> Show ServeOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServeOptions -> ShowS
showsPrec :: Int -> ServeOptions -> ShowS
$cshow :: ServeOptions -> String
show :: ServeOptions -> String
$cshowList :: [ServeOptions] -> ShowS
showList :: [ServeOptions] -> ShowS
Show)


-- Archive specification

type ArchiveName = String

data ArchiveSpec = ArchiveSpec
    { ArchiveSpec -> String
_archSpecName               :: ArchiveName
    , ArchiveSpec -> [String]
_archSpecPaths              :: [FilePath]
    , ArchiveSpec -> Maybe String
_archSpecDescription        :: Maybe String
    , ArchiveSpec -> Maybe String
_archSpecURL                :: Maybe String
    , ArchiveSpec -> Maybe String
_archSpecDataURL            :: Maybe String
    , ArchiveSpec -> [String]
_archSpecExcludePacsFromMap :: [String]
    , ArchiveSpec -> Maybe String
_archRetiredPackagesFile    :: Maybe FilePath
    } deriving (Int -> ArchiveSpec -> ShowS
[ArchiveSpec] -> ShowS
ArchiveSpec -> String
(Int -> ArchiveSpec -> ShowS)
-> (ArchiveSpec -> String)
-> ([ArchiveSpec] -> ShowS)
-> Show ArchiveSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchiveSpec -> ShowS
showsPrec :: Int -> ArchiveSpec -> ShowS
$cshow :: ArchiveSpec -> String
show :: ArchiveSpec -> String
$cshowList :: [ArchiveSpec] -> ShowS
showList :: [ArchiveSpec] -> ShowS
Show)

data RetiredPackages = RetiredPackages
    { RetiredPackages -> String
_retPacFileTitle        :: String
    , RetiredPackages -> Version
_retPacFileVersion      :: Version
    , RetiredPackages -> Day
_retPacFileLastModified :: Day
    , RetiredPackages -> [RetiredPac]
_retPacFilePackages     :: [RetiredPac]
    } deriving (Int -> RetiredPackages -> ShowS
[RetiredPackages] -> ShowS
RetiredPackages -> String
(Int -> RetiredPackages -> ShowS)
-> (RetiredPackages -> String)
-> ([RetiredPackages] -> ShowS)
-> Show RetiredPackages
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetiredPackages -> ShowS
showsPrec :: Int -> RetiredPackages -> ShowS
$cshow :: RetiredPackages -> String
show :: RetiredPackages -> String
$cshowList :: [RetiredPackages] -> ShowS
showList :: [RetiredPackages] -> ShowS
Show)

data RetiredPac = RetiredPac
    { RetiredPac -> String
_retPacName    :: String
    , RetiredPac -> Maybe Version
_retPacVersion :: Maybe Version
    , RetiredPac -> String
_retPacComment :: String
    } deriving (Int -> RetiredPac -> ShowS
[RetiredPac] -> ShowS
RetiredPac -> String
(Int -> RetiredPac -> ShowS)
-> (RetiredPac -> String)
-> ([RetiredPac] -> ShowS)
-> Show RetiredPac
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetiredPac -> ShowS
showsPrec :: Int -> RetiredPac -> ShowS
$cshow :: RetiredPac -> String
show :: RetiredPac -> String
$cshowList :: [RetiredPac] -> ShowS
showList :: [RetiredPac] -> ShowS
Show)
-- package names with no version: all versions are retired.
-- with version: only this version is retired.
-- The "retired" feature is used to filter out retired packages from the API responses.
-- It is not used for the zip file API, which always serves the requested package.
-- It is not used for the HTML per-package page, which always shows the requested package.
-- It is used, however, for the Archive HTML page, which lists only non-retired packages.
-- all APIs, both HTML and JSON, read a parameter "includeRetired" to determine whether to include retired packages in the response.
-- If this parameter is not set, the default is to not include retired packages.


instance FromJSON ArchiveSpec where
    parseJSON :: Value -> Parser ArchiveSpec
parseJSON = String
-> (Object -> Parser ArchiveSpec) -> Value -> Parser ArchiveSpec
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"archiveSpec" ((Object -> Parser ArchiveSpec) -> Value -> Parser ArchiveSpec)
-> (Object -> Parser ArchiveSpec) -> Value -> Parser ArchiveSpec
forall a b. (a -> b) -> a -> b
$ \Object
v -> String
-> [String]
-> Maybe String
-> Maybe String
-> Maybe String
-> [String]
-> Maybe String
-> ArchiveSpec
ArchiveSpec
        (String
 -> [String]
 -> Maybe String
 -> Maybe String
 -> Maybe String
 -> [String]
 -> Maybe String
 -> ArchiveSpec)
-> Parser String
-> Parser
     ([String]
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> [String]
      -> Maybe String
      -> ArchiveSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"name"
        Parser
  ([String]
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> [String]
   -> Maybe String
   -> ArchiveSpec)
-> Parser [String]
-> Parser
     (Maybe String
      -> Maybe String
      -> Maybe String
      -> [String]
      -> Maybe String
      -> ArchiveSpec)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser [String]
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"paths"
        Parser
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> [String]
   -> Maybe String
   -> ArchiveSpec)
-> Parser (Maybe String)
-> Parser
     (Maybe String
      -> Maybe String -> [String] -> Maybe String -> ArchiveSpec)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
        Parser
  (Maybe String
   -> Maybe String -> [String] -> Maybe String -> ArchiveSpec)
-> Parser (Maybe String)
-> Parser (Maybe String -> [String] -> Maybe String -> ArchiveSpec)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"URL"
        Parser (Maybe String -> [String] -> Maybe String -> ArchiveSpec)
-> Parser (Maybe String)
-> Parser ([String] -> Maybe String -> ArchiveSpec)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dataURL"
        Parser ([String] -> Maybe String -> ArchiveSpec)
-> Parser [String] -> Parser (Maybe String -> ArchiveSpec)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Object
v Object -> Key -> Parser (Maybe [String])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"excludeFromMap") Parser (Maybe [String])
-> (Maybe [String] -> Parser [String]) -> Parser [String]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser [String]
-> ([String] -> Parser [String])
-> Maybe [String]
-> Parser [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> Parser [String]
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return []) [String] -> Parser [String]
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return)
        Parser (Maybe String -> ArchiveSpec)
-> Parser (Maybe String) -> Parser ArchiveSpec
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"retiredPackagesFile")

newtype ArchiveConfig = ArchiveConfig [ArchiveSpec] deriving Int -> ArchiveConfig -> ShowS
[ArchiveConfig] -> ShowS
ArchiveConfig -> String
(Int -> ArchiveConfig -> ShowS)
-> (ArchiveConfig -> String)
-> ([ArchiveConfig] -> ShowS)
-> Show ArchiveConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchiveConfig -> ShowS
showsPrec :: Int -> ArchiveConfig -> ShowS
$cshow :: ArchiveConfig -> String
show :: ArchiveConfig -> String
$cshowList :: [ArchiveConfig] -> ShowS
showList :: [ArchiveConfig] -> ShowS
Show

instance FromJSON ArchiveConfig where
    parseJSON :: Value -> Parser ArchiveConfig
parseJSON = String
-> (Object -> Parser ArchiveConfig)
-> Value
-> Parser ArchiveConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"archiveConfig" ((Object -> Parser ArchiveConfig) -> Value -> Parser ArchiveConfig)
-> (Object -> Parser ArchiveConfig)
-> Value
-> Parser ArchiveConfig
forall a b. (a -> b) -> a -> b
$ \Object
v -> [ArchiveSpec] -> ArchiveConfig
ArchiveConfig
        ([ArchiveSpec] -> ArchiveConfig)
-> Parser [ArchiveSpec] -> Parser ArchiveConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser [ArchiveSpec]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"archives"


instance FromJSON RetiredPackages where
    parseJSON :: Value -> Parser RetiredPackages
parseJSON = String
-> (Object -> Parser RetiredPackages)
-> Value
-> Parser RetiredPackages
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"retiredPackages" ((Object -> Parser RetiredPackages)
 -> Value -> Parser RetiredPackages)
-> (Object -> Parser RetiredPackages)
-> Value
-> Parser RetiredPackages
forall a b. (a -> b) -> a -> b
$ \Object
v -> String -> Version -> Day -> [RetiredPac] -> RetiredPackages
RetiredPackages
        (String -> Version -> Day -> [RetiredPac] -> RetiredPackages)
-> Parser String
-> Parser (Version -> Day -> [RetiredPac] -> RetiredPackages)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"title"
        Parser (Version -> Day -> [RetiredPac] -> RetiredPackages)
-> Parser Version
-> Parser (Day -> [RetiredPac] -> RetiredPackages)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Version
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"version"
        Parser (Day -> [RetiredPac] -> RetiredPackages)
-> Parser Day -> Parser ([RetiredPac] -> RetiredPackages)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Day
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"lastModified"
        Parser ([RetiredPac] -> RetiredPackages)
-> Parser [RetiredPac] -> Parser RetiredPackages
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser [RetiredPac]
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"packages"

instance FromJSON RetiredPac where
    parseJSON :: Value -> Parser RetiredPac
parseJSON = String
-> (Object -> Parser RetiredPac) -> Value -> Parser RetiredPac
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"retiredPac" ((Object -> Parser RetiredPac) -> Value -> Parser RetiredPac)
-> (Object -> Parser RetiredPac) -> Value -> Parser RetiredPac
forall a b. (a -> b) -> a -> b
$ \Object
v -> String -> Maybe Version -> String -> RetiredPac
RetiredPac
        (String -> Maybe Version -> String -> RetiredPac)
-> Parser String -> Parser (Maybe Version -> String -> RetiredPac)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"name"
        Parser (Maybe Version -> String -> RetiredPac)
-> Parser (Maybe Version) -> Parser (String -> RetiredPac)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Version)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"version"
        Parser (String -> RetiredPac) -> Parser String -> Parser RetiredPac
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"comment"

parseArchiveConfigFile :: (MonadIO m) => FilePath -> m ArchiveConfig
parseArchiveConfigFile :: forall (m :: * -> *). MonadIO m => String -> m ArchiveConfig
parseArchiveConfigFile = String -> m ArchiveConfig
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
decodeFileThrow

-- Stores to be used by the server App

type ArchiveStore a = [(ArchiveSpec, a)] -- a generic lookup table from an archive specification to an item

type ArchiveStorePackages = ArchiveStore [PoseidonPackage]
type ArchiveStoreZipFiles = ArchiveStore ZipStore

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

getArchiveSpecs :: ArchiveStore a -> [ArchiveSpec]
getArchiveSpecs :: forall a. ArchiveStore a -> [ArchiveSpec]
getArchiveSpecs = ((ArchiveSpec, a) -> ArchiveSpec)
-> [(ArchiveSpec, a)] -> [ArchiveSpec]
forall a b. (a -> b) -> [a] -> [b]
map (ArchiveSpec, a) -> ArchiveSpec
forall a b. (a, b) -> a
fst

extractFromArchive :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m (ArchiveSpec, a)
extractFromArchive :: forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m (ArchiveSpec, a)
extractFromArchive String
name ArchiveStore a
store =
    case ((ArchiveSpec, a) -> Bool) -> ArchiveStore a -> ArchiveStore a
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ArchiveSpec
spec, a
_) -> ArchiveSpec -> String
_archSpecName ArchiveSpec
spec String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name) ArchiveStore a
store of
      []     -> String -> m (ArchiveSpec, a)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (ArchiveSpec, a)) -> String -> m (ArchiveSpec, a)
forall a b. (a -> b) -> a -> b
$ String
"Archive " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not exist"
      [(ArchiveSpec, a)
pair] -> (ArchiveSpec, a) -> m (ArchiveSpec, a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArchiveSpec, a)
pair
      ArchiveStore a
_      -> String -> m (ArchiveSpec, a)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (ArchiveSpec, a)) -> String -> m (ArchiveSpec, a)
forall a b. (a -> b) -> a -> b
$ String
"Archive " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is ambiguous"

getArchiveSpecByName :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m ArchiveSpec
getArchiveSpecByName :: forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m ArchiveSpec
getArchiveSpecByName String
name ArchiveStore a
store = (ArchiveSpec, a) -> ArchiveSpec
forall a b. (a, b) -> a
fst ((ArchiveSpec, a) -> ArchiveSpec)
-> m (ArchiveSpec, a) -> m ArchiveSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ArchiveStore a -> m (ArchiveSpec, a)
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m (ArchiveSpec, a)
extractFromArchive String
name ArchiveStore a
store

getArchiveContentByName :: (MonadFail m) => ArchiveName -> ArchiveStore a -> m a
getArchiveContentByName :: forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m a
getArchiveContentByName String
name ArchiveStore a
store = (ArchiveSpec, a) -> a
forall a b. (a, b) -> b
snd ((ArchiveSpec, a) -> a) -> m (ArchiveSpec, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ArchiveStore a -> m (ArchiveSpec, a)
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m (ArchiveSpec, a)
extractFromArchive String
name ArchiveStore a
store

readArchiveStore :: ArchiveConfig -> PackageReadOptions -> PoseidonIO ArchiveStorePackages
readArchiveStore :: ArchiveConfig
-> PackageReadOptions -> PoseidonIO ArchiveStorePackages
readArchiveStore (ArchiveConfig [ArchiveSpec]
archiveSpecs) PackageReadOptions
pacReadOpts = do
    [ArchiveSpec]
-> (ArchiveSpec -> ReaderT Env IO (ArchiveSpec, [PoseidonPackage]))
-> PoseidonIO ArchiveStorePackages
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ArchiveSpec]
archiveSpecs ((ArchiveSpec -> ReaderT Env IO (ArchiveSpec, [PoseidonPackage]))
 -> PoseidonIO ArchiveStorePackages)
-> (ArchiveSpec -> ReaderT Env IO (ArchiveSpec, [PoseidonPackage]))
-> PoseidonIO ArchiveStorePackages
forall a b. (a -> b) -> a -> b
$ \ArchiveSpec
spec -> do
        String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Loading packages for archive " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ArchiveSpec -> String
_archSpecName ArchiveSpec
spec
        let relevantDirs :: [String]
relevantDirs = ArchiveSpec -> [String]
_archSpecPaths ArchiveSpec
spec
        [PoseidonPackage]
pacs <- PackageReadOptions -> [String] -> PoseidonIO [PoseidonPackage]
readPoseidonPackageCollection PackageReadOptions
pacReadOpts [String]
relevantDirs
        (ArchiveSpec, [PoseidonPackage])
-> ReaderT Env IO (ArchiveSpec, [PoseidonPackage])
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchiveSpec
spec, [PoseidonPackage]
pacs)

createZipArchiveStore :: ArchiveStorePackages -> FilePath -> PoseidonIO ArchiveStoreZipFiles
createZipArchiveStore :: ArchiveStorePackages -> String -> PoseidonIO ArchiveStoreZipFiles
createZipArchiveStore ArchiveStorePackages
archiveStore String
zipPath =
    ArchiveStorePackages
-> ((ArchiveSpec, [PoseidonPackage])
    -> ReaderT Env IO (ArchiveSpec, ZipStore))
-> PoseidonIO ArchiveStoreZipFiles
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ArchiveStorePackages
archiveStore (((ArchiveSpec, [PoseidonPackage])
  -> ReaderT Env IO (ArchiveSpec, ZipStore))
 -> PoseidonIO ArchiveStoreZipFiles)
-> ((ArchiveSpec, [PoseidonPackage])
    -> ReaderT Env IO (ArchiveSpec, ZipStore))
-> PoseidonIO ArchiveStoreZipFiles
forall a b. (a -> b) -> a -> b
$ \(ArchiveSpec
spec, [PoseidonPackage]
packages) -> do
        String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Zipping packages in archive " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ArchiveSpec -> String
_archSpecName ArchiveSpec
spec
        (ArchiveSpec
spec,) (ZipStore -> (ArchiveSpec, ZipStore))
-> ReaderT Env IO ZipStore
-> ReaderT Env IO (ArchiveSpec, ZipStore)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoseidonPackage]
-> (PoseidonPackage -> ReaderT Env IO (PacNameAndVersion, String))
-> ReaderT Env IO ZipStore
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PoseidonPackage]
packages (\PoseidonPackage
pac -> do
            String -> PoseidonIO ()
logInfo String
"Checking whether zip files are missing or outdated"
            IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
zipPath String -> ShowS
</> ArchiveSpec -> String
_archSpecName ArchiveSpec
spec)
            let combinedPackageVersionTitle :: String
combinedPackageVersionTitle = PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
renderNameWithVersion PoseidonPackage
pac
            let fn :: String
fn = String
zipPath String -> ShowS
</> ArchiveSpec -> String
_archSpecName ArchiveSpec
spec String -> ShowS
</> String
combinedPackageVersionTitle String -> ShowS
<.> String
"zip"
            Bool
zipFileOutdated <- IO Bool -> ReaderT Env IO Bool
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT Env IO Bool) -> IO Bool -> ReaderT Env IO Bool
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> String -> IO Bool
checkZipFileOutdated PoseidonPackage
pac String
fn
            Bool -> PoseidonIO () -> PoseidonIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
zipFileOutdated (PoseidonIO () -> PoseidonIO ()) -> PoseidonIO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ do
                String -> PoseidonIO ()
logInfo (String
"Zip Archive for package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
combinedPackageVersionTitle String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" missing or outdated. Zipping now")
                Archive
zip_ <- IO Archive -> ReaderT Env IO Archive
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Archive -> ReaderT Env IO Archive)
-> IO Archive -> ReaderT Env IO Archive
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> IO Archive
makeZipArchive PoseidonPackage
pac
                let zip_raw :: ByteString
zip_raw = Archive -> ByteString
fromArchive Archive
zip_
                IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
B.writeFile String
fn ByteString
zip_raw
            (PacNameAndVersion, String)
-> ReaderT Env IO (PacNameAndVersion, String)
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PoseidonPackage -> PacNameAndVersion
posPacNameAndVersion PoseidonPackage
pac, String
fn))

runServerMainThread :: ServeOptions -> PoseidonIO ()
runServerMainThread :: ServeOptions -> PoseidonIO ()
runServerMainThread ServeOptions
opts = do
    -- the MVar is used as a signal from the server to the calling thread that it is ready.
    -- It is used for testing. Here we just use it as a dummy.
    MVar ()
dummy <- IO (MVar ()) -> ReaderT Env IO (MVar ())
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    ServeOptions -> MVar () -> PoseidonIO ()
runServer ServeOptions
opts MVar ()
dummy

runServer :: ServeOptions -> MVar () -> PoseidonIO ()
runServer :: ServeOptions -> MVar () -> PoseidonIO ()
runServer (ServeOptions Either ArchiveConfig String
archBaseDirs Maybe String
maybeZipPath Int
port Bool
ignoreChecksums Maybe (String, [String], String)
certFiles) MVar ()
serverReady = do
    let archiveZip :: Bool
archiveZip = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
maybeZipPath
        pacReadOpts :: PackageReadOptions
pacReadOpts = PackageReadOptions
defaultPackageReadOptions {
              _readOptIgnoreChecksums  = ignoreChecksums
            , _readOptGenoCheck        = archiveZip
        }

    String -> PoseidonIO ()
logInfo String
"Server starting up. Loading packages..."
    ArchiveStorePackages
archiveStore <- case Either ArchiveConfig String
archBaseDirs of
        Left ArchiveConfig
archiveConfig -> ArchiveConfig
-> PackageReadOptions -> PoseidonIO ArchiveStorePackages
readArchiveStore ArchiveConfig
archiveConfig PackageReadOptions
pacReadOpts
        Right String
path -> do
            ArchiveConfig
archiveConfig <- String -> ReaderT Env IO ArchiveConfig
forall (m :: * -> *). MonadIO m => String -> m ArchiveConfig
parseArchiveConfigFile String
path
            ArchiveConfig
-> PackageReadOptions -> PoseidonIO ArchiveStorePackages
readArchiveStore ArchiveConfig
archiveConfig PackageReadOptions
pacReadOpts

    String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Using " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ArchiveSpec -> String
_archSpecName (ArchiveSpec -> String)
-> (ArchiveStorePackages -> ArchiveSpec)
-> ArchiveStorePackages
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ArchiveSpec, [PoseidonPackage]) -> ArchiveSpec
forall a b. (a, b) -> a
fst ((ArchiveSpec, [PoseidonPackage]) -> ArchiveSpec)
-> (ArchiveStorePackages -> (ArchiveSpec, [PoseidonPackage]))
-> ArchiveStorePackages
-> ArchiveSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveStorePackages -> (ArchiveSpec, [PoseidonPackage])
forall a. HasCallStack => [a] -> a
head) ArchiveStorePackages
archiveStore String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" as the default archive"

    ArchiveStoreZipFiles
zipArchiveStore <- case Maybe String
maybeZipPath of
        Maybe String
Nothing -> ArchiveStoreZipFiles -> PoseidonIO ArchiveStoreZipFiles
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just String
z  -> ArchiveStorePackages -> String -> PoseidonIO ArchiveStoreZipFiles
createZipArchiveStore ArchiveStorePackages
archiveStore String
z

    let archiveSpecs :: [ArchiveSpec]
archiveSpecs = ArchiveStorePackages -> [ArchiveSpec]
forall a. ArchiveStore a -> [ArchiveSpec]
getArchiveSpecs ArchiveStorePackages
archiveStore

    let runScotty :: ScottyM () -> PoseidonIO ()
runScotty = case Maybe (String, [String], String)
certFiles of
            Maybe (String, [String], String)
Nothing                              -> MVar () -> Int -> ScottyM () -> PoseidonIO ()
scottyHTTP  MVar ()
serverReady Int
port
            Just (String
certFile, [String]
chainFiles, String
keyFile) -> MVar ()
-> Int
-> String
-> [String]
-> String
-> ScottyM ()
-> PoseidonIO ()
scottyHTTPS MVar ()
serverReady Int
port String
certFile [String]
chainFiles String
keyFile

    LogA
logA <- PoseidonIO LogA
envLogAction
    ScottyM () -> PoseidonIO ()
runScotty (ScottyM () -> PoseidonIO ()) -> ScottyM () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ do
        Middleware -> ScottyM ()
middleware Middleware
simpleCors

        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/server_version" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            Text -> ActionM ()
text (Text -> ActionM ()) -> (Version -> Text) -> Version -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (Version -> String) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
showVersion (Version -> ActionM ()) -> Version -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Version
version

        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/packages" (ActionM () -> ScottyM ())
-> (ActionM ServerApiReturnType -> ActionM ())
-> ActionM ServerApiReturnType
-> ScottyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion (ActionM ServerApiReturnType -> ScottyM ())
-> ActionM ServerApiReturnType -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            [PacNameAndVersion]
retiredPacs <- ArchiveStorePackages -> ActionM ArchiveSpec
forall a. ArchiveStore a -> ActionM ArchiveSpec
getArchiveSpecFromArchiveStore ArchiveStorePackages
archiveStore ActionM ArchiveSpec
-> (ArchiveSpec -> ActionT IO [PacNameAndVersion])
-> ActionT IO [PacNameAndVersion]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ArchiveSpec -> ActionT IO [PacNameAndVersion]
forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages
            [PoseidonPackage]
pacs <- ArchiveStorePackages -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStorePackages
archiveStore ActionM [PoseidonPackage]
-> ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ActionM [PoseidonPackage]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
retiredPacs
            [PackageInfo]
pacInfos <- Bool -> [PoseidonPackage] -> ActionT IO [PackageInfo]
forall (m :: * -> *).
MonadThrow m =>
Bool -> [PoseidonPackage] -> m [PackageInfo]
packagesToPackageInfos Bool
False [PoseidonPackage]
pacs
            let retData :: ApiReturnData
retData = [PackageInfo] -> ApiReturnData
ApiReturnPackageInfo [PackageInfo]
pacInfos
            ServerApiReturnType -> ActionM ServerApiReturnType
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerApiReturnType -> ActionM ServerApiReturnType)
-> ServerApiReturnType -> ActionM ServerApiReturnType
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType [] (ApiReturnData -> Maybe ApiReturnData
forall a. a -> Maybe a
Just ApiReturnData
retData)

        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/groups" (ActionM () -> ScottyM ())
-> (ActionM ServerApiReturnType -> ActionM ())
-> ActionM ServerApiReturnType
-> ScottyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion (ActionM ServerApiReturnType -> ScottyM ())
-> ActionM ServerApiReturnType -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            [PacNameAndVersion]
retiredPacs <- ArchiveStorePackages -> ActionM ArchiveSpec
forall a. ArchiveStore a -> ActionM ArchiveSpec
getArchiveSpecFromArchiveStore ArchiveStorePackages
archiveStore ActionM ArchiveSpec
-> (ArchiveSpec -> ActionT IO [PacNameAndVersion])
-> ActionT IO [PacNameAndVersion]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ArchiveSpec -> ActionT IO [PacNameAndVersion]
forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages
            [PoseidonPackage]
pacs <- ArchiveStorePackages -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStorePackages
archiveStore ActionM [PoseidonPackage]
-> ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ActionM [PoseidonPackage]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
retiredPacs
            [GroupInfo]
groupInfos <- [PoseidonPackage] -> ActionT IO [GroupInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> m [GroupInfo]
getAllGroupInfo [PoseidonPackage]
pacs
            let retData :: ApiReturnData
retData = [GroupInfo] -> ApiReturnData
ApiReturnGroupInfo [GroupInfo]
groupInfos
            ServerApiReturnType -> ActionM ServerApiReturnType
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerApiReturnType -> ActionM ServerApiReturnType)
-> ServerApiReturnType -> ActionM ServerApiReturnType
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType [] (ApiReturnData -> Maybe ApiReturnData
forall a. a -> Maybe a
Just ApiReturnData
retData)

        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/individuals" (ActionM () -> ScottyM ())
-> (ActionM ServerApiReturnType -> ActionM ())
-> ActionM ServerApiReturnType
-> ScottyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion (ActionM ServerApiReturnType -> ScottyM ())
-> ActionM ServerApiReturnType -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            [PacNameAndVersion]
retiredPacs <- ArchiveStorePackages -> ActionM ArchiveSpec
forall a. ArchiveStore a -> ActionM ArchiveSpec
getArchiveSpecFromArchiveStore ArchiveStorePackages
archiveStore ActionM ArchiveSpec
-> (ArchiveSpec -> ActionT IO [PacNameAndVersion])
-> ActionT IO [PacNameAndVersion]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ArchiveSpec -> ActionT IO [PacNameAndVersion]
forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages
            [PoseidonPackage]
pacs <- ArchiveStorePackages -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStorePackages
archiveStore ActionM [PoseidonPackage]
-> ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ActionM [PoseidonPackage]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
retiredPacs
            Maybe String
maybeAdditionalColumnsString <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"additionalJannoColumns"
            [ExtendedIndividualInfo]
indInfo <- case Maybe String
maybeAdditionalColumnsString of
                    Just String
"ALL" -> [PoseidonPackage]
-> AddColSpec -> ActionT IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs AddColSpec
AddColAll -- Nothing means all Janno Columns
                    Just String
additionalColumnsString ->
                        let additionalColumnNames :: [String]
additionalColumnNames = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"," String
additionalColumnsString
                        in  [PoseidonPackage]
-> AddColSpec -> ActionT IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs ([String] -> AddColSpec
AddColList [String]
additionalColumnNames)
                    Maybe String
Nothing -> [PoseidonPackage]
-> AddColSpec -> ActionT IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs ([String] -> AddColSpec
AddColList [])
            let retData :: ApiReturnData
retData = [ExtendedIndividualInfo] -> ApiReturnData
ApiReturnExtIndividualInfo [ExtendedIndividualInfo]
indInfo
            ServerApiReturnType -> ActionM ServerApiReturnType
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerApiReturnType -> ActionM ServerApiReturnType)
-> ServerApiReturnType -> ActionM ServerApiReturnType
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType [] (ApiReturnData -> Maybe ApiReturnData
forall a. a -> Maybe a
Just ApiReturnData
retData)

        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/bibliography" (ActionM () -> ScottyM ())
-> (ActionM ServerApiReturnType -> ActionM ())
-> ActionM ServerApiReturnType
-> ScottyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion (ActionM ServerApiReturnType -> ScottyM ())
-> ActionM ServerApiReturnType -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            [PacNameAndVersion]
retiredPacs <- ArchiveStorePackages -> ActionM ArchiveSpec
forall a. ArchiveStore a -> ActionM ArchiveSpec
getArchiveSpecFromArchiveStore ArchiveStorePackages
archiveStore ActionM ArchiveSpec
-> (ArchiveSpec -> ActionT IO [PacNameAndVersion])
-> ActionT IO [PacNameAndVersion]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ArchiveSpec -> ActionT IO [PacNameAndVersion]
forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages
            [PoseidonPackage]
pacs <- ArchiveStorePackages -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStorePackages
archiveStore ActionM [PoseidonPackage]
-> ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ActionM [PoseidonPackage]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
retiredPacs
            Maybe String
maybeAdditionalBibFieldsString <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"additionalBibColumns"
            [BibliographyInfo]
bibInfo <- case Maybe String
maybeAdditionalBibFieldsString of
                    Just String
"ALL" -> [PoseidonPackage] -> AddColSpec -> ActionT IO [BibliographyInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [BibliographyInfo]
getBibliographyInfo [PoseidonPackage]
pacs AddColSpec
AddColAll -- Nothing means all Janno Columns
                    Just String
additionalBibFieldsString ->
                        let additionalBibFields :: [String]
additionalBibFields = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"," String
additionalBibFieldsString
                        in  [PoseidonPackage] -> AddColSpec -> ActionT IO [BibliographyInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [BibliographyInfo]
getBibliographyInfo [PoseidonPackage]
pacs ([String] -> AddColSpec
AddColList [String]
additionalBibFields)
                    Maybe String
Nothing -> [PoseidonPackage] -> AddColSpec -> ActionT IO [BibliographyInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [BibliographyInfo]
getBibliographyInfo [PoseidonPackage]
pacs ([String] -> AddColSpec
AddColList [])
            let retData :: ApiReturnData
retData = [BibliographyInfo] -> ApiReturnData
ApiReturnBibInfo [BibliographyInfo]
bibInfo
            ServerApiReturnType -> ActionM ServerApiReturnType
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerApiReturnType -> ActionM ServerApiReturnType)
-> ServerApiReturnType -> ActionM ServerApiReturnType
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType [] (ApiReturnData -> Maybe ApiReturnData
forall a. a -> Maybe a
Just ApiReturnData
retData)

        -- API for retreiving package zip files
        Bool -> ScottyM () -> ScottyM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
archiveZip (ScottyM () -> ScottyM ())
-> (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/zip_file/:package_name" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            -- here we do not filter on retired. Requested packages are always served.
            ZipStore
zipStore <- ArchiveStoreZipFiles -> ActionM ZipStore
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStoreZipFiles
zipArchiveStore
            String
packageName <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            Maybe String
maybeVersionString <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"package_version"
            Maybe Version
maybeVersion <- case Maybe String
maybeVersionString of
                Maybe String
Nothing -> Maybe Version -> ActionT IO (Maybe Version)
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
                Just String
versionStr -> case String -> Maybe Version
parseVersionString String
versionStr of
                    Maybe Version
Nothing -> String -> ActionT IO (Maybe Version)
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionT IO (Maybe Version))
-> String -> ActionT IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ String
"Could not parse package version string " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
versionStr
                    Just Version
v -> Maybe Version -> ActionT IO (Maybe Version)
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> ActionT IO (Maybe Version))
-> Maybe Version -> ActionT IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
            case ((PacNameAndVersion, String) -> Down PacNameAndVersion)
-> ZipStore -> ZipStore
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (PacNameAndVersion -> Down PacNameAndVersion
forall a. a -> Down a
Down (PacNameAndVersion -> Down PacNameAndVersion)
-> ((PacNameAndVersion, String) -> PacNameAndVersion)
-> (PacNameAndVersion, String)
-> Down PacNameAndVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PacNameAndVersion, String) -> PacNameAndVersion
forall a b. (a, b) -> a
fst) (ZipStore -> ZipStore)
-> (ZipStore -> ZipStore) -> ZipStore -> ZipStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PacNameAndVersion, String) -> Bool) -> ZipStore -> ZipStore
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
packageName) (String -> Bool)
-> ((PacNameAndVersion, String) -> String)
-> (PacNameAndVersion, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacNameAndVersion -> String
forall a. HasNameAndVersion a => a -> String
getPacName (PacNameAndVersion -> String)
-> ((PacNameAndVersion, String) -> PacNameAndVersion)
-> (PacNameAndVersion, String)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PacNameAndVersion, String) -> PacNameAndVersion
forall a b. (a, b) -> a
fst) (ZipStore -> ZipStore) -> ZipStore -> ZipStore
forall a b. (a -> b) -> a -> b
$ ZipStore
zipStore of
                [] -> String -> ActionM ()
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"unknown package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
packageName -- no version found
                [(PacNameAndVersion
pacNameAndVersion, String
fn)] -> case Maybe Version
maybeVersion of -- exactly one version found
                    Maybe Version
Nothing -> String -> ActionM ()
file String
fn
                    Just Version
v -> if PacNameAndVersion -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PacNameAndVersion
pacNameAndVersion Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
                            then String -> ActionM ()
file String
fn
                            else
                                String -> ActionM ()
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"Package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
packageName String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                    String
" is not available for version " String -> ShowS
forall a. [a] -> [a] -> [a]
++Version -> String
showVersion Version
v
                pl :: ZipStore
pl@((PacNameAndVersion
_, String
fnLatest) : ZipStore
_) -> case Maybe Version
maybeVersion of
                    Maybe Version
Nothing -> String -> ActionM ()
file String
fnLatest
                    Just Version
v -> case ((PacNameAndVersion, String) -> Bool) -> ZipStore -> ZipStore
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
==Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v) (Maybe Version -> Bool)
-> ((PacNameAndVersion, String) -> Maybe Version)
-> (PacNameAndVersion, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacNameAndVersion -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion (PacNameAndVersion -> Maybe Version)
-> ((PacNameAndVersion, String) -> PacNameAndVersion)
-> (PacNameAndVersion, String)
-> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PacNameAndVersion, String) -> PacNameAndVersion
forall a b. (a, b) -> a
fst) ZipStore
pl of
                        [] -> String -> ActionM ()
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$
                            String
"Package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
packageName String -> ShowS
forall a. [a] -> [a] -> [a]
++
                            String
"is not available for version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
v
                        [(PacNameAndVersion
_, String
fn)] -> String -> ActionM ()
file String
fn
                        ZipStore
_ -> String -> ActionM ()
forall a. HasCallStack => String -> a
error String
"Should never happen" -- packageCollection should have been filtered to have only one version per package

        -- html API

        -- css stylesheet
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/styles.css" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> Text -> ActionM ()
setHeader Text
"Content-Type" Text
"text/css; charset=utf-8"
            ByteString -> ActionM ()
raw ByteString
stylesBS
        -- landing page
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> ActionM ()
forall a. Text -> ActionM a
redirect Text
"/explorer"
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/explorer" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            [(String, Maybe String, Maybe String, [PoseidonPackage])]
pacsPerArchive <- [ArchiveSpec]
-> (ArchiveSpec
    -> ActionT
         IO (String, Maybe String, Maybe String, [PoseidonPackage]))
-> ActionT
     IO [(String, Maybe String, Maybe String, [PoseidonPackage])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ArchiveSpec]
archiveSpecs ((ArchiveSpec
  -> ActionT
       IO (String, Maybe String, Maybe String, [PoseidonPackage]))
 -> ActionT
      IO [(String, Maybe String, Maybe String, [PoseidonPackage])])
-> (ArchiveSpec
    -> ActionT
         IO (String, Maybe String, Maybe String, [PoseidonPackage]))
-> ActionT
     IO [(String, Maybe String, Maybe String, [PoseidonPackage])]
forall a b. (a -> b) -> a -> b
$ \ArchiveSpec
spec -> do
                let n :: String
n = ArchiveSpec -> String
_archSpecName ArchiveSpec
spec
                    d :: Maybe String
d = ArchiveSpec -> Maybe String
_archSpecDescription ArchiveSpec
spec
                    u :: Maybe String
u = ArchiveSpec -> Maybe String
_archSpecURL ArchiveSpec
spec
                [PacNameAndVersion]
re <- ArchiveSpec -> ActionT IO [PacNameAndVersion]
forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages ArchiveSpec
spec
                [PoseidonPackage]
pacs <- String -> ArchiveStorePackages -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m a
getArchiveContentByName String
n ArchiveStorePackages
archiveStore ActionM [PoseidonPackage]
-> ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ActionM [PoseidonPackage]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
re ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ([PoseidonPackage] -> [PoseidonPackage])
-> [PoseidonPackage]
-> ActionM [PoseidonPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PoseidonPackage] -> [PoseidonPackage]
selectLatest
                (String, Maybe String, Maybe String, [PoseidonPackage])
-> ActionT
     IO (String, Maybe String, Maybe String, [PoseidonPackage])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
n, Maybe String
d, Maybe String
u, [PoseidonPackage]
pacs)
            [(String, Maybe String, Maybe String, [PoseidonPackage])]
-> ActionM ()
mainPage [(String, Maybe String, Maybe String, [PoseidonPackage])]
pacsPerArchive
        -- archive pages
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/explorer/:archive_name" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            String
archiveName <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            ArchiveSpec
spec <- String -> ArchiveStorePackages -> ActionM ArchiveSpec
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m ArchiveSpec
getArchiveSpecByName String
archiveName ArchiveStorePackages
archiveStore
            let maybeArchiveDataURL :: Maybe String
maybeArchiveDataURL = ArchiveSpec -> Maybe String
_archSpecDataURL ArchiveSpec
spec
                excludeFromMap :: [String]
excludeFromMap = ArchiveSpec -> [String]
_archSpecExcludePacsFromMap ArchiveSpec
spec
            [PacNameAndVersion]
retiredPacs <- ArchiveSpec -> ActionT IO [PacNameAndVersion]
forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages ArchiveSpec
spec
            [PoseidonPackage]
latestPacs <- [PoseidonPackage] -> [PoseidonPackage]
selectLatest ([PoseidonPackage] -> [PoseidonPackage])
-> ActionM [PoseidonPackage] -> ActionM [PoseidonPackage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ArchiveStorePackages -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m a
getArchiveContentByName String
archiveName ArchiveStorePackages
archiveStore ActionM [PoseidonPackage]
-> ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> ActionM [PoseidonPackage]
forall a b. ActionT IO a -> (a -> ActionT IO b) -> ActionT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
retiredPacs)
            let packagesToMap :: [PoseidonPackage]
packagesToMap = [String] -> [PoseidonPackage] -> [PoseidonPackage]
excludePackagesByName [String]
excludeFromMap [PoseidonPackage]
latestPacs
                nrSamplesToMap :: Int
nrSamplesToMap = (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]
packagesToMap
                mapMarkers :: [MapMarker]
mapMarkers = (PoseidonPackage -> [MapMarker])
-> [PoseidonPackage] -> [MapMarker]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> PoseidonPackage -> [MapMarker]
prepMappable String
archiveName) [PoseidonPackage]
packagesToMap
            String
-> Maybe String
-> Bool
-> [String]
-> Int
-> [MapMarker]
-> [PoseidonPackage]
-> ActionM ()
archivePage String
archiveName Maybe String
maybeArchiveDataURL Bool
archiveZip [String]
excludeFromMap Int
nrSamplesToMap [MapMarker]
mapMarkers [PoseidonPackage]
latestPacs
        -- per package pages
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/explorer/:archive_name/:package_name" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            -- we do not filter by retired. A requested package is always shown, even if it is retired.
            Text
archive_name <- Text -> ActionM Text
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            Text
package_name <- Text -> ActionM Text
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            Text -> ActionM ()
forall a. Text -> ActionM a
redirect (Text
"/explorer/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
archive_name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
package_name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/latest")
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/explorer/:archive_name/:package_name/:package_version" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            String
archiveName      <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            String
pacName          <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            String
pacVersionString <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_version"
            PacVersion
pacVersionWL <- case String -> Maybe PacVersion
parsePackageVersionString String
pacVersionString of
                Maybe PacVersion
Nothing -> String -> ActionT IO PacVersion
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionT IO PacVersion)
-> String -> ActionT IO PacVersion
forall a b. (a -> b) -> a -> b
$ String
"Could not parse package version string " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pacVersionString
                Just PacVersion
v -> PacVersion -> ActionT IO PacVersion
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PacVersion
v
            [PoseidonPackage]
allPacs     <- String -> ArchiveStorePackages -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m a
getArchiveContentByName String
archiveName ArchiveStorePackages
archiveStore
            [PoseidonPackage]
allVersions <- String -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions String
pacName [PoseidonPackage]
allPacs
            PoseidonPackage
oneVersion  <- PacVersion -> [PoseidonPackage] -> ActionM PoseidonPackage
prepPacVersion PacVersion
pacVersionWL [PoseidonPackage]
allVersions
            let mapMarkers :: [MapMarker]
mapMarkers = String -> PoseidonPackage -> [MapMarker]
prepMappable String
archiveName PoseidonPackage
oneVersion
                bib :: String
bib = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (BibEntry -> String) -> [BibEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map BibEntry -> String
renderBibEntry ([BibEntry] -> [String]) -> [BibEntry] -> [String]
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> [BibEntry]
posPacBib PoseidonPackage
oneVersion
                pacVersion :: Maybe Version
pacVersion = PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
oneVersion
            [JannoRow]
samples <- PoseidonPackage -> ActionM [JannoRow]
prepSamples PoseidonPackage
oneVersion
            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
        -- per sample pages
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/explorer/:archive_name/:package_name/:package_version/:sample" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            LogA -> ActionM ()
logRequest LogA
logA
            String
archiveName <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            [PoseidonPackage]
allPacs <- String -> ArchiveStorePackages -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m a
getArchiveContentByName String
archiveName ArchiveStorePackages
archiveStore
            String
pacName <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            [PoseidonPackage]
allVersions <- String -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions String
pacName [PoseidonPackage]
allPacs
            String
pacVersionString <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_version"
            PacVersion
pacVersionWL <- case String -> Maybe PacVersion
parsePackageVersionString String
pacVersionString of
                    Maybe PacVersion
Nothing -> String -> ActionT IO PacVersion
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionT IO PacVersion)
-> String -> ActionT IO PacVersion
forall a b. (a -> b) -> a -> b
$ String
"Could not parse package version string " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pacVersionString
                    Just PacVersion
v -> PacVersion -> ActionT IO PacVersion
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PacVersion
v
            PoseidonPackage
oneVersion <- PacVersion -> [PoseidonPackage] -> ActionM PoseidonPackage
prepPacVersion PacVersion
pacVersionWL [PoseidonPackage]
allVersions
            let pacVersion :: Maybe String
pacVersion = Version -> String
showVersion (Version -> String) -> Maybe Version -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
oneVersion
            [JannoRow]
samples <- PoseidonPackage -> ActionM [JannoRow]
prepSamples PoseidonPackage
oneVersion
            String
sampleName <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
captureParam Text
"sample"
            JannoRow
sample <- String -> [JannoRow] -> ActionM JannoRow
prepSample String
sampleName [JannoRow]
samples
            let maybeMapMarker :: Maybe MapMarker
maybeMapMarker = String -> String -> Maybe String -> JannoRow -> Maybe MapMarker
extractPosJannoRow String
archiveName String
pacName Maybe String
pacVersion JannoRow
sample
            Maybe MapMarker -> JannoRow -> ActionM ()
samplePage Maybe MapMarker
maybeMapMarker JannoRow
sample

        -- catch anything else
        ActionM () -> ScottyM ()
notFound (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ String -> ActionM ()
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown request"


-- prepare data for the html API

excludePackagesByName :: [String] -> [PoseidonPackage] -> [PoseidonPackage]
excludePackagesByName :: [String] -> [PoseidonPackage] -> [PoseidonPackage]
excludePackagesByName [String]
exclude = (PoseidonPackage -> Bool) -> [PoseidonPackage] -> [PoseidonPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PoseidonPackage
pac -> PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
pac String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
exclude)

data PacVersion =
      Latest
    | NumericalVersion Version

instance Show PacVersion where
  show :: PacVersion -> String
show PacVersion
Latest               = String
"latest"
  show (NumericalVersion Version
v) = Version -> String
showVersion Version
v

selectLatest :: [PoseidonPackage] -> [PoseidonPackage]
selectLatest :: [PoseidonPackage] -> [PoseidonPackage]
selectLatest =
      ([PoseidonPackage] -> PoseidonPackage)
-> [[PoseidonPackage]] -> [PoseidonPackage]
forall a b. (a -> b) -> [a] -> [b]
map [PoseidonPackage] -> PoseidonPackage
forall a. HasCallStack => [a] -> a
last
    ([[PoseidonPackage]] -> [PoseidonPackage])
-> ([PoseidonPackage] -> [[PoseidonPackage]])
-> [PoseidonPackage]
-> [PoseidonPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> PoseidonPackage -> Bool)
-> [PoseidonPackage] -> [[PoseidonPackage]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\PoseidonPackage
a PoseidonPackage
b -> PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
b)
    ([PoseidonPackage] -> [[PoseidonPackage]])
-> ([PoseidonPackage] -> [PoseidonPackage])
-> [PoseidonPackage]
-> [[PoseidonPackage]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> PacNameAndVersion)
-> [PoseidonPackage] -> [PoseidonPackage]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn PoseidonPackage -> PacNameAndVersion
posPacNameAndVersion

prepMappable :: String -> PoseidonPackage -> [MapMarker]
prepMappable :: String -> PoseidonPackage -> [MapMarker]
prepMappable String
archiveName PoseidonPackage
pac =
    let packageName :: String
packageName = PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
pac
        packageVersion :: Maybe String
packageVersion = Version -> String
showVersion (Version -> String) -> Maybe Version -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
pac
        jannoRows :: [JannoRow]
jannoRows = JannoRows -> [JannoRow]
getJannoRows (JannoRows -> [JannoRow])
-> (PoseidonPackage -> JannoRows) -> PoseidonPackage -> [JannoRow]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoseidonPackage -> JannoRows
posPacJanno (PoseidonPackage -> [JannoRow]) -> PoseidonPackage -> [JannoRow]
forall a b. (a -> b) -> a -> b
$ PoseidonPackage
pac
    in (JannoRow -> Maybe MapMarker) -> [JannoRow] -> [MapMarker]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> String -> Maybe String -> JannoRow -> Maybe MapMarker
extractPosJannoRow String
archiveName String
packageName Maybe String
packageVersion) [JannoRow]
jannoRows

extractPosJannoRow :: String -> String -> Maybe String -> JannoRow -> Maybe MapMarker
extractPosJannoRow :: String -> String -> Maybe String -> JannoRow -> Maybe MapMarker
extractPosJannoRow String
archiveName String
pacName Maybe String
pacVersion JannoRow
row = case (JannoRow -> Maybe JannoLatitude
jLatitude JannoRow
row, JannoRow -> Maybe JannoLongitude
jLongitude JannoRow
row) of
    (Just (JannoLatitude Double
lat), Just (JannoLongitude Double
lon)) ->
        let poseidonID :: String
poseidonID = JannoRow -> String
jPoseidonID JannoRow
row
            loc :: Maybe String
loc = JannoLocation -> String
forall a. Show a => a -> String
show (JannoLocation -> String) -> Maybe JannoLocation -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JannoRow -> Maybe JannoLocation
jLocation JannoRow
row
            age :: Maybe String
age = JannoDateBCADMedian -> String
forall a. Show a => a -> String
show (JannoDateBCADMedian -> String)
-> Maybe JannoDateBCADMedian -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JannoRow -> Maybe JannoDateBCADMedian
jDateBCADMedian JannoRow
row
        in MapMarker -> Maybe MapMarker
forall a. a -> Maybe a
Just (MapMarker -> Maybe MapMarker) -> MapMarker -> Maybe MapMarker
forall a b. (a -> b) -> a -> b
$ Double
-> Double
-> String
-> String
-> Maybe String
-> String
-> Maybe String
-> Maybe String
-> MapMarker
MapMarker Double
lat Double
lon String
poseidonID String
pacName Maybe String
pacVersion String
archiveName Maybe String
loc Maybe String
age
    (Maybe JannoLatitude, Maybe JannoLongitude)
_                                                     -> Maybe MapMarker
forall a. Maybe a
Nothing

prepPacVersions :: String -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions :: String -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions String
pacName [PoseidonPackage]
pacs = do
    case (PoseidonPackage -> Bool) -> [PoseidonPackage] -> [PoseidonPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PoseidonPackage
pac -> PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
pac String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pacName) [PoseidonPackage]
pacs of
       [] -> String -> ActionM [PoseidonPackage]
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM [PoseidonPackage])
-> String -> ActionM [PoseidonPackage]
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
" does not exist"
       [PoseidonPackage]
xs -> [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [PoseidonPackage]
xs

prepPacVersion :: PacVersion -> [PoseidonPackage] -> ActionM PoseidonPackage
prepPacVersion :: PacVersion -> [PoseidonPackage] -> ActionM PoseidonPackage
prepPacVersion PacVersion
pacVersion [PoseidonPackage]
pacs = do
    case PacVersion
pacVersion of
        PacVersion
Latest -> PoseidonPackage -> ActionM PoseidonPackage
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PoseidonPackage -> ActionM PoseidonPackage)
-> PoseidonPackage -> ActionM PoseidonPackage
forall a b. (a -> b) -> a -> b
$ [PoseidonPackage] -> PoseidonPackage
forall a. HasCallStack => [a] -> a
head ([PoseidonPackage] -> PoseidonPackage)
-> [PoseidonPackage] -> PoseidonPackage
forall a b. (a -> b) -> a -> b
$ [PoseidonPackage] -> [PoseidonPackage]
selectLatest [PoseidonPackage]
pacs
        NumericalVersion Version
v -> case (PoseidonPackage -> Bool) -> [PoseidonPackage] -> [PoseidonPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PoseidonPackage
pac -> PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
pac Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v) [PoseidonPackage]
pacs of
            [] -> String -> ActionM PoseidonPackage
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM PoseidonPackage)
-> String -> ActionM PoseidonPackage
forall a b. (a -> b) -> a -> b
$ String
"Package version " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PacVersion -> String
forall a. Show a => a -> String
show PacVersion
pacVersion String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not exist"
            [PoseidonPackage
x] -> PoseidonPackage -> ActionM PoseidonPackage
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PoseidonPackage
x
            [PoseidonPackage]
_ -> String -> ActionM PoseidonPackage
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM PoseidonPackage)
-> String -> ActionM PoseidonPackage
forall a b. (a -> b) -> a -> b
$ String
"Package version " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PacVersion -> String
forall a. Show a => a -> String
show PacVersion
pacVersion String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" exists multiple times"

prepSamples :: PoseidonPackage -> ActionM [JannoRow]
prepSamples :: PoseidonPackage -> ActionM [JannoRow]
prepSamples PoseidonPackage
pac = [JannoRow] -> ActionM [JannoRow]
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([JannoRow] -> ActionM [JannoRow])
-> [JannoRow] -> ActionM [JannoRow]
forall a b. (a -> b) -> a -> b
$ PoseidonPackage -> [JannoRow]
getJannoRowsFromPac PoseidonPackage
pac

prepSample :: String -> [JannoRow] -> ActionM JannoRow
prepSample :: String -> [JannoRow] -> ActionM JannoRow
prepSample String
sampleName [JannoRow]
rows = do
    case (JannoRow -> Bool) -> [JannoRow] -> [JannoRow]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JannoRow
r -> JannoRow -> String
jPoseidonID JannoRow
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
sampleName) [JannoRow]
rows of
       []  -> String -> ActionM JannoRow
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM JannoRow) -> String -> ActionM JannoRow
forall a b. (a -> b) -> a -> b
$ String
"Sample " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
sampleName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not exist"
       [JannoRow
x] -> JannoRow -> ActionM JannoRow
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JannoRow
x
       [JannoRow]
_   -> String -> ActionM JannoRow
forall a. String -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionM JannoRow) -> String -> ActionM JannoRow
forall a b. (a -> b) -> a -> b
$ String
"Sample " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
sampleName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" exists multiple times"

-- this serves as a point to broadcast messages to clients. Adapt in the future as necessary.
genericServerMessages :: [String]
genericServerMessages :: [String]
genericServerMessages = [String
"Greetings from the Poseidon Server, version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version]


-- other helper functions

parsePackageVersionString :: String -> Maybe PacVersion
parsePackageVersionString :: String -> Maybe PacVersion
parsePackageVersionString String
vStr = case String
vStr of
    String
"" -> PacVersion -> Maybe PacVersion
forall a. a -> Maybe a
Just PacVersion
Latest
    String
"latest" -> PacVersion -> Maybe PacVersion
forall a. a -> Maybe a
Just PacVersion
Latest
    String
x -> case ((Version, String) -> Bool)
-> [(Version, String)] -> [(Version, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"") (String -> Bool)
-> ((Version, String) -> String) -> (Version, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, String) -> String
forall a b. (a, b) -> b
snd) ([(Version, String)] -> [(Version, String)])
-> [(Version, String)] -> [(Version, String)]
forall a b. (a -> b) -> a -> b
$ ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion String
x of
        [(Version
v, String
"")] -> PacVersion -> Maybe PacVersion
forall a. a -> Maybe a
Just (PacVersion -> Maybe PacVersion) -> PacVersion -> Maybe PacVersion
forall a b. (a -> b) -> a -> b
$ Version -> PacVersion
NumericalVersion Version
v
        [(Version, String)]
_         -> Maybe PacVersion
forall a. Maybe a
Nothing

parseVersionString :: String -> Maybe Version
parseVersionString :: String -> Maybe Version
parseVersionString String
vStr = case ((Version, String) -> Bool)
-> [(Version, String)] -> [(Version, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"") (String -> Bool)
-> ((Version, String) -> String) -> (Version, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, String) -> String
forall a b. (a, b) -> b
snd) ([(Version, String)] -> [(Version, String)])
-> [(Version, String)] -> [(Version, String)]
forall a b. (a -> b) -> a -> b
$ ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion String
vStr of
    [(Version
v', String
"")] -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v'
    [(Version, String)]
_          -> Maybe Version
forall a. Maybe a
Nothing

conditionOnClientVersion :: ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion :: ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion ActionM ServerApiReturnType
contentAction = do
    Maybe String
maybeClientVersion <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"client_version"
    (Version
clientVersion, [String]
versionWarnings) <- case Maybe String
maybeClientVersion of
        Maybe String
Nothing            -> (Version, [String]) -> ActionT IO (Version, [String])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, [String
"No client_version passed. Assuming latest version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version])
        Just String
versionString -> case String -> Maybe Version
parseVersionString String
versionString of
            Just Version
v -> (Version, [String]) -> ActionT IO (Version, [String])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
v, [])
            Maybe Version
Nothing -> (Version, [String]) -> ActionT IO (Version, [String])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, [String
"Could not parse Client Version string " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
versionString String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", assuming latest version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version])
    if Version
clientVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
minimalRequiredClientVersion then do
        let msg :: String
msg = String
"This Server API requires trident version at least " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
minimalRequiredClientVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++
                String
"Please go to https://poseidon-framework.github.io/#/trident and update your trident installation."
        ServerApiReturnType -> ActionM ()
forall a. ToJSON a => a -> ActionM ()
json (ServerApiReturnType -> ActionM ())
-> ServerApiReturnType -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType ([String]
genericServerMessages [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
versionWarnings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
msg]) Maybe ApiReturnData
forall a. Maybe a
Nothing
    else do
        ServerApiReturnType [String]
messages Maybe ApiReturnData
content <- ActionM ServerApiReturnType
contentAction
        ServerApiReturnType -> ActionM ()
forall a. ToJSON a => a -> ActionM ()
json (ServerApiReturnType -> ActionM ())
-> ServerApiReturnType -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType ([String]
genericServerMessages [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
versionWarnings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
messages) Maybe ApiReturnData
content

checkZipFileOutdated :: PoseidonPackage -> FilePath -> IO Bool
checkZipFileOutdated :: PoseidonPackage -> String -> IO Bool
checkZipFileOutdated PoseidonPackage
pac String
fn = do
    Bool
zipFileExists <- String -> IO Bool
doesFileExist String
fn
    if Bool
zipFileExists
    then do
        UTCTime
zipModTime <- String -> IO UTCTime
getModificationTime String
fn
        Bool
yamlOutdated <- UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
"POSEIDON.yml")
        Bool
bibOutdated <- case PoseidonPackage -> Maybe String
posPacBibFile PoseidonPackage
pac of
            Just String
fn_ -> UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
fn_)
            Maybe String
Nothing  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
jannoOutdated <- case PoseidonPackage -> Maybe String
posPacJannoFile PoseidonPackage
pac of
            Just String
fn_ -> UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
fn_)
            Maybe String
Nothing  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
readmeOutdated <- case PoseidonPackage -> Maybe String
posPacReadmeFile PoseidonPackage
pac of
            Just String
fn_ -> UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
fn_)
            Maybe String
Nothing  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
changelogOutdated <- case PoseidonPackage -> Maybe String
posPacChangelogFile PoseidonPackage
pac of
            Just String
fn_ -> UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
fn_)
            Maybe String
Nothing  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
ssfOutdated <- case PoseidonPackage -> Maybe String
posPacSeqSourceFile PoseidonPackage
pac of
            Just String
fn_ -> UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
fn_)
            Maybe String
Nothing  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        let gd :: GenotypeDataSpec
gd = PoseidonPackage -> GenotypeDataSpec
posPacGenotypeData PoseidonPackage
pac
        [Bool]
genoFilesOutdated <- case  GenotypeDataSpec -> GenotypeFileSpec
genotypeFileSpec GenotypeDataSpec
gd of
            GenotypeEigenstrat String
gf Maybe String
_ String
sf Maybe String
_ String
i Maybe String
_ -> (String -> IO Bool) -> [String] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</>)) [String
gf, String
sf, String
i]
            GenotypePlink String
gf Maybe String
_ String
sf Maybe String
_ String
i Maybe String
_      -> (String -> IO Bool) -> [String] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</>)) [String
gf, String
sf, String
i]
            GenotypeVCF String
gf Maybe String
_                 -> (String -> IO Bool) -> [String] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</>)) [String
gf]
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> ([Bool] -> Bool) -> [Bool] -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> IO Bool) -> [Bool] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Bool
yamlOutdated, Bool
bibOutdated, Bool
jannoOutdated, Bool
readmeOutdated, Bool
changelogOutdated, Bool
ssfOutdated] [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool]
genoFilesOutdated
    else
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    checkOutdated :: UTCTime -> String -> IO Bool
checkOutdated UTCTime
zipModTime String
fn_ = (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
zipModTime) (UTCTime -> Bool) -> IO UTCTime -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO UTCTime
getModificationTime String
fn_

makeZipArchive :: PoseidonPackage -> IO Archive
makeZipArchive :: PoseidonPackage -> IO Archive
makeZipArchive PoseidonPackage
pac =
    Archive -> IO Archive
addYaml Archive
emptyArchive IO Archive -> (Archive -> IO Archive) -> IO Archive
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> IO Archive
addJanno IO Archive -> (Archive -> IO Archive) -> IO Archive
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> IO Archive
addBib IO Archive -> (Archive -> IO Archive) -> IO Archive
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> IO Archive
addReadme IO Archive -> (Archive -> IO Archive) -> IO Archive
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> IO Archive
addChangelog IO Archive -> (Archive -> IO Archive) -> IO Archive
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> IO Archive
addGenos IO Archive -> (Archive -> IO Archive) -> IO Archive
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Archive -> IO Archive
addSSF
  where
    addYaml :: Archive -> IO Archive
addYaml      = String -> Archive -> IO Archive
addFN String
"POSEIDON.yml"
    addJanno :: Archive -> IO Archive
addJanno     = (Archive -> IO Archive)
-> (String -> Archive -> IO Archive)
-> Maybe String
-> Archive
-> IO Archive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Archive -> IO Archive
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe String
posPacJannoFile PoseidonPackage
pac)
    addBib :: Archive -> IO Archive
addBib       = (Archive -> IO Archive)
-> (String -> Archive -> IO Archive)
-> Maybe String
-> Archive
-> IO Archive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Archive -> IO Archive
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe String
posPacBibFile PoseidonPackage
pac)
    addReadme :: Archive -> IO Archive
addReadme    = (Archive -> IO Archive)
-> (String -> Archive -> IO Archive)
-> Maybe String
-> Archive
-> IO Archive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Archive -> IO Archive
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe String
posPacReadmeFile PoseidonPackage
pac)
    addChangelog :: Archive -> IO Archive
addChangelog = (Archive -> IO Archive)
-> (String -> Archive -> IO Archive)
-> Maybe String
-> Archive
-> IO Archive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Archive -> IO Archive
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe String
posPacChangelogFile PoseidonPackage
pac)
    addSSF :: Archive -> IO Archive
addSSF       = (Archive -> IO Archive)
-> (String -> Archive -> IO Archive)
-> Maybe String
-> Archive
-> IO Archive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Archive -> IO Archive
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe String
posPacSeqSourceFile PoseidonPackage
pac)
    addGenos :: Archive -> IO Archive
addGenos Archive
archive = case GenotypeDataSpec -> GenotypeFileSpec
genotypeFileSpec (GenotypeDataSpec -> GenotypeFileSpec)
-> (PoseidonPackage -> GenotypeDataSpec)
-> PoseidonPackage
-> GenotypeFileSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoseidonPackage -> GenotypeDataSpec
posPacGenotypeData (PoseidonPackage -> GenotypeFileSpec)
-> PoseidonPackage -> GenotypeFileSpec
forall a b. (a -> b) -> a -> b
$ PoseidonPackage
pac of
        GenotypeEigenstrat String
gf Maybe String
_ String
sf Maybe String
_ String
i Maybe String
_ -> (Archive -> String -> IO Archive)
-> Archive -> [String] -> IO Archive
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((String -> Archive -> IO Archive)
-> Archive -> String -> IO Archive
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Archive -> IO Archive
addFN) Archive
archive [String
gf, String
sf, String
i]
        GenotypePlink String
gf Maybe String
_ String
sf Maybe String
_ String
i Maybe String
_      -> (Archive -> String -> IO Archive)
-> Archive -> [String] -> IO Archive
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((String -> Archive -> IO Archive)
-> Archive -> String -> IO Archive
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Archive -> IO Archive
addFN) Archive
archive [String
gf, String
sf, String
i]
        GenotypeVCF String
gf Maybe String
_                 -> String -> Archive -> IO Archive
addFN String
gf Archive
archive
    addFN :: FilePath -> Archive -> IO Archive
    addFN :: String -> Archive -> IO Archive
addFN String
fn Archive
a = do
        let fullFN :: String
fullFN = PoseidonPackage -> String
posPacBaseDir PoseidonPackage
pac String -> ShowS
</> String
fn
        ByteString
rawFN <- String -> IO ByteString
B.readFile String
fullFN
        Integer
modTime <- POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer)
-> (UTCTime -> POSIXTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> Integer) -> IO UTCTime -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO UTCTime
getModificationTime String
fullFN
        let zipEntry :: Entry
zipEntry = String -> Integer -> ByteString -> Entry
toEntry String
fn Integer
modTime ByteString
rawFN
        Archive -> IO Archive
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> Archive -> Archive
addEntryToArchive Entry
zipEntry Archive
a)

scottyHTTPS :: MVar () -> Int -> FilePath -> [FilePath] -> FilePath -> ScottyM () -> PoseidonIO ()
scottyHTTPS :: MVar ()
-> Int
-> String
-> [String]
-> String
-> ScottyM ()
-> PoseidonIO ()
scottyHTTPS MVar ()
serverReady Int
port String
cert [String]
chains String
key ScottyM ()
s = do
    -- this is just the same output as with scotty, to make it consistent whether or not using https
    String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Server now listening via HTTPS on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
port
    let tsls :: TLSSettings
tsls = case [String]
chains of
            [] -> String -> String -> TLSSettings
tlsSettings String
cert String
key
            [String]
c  -> String -> [String] -> String -> TLSSettings
tlsSettingsChain String
cert [String]
c String
key
        settings :: Settings
settings = Int -> Settings -> Settings
setPort Int
port (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Settings -> Settings
setBeforeMainLoop (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
serverReady ()) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
    IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ do
        Application
app <- IO Application -> IO Application
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Application -> IO Application)
-> IO Application -> IO Application
forall a b. (a -> b) -> a -> b
$ ScottyM () -> IO Application
scottyApp ScottyM ()
s
        TLSSettings -> Settings -> Application -> IO ()
runTLS TLSSettings
tsls Settings
settings Application
app

scottyHTTP :: MVar () -> Int -> ScottyM () -> PoseidonIO ()
scottyHTTP :: MVar () -> Int -> ScottyM () -> PoseidonIO ()
scottyHTTP MVar ()
serverReady Int
port ScottyM ()
s = do
    String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Server now listening via HTTP on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
port
    let settings :: Settings
settings = Int -> Settings -> Settings
setPort Int
port (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Settings -> Settings
setBeforeMainLoop (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
serverReady ()) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
    IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ do
        Application
app <- ScottyM () -> IO Application
scottyApp ScottyM ()
s
        Settings -> Application -> IO ()
runSettings Settings
settings Application
app

logRequest :: LogA -> ActionM ()
logRequest :: LogA -> ActionM ()
logRequest LogA
logA = do
    Request
req <- ActionM Request
request
    let p :: [Text]
p = Request -> [Text]
pathInfo Request
req
        q :: Query
q = Request -> Query
queryString Request
req
    IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (String -> IO ()) -> String -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogA -> PoseidonIO () -> IO ()
forall (m :: * -> *). MonadIO m => LogA -> PoseidonIO () -> m ()
logWithEnv LogA
logA (PoseidonIO () -> IO ())
-> (String -> PoseidonIO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PoseidonIO ()
logDebug (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"Request: Path=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", qstring=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Query -> String
forall a. Show a => a -> String
show Query
q

getItemFromArchiveStore :: ArchiveStore a -> ActionM a
getItemFromArchiveStore :: forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStore a
store = do
    Maybe String
maybeArchiveName <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"archive"
    case Maybe String
maybeArchiveName of
        Maybe String
Nothing   -> a -> ActionM a
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ActionM a)
-> (ArchiveStore a -> a) -> ArchiveStore a -> ActionM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ArchiveSpec, a) -> a
forall a b. (a, b) -> b
snd ((ArchiveSpec, a) -> a)
-> (ArchiveStore a -> (ArchiveSpec, a)) -> ArchiveStore a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveStore a -> (ArchiveSpec, a)
forall a. HasCallStack => [a] -> a
head (ArchiveStore a -> ActionM a) -> ArchiveStore a -> ActionM a
forall a b. (a -> b) -> a -> b
$ ArchiveStore a
store
        Just String
name -> String -> ArchiveStore a -> ActionM a
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m a
getArchiveContentByName String
name ArchiveStore a
store

getArchiveSpecFromArchiveStore :: ArchiveStore a -> ActionM ArchiveSpec
getArchiveSpecFromArchiveStore :: forall a. ArchiveStore a -> ActionM ArchiveSpec
getArchiveSpecFromArchiveStore ArchiveStore a
store = do
    Maybe String
maybeArchiveName <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"archive"
    case Maybe String
maybeArchiveName of
        Maybe String
Nothing   -> ArchiveSpec -> ActionM ArchiveSpec
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchiveSpec -> ActionM ArchiveSpec)
-> (ArchiveStore a -> ArchiveSpec)
-> ArchiveStore a
-> ActionM ArchiveSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ArchiveSpec, a) -> ArchiveSpec
forall a b. (a, b) -> a
fst ((ArchiveSpec, a) -> ArchiveSpec)
-> (ArchiveStore a -> (ArchiveSpec, a))
-> ArchiveStore a
-> ArchiveSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveStore a -> (ArchiveSpec, a)
forall a. HasCallStack => [a] -> a
head (ArchiveStore a -> ActionM ArchiveSpec)
-> ArchiveStore a -> ActionM ArchiveSpec
forall a b. (a -> b) -> a -> b
$ ArchiveStore a
store
        Just String
name -> String -> ArchiveStore a -> ActionM ArchiveSpec
forall (m :: * -> *) a.
MonadFail m =>
String -> ArchiveStore a -> m ArchiveSpec
getArchiveSpecByName String
name ArchiveStore a
store

getRetiredPackages :: (MonadIO m) => ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages :: forall (m :: * -> *).
MonadIO m =>
ArchiveSpec -> m [PacNameAndVersion]
getRetiredPackages ArchiveSpec
spec = case ArchiveSpec -> Maybe String
_archRetiredPackagesFile ArchiveSpec
spec of
    Maybe String
Nothing -> [PacNameAndVersion] -> m [PacNameAndVersion]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
fn -> do
        RetiredPackages
retiredPacsData <- String -> m RetiredPackages
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
decodeFileThrow String
fn
        [PacNameAndVersion] -> m [PacNameAndVersion]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe Version -> PacNameAndVersion
PacNameAndVersion String
n Maybe Version
v | RetiredPac String
n Maybe Version
v String
_ <- RetiredPackages -> [RetiredPac]
_retPacFilePackages RetiredPackages
retiredPacsData]

filterRetired :: [PacNameAndVersion] -> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired :: [PacNameAndVersion]
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
filterRetired [PacNameAndVersion]
retiredPacs [PoseidonPackage]
pacs = do
    Maybe String
includeRetired <- Text -> ActionM (Maybe String)
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"includeRetired" :: ActionM (Maybe String)
    if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
includeRetired
    then [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [PoseidonPackage]
pacs
    else do
        -- Split retiredPacs into those with and without version
        let retiredNameOnly :: [String]
retiredNameOnly = [String
name | PacNameAndVersion String
name Maybe Version
Nothing <- [PacNameAndVersion]
retiredPacs]
            retiredNameAndVersion :: [(String, Version)]
retiredNameAndVersion = [(String
name, Version
v) | PacNameAndVersion String
name (Just Version
v) <- [PacNameAndVersion]
retiredPacs]
        [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PoseidonPackage] -> ActionM [PoseidonPackage])
-> [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a b. (a -> b) -> a -> b
$ do -- list monad to filter retired packages
            PoseidonPackage
pac <- [PoseidonPackage]
pacs
            let name :: String
name = PoseidonPackage -> String
forall a. HasNameAndVersion a => a -> String
getPacName PoseidonPackage
pac
                maybeVersion :: Maybe Version
maybeVersion = PoseidonPackage -> Maybe Version
forall a. HasNameAndVersion a => a -> Maybe Version
getPacVersion PoseidonPackage
pac
            if String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
retiredNameOnly
                then [] -- all versions of this package are retired, so we skip it
                else case Maybe Version
maybeVersion of
                    Maybe Version
Nothing -> [PoseidonPackage
pac] -- no version specified, so we keep the package as it is not retired
                    Just Version
ver ->
                        -- if a version is specified, we check if it is retired
                        if (String
name, Version
ver) (String, Version) -> [(String, Version)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(String, Version)]
retiredNameAndVersion
                             then [] -- this specific version is retired, so we skip it
                             else [PoseidonPackage
pac] -- this package is not retired, so we keep it