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

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

import           Poseidon.EntityTypes         (HasNameAndVersion (..),
                                               PacNameAndVersion,
                                               renderNameWithVersion)
import           Poseidon.GenotypeData        (GenotypeDataSpec (..),
                                               GenotypeFileSpec (..))
import           Poseidon.Package             (PackageReadOptions (..),
                                               PoseidonPackage (..),
                                               defaultPackageReadOptions,
                                               getAllGroupInfo,
                                               getExtendedIndividualInfo,
                                               packagesToPackageInfos,
                                               readPoseidonPackageCollection)
import           Poseidon.PoseidonVersion     (minimalRequiredClientVersion)
import           Poseidon.ServerClient        (AddJannoColSpec (..),
                                               ApiReturnData (..),
                                               ServerApiReturnType (..))
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       (liftIO)
import qualified Data.ByteString.Lazy         as B
import           Data.List                    (nub, sortOn)
import           Data.List.Split              (splitOn)
import           Data.Maybe                   (isJust)
import           Data.Ord                     (Down (..))
import           Data.Text.Lazy               (pack)
import           Data.Time.Clock.POSIX        (utcTimeToPOSIXSeconds)
import           Data.Version                 (Version, parseVersion,
                                               showVersion)
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           System.Directory             (createDirectoryIfMissing,
                                               doesFileExist,
                                               getModificationTime)
import           System.FilePath              ((<.>), (</>))
import           Text.ParserCombinators.ReadP (readP_to_S)
import           Web.Scotty                   (ActionM, ScottyM, file, get,
                                               json, middleware, notFound,
                                               param, raise, request, rescue,
                                               scottyApp, text)
data ServeOptions = ServeOptions
    { ServeOptions -> [([Char], [Char])]
cliArchiveBaseDirs :: [(String, 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)

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

type ArchiveName = String

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

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

    [Char] -> PoseidonIO ()
logInfo [Char]
"Server starting up. Loading packages..."
    ArchiveStore [PoseidonPackage]
archiveStore <- [([Char], [Char])]
-> PackageReadOptions
-> PoseidonIO (ArchiveStore [PoseidonPackage])
readArchiveStore [([Char], [Char])]
archBaseDirs 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]
++ (([Char], [PoseidonPackage]) -> [Char]
forall a b. (a, b) -> a
fst (([Char], [PoseidonPackage]) -> [Char])
-> (ArchiveStore [PoseidonPackage] -> ([Char], [PoseidonPackage]))
-> ArchiveStore [PoseidonPackage]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveStore [PoseidonPackage] -> ([Char], [PoseidonPackage])
forall a. HasCallStack => [a] -> a
head) ArchiveStore [PoseidonPackage]
archiveStore [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" as the default archive"

    [([Char], ZipStore)]
zipArchiveStore <- case Maybe [Char]
maybeZipPath of
        Maybe [Char]
Nothing -> [([Char], ZipStore)] -> ReaderT Env IO [([Char], 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 [([Char], ZipStore)]
createZipArchiveStore ArchiveStore [PoseidonPackage]
archiveStore [Char]
z

    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 Text 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 Text 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 Text 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 Text 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 <- ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> ActionT Text IO [Char] -> ActionT Text IO (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionT Text IO [Char]
forall a. Parsable a => Text -> ActionM a
param Text
"additionalJannoColumns") ActionT Text IO (Maybe [Char])
-> (Text -> ActionT Text IO (Maybe [Char]))
-> ActionT Text IO (Maybe [Char])
forall a. ActionM a -> (Text -> ActionM a) -> ActionM a
`rescue` (\Text
_ -> Maybe [Char] -> ActionT Text IO (Maybe [Char])
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
            [ExtendedIndividualInfo]
indInfo <- case Maybe [Char]
maybeAdditionalColumnsString of
                    Just [Char]
"ALL" -> [PoseidonPackage]
-> AddJannoColSpec -> ActionT Text IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddJannoColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs AddJannoColSpec
AddJannoColAll -- 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]
-> AddJannoColSpec -> ActionT Text IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddJannoColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs ([[Char]] -> AddJannoColSpec
AddJannoColList [[Char]]
additionalColumnNames)
                    Maybe [Char]
Nothing -> [PoseidonPackage]
-> AddJannoColSpec -> ActionT Text IO [ExtendedIndividualInfo]
forall (m :: * -> *).
MonadThrow m =>
[PoseidonPackage] -> AddJannoColSpec -> m [ExtendedIndividualInfo]
getExtendedIndividualInfo [PoseidonPackage]
pacs ([[Char]] -> AddJannoColSpec
AddJannoColList [])
            let retData :: ApiReturnData
retData = [ExtendedIndividualInfo] -> ApiReturnData
ApiReturnExtIndividualInfo [ExtendedIndividualInfo]
indInfo
            ServerApiReturnType -> ActionM ServerApiReturnType
forall a. a -> ActionT Text 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 (Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Char]
maybeZipPath) (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 <- [([Char], ZipStore)] -> ActionM ZipStore
forall a. ArchiveStore a -> ActionM a
getItemFromArchiveStore [([Char], ZipStore)]
zipArchiveStore
            [Char]
packageName <- Text -> ActionT Text IO [Char]
forall a. Parsable a => Text -> ActionM a
param Text
"package_name"
            Maybe [Char]
maybeVersionString <- ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> ActionT Text IO [Char] -> ActionT Text IO (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionT Text IO [Char]
forall a. Parsable a => Text -> ActionM a
param Text
"package_version") ActionT Text IO (Maybe [Char])
-> (Text -> ActionT Text IO (Maybe [Char]))
-> ActionT Text IO (Maybe [Char])
forall a. ActionM a -> (Text -> ActionM a) -> ActionM a
`rescue` (\Text
_ -> Maybe [Char] -> ActionT Text IO (Maybe [Char])
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
            Maybe Version
maybeVersion <- case Maybe [Char]
maybeVersionString of
                Maybe [Char]
Nothing -> Maybe Version -> ActionT Text IO (Maybe Version)
forall a. a -> ActionT Text 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 -> Text -> ActionT Text IO (Maybe Version)
forall a. Text -> ActionM a
raise (Text -> ActionT Text IO (Maybe Version))
-> ([Char] -> Text) -> [Char] -> ActionT Text IO (Maybe Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack ([Char] -> ActionT Text IO (Maybe Version))
-> [Char] -> ActionT Text 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 Text IO (Maybe Version)
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> ActionT Text IO (Maybe Version))
-> Maybe Version -> ActionT Text 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
                [] -> Text -> ActionM ()
forall a. Text -> ActionM a
raise (Text -> ActionM ()) -> ([Char] -> Text) -> [Char] -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack ([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 Text -> ActionM ()
forall a. Text -> ActionM a
raise (Text -> ActionM ()) -> ([Char] -> Text) -> [Char] -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack ([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
                        [] -> Text -> ActionM ()
forall a. Text -> ActionM a
raise (Text -> ActionM ()) -> ([Char] -> Text) -> [Char] -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack ([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
        ActionM () -> ScottyM ()
notFound (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ Text -> ActionM ()
forall a. Text -> ActionM a
raise Text
"Unknown request"


readArchiveStore :: [(ArchiveName, FilePath)] -> PackageReadOptions -> PoseidonIO (ArchiveStore [PoseidonPackage])
readArchiveStore :: [([Char], [Char])]
-> PackageReadOptions
-> PoseidonIO (ArchiveStore [PoseidonPackage])
readArchiveStore [([Char], [Char])]
archBaseDirs PackageReadOptions
pacReadOpts = do
    let archiveNames :: [[Char]]
archiveNames = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]])
-> ([([Char], [Char])] -> [[Char]])
-> [([Char], [Char])]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], [Char])] -> [[Char]]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
archBaseDirs
    [[Char]]
-> ([Char] -> ReaderT Env IO ([Char], [PoseidonPackage]))
-> PoseidonIO (ArchiveStore [PoseidonPackage])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
archiveNames (([Char] -> ReaderT Env IO ([Char], [PoseidonPackage]))
 -> PoseidonIO (ArchiveStore [PoseidonPackage]))
-> ([Char] -> ReaderT Env IO ([Char], [PoseidonPackage]))
-> PoseidonIO (ArchiveStore [PoseidonPackage])
forall a b. (a -> b) -> a -> b
$ \[Char]
archiveName -> 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]
++ [Char]
archiveName
        let relevantDirs :: [[Char]]
relevantDirs = (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd ([([Char], [Char])] -> [[Char]])
-> ([([Char], [Char])] -> [([Char], [Char])])
-> [([Char], [Char])]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
archiveName) ([Char] -> Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], [Char])] -> [[Char]]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
archBaseDirs
        [PoseidonPackage]
pacs <- PackageReadOptions -> [[Char]] -> PoseidonIO [PoseidonPackage]
readPoseidonPackageCollection PackageReadOptions
pacReadOpts [[Char]]
relevantDirs
        ([Char], [PoseidonPackage])
-> ReaderT Env IO ([Char], [PoseidonPackage])
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
archiveName, [PoseidonPackage]
pacs)

createZipArchiveStore :: ArchiveStore [PoseidonPackage] -> FilePath -> PoseidonIO (ArchiveStore ZipStore)
createZipArchiveStore :: ArchiveStore [PoseidonPackage]
-> [Char] -> ReaderT Env IO [([Char], ZipStore)]
createZipArchiveStore ArchiveStore [PoseidonPackage]
archiveStore [Char]
zipPath =
    ArchiveStore [PoseidonPackage]
-> (([Char], [PoseidonPackage])
    -> ReaderT Env IO ([Char], ZipStore))
-> ReaderT Env IO [([Char], ZipStore)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ArchiveStore [PoseidonPackage]
archiveStore ((([Char], [PoseidonPackage]) -> ReaderT Env IO ([Char], ZipStore))
 -> ReaderT Env IO [([Char], ZipStore)])
-> (([Char], [PoseidonPackage])
    -> ReaderT Env IO ([Char], ZipStore))
-> ReaderT Env IO [([Char], ZipStore)]
forall a b. (a -> b) -> a -> b
$ \([Char]
archiveName, [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]
++ [Char]
archiveName
        ([Char]
archiveName,) (ZipStore -> ([Char], ZipStore))
-> ReaderT Env IO ZipStore -> ReaderT Env IO ([Char], 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
</> [Char]
archiveName)
            let combinedPackageVersionTitle :: [Char]
combinedPackageVersionTitle = PoseidonPackage -> [Char]
forall a. HasNameAndVersion a => a -> [Char]
renderNameWithVersion PoseidonPackage
pac
            let fn :: [Char]
fn = [Char]
zipPath [Char] -> ShowS
</> [Char]
archiveName [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]

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 <- ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> ActionT Text IO [Char] -> ActionT Text IO (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionT Text IO [Char]
forall a. Parsable a => Text -> ActionM a
param Text
"client_version") ActionT Text IO (Maybe [Char])
-> (Text -> ActionT Text IO (Maybe [Char]))
-> ActionT Text IO (Maybe [Char])
forall a. ActionM a -> (Text -> ActionM a) -> ActionM a
`rescue` (\Text
_ -> Maybe [Char] -> ActionT Text IO (Maybe [Char])
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
    (Version
clientVersion, [[Char]]
versionWarnings) <- case Maybe [Char]
maybeClientVersion of
        Maybe [Char]
Nothing            -> (Version, [[Char]]) -> ActionT Text IO (Version, [[Char]])
forall a. a -> ActionT Text 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 Text IO (Version, [[Char]])
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
v, [])
            Maybe Version
Nothing -> (Version, [[Char]]) -> ActionT Text IO (Version, [[Char]])
forall a. a -> ActionT Text 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
raw <- [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
raw
        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 Text 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 <- ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> ActionT Text IO [Char] -> ActionT Text IO (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionT Text IO [Char]
forall a. Parsable a => Text -> ActionM a
param Text
"archive") ActionT Text IO (Maybe [Char])
-> (Text -> ActionT Text IO (Maybe [Char]))
-> ActionT Text IO (Maybe [Char])
forall a. ActionM a -> (Text -> ActionM a) -> ActionM a
`rescue` (\Text
_ -> Maybe [Char] -> ActionT Text IO (Maybe [Char])
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
    case Maybe [Char]
maybeArchiveName of
        Maybe [Char]
Nothing -> a -> ActionM a
forall a. a -> ActionT Text 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
. ([Char], a) -> a
forall a b. (a, b) -> b
snd (([Char], a) -> a)
-> (ArchiveStore a -> ([Char], a)) -> ArchiveStore a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveStore a -> ([Char], 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]
a -> case [Char] -> ArchiveStore a -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
a ArchiveStore a
store of
            Maybe a
Nothing -> Text -> ActionM a
forall a. Text -> ActionM a
raise (Text -> ActionM a) -> ([Char] -> Text) -> [Char] -> ActionM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack ([Char] -> ActionM a) -> [Char] -> ActionM a
forall a b. (a -> b) -> a -> b
$
                [Char]
"The requested archive named " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" does not exist. Possible archives are " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ((([Char], a) -> [Char]) -> ArchiveStore a -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], a) -> [Char]
forall a b. (a, b) -> a
fst ArchiveStore a
store)
            Just a
pacs -> a -> ActionM a
forall a. a -> ActionT Text IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
pacs