From d6ae7039152d4a3c9ceba2b5168cd38731044b66 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 14:57:06 -0600 Subject: [PATCH] more cleanup --- src/Application.hs | 22 +++++++++------ src/Handler/Apps.hs | 4 +-- src/Handler/Marketplace.hs | 57 ++++++++++++++++++++++++++++---------- src/Handler/Version.hs | 32 --------------------- src/Lib/PkgRepository.hs | 3 +- src/Lib/Types/AppIndex.hs | 2 +- 6 files changed, 60 insertions(+), 60 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index cb1d049..ffa7c46 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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)) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index ea8912b..7ef0b06 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index f82d639..f1df3e2 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -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" "") 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" "") 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 diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 4e0a1ac..6839bbf 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -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 diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index d0ede79..f79d4d6 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -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 diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index a6d23d4..40fad6f 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -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