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

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

import           Poseidon.EntityTypes         (HasNameAndVersion (..),
                                               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                    (groupBy, intercalate, sortOn)
import           Data.List.Split              (splitOn)
import           Data.Maybe                   (isJust, mapMaybe)
import           Data.Ord                     (Down (..))
import           Data.Text.Lazy               (pack)
import           Data.Time.Clock.POSIX        (utcTimeToPOSIXSeconds)
import           Data.Version                 (Version, parseVersion,
                                               showVersion)
import           Data.Yaml                    (FromJSON, decodeFileThrow,
                                               parseJSON, (.:?))
import           Data.Yaml.Aeson              (withObject, (.:))
import           Network.Wai                  (pathInfo, queryString)
import           Network.Wai.Handler.Warp     (defaultSettings, runSettings,
                                               setBeforeMainLoop, setPort)
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.ColumnTypes         (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)

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

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

instance FromJSON ArchiveConfig where
    parseJSON :: Value -> Parser ArchiveConfig
parseJSON = [Char]
-> (Object -> Parser ArchiveConfig)
-> Value
-> Parser ArchiveConfig
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"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"

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

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

instance FromJSON ArchiveSpec where
    parseJSON :: Value -> Parser ArchiveSpec
parseJSON = [Char]
-> (Object -> Parser ArchiveSpec) -> Value -> Parser ArchiveSpec
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"archiveSpec" ((Object -> Parser ArchiveSpec) -> Value -> Parser ArchiveSpec)
-> (Object -> Parser ArchiveSpec) -> Value -> Parser ArchiveSpec
forall a b. (a -> b) -> a -> b
$ \Object
v -> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> ArchiveSpec
ArchiveSpec
        ([Char]
 -> [[Char]]
 -> Maybe [Char]
 -> Maybe [Char]
 -> Maybe [Char]
 -> ArchiveSpec)
-> Parser [Char]
-> Parser
     ([[Char]]
      -> Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> ArchiveSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser [Char]
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"name"
        Parser
  ([[Char]]
   -> Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> ArchiveSpec)
-> Parser [[Char]]
-> Parser
     (Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> 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 [[Char]]
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"paths"
        Parser
  (Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> ArchiveSpec)
-> Parser (Maybe [Char])
-> Parser (Maybe [Char] -> Maybe [Char] -> 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 [Char])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
        Parser (Maybe [Char] -> Maybe [Char] -> ArchiveSpec)
-> Parser (Maybe [Char]) -> Parser (Maybe [Char] -> 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 [Char])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"URL"
        Parser (Maybe [Char] -> ArchiveSpec)
-> Parser (Maybe [Char]) -> 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 [Char])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dataURL"

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

type ArchiveName = String

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

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

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

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

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 [Char]
archBaseDirs Maybe [Char]
maybeZipPath Int
port Bool
ignoreChecksums Maybe ([Char], [[Char]], [Char])
certFiles) MVar ()
serverReady = do
    let archiveZip :: Bool
archiveZip = Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Char]
maybeZipPath
        pacReadOpts :: PackageReadOptions
pacReadOpts = PackageReadOptions
defaultPackageReadOptions {
              _readOptIgnoreChecksums  = ignoreChecksums
            , _readOptGenoCheck        = archiveZip
        }

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

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

    [(ArchiveSpec, ZipStore)]
zipArchiveStore <- case Maybe [Char]
maybeZipPath of
        Maybe [Char]
Nothing -> [(ArchiveSpec, ZipStore)]
-> ReaderT Env IO [(ArchiveSpec, ZipStore)]
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just [Char]
z  -> ArchiveStore [PoseidonPackage]
-> [Char] -> ReaderT Env IO [(ArchiveSpec, ZipStore)]
createZipArchiveStore ArchiveStore [PoseidonPackage]
archiveStore [Char]
z

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

    let runScotty :: ScottyM () -> PoseidonIO ()
runScotty = case Maybe ([Char], [[Char]], [Char])
certFiles of
            Maybe ([Char], [[Char]], [Char])
Nothing                              -> MVar () -> Int -> ScottyM () -> PoseidonIO ()
scottyHTTP  MVar ()
serverReady Int
port
            Just ([Char]
certFile, [[Char]]
chainFiles, [Char]
keyFile) -> MVar ()
-> Int
-> [Char]
-> [[Char]]
-> [Char]
-> ScottyM ()
-> PoseidonIO ()
scottyHTTPS MVar ()
serverReady Int
port [Char]
certFile [[Char]]
chainFiles [Char]
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
. [Char] -> Text
pack ([Char] -> Text) -> (Version -> [Char]) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Char]
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
            [PoseidonPackage]
pacs <- ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStore [PoseidonPackage]
archiveStore
            [PackageInfo]
pacInfos <- [PoseidonPackage] -> ActionT IO [PackageInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> m [PackageInfo]
packagesToPackageInfos [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
$ [[Char]] -> 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
            [PoseidonPackage]
pacs <- ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStore [PoseidonPackage]
archiveStore
            [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
$ [[Char]] -> 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
            [PoseidonPackage]
pacs <- ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStore [PoseidonPackage]
archiveStore
            Maybe [Char]
maybeAdditionalColumnsString <- Text -> ActionM (Maybe [Char])
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"additionalJannoColumns"
            [ExtendedIndividualInfo]
indInfo <- case Maybe [Char]
maybeAdditionalColumnsString of
                    Just [Char]
"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 [Char]
additionalColumnsString ->
                        let additionalColumnNames :: [[Char]]
additionalColumnNames = [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"," [Char]
additionalColumnsString
                        in  [PoseidonPackage]
-> AddColSpec -> ActionT IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs ([[Char]] -> AddColSpec
AddColList [[Char]]
additionalColumnNames)
                    Maybe [Char]
Nothing -> [PoseidonPackage]
-> AddColSpec -> ActionT IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs ([[Char]] -> 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
$ [[Char]] -> 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
            [PoseidonPackage]
pacs <- ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStore [PoseidonPackage]
archiveStore
            Maybe [Char]
maybeAdditionalBibFieldsString <- Text -> ActionM (Maybe [Char])
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"additionalBibColumns"
            [BibliographyInfo]
bibInfo <- case Maybe [Char]
maybeAdditionalBibFieldsString of
                    Just [Char]
"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 [Char]
additionalBibFieldsString ->
                        let additionalBibFields :: [[Char]]
additionalBibFields = [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"," [Char]
additionalBibFieldsString
                        in  [PoseidonPackage] -> AddColSpec -> ActionT IO [BibliographyInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [BibliographyInfo]
getBibliographyInfo [PoseidonPackage]
pacs ([[Char]] -> AddColSpec
AddColList [[Char]]
additionalBibFields)
                    Maybe [Char]
Nothing -> [PoseidonPackage] -> AddColSpec -> ActionT IO [BibliographyInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddColSpec -> m [BibliographyInfo]
getBibliographyInfo [PoseidonPackage]
pacs ([[Char]] -> 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
$ [[Char]] -> 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
            ZipStore
zipStore <- [(ArchiveSpec, ZipStore)] -> ActionM ZipStore
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore [(ArchiveSpec, ZipStore)]
zipArchiveStore
            [Char]
packageName <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            Maybe [Char]
maybeVersionString <- Text -> ActionM (Maybe [Char])
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"package_version"
            Maybe Version
maybeVersion <- case Maybe [Char]
maybeVersionString of
                Maybe [Char]
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 [Char]
versionStr -> case [Char] -> Maybe Version
parseVersionString [Char]
versionStr of
                    Maybe Version
Nothing -> [Char] -> ActionT IO (Maybe Version)
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionT IO (Maybe Version))
-> [Char] -> ActionT IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not parse package version string " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
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, [Char]) -> 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, [Char]) -> PacNameAndVersion)
-> (PacNameAndVersion, [Char])
-> Down PacNameAndVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PacNameAndVersion, [Char]) -> 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, [Char]) -> Bool) -> ZipStore -> ZipStore
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
packageName) ([Char] -> Bool)
-> ((PacNameAndVersion, [Char]) -> [Char])
-> (PacNameAndVersion, [Char])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacNameAndVersion -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
getPacName (PacNameAndVersion -> [Char])
-> ((PacNameAndVersion, [Char]) -> PacNameAndVersion)
-> (PacNameAndVersion, [Char])
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PacNameAndVersion, [Char]) -> PacNameAndVersion
forall a b. (a, b) -> a
fst) (ZipStore -> ZipStore) -> ZipStore -> ZipStore
forall a b. (a -> b) -> a -> b
$ ZipStore
zipStore of
                [] -> [Char] -> ActionM ()
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM ()) -> [Char] -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown package " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
packageName -- no version found
                [(PacNameAndVersion
pacNameAndVersion, [Char]
fn)] -> case Maybe Version
maybeVersion of -- exactly one version found
                    Maybe Version
Nothing -> [Char] -> ActionM ()
file [Char]
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 [Char] -> ActionM ()
file [Char]
fn else [Char] -> ActionM ()
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM ()) -> [Char] -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Package " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
packageName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not available for version " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
v
                pl :: ZipStore
pl@((PacNameAndVersion
_, [Char]
fnLatest) : ZipStore
_) -> case Maybe Version
maybeVersion of
                    Maybe Version
Nothing -> [Char] -> ActionM ()
file [Char]
fnLatest
                    Just Version
v -> case ((PacNameAndVersion, [Char]) -> 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, [Char]) -> Maybe Version)
-> (PacNameAndVersion, [Char])
-> 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, [Char]) -> PacNameAndVersion)
-> (PacNameAndVersion, [Char])
-> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PacNameAndVersion, [Char]) -> PacNameAndVersion
forall a b. (a, b) -> a
fst) ZipStore
pl of
                        [] -> [Char] -> ActionM ()
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM ()) -> [Char] -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Package " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
packageName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"is not available for version " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
v
                        [(PacNameAndVersion
_, [Char]
fn)] -> [Char] -> ActionM ()
file [Char]
fn
                        ZipStore
_ -> [Char] -> ActionM ()
forall a. HasCallStack => [Char] -> a
error [Char]
"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
            [([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])]
pacsPerArchive <- [ArchiveSpec]
-> (ArchiveSpec
    -> ActionT
         IO ([Char], Maybe [Char], Maybe [Char], [PoseidonPackage]))
-> ActionT
     IO [([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ArchiveSpec]
archiveSpecs ((ArchiveSpec
  -> ActionT
       IO ([Char], Maybe [Char], Maybe [Char], [PoseidonPackage]))
 -> ActionT
      IO [([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])])
-> (ArchiveSpec
    -> ActionT
         IO ([Char], Maybe [Char], Maybe [Char], [PoseidonPackage]))
-> ActionT
     IO [([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])]
forall a b. (a -> b) -> a -> b
$ \ArchiveSpec
spec -> do
                let n :: [Char]
n = ArchiveSpec -> [Char]
_archSpecName ArchiveSpec
spec
                    d :: Maybe [Char]
d = ArchiveSpec -> Maybe [Char]
_archSpecDescription ArchiveSpec
spec
                    u :: Maybe [Char]
u = ArchiveSpec -> Maybe [Char]
_archSpecURL ArchiveSpec
spec
                [PoseidonPackage]
pacs <- [PoseidonPackage] -> [PoseidonPackage]
selectLatest ([PoseidonPackage] -> [PoseidonPackage])
-> ActionM [PoseidonPackage] -> ActionM [PoseidonPackage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
[Char] -> ArchiveStore a -> m a
getArchiveContentByName [Char]
n ArchiveStore [PoseidonPackage]
archiveStore
                ([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])
-> ActionT
     IO ([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
n, Maybe [Char]
d, Maybe [Char]
u, [PoseidonPackage]
pacs)
            [([Char], Maybe [Char], Maybe [Char], [PoseidonPackage])]
-> ActionM ()
mainPage [([Char], Maybe [Char], Maybe [Char], [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
            [Char]
archiveName <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            ArchiveSpec
spec <- [Char] -> ArchiveStore [PoseidonPackage] -> ActionT IO ArchiveSpec
forall (m :: * -> *) a.
MonadFail m =>
[Char] -> ArchiveStore a -> m ArchiveSpec
getArchiveSpecByName [Char]
archiveName ArchiveStore [PoseidonPackage]
archiveStore
            let maybeArchiveDataURL :: Maybe [Char]
maybeArchiveDataURL = ArchiveSpec -> Maybe [Char]
_archSpecDataURL 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
<$> [Char]
-> ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
[Char] -> ArchiveStore a -> m a
getArchiveContentByName [Char]
archiveName ArchiveStore [PoseidonPackage]
archiveStore
            let mapMarkers :: [MapMarker]
mapMarkers = (PoseidonPackage -> [MapMarker])
-> [PoseidonPackage] -> [MapMarker]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> PoseidonPackage -> [MapMarker]
prepMappable [Char]
archiveName) [PoseidonPackage]
latestPacs
            [Char]
-> Maybe [Char]
-> Bool
-> [MapMarker]
-> [PoseidonPackage]
-> ActionM ()
archivePage [Char]
archiveName Maybe [Char]
maybeArchiveDataURL Bool
archiveZip [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
            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
            [Char]
archiveName      <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            [Char]
pacName          <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            [Char]
pacVersionString <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_version"
            PacVersion
pacVersionWL <- case [Char] -> Maybe PacVersion
parsePackageVersionString [Char]
pacVersionString of
                Maybe PacVersion
Nothing -> [Char] -> ActionT IO PacVersion
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionT IO PacVersion)
-> [Char] -> ActionT IO PacVersion
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not parse package version string " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
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     <- [Char]
-> ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
[Char] -> ArchiveStore a -> m a
getArchiveContentByName [Char]
archiveName ArchiveStore [PoseidonPackage]
archiveStore
            [PoseidonPackage]
allVersions <- [Char] -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions [Char]
pacName [PoseidonPackage]
allPacs
            PoseidonPackage
oneVersion  <- PacVersion -> [PoseidonPackage] -> ActionM PoseidonPackage
prepPacVersion PacVersion
pacVersionWL [PoseidonPackage]
allVersions
            let mapMarkers :: [MapMarker]
mapMarkers = [Char] -> PoseidonPackage -> [MapMarker]
prepMappable [Char]
archiveName PoseidonPackage
oneVersion
                bib :: [Char]
bib = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (BibEntry -> [Char]) -> [BibEntry] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map BibEntry -> [Char]
renderBibEntry ([BibEntry] -> [[Char]]) -> [BibEntry] -> [[Char]]
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
            [Char]
-> [Char]
-> Maybe Version
-> Bool
-> [MapMarker]
-> [Char]
-> PoseidonPackage
-> [PoseidonPackage]
-> [JannoRow]
-> ActionM ()
packageVersionPage [Char]
archiveName [Char]
pacName Maybe Version
pacVersion Bool
archiveZip [MapMarker]
mapMarkers [Char]
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
            [Char]
archiveName <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"archive_name"
            [PoseidonPackage]
allPacs <- [Char]
-> ArchiveStore [PoseidonPackage] -> ActionM [PoseidonPackage]
forall (m :: * -> *) a.
MonadFail m =>
[Char] -> ArchiveStore a -> m a
getArchiveContentByName [Char]
archiveName ArchiveStore [PoseidonPackage]
archiveStore
            [Char]
pacName <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_name"
            [PoseidonPackage]
allVersions <- [Char] -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions [Char]
pacName [PoseidonPackage]
allPacs
            [Char]
pacVersionString <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"package_version"
            PacVersion
pacVersionWL <- case [Char] -> Maybe PacVersion
parsePackageVersionString [Char]
pacVersionString of
                    Maybe PacVersion
Nothing -> [Char] -> ActionT IO PacVersion
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionT IO PacVersion)
-> [Char] -> ActionT IO PacVersion
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not parse package version string " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
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 [Char]
pacVersion = Version -> [Char]
showVersion (Version -> [Char]) -> Maybe Version -> Maybe [Char]
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
            [Char]
sampleName <- Text -> ActionM [Char]
forall a. Parsable a => Text -> ActionM a
captureParam Text
"sample"
            JannoRow
sample <- [Char] -> [JannoRow] -> ActionM JannoRow
prepSample [Char]
sampleName [JannoRow]
samples
            let maybeMapMarker :: Maybe MapMarker
maybeMapMarker = [Char] -> [Char] -> Maybe [Char] -> JannoRow -> Maybe MapMarker
extractPosJannoRow [Char]
archiveName [Char]
pacName Maybe [Char]
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
$ [Char] -> ActionM ()
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unknown request"

-- prepare data for the html API

data PacVersion =
      Latest
    | NumericalVersion Version

instance Show PacVersion where
  show :: PacVersion -> [Char]
show PacVersion
Latest               = [Char]
"latest"
  show (NumericalVersion Version
v) = Version -> [Char]
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 -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
getPacName PoseidonPackage
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== PoseidonPackage -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
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 :: [Char] -> PoseidonPackage -> [MapMarker]
prepMappable [Char]
archiveName PoseidonPackage
pac =
    let packageName :: [Char]
packageName = PoseidonPackage -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
getPacName PoseidonPackage
pac
        packageVersion :: Maybe [Char]
packageVersion = Version -> [Char]
showVersion (Version -> [Char]) -> Maybe Version -> Maybe [Char]
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 ([Char] -> [Char] -> Maybe [Char] -> JannoRow -> Maybe MapMarker
extractPosJannoRow [Char]
archiveName [Char]
packageName Maybe [Char]
packageVersion) [JannoRow]
jannoRows

extractPosJannoRow :: String -> String -> Maybe String -> JannoRow -> Maybe MapMarker
extractPosJannoRow :: [Char] -> [Char] -> Maybe [Char] -> JannoRow -> Maybe MapMarker
extractPosJannoRow [Char]
archiveName [Char]
pacName Maybe [Char]
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 :: [Char]
poseidonID = JannoRow -> [Char]
jPoseidonID JannoRow
row
            loc :: Maybe [Char]
loc = JannoLocation -> [Char]
forall a. Show a => a -> [Char]
show (JannoLocation -> [Char]) -> Maybe JannoLocation -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JannoRow -> Maybe JannoLocation
jLocation JannoRow
row
            age :: Maybe [Char]
age = JannoDateBCADMedian -> [Char]
forall a. Show a => a -> [Char]
show (JannoDateBCADMedian -> [Char])
-> Maybe JannoDateBCADMedian -> Maybe [Char]
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
-> [Char]
-> [Char]
-> Maybe [Char]
-> [Char]
-> Maybe [Char]
-> Maybe [Char]
-> MapMarker
MapMarker Double
lat Double
lon [Char]
poseidonID [Char]
pacName Maybe [Char]
pacVersion [Char]
archiveName Maybe [Char]
loc Maybe [Char]
age
    (Maybe JannoLatitude, Maybe JannoLongitude)
_                                                     -> Maybe MapMarker
forall a. Maybe a
Nothing

prepPacVersions :: String -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions :: [Char] -> [PoseidonPackage] -> ActionM [PoseidonPackage]
prepPacVersions [Char]
pacName [PoseidonPackage]
pacs = do
    case (PoseidonPackage -> Bool) -> [PoseidonPackage] -> [PoseidonPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PoseidonPackage
pac -> PoseidonPackage -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
getPacName PoseidonPackage
pac [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
pacName) [PoseidonPackage]
pacs of
       [] -> [Char] -> ActionM [PoseidonPackage]
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM [PoseidonPackage])
-> [Char] -> ActionM [PoseidonPackage]
forall a b. (a -> b) -> a -> b
$ [Char]
"Package " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
pacName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" 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
            [] -> [Char] -> ActionM PoseidonPackage
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM PoseidonPackage)
-> [Char] -> ActionM PoseidonPackage
forall a b. (a -> b) -> a -> b
$ [Char]
"Package version " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> PacVersion -> [Char]
forall a. Show a => a -> [Char]
show PacVersion
pacVersion [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" 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]
_ -> [Char] -> ActionM PoseidonPackage
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM PoseidonPackage)
-> [Char] -> ActionM PoseidonPackage
forall a b. (a -> b) -> a -> b
$ [Char]
"Package version " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> PacVersion -> [Char]
forall a. Show a => a -> [Char]
show PacVersion
pacVersion [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" 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 :: [Char] -> [JannoRow] -> ActionM JannoRow
prepSample [Char]
sampleName [JannoRow]
rows = do
    case (JannoRow -> Bool) -> [JannoRow] -> [JannoRow]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JannoRow
r -> JannoRow -> [Char]
jPoseidonID JannoRow
r [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
sampleName) [JannoRow]
rows of
       []  -> [Char] -> ActionM JannoRow
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM JannoRow) -> [Char] -> ActionM JannoRow
forall a b. (a -> b) -> a -> b
$ [Char]
"Sample " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
sampleName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" 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]
_   -> [Char] -> ActionM JannoRow
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionM JannoRow) -> [Char] -> ActionM JannoRow
forall a b. (a -> b) -> a -> b
$ [Char]
"Sample " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
sampleName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" exists multiple times"

readArchiveStore :: ArchiveConfig -> PackageReadOptions -> PoseidonIO (ArchiveStore [PoseidonPackage])
readArchiveStore :: ArchiveConfig
-> PackageReadOptions
-> ReaderT Env IO (ArchiveStore [PoseidonPackage])
readArchiveStore (ArchiveConfig [ArchiveSpec]
archiveSpecs) PackageReadOptions
pacReadOpts = do
    [ArchiveSpec]
-> (ArchiveSpec -> ReaderT Env IO (ArchiveSpec, [PoseidonPackage]))
-> ReaderT Env IO (ArchiveStore [PoseidonPackage])
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]))
 -> ReaderT Env IO (ArchiveStore [PoseidonPackage]))
-> (ArchiveSpec -> ReaderT Env IO (ArchiveSpec, [PoseidonPackage]))
-> ReaderT Env IO (ArchiveStore [PoseidonPackage])
forall a b. (a -> b) -> a -> b
$ \ArchiveSpec
spec -> do
        [Char] -> PoseidonIO ()
logInfo ([Char] -> PoseidonIO ()) -> [Char] -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Loading packages for archive " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ArchiveSpec -> [Char]
_archSpecName ArchiveSpec
spec
        let relevantDirs :: [[Char]]
relevantDirs = ArchiveSpec -> [[Char]]
_archSpecPaths ArchiveSpec
spec
        [PoseidonPackage]
pacs <- PackageReadOptions -> [[Char]] -> PoseidonIO [PoseidonPackage]
readPoseidonPackageCollection PackageReadOptions
pacReadOpts [[Char]]
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 :: ArchiveStore [PoseidonPackage] -> FilePath -> PoseidonIO (ArchiveStore ZipStore)
createZipArchiveStore :: ArchiveStore [PoseidonPackage]
-> [Char] -> ReaderT Env IO [(ArchiveSpec, ZipStore)]
createZipArchiveStore ArchiveStore [PoseidonPackage]
archiveStore [Char]
zipPath =
    ArchiveStore [PoseidonPackage]
-> ((ArchiveSpec, [PoseidonPackage])
    -> ReaderT Env IO (ArchiveSpec, ZipStore))
-> ReaderT Env IO [(ArchiveSpec, ZipStore)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ArchiveStore [PoseidonPackage]
archiveStore (((ArchiveSpec, [PoseidonPackage])
  -> ReaderT Env IO (ArchiveSpec, ZipStore))
 -> ReaderT Env IO [(ArchiveSpec, ZipStore)])
-> ((ArchiveSpec, [PoseidonPackage])
    -> ReaderT Env IO (ArchiveSpec, ZipStore))
-> ReaderT Env IO [(ArchiveSpec, ZipStore)]
forall a b. (a -> b) -> a -> b
$ \(ArchiveSpec
spec, [PoseidonPackage]
packages) -> do
        [Char] -> PoseidonIO ()
logInfo ([Char] -> PoseidonIO ()) -> [Char] -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Zipping packages in archive " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ArchiveSpec -> [Char]
_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, [Char]))
-> 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
            [Char] -> PoseidonIO ()
logInfo [Char]
"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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char]
zipPath [Char] -> ShowS
</> ArchiveSpec -> [Char]
_archSpecName ArchiveSpec
spec)
            let combinedPackageVersionTitle :: [Char]
combinedPackageVersionTitle = PoseidonPackage -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
renderNameWithVersion PoseidonPackage
pac
            let fn :: [Char]
fn = [Char]
zipPath [Char] -> ShowS
</> ArchiveSpec -> [Char]
_archSpecName ArchiveSpec
spec [Char] -> ShowS
</> [Char]
combinedPackageVersionTitle [Char] -> ShowS
<.> [Char]
"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 -> [Char] -> IO Bool
checkZipFileOutdated PoseidonPackage
pac [Char]
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
                [Char] -> PoseidonIO ()
logInfo ([Char]
"Zip Archive for package " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
combinedPackageVersionTitle [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" 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
$ [Char] -> ByteString -> IO ()
B.writeFile [Char]
fn ByteString
zip_raw
            (PacNameAndVersion, [Char])
-> ReaderT Env IO (PacNameAndVersion, [Char])
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PoseidonPackage -> PacNameAndVersion
posPacNameAndVersion PoseidonPackage
pac, [Char]
fn))

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


-- other helper functions

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

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

conditionOnClientVersion :: ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion :: ActionM ServerApiReturnType -> ActionM ()
conditionOnClientVersion ActionM ServerApiReturnType
contentAction = do
    Maybe [Char]
maybeClientVersion <- Text -> ActionM (Maybe [Char])
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"client_version"
    (Version
clientVersion, [[Char]]
versionWarnings) <- case Maybe [Char]
maybeClientVersion of
        Maybe [Char]
Nothing            -> (Version, [[Char]]) -> ActionT IO (Version, [[Char]])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, [[Char]
"No client_version passed. Assuming latest version " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version])
        Just [Char]
versionString -> case [Char] -> Maybe Version
parseVersionString [Char]
versionString of
            Just Version
v -> (Version, [[Char]]) -> ActionT IO (Version, [[Char]])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
v, [])
            Maybe Version
Nothing -> (Version, [[Char]]) -> ActionT IO (Version, [[Char]])
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
version, [[Char]
"Could not parse Client Version string " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
versionString [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", assuming latest version " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version])
    if Version
clientVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
minimalRequiredClientVersion then do
        let msg :: [Char]
msg = [Char]
"This Server API requires trident version at least " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Show a => a -> [Char]
show Version
minimalRequiredClientVersion [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                [Char]
"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
$ [[Char]] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType ([[Char]]
genericServerMessages [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
versionWarnings [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
msg]) Maybe ApiReturnData
forall a. Maybe a
Nothing
    else do
        ServerApiReturnType [[Char]]
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
$ [[Char]] -> Maybe ApiReturnData -> ServerApiReturnType
ServerApiReturnType ([[Char]]
genericServerMessages [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
versionWarnings [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
messages) Maybe ApiReturnData
content

checkZipFileOutdated :: PoseidonPackage -> FilePath -> IO Bool
checkZipFileOutdated :: PoseidonPackage -> [Char] -> IO Bool
checkZipFileOutdated PoseidonPackage
pac [Char]
fn = do
    Bool
zipFileExists <- [Char] -> IO Bool
doesFileExist [Char]
fn
    if Bool
zipFileExists
    then do
        UTCTime
zipModTime <- [Char] -> IO UTCTime
getModificationTime [Char]
fn
        Bool
yamlOutdated <- UTCTime -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
"POSEIDON.yml")
        Bool
bibOutdated <- case PoseidonPackage -> Maybe [Char]
posPacBibFile PoseidonPackage
pac of
            Just [Char]
fn_ -> UTCTime -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
fn_)
            Maybe [Char]
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 [Char]
posPacJannoFile PoseidonPackage
pac of
            Just [Char]
fn_ -> UTCTime -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
fn_)
            Maybe [Char]
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 [Char]
posPacReadmeFile PoseidonPackage
pac of
            Just [Char]
fn_ -> UTCTime -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
fn_)
            Maybe [Char]
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 [Char]
posPacChangelogFile PoseidonPackage
pac of
            Just [Char]
fn_ -> UTCTime -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
fn_)
            Maybe [Char]
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 [Char]
posPacSeqSourceFile PoseidonPackage
pac of
            Just [Char]
fn_ -> UTCTime -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
fn_)
            Maybe [Char]
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 [Char]
gf Maybe [Char]
_ [Char]
sf Maybe [Char]
_ [Char]
i Maybe [Char]
_ -> ([Char] -> IO Bool) -> [[Char]] -> 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 -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime ([Char] -> IO Bool) -> ShowS -> [Char] -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</>)) [[Char]
gf, [Char]
sf, [Char]
i]
            GenotypePlink [Char]
gf Maybe [Char]
_ [Char]
sf Maybe [Char]
_ [Char]
i Maybe [Char]
_      -> ([Char] -> IO Bool) -> [[Char]] -> 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 -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime ([Char] -> IO Bool) -> ShowS -> [Char] -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</>)) [[Char]
gf, [Char]
sf, [Char]
i]
            GenotypeVCF [Char]
gf Maybe [Char]
_                 -> ([Char] -> IO Bool) -> [[Char]] -> 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 -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime ([Char] -> IO Bool) -> ShowS -> [Char] -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</>)) [[Char]
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 -> [Char] -> IO Bool
checkOutdated UTCTime
zipModTime [Char]
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
<$> [Char] -> IO UTCTime
getModificationTime [Char]
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      = [Char] -> Archive -> IO Archive
addFN [Char]
"POSEIDON.yml"
    addJanno :: Archive -> IO Archive
addJanno     = (Archive -> IO Archive)
-> ([Char] -> Archive -> IO Archive)
-> Maybe [Char]
-> 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 [Char] -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe [Char]
posPacJannoFile PoseidonPackage
pac)
    addBib :: Archive -> IO Archive
addBib       = (Archive -> IO Archive)
-> ([Char] -> Archive -> IO Archive)
-> Maybe [Char]
-> 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 [Char] -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe [Char]
posPacBibFile PoseidonPackage
pac)
    addReadme :: Archive -> IO Archive
addReadme    = (Archive -> IO Archive)
-> ([Char] -> Archive -> IO Archive)
-> Maybe [Char]
-> 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 [Char] -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe [Char]
posPacReadmeFile PoseidonPackage
pac)
    addChangelog :: Archive -> IO Archive
addChangelog = (Archive -> IO Archive)
-> ([Char] -> Archive -> IO Archive)
-> Maybe [Char]
-> 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 [Char] -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe [Char]
posPacChangelogFile PoseidonPackage
pac)
    addSSF :: Archive -> IO Archive
addSSF       = (Archive -> IO Archive)
-> ([Char] -> Archive -> IO Archive)
-> Maybe [Char]
-> 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 [Char] -> Archive -> IO Archive
addFN (PoseidonPackage -> Maybe [Char]
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 [Char]
gf Maybe [Char]
_ [Char]
sf Maybe [Char]
_ [Char]
i Maybe [Char]
_ -> (Archive -> [Char] -> IO Archive)
-> Archive -> [[Char]] -> IO Archive
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (([Char] -> Archive -> IO Archive)
-> Archive -> [Char] -> IO Archive
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> Archive -> IO Archive
addFN) Archive
archive [[Char]
gf, [Char]
sf, [Char]
i]
        GenotypePlink [Char]
gf Maybe [Char]
_ [Char]
sf Maybe [Char]
_ [Char]
i Maybe [Char]
_      -> (Archive -> [Char] -> IO Archive)
-> Archive -> [[Char]] -> IO Archive
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (([Char] -> Archive -> IO Archive)
-> Archive -> [Char] -> IO Archive
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> Archive -> IO Archive
addFN) Archive
archive [[Char]
gf, [Char]
sf, [Char]
i]
        GenotypeVCF [Char]
gf Maybe [Char]
_                 -> [Char] -> Archive -> IO Archive
addFN [Char]
gf Archive
archive
    addFN :: FilePath -> Archive -> IO Archive
    addFN :: [Char] -> Archive -> IO Archive
addFN [Char]
fn Archive
a = do
        let fullFN :: [Char]
fullFN = PoseidonPackage -> [Char]
posPacBaseDir PoseidonPackage
pac [Char] -> ShowS
</> [Char]
fn
        ByteString
rawFN <- [Char] -> IO ByteString
B.readFile [Char]
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
<$> [Char] -> IO UTCTime
getModificationTime [Char]
fullFN
        let zipEntry :: Entry
zipEntry = [Char] -> Integer -> ByteString -> Entry
toEntry [Char]
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
-> [Char]
-> [[Char]]
-> [Char]
-> ScottyM ()
-> PoseidonIO ()
scottyHTTPS MVar ()
serverReady Int
port [Char]
cert [[Char]]
chains [Char]
key ScottyM ()
s = do
    -- this is just the same output as with scotty, to make it consistent whether or not using https
    [Char] -> PoseidonIO ()
logInfo ([Char] -> PoseidonIO ()) -> [Char] -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Server now listening via HTTPS on " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port
    let tsls :: TLSSettings
tsls = case [[Char]]
chains of
            [] -> [Char] -> [Char] -> TLSSettings
tlsSettings [Char]
cert [Char]
key
            [[Char]]
c  -> [Char] -> [[Char]] -> [Char] -> TLSSettings
tlsSettingsChain [Char]
cert [[Char]]
c [Char]
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
    [Char] -> PoseidonIO ()
logInfo ([Char] -> PoseidonIO ()) -> [Char] -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Server now listening via HTTP on " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 ()) -> ([Char] -> IO ()) -> [Char] -> 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 ())
-> ([Char] -> PoseidonIO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PoseidonIO ()
logDebug ([Char] -> ActionM ()) -> [Char] -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Request: Path=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
p [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", qstring=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Query -> [Char]
forall a. Show a => a -> [Char]
show Query
q

getItemFromArchiveStore :: ArchiveStore a -> ActionM a
getItemFromArchiveStore :: forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore ArchiveStore a
store = do
    Maybe [Char]
maybeArchiveName <- Text -> ActionM (Maybe [Char])
forall a. Parsable a => Text -> ActionM (Maybe a)
queryParamMaybe Text
"archive"
    case Maybe [Char]
maybeArchiveName of
        Maybe [Char]
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 [Char]
name -> [Char] -> ArchiveStore a -> ActionM a
forall (m :: * -> *) a.
MonadFail m =>
[Char] -> ArchiveStore a -> m a
getArchiveContentByName [Char]
name ArchiveStore a
store