attempts at fixing this

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 ()

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

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 }
+        Nothing   -> pure Nothing
+        Just file -> do
+            time <- getModificationTime file
+            pure $ Just service { storeAppTimestamp = Just time }

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