Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 10:21:51 +00:00
Code Issues Packages Projects Releases Wiki Activity

more cleanup

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-29 14:57:06 -06:00
parent 6c55244aa4
commit 1a43fc52b6
6 changed files with 60 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/Application.hs
View File

@@ -29,7 +29,8 @@ module Application
import Startlude hiding ( Handler )
import Control.Monad.Logger ( liftLoc
import Control.Monad.Logger ( LoggingT
, liftLoc
, runLoggingT
)
import Data.Default
@@ -80,6 +81,8 @@ import Yesod.Default.Config2
import Control.Arrow ( (***) )
import Control.Lens
import Data.List ( lookup )
import Data.String.Interpolate.IsString
( i )
import Database.Persist.Sql ( SqlBackend )
import Foundation
import Handler.Apps
@@ -268,21 +271,24 @@ startApp :: RegistryCtx -> IO ()
startApp foundation = do
when (sslAuto . appSettings $ foundation) $ do
-- set up ssl certificates
putStrLn @Text "Setting up SSL"
runLog $ $logInfo "Setting up SSL"
_ <- setupSsl $ appSettings foundation
putStrLn @Text "SSL Setup Complete"
runLog $ $logInfo "SSL Setup Complete"
-- certbot renew loop
void . forkIO $ forever $ flip runReaderT foundation $ do
shouldRenew <- doesSslNeedRenew
putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew
runLog $ $logInfo $ [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
when shouldRenew $ do
putStrLn @Text "Renewing SSL Certs."
runLog $ $logInfo "Renewing SSL Certs."
renewSslCerts
liftIO $ restartWeb foundation
liftIO $ sleep 86_400
startWeb foundation
where
runLog :: MonadIO m => LoggingT m a -> m a
runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))
startWeb :: RegistryCtx -> IO ()
startWeb foundation = do
@@ -291,9 +297,9 @@ startWeb foundation = do
where
startWeb' app = (`onException` (appStopFsNotify foundation)) $ do
let AppSettings {..} = appSettings foundation
runLog $ $logInfo $ "Launching Tor Web Server on port " <> show torPort
runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|]
torAction <- async $ runSettings (warpSettings torPort foundation) app
runLog $ $logInfo $ "Launching Web Server on port " <> show appPort
runLog $ $logInfo $ [i|Launching Web Server on port #{appPort}|]
action <- if sslAuto
then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
else async $ runSettings (warpSettings appPort foundation) app
@@ -314,7 +320,7 @@ startWeb foundation = do
shouldRestart <- takeMVar (appShouldRestartWeb foundation)
when shouldRestart $ do
putMVar (appShouldRestartWeb foundation) False
putStrLn @Text "Restarting Web Server"
runLog $ $logInfo "Restarting Web Server"
startWeb' app
runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))

4
src/Handler/Apps.hs
View File

@@ -114,14 +114,14 @@ recordMetrics pkg appVersion = do
sa <- runDB $ fetchApp $ pkg
case sa of
Nothing -> do
$logError $ show pkg <> " not found in database"
$logError $ [i|#{pkg} not found in database|]
notFound
Just a -> do
let appKey' = entityKey a
existingVersion <- runDB $ fetchAppVersion appVersion appKey'
case existingVersion of
Nothing -> do
$logError $ "Version: " <> show appVersion <> " not found in database"
$logError $ [i|#{pkg}@#{appVersion} not found in database|]
notFound
Just v -> runDB $ createMetric (entityKey a) (entityKey v)

57
src/Handler/Marketplace.hs
View File

@@ -19,7 +19,9 @@ import Startlude hiding ( Handler
)
import Conduit ( (.|)
, awaitForever
, runConduit
, sourceFile
)
import Control.Monad.Except.CoHas ( liftEither )
import Control.Parallel.Strategies ( parMap
@@ -36,6 +38,7 @@ import Data.Aeson ( (.:)
, object
, withObject
)
import qualified Data.Attoparsec.Text as Atto
import qualified Data.ByteString.Lazy as BS
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Strict as HM
@@ -78,9 +81,7 @@ import qualified Database.Persist as P
import Foundation ( Handler
, RegistryCtx(appSettings)
)
import Lib.Error ( S9Error(AssetParseE, InvalidParamsE, NotFoundE)
, errOnNothing
)
import Lib.Error ( S9Error(..) )
import Lib.PkgRepository ( getManifest )
import Lib.Types.AppIndex ( PkgId(PkgId)
, ServiceDependencyInfo(serviceDependencyInfoVersion)
@@ -92,6 +93,8 @@ import Lib.Types.Category ( CategoryTitle(FEATURED) )
import Lib.Types.Emver ( (<||)
, Version
, VersionRange
, parseVersion
, satisfies
)
import Model ( Category(..)
, EntityField(..)
@@ -104,22 +107,31 @@ import Network.HTTP.Types ( status400
, status404
)
import Protolude.Unsafe ( unsafeFromJust )
import Settings ( AppSettings(registryHostname) )
import Settings ( AppSettings(registryHostname, resourcesDir) )
import System.FilePath ( (</>) )
import UnliftIO.Async ( concurrently
, mapConcurrently
)
import UnliftIO.Directory ( listDirectory )
import Util.Shared ( getVersionSpecFromQuery
, orThrow
)
import Yesod.Core ( HandlerFor
, MonadLogger
, MonadResource
, MonadUnliftIO
, ToContent(..)
, ToTypedContent(..)
, TypedContent
, YesodRequest(..)
, getRequest
, getsYesod
, logWarn
, lookupGetParam
, respondSource
, sendChunkBS
, sendResponseStatus
, typeOctet
)
import Yesod.Persist.Core ( YesodPersist(runDB) )
@@ -266,8 +278,8 @@ getCategoriesR = do
pure cats
pure $ CategoryRes $ categoryName . entityVal <$> allCategories
getEosR :: Handler EosRes
getEosR = do
getEosVersionR :: Handler EosRes
getEosVersionR = do
allEosVersions <- runDB $ select $ do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
@@ -289,19 +301,35 @@ getReleaseNotesR :: Handler ReleaseNotes
getReleaseNotesR = do
getParameters <- reqGetParams <$> getRequest
case lookup "id" getParameters of
Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text)
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "<MISSING>")
Just package -> do
(service, _) <- runDB $ fetchLatestApp (PkgId package) >>= errOnNothing status404 "package not found"
(service, _) <- runDB $ fetchLatestApp (PkgId package) `orThrow` sendResponseStatus
status404
(NotFoundE $ show package)
(_, mappedVersions) <- fetchAllAppVersions (entityKey service)
pure mappedVersions
getEosR :: Handler TypedContent
getEosR = do
spec <- getVersionSpecFromQuery
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
subdirs <- listDirectory root
let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes
case res of
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Just r -> do
let imgPath = root </> show r </> "eos.img"
respondSource typeOctet (sourceFile imgPath .| awaitForever sendChunkBS)
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of
Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text)
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
Right (p :: [PkgId]) -> do
let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
@@ -404,9 +432,8 @@ getPackageListR = do
let satisfactory = filter (<|| spec) (fst pacakgeMetadata)
let best = getMax <$> foldMap (Just . Max) satisfactory
case best of
Nothing ->
pure $ Left $ "best version could not be found for " <> show appId <> " with spec " <> show spec
Just v -> do
Nothing -> pure $ Left $ [i|Best version could not be found for #{appId} with spec #{spec}|]
Just v -> do
pure $ Right (Just v, appId)
getServiceDetails :: (MonadIO m, MonadResource m)
@@ -424,7 +451,7 @@ getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do
Nothing -> do
-- grab first value, which will be the latest version
case fst packageMetadata of
[] -> liftEither . Left $ NotFoundE $ "no latest version found for " <> show pkg
[] -> liftEither . Left $ NotFoundE $ [i|No latest version found for #{pkg}|]
x : _ -> pure x
Just v -> pure v
manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs ->
@@ -455,7 +482,7 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do
let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata)
let best = getMax <$> foldMap (Just . Max) satisfactory
version <- case best of
Nothing -> Left $ NotFoundE $ "best version not found for dependent package " <> show appId
Nothing -> Left $ NotFoundE $ [i|No satisfactory version for dependent package #{appId}|]
Just v -> pure v
pure
( appId

32
src/Handler/Version.hs
View File

@@ -11,25 +11,15 @@ import Startlude hiding ( Handler )
import Yesod.Core
import qualified Data.Attoparsec.Text as Atto
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Foundation
import Handler.Types.Status
import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion )
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version(..)
, parseVersion
, satisfies
)
import Network.HTTP.Types.Status ( status404 )
import Settings
import System.FilePath ( (</>) )
import System.IO.Error ( isDoesNotExistError )
import UnliftIO.Directory ( listDirectory )
import Util.Shared ( getVersionSpecFromQuery
, orThrow
)
@@ -43,25 +33,3 @@ getPkgVersionR pkg = do
AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus
status404
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])
data EosVersionRes = EosVersionRes
{ eosVersionVersion :: Version
, eosVersionReleaseNotes :: Text
}
getEosVersionR :: Handler EosVersionRes
getEosVersionR = do
spec <- getVersionSpecFromQuery
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
subdirs <- listDirectory root
let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes
case res of
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Just r -> do
let notesPath = root </> show r </> "release-notes.md"
notes <- liftIO $ T.readFile notesPath `catch` \e ->
if isDoesNotExistError e then pure [i|# Release Notes Missing for #{r}|] else throwIO e
pure $ EosVersionRes r notes

3
src/Lib/PkgRepository.hs
View File

@@ -48,7 +48,6 @@ import Startlude ( ($)
, (&&)
, (.)
, (<$>)
, (<>)
, Bool(..)
, ByteString
, Down(..)
@@ -234,7 +233,7 @@ getIcon pkg version = do
let pkgRoot = root </> show pkg </> show version
mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot
case mIconFile of
Nothing -> throwIO $ NotFoundE $ show pkg <> ": Icon"
Nothing -> throwIO $ NotFoundE $ [i|#{pkg}: Icon|]
Just x -> do
let ct = case takeExtension x of
".png" -> typePng

2
src/Lib/Types/AppIndex.hs
View File

@@ -49,7 +49,7 @@ instance ToJSONKey PkgId where
instance PersistField PkgId where
toPersistValue = PersistText . show
fromPersistValue (PersistText t) = Right . PkgId $ toS t
fromPersistValue other = Left $ "Invalid AppId: " <> show other
fromPersistValue other = Left $ [i|Invalid AppId: #{other}|]
instance PersistFieldSql PkgId where
sqlType _ = SqlString
instance PathPiece PkgId where