mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
202 lines
9.2 KiB
Haskell
202 lines
9.2 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Handler.Apps where
|
|
|
|
import Startlude hiding (Handler)
|
|
|
|
import Control.Monad.Logger
|
|
import Data.Aeson
|
|
import qualified Data.Attoparsec.Text as Atto
|
|
import qualified Data.ByteString.Lazy as BS
|
|
import Data.Conduit
|
|
import qualified Data.Conduit.Binary as CB
|
|
import qualified Data.HashMap.Strict as HM
|
|
import qualified Data.Text as T
|
|
import qualified Data.Yaml as Yaml
|
|
import Database.Persist
|
|
import qualified GHC.Show ( Show(..) )
|
|
import Network.HTTP.Types
|
|
import System.Directory
|
|
import System.FilePath ( (<.>)
|
|
, (</>)
|
|
)
|
|
import System.Posix.Files ( fileSize
|
|
, getFileStatus
|
|
)
|
|
import Yesod.Core
|
|
import Yesod.Persist.Core
|
|
|
|
import Foundation
|
|
import Lib.Registry
|
|
import Lib.Types.AppIndex
|
|
import Lib.Types.Emver
|
|
import Lib.Types.FileSystem
|
|
import Lib.Error
|
|
import Lib.External.AppMgr
|
|
import Settings
|
|
import Database.Queries
|
|
import Network.Wai ( Request(requestHeaderUserAgent) )
|
|
import Util.Shared
|
|
|
|
|
|
pureLog :: Show a => a -> Handler a
|
|
pureLog = liftA2 (*>) ($logInfo . show) pure
|
|
|
|
logRet :: ToJSON a => Handler a -> Handler a
|
|
logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure)
|
|
|
|
data FileExtension = FileExtension FilePath (Maybe String)
|
|
instance Show FileExtension where
|
|
show (FileExtension f Nothing ) = f
|
|
show (FileExtension f (Just e)) = f <.> e
|
|
|
|
userAgentOsVersionParser :: Atto.Parser Version
|
|
userAgentOsVersionParser = do
|
|
void $ (Atto.string "EmbassyOS" <|> Atto.string "AmbassadorOS" <|> Atto.string "MeshOS") *> Atto.char '/'
|
|
parseVersion
|
|
|
|
getEmbassyOsVersion :: Handler (Maybe Version)
|
|
getEmbassyOsVersion = userAgentOsVersion
|
|
where
|
|
userAgentOsVersion =
|
|
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
|
|
|
|
getAppsManifestR :: Handler TypedContent
|
|
getAppsManifestR = do
|
|
osVersion <- getEmbassyOsVersion
|
|
appsDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
|
|
let appResourceFile = appsDir </> "apps.yaml"
|
|
manifest <- liftIO (Yaml.decodeFileEither appResourceFile) >>= \case
|
|
Left e -> do
|
|
$logError "COULD NOT PARSE APP INDEX! CORRECT IMMEDIATELY!"
|
|
$logError (show e)
|
|
sendResponseStatus status500 ("Internal Server Error" :: Text)
|
|
Right a -> pure a
|
|
m <- mapM (addFileTimestamp' appsDir) (HM.toList $ unAppManifest manifest)
|
|
let withServiceTimestamps = AppManifest $ HM.fromList m
|
|
let pruned = case osVersion of
|
|
Nothing -> withServiceTimestamps
|
|
Just av -> AppManifest $ HM.mapMaybe (filterOsRecommended av) $ unAppManifest withServiceTimestamps
|
|
pure $ TypedContent "application/x-yaml" (toContent $ Yaml.encode pruned)
|
|
where
|
|
addFileTimestamp' :: (MonadHandler m, MonadIO m) => FilePath -> (AppIdentifier, StoreApp) -> m (AppIdentifier, StoreApp)
|
|
addFileTimestamp' dir (appId, service) = do
|
|
let ext = (Extension (toS appId) :: Extension "s9pk")
|
|
mostRecentVersion <- liftIO $ getMostRecentAppVersion dir ext
|
|
(v, _) <- case mostRecentVersion of
|
|
Nothing -> notFound
|
|
Just a -> pure $ unRegisteredAppVersion a
|
|
liftIO (addFileTimestamp dir ext service v) >>= \case
|
|
Nothing -> notFound
|
|
Just appWithTimestamp -> pure (appId, appWithTimestamp)
|
|
|
|
getSysR :: Extension "" -> Handler TypedContent
|
|
getSysR e = do
|
|
sysResourceDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
|
|
-- @TODO update with new response type here
|
|
getApp sysResourceDir e
|
|
|
|
getAppManifestR :: AppIdentifier -> Handler TypedContent
|
|
getAppManifestR appId = do
|
|
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
|
av <- getVersionFromQuery appsDir appExt >>= \case
|
|
Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text)
|
|
Just v -> pure v
|
|
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
|
|
manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt
|
|
addPackageHeader appMgrDir appDir appExt
|
|
pure $ TypedContent "application/json" (toContent manifest)
|
|
where appExt = Extension (toS appId) :: Extension "s9pk"
|
|
|
|
getAppConfigR :: AppIdentifier -> Handler TypedContent
|
|
getAppConfigR appId = do
|
|
appSettings <- appSettings <$> getYesod
|
|
let appsDir = (</> "apps") . resourcesDir $ appSettings
|
|
let appMgrDir = staticBinDir appSettings
|
|
av <- getVersionFromQuery appsDir appExt >>= \case
|
|
Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text)
|
|
Just v -> pure v
|
|
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
|
|
config <- handleS9ErrT $ getConfig appMgrDir appDir appExt
|
|
addPackageHeader appMgrDir appDir appExt
|
|
pure $ TypedContent "application/json" (toContent config)
|
|
where appExt = Extension (toS appId) :: Extension "s9pk"
|
|
|
|
getAppR :: Extension "s9pk" -> Handler TypedContent
|
|
getAppR e = do
|
|
appResourceDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
|
|
getApp appResourceDir e
|
|
|
|
getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent
|
|
getApp rootDir ext@(Extension appId) = do
|
|
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
|
|
spec <- case readMaybe specString of
|
|
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
|
|
Just t -> pure t
|
|
appVersions <- liftIO $ getAvailableAppVersions rootDir ext
|
|
putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions
|
|
let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions
|
|
let best = fst . getMaxVersion <$> foldMap (Just . MaxVersion . (, fst . unRegisteredAppVersion)) satisfactory
|
|
case best of
|
|
Nothing -> notFound
|
|
Just (RegisteredAppVersion (appVersion, filePath)) -> do
|
|
exists' <- liftIO $ doesFileExist filePath >>= \case
|
|
True -> pure Existent
|
|
False -> pure NonExistent
|
|
determineEvent exists' (extension ext) filePath appVersion
|
|
where
|
|
determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent
|
|
-- for app files
|
|
determineEvent Existent "s9pk" fp av = do
|
|
_ <- recordMetrics appId rootDir av
|
|
chunkIt fp
|
|
-- for png, system, etc
|
|
determineEvent Existent _ fp _ = chunkIt fp
|
|
determineEvent NonExistent _ _ _ = notFound
|
|
|
|
chunkIt :: FilePath -> HandlerFor RegistryCtx TypedContent
|
|
chunkIt fp = do
|
|
sz <- liftIO $ fileSize <$> getFileStatus fp
|
|
addHeader "Content-Length" (show sz)
|
|
respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS
|
|
|
|
recordMetrics :: String -> FilePath -> Version -> HandlerFor RegistryCtx ()
|
|
recordMetrics appId rootDir appVersion = do
|
|
let appId' = T.pack appId
|
|
manifest <- liftIO $ getAppManifest rootDir
|
|
(storeApp, versionInfo) <- case HM.lookup appId' $ unAppManifest manifest of
|
|
Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text)
|
|
Just sa -> do
|
|
-- look up at specfic version
|
|
vi <- case find ((appVersion ==) . versionInfoVersion) (storeAppVersionInfo sa) of
|
|
Nothing -> sendResponseStatus status400 ("App version not present in manifest" :: Text)
|
|
Just x -> pure x
|
|
pure (sa, vi)
|
|
-- lazy load app at requested version if it does not yet exist to automatically transfer from using apps.yaml
|
|
sa <- runDB $ fetchApp appId'
|
|
(appKey, versionKey) <- case sa of
|
|
Nothing -> do
|
|
appKey' <- runDB $ createApp appId' storeApp >>= errOnNothing status500 "duplicate app created"
|
|
versionKey' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing
|
|
status500
|
|
"duplicate app version created"
|
|
pure (appKey', versionKey')
|
|
Just a -> do
|
|
let appKey' = entityKey a
|
|
existingVersion <- runDB $ fetchAppVersion appVersion appKey'
|
|
case existingVersion of
|
|
Nothing -> do
|
|
appVersion' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing
|
|
status500
|
|
"duplicate app version created"
|
|
pure (appKey', appVersion')
|
|
Just v -> pure (appKey', entityKey v)
|
|
runDB $ createMetric appKey versionKey
|