diff --git a/src/Application.hs b/src/Application.hs index 845790a..350b543 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -27,26 +27,58 @@ module Application import Startlude -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger ( liftLoc + , runLoggingT + ) import Data.Default -import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration) -import Language.Haskell.TH.Syntax (qLocation) +import Database.Persist.Postgresql ( createPostgresqlPool + , pgConnStr + , pgPoolSize + , runMigration + , runSqlPool + ) +import Language.Haskell.TH.Syntax ( qLocation ) import Network.Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - getPort, setHost, setOnException, setPort, runSettings) +import Network.Wai.Handler.Warp ( Settings + , defaultSettings + , defaultShouldDisplayException + , getPort + , runSettings + , setHTTP2Disabled + , setHost + , setOnException + , setPort + ) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsResourcePolicy) +import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) + , cors + , simpleCorsResourcePolicy + ) import Network.Wai.Middleware.MethodOverride -import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), - destination, mkRequestLogger, outputFormat) -import System.IO (hSetBuffering, BufferMode (..)) -import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Network.Wai.Middleware.RequestLogger + ( Destination(Logger) + , IPAddrSource(..) + , OutputFormat(..) + , destination + , mkRequestLogger + , outputFormat + ) +import System.IO ( BufferMode(..) + , hSetBuffering + ) +import System.Log.FastLogger ( defaultBufSize + , newStdoutLoggerSet + , toLogStr + ) import Yesod.Core -import Yesod.Core.Types hiding (Logger) +import Yesod.Core.Types hiding ( Logger ) import Yesod.Default.Config2 +import Control.Arrow ( (***) ) +import Control.Lens +import Data.List ( lookup ) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Foundation @@ -54,14 +86,12 @@ import Handler.Apps import Handler.Icons import Handler.Version import Lib.Ssl +import Model +import Network.HTTP.Types.Header ( hOrigin ) import Settings +import System.Mem ( performGC ) import System.Posix.Process import System.Time.Extra -import Model -import Control.Lens -import Control.Arrow ((***)) -import Network.HTTP.Types.Header ( hOrigin ) -import Data.List (lookup) -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -76,27 +106,26 @@ makeFoundation :: AppSettings -> IO RegistryCtx makeFoundation appSettings = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. - appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appWebServerThreadId <- newEmptyMVar - appShouldRestartWeb <- newMVar False + appShouldRestartWeb <- newMVar False -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool = RegistryCtx {..} - -- The RegistryCtx {..} syntax is an example of record wild cards. For more - -- information, see: - -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + let mkFoundation appConnPool = RegistryCtx { .. } +-- The RegistryCtx {..} syntax is an example of record wild cards. For more +-- information, see: +-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation" - logFunc = messageLoggerSource tempFoundation appLogger + logFunc = messageLoggerSource tempFoundation appLogger -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool - (pgConnStr $ appDatabaseConf appSettings) - (pgPoolSize . appDatabaseConf $ appSettings) + pool <- flip runLoggingT logFunc + $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) -- Preform database migration using application logging settings runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc @@ -108,11 +137,10 @@ makeFoundation appSettings = do -- applying some additional middlewares. makeApplication :: RegistryCtx -> IO Application makeApplication foundation = do - logWare <- makeLogWare foundation - let authWare = makeAuthWare foundation + logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation - pure . logWare . cors dynamicCorsResourcePolicy . authWare . acceptOverride . autohead . methodOverride $ appPlain + pure . logWare . cors dynamicCorsResourcePolicy . acceptOverride . autohead . methodOverride $ appPlain dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req @@ -178,30 +206,14 @@ dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders ] , corsIgnoreFailures = True } --- TODO: create a middle ware which will attempt to verify an ecdsa signed transaction against one of the public keys --- in the validDevices table. --- makeCheckSigWare :: RegistryCtx -> IO Middleware --- makeCheckSigWare = _ makeLogWare :: RegistryCtx -> IO Middleware -makeLogWare foundation = - mkRequestLogger def - { outputFormat = - if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else Apache - (if appIpFromHeader $ appSettings foundation - then FromFallback - else FromSocket) - , destination = Logger $ loggerSet $ appLogger foundation - } - --- TODO : what kind of auth is needed here -makeAuthWare :: RegistryCtx -> Middleware -makeAuthWare _ app req res = next - where - next :: IO ResponseReceived - next = app req res +makeLogWare foundation = mkRequestLogger def + { outputFormat = if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else Apache (if appIpFromHeader $ appSettings foundation then FromFallback else FromSocket) + , destination = Logger $ loggerSet $ appLogger foundation + } -- | Warp settings for the given foundation value. warpSettings :: AppPort -> RegistryCtx -> Settings @@ -216,6 +228,7 @@ warpSettings port foundation = "yesod" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) + $ setHTTP2Disabled defaultSettings getAppSettings :: IO AppSettings @@ -228,11 +241,10 @@ appMain = do -- Get the settings from all relevant sources settings <- loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] + [configSettingsYmlValue] -- allow environment variables to override - useEnv - + useEnv -- Generate the foundation from the settings makeFoundation settings >>= startApp @@ -259,17 +271,17 @@ startApp foundation = do startWeb :: RegistryCtx -> IO () startWeb foundation = do app <- makeApplication foundation + void $ forkIO $ forever $ sleep 10 *> putStrLn @Text "Performing GC" *> performGC startWeb' app where startWeb' app = do - let AppSettings{..} = appSettings foundation + let AppSettings {..} = appSettings foundation putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort torAction <- async $ runSettings (warpSettings torPort foundation) app putStrLn @Text $ "Launching Web Server on port " <> show appPort action <- if sslAuto - then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings appPort foundation) app - else async $ runSettings (warpSettings appPort foundation) app + then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app + else async $ runSettings (warpSettings appPort foundation) app let actions = (action, torAction) setWebProcessThreadId (join (***) asyncThreadId actions) foundation @@ -292,7 +304,7 @@ startWeb foundation = do restartWeb :: RegistryCtx -> IO () restartWeb foundation = do - void $ swapMVar (appShouldRestartWeb foundation) True + putMVar (appShouldRestartWeb foundation) True shutdownWeb foundation shutdownAll :: [ThreadId] -> IO () @@ -302,8 +314,8 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () -shutdownWeb RegistryCtx{..} = do - threadIds <- takeMVar appWebServerThreadId +shutdownWeb RegistryCtx {..} = do + threadIds <- takeMVar appWebServerThreadId void $ both killThread threadIds -------------------------------------------------------------- @@ -313,9 +325,9 @@ shutdownWeb RegistryCtx{..} = do getApplicationRepl :: AppPort -> IO (Int, RegistryCtx, Application) getApplicationRepl port = do foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings port foundation - app1 <- makeApplication foundation - return (getPort wsettings, foundation, app1) + wsettings <- getDevSettings $ warpSettings port foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) shutdownApp :: RegistryCtx -> IO () shutdownApp _ = return () diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index c7261c5..5f86383 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} module Handler.Apps where @@ -14,7 +15,8 @@ import Startlude import Control.Monad.Logger import Data.Aeson import qualified Data.Attoparsec.Text as Atto -import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.Char import Data.Conduit import qualified Data.Conduit.Binary as CB @@ -34,16 +36,16 @@ import System.Posix.Files ( fileSize import Yesod.Core import Yesod.Persist.Core +import Database.Queries import Foundation +import Lib.Error +import Lib.External.AppMgr 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 Settings import Util.Shared @@ -51,7 +53,7 @@ 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) +logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . LBS.toStrict . encode) pure) data FileExtension = FileExtension FilePath (Maybe String) instance Show FileExtension where @@ -71,32 +73,37 @@ getEmbassyOsVersion = userAgentOsVersion getAppsManifestR :: Handler TypedContent getAppsManifestR = do - osVersion <- getEmbassyOsVersion - appsDir <- ( "apps") . resourcesDir . appSettings <$> getYesod + osVersion <- getEmbassyOsVersion + appsDir <- ( "apps") . resourcesDir . appSettings <$> getYesod let appResourceFile = appsDir "apps.yaml" - manifest <- liftIO (Yaml.decodeFileEither appResourceFile) >>= \case - Left e -> do + appResourceBytes <- liftIO $ BS.readFile appResourceFile + manifest <- case {-# SCC yaml_decode_either #-} Yaml.decodeEither' appResourceBytes of + 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 + Right !a -> pure a 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) + Nothing -> manifest + Just av -> AppManifest . HM.mapMaybe (filterOsRecommended av) . unAppManifest $ manifest + withServiceTimestamps <- + fmap AppManifest + . HM.traverseWithKey (const pure {-addFileTimestamp' appsDir-} + ) + . unAppManifest + $ pruned + pure . TypedContent "application/x-yaml" . toContent . Yaml.encode $! withServiceTimestamps where - addFileTimestamp' :: (MonadHandler m, MonadIO m) => FilePath -> (AppIdentifier, StoreApp) -> m (AppIdentifier, StoreApp) - addFileTimestamp' dir (appId, service) = do + addFileTimestamp' :: (MonadHandler m, MonadIO m) => FilePath -> AppIdentifier -> StoreApp -> m 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 + (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) + Nothing -> notFound + Just appWithTimestamp -> pure appWithTimestamp getSysR :: Extension "" -> Handler TypedContent getSysR e = do @@ -106,7 +113,7 @@ getSysR e = do getAppManifestR :: AppIdentifier -> Handler TypedContent getAppManifestR appId = do (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - av <- getVersionFromQuery appsDir appExt >>= \case + 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 @@ -145,10 +152,10 @@ getApp rootDir ext@(Extension appId) = do case best of Nothing -> notFound Just (RegisteredAppVersion (appVersion, filePath)) -> do - exists <- liftIO $ doesFileExist filePath >>= \case + existence <- liftIO $ doesFileExist filePath >>= \case True -> pure Existent False -> pure NonExistent - determineEvent exists (extension ext) filePath appVersion + determineEvent existence (extension ext) filePath appVersion where determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent -- for app files diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index e939e6d..b32c44c 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -10,20 +10,20 @@ import Data.Aeson import qualified Data.HashMap.Strict as HM import qualified Data.List.NonEmpty as NE +import Lib.Registry import Lib.Types.Emver import Orphans.Emver ( ) import System.Directory -import Lib.Registry type AppIdentifier = Text data VersionInfo = VersionInfo - { versionInfoVersion :: Version - , versionInfoReleaseNotes :: Text - , versionInfoDependencies :: HM.HashMap Text VersionRange - , versionInfoOsRequired :: VersionRange - , versionInfoOsRecommended :: VersionRange - , versionInfoInstallAlert :: Maybe Text + { versionInfoVersion :: !Version + , versionInfoReleaseNotes :: !Text + , versionInfoDependencies :: !(HM.HashMap Text VersionRange) + , versionInfoOsRequired :: !VersionRange + , versionInfoOsRecommended :: !VersionRange + , versionInfoInstallAlert :: !(Maybe Text) } deriving (Eq, Show) @@ -51,12 +51,12 @@ instance ToJSON VersionInfo where ] data StoreApp = StoreApp - { storeAppTitle :: Text - , storeAppDescShort :: Text - , storeAppDescLong :: Text - , storeAppVersionInfo :: NonEmpty VersionInfo - , storeAppIconType :: Text - , storeAppTimestamp :: Maybe UTCTime + { storeAppTitle :: !Text + , storeAppDescShort :: !Text + , storeAppDescLong :: !Text + , storeAppVersionInfo :: !(NonEmpty VersionInfo) + , storeAppIconType :: !Text + , storeAppTimestamp :: !(Maybe UTCTime) } deriving Show @@ -84,7 +84,7 @@ instance FromJSON AppManifest where storeAppVersionInfo <- config .: "version-info" >>= \case [] -> fail "No Valid Version Info" (x : xs) -> pure $ x :| xs - storeAppTimestamp <- config .:? "timestamp" + storeAppTimestamp <- config .:? "timestamp" pure (appId, StoreApp { .. }) return $ AppManifest (HM.fromList apps) instance ToJSON AppManifest where @@ -104,7 +104,7 @@ filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) addFileTimestamp :: KnownSymbol a => FilePath -> Extension a -> StoreApp -> Version -> IO (Maybe StoreApp) addFileTimestamp appDir ext service v = do getVersionedFileFromDir appDir ext v >>= \case - Nothing -> pure Nothing - Just file -> do - time <- getModificationTime file - pure $ Just service {storeAppTimestamp = Just time } \ No newline at end of file + Nothing -> pure Nothing + Just file -> do + time <- getModificationTime file + pure $ Just service { storeAppTimestamp = Just time } diff --git a/stack.yaml b/stack.yaml index 5af9d27..853e344 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.11 +resolver: lts-18.19 # User packages to be built. # Various formats can be used as shown in the example below. @@ -29,7 +29,7 @@ resolver: lts-18.11 # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: @@ -41,7 +41,6 @@ packages: # extra-deps: - protolude-0.2.4 - # Override default flag values for local packages and extra-deps # flags: {} @@ -66,4 +65,4 @@ extra-deps: # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor # docker: - # enable: true +# enable: true