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

bang patterns optimization to avoid unnecessary laziness

Browse Source
This commit is contained in:
Keagan McClelland
2022-05-27 10:53:09 -06:00
parent 2105c58182
commit f761677420
12 changed files with 101 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/Cli/Cli.hs
View File

@@ -178,9 +178,9 @@ import Yesod ( logError
)
data Upload = Upload
{ publishRepoName :: String
, publishPkg :: Maybe FilePath
, publishIndex :: Bool
{ publishRepoName :: !String
, publishPkg :: !(Maybe FilePath)
, publishIndex :: !Bool
}
deriving Show
@@ -195,9 +195,9 @@ instance Default PublishCfg where
data PublishCfgRepo = PublishCfgRepo
{ publishCfgRepoLocation :: URI
, publishCfgRepoUser :: String
, publishCfgRepoPass :: String
{ publishCfgRepoLocation :: !URI
, publishCfgRepoUser :: !String
, publishCfgRepoPass :: !String
}
deriving (Show, Generic)
instance FromDhall PublishCfgRepo
@@ -214,13 +214,13 @@ instance IsString URI where
data Shell = Bash | Fish | Zsh deriving Show
data Command
= CmdInit (Maybe Shell)
| CmdRegAdd String PublishCfgRepo
| CmdRegDel String
= CmdInit !(Maybe Shell)
| CmdRegAdd !String !PublishCfgRepo
| CmdRegDel !String
| CmdRegList
| CmdUpload Upload
| CmdIndex String String Version Bool
| CmdListUnindexed String
| CmdUpload !Upload
| CmdIndex !String !String !Version !Bool
| CmdListUnindexed !String
deriving Show
cfgLocation :: IO FilePath

6
src/Foundation.hs
View File

@@ -10,6 +10,7 @@
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
module Foundation where
@@ -166,14 +167,17 @@ instance Has EosRepo RegistryCtx where
extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings
{-# INLINE transitiveExtract #-}
transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a
transitiveExtract = extract @a . extract @b
{-# INLINE transitiveUpdate #-}
transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate f = update (update @a @b f)
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) tid
setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:

2
src/Handler/Admin.hs
View File

@@ -186,5 +186,7 @@ getPkgDeindexR = do
onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb
{-# INLINE (.*) #-}
infixr 8 .*
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.*) = (.) . (.)

2
src/Handler/Apps.hs
View File

@@ -65,7 +65,7 @@ import Util.Shared ( addPackageHeader
, versionPriorityFromQueryIsMin
)
data FileExtension = FileExtension FilePath (Maybe String)
data FileExtension = FileExtension !FilePath !(Maybe String)
instance Show FileExtension where
show (FileExtension f Nothing ) = f
show (FileExtension f (Just e)) = f <.> e

14
src/Handler/ErrorLogs.hs
View File

@@ -27,13 +27,13 @@ import Yesod.Persist ( (+=.)
)
data ErrorLog = ErrorLog
{ errorLogEpoch :: Text
, errorLogCommitHash :: Text
, errorLogSourceFile :: Text
, errorLogLine :: Word32
, errorLogTarget :: Text
, errorLogLevel :: Text
, errorLogMessage :: Text
{ errorLogEpoch :: !Text
, errorLogCommitHash :: !Text
, errorLogSourceFile :: !Text
, errorLogLine :: !Word32
, errorLogTarget :: !Text
, errorLogLevel :: !Text
, errorLogMessage :: !Text
}
deriving (Eq, Show)

56
src/Handler/Types/Marketplace.hs
View File

@@ -40,8 +40,8 @@ import Yesod ( Entity
type URL = Text
type CategoryTitle = Text
data InfoRes = InfoRes
{ name :: Text
, categories :: [CategoryTitle]
{ name :: !Text
, categories :: ![CategoryTitle]
}
deriving (Show, Generic)
instance ToJSON InfoRes
@@ -50,13 +50,13 @@ instance ToContent InfoRes where
instance ToTypedContent InfoRes where
toTypedContent = toTypedContent . toJSON
data PackageRes = PackageRes
{ packageResIcon :: URL
, packageResManifest :: Data.Aeson.Value -- PackageManifest
, packageResCategories :: [CategoryTitle]
, packageResInstructions :: URL
, packageResLicense :: URL
, packageResVersions :: [Version]
, packageResDependencies :: HM.HashMap PkgId DependencyRes
{ packageResIcon :: !URL
, packageResManifest :: !Data.Aeson.Value -- PackageManifest
, packageResCategories :: ![CategoryTitle]
, packageResInstructions :: !URL
, packageResLicense :: !URL
, packageResVersions :: ![Version]
, packageResDependencies :: !(HM.HashMap PkgId DependencyRes)
}
deriving (Show, Generic)
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
@@ -88,8 +88,8 @@ instance FromJSON PackageRes where
packageResDependencies <- o .: "dependency-metadata"
pure PackageRes { .. }
data DependencyRes = DependencyRes
{ dependencyResTitle :: Text
, dependencyResIcon :: Text
{ dependencyResTitle :: !Text
, dependencyResIcon :: !Text
}
deriving (Eq, Show)
instance ToJSON DependencyRes where
@@ -117,17 +117,17 @@ instance ToTypedContent VersionLatestRes where
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
data PackageListDefaults = PackageListDefaults
{ packageListOrder :: OrderArrangement
, packageListPageLimit :: Int -- the number of items per page
, packageListPageNumber :: Int -- the page you are on
, packageListCategory :: Maybe CategoryTitle
, packageListQuery :: Text
{ packageListOrder :: !OrderArrangement
, packageListPageLimit :: !Int -- the number of items per page
, packageListPageNumber :: !Int -- the page you are on
, packageListCategory :: !(Maybe CategoryTitle)
, packageListQuery :: !Text
}
deriving (Eq, Show, Read)
data EosRes = EosRes
{ eosResVersion :: Version
, eosResHeadline :: Text
, eosResReleaseNotes :: ReleaseNotes
{ eosResVersion :: !Version
, eosResHeadline :: !Text
, eosResReleaseNotes :: !ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
@@ -139,8 +139,8 @@ instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
data PackageReq = PackageReq
{ packageReqId :: PkgId
, packageReqVersion :: VersionRange
{ packageReqId :: !PkgId
, packageReqVersion :: !VersionRange
}
deriving Show
instance FromJSON PackageReq where
@@ -149,15 +149,15 @@ instance FromJSON PackageReq where
packageReqVersion <- o .: "version"
pure PackageReq { .. }
data PackageMetadata = PackageMetadata
{ packageMetadataPkgId :: PkgId
, packageMetadataPkgVersionRecords :: [Entity VersionRecord]
, packageMetadataPkgCategories :: [Entity Category]
, packageMetadataPkgVersion :: Version
{ packageMetadataPkgId :: !PkgId
, packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
, packageMetadataPkgCategories :: ![Entity Category]
, packageMetadataPkgVersion :: !Version
}
deriving (Eq, Show)
data PackageDependencyMetadata = PackageDependencyMetadata
{ packageDependencyMetadataPkgDependencyRecord :: Entity PkgDependency
, packageDependencyMetadataDepPkgRecord :: Entity PkgRecord
, packageDependencyMetadataDepVersions :: [Entity VersionRecord]
{ packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency)
, packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord)
, packageDependencyMetadataDepVersions :: ![Entity VersionRecord]
}
deriving (Eq, Show)

2
src/Handler/Types/Status.hs
View File

@@ -21,7 +21,7 @@ import Yesod.Core.Content ( ToContent(..)
import Lib.Types.Emver ( Version )
import Orphans.Emver ( )
data AppVersionRes = AppVersionRes
newtype AppVersionRes = AppVersionRes
{ appVersionVersion :: Version
}
deriving (Eq, Show)

14
src/Lib/Error.hs
View File

@@ -31,11 +31,11 @@ import Yesod.Core ( (.=)
type S9ErrT m = ExceptT S9Error m
data S9Error =
PersistentE Text
| AppMgrE Text ExitCode
| NotFoundE Text
| InvalidParamsE Text Text
| AssetParseE Text Text
PersistentE !Text
| AppMgrE !Text !ExitCode
| NotFoundE !Text
| InvalidParamsE !Text !Text
| AssetParseE !Text !Text
deriving (Show, Eq)
instance Exception S9Error
@@ -60,8 +60,8 @@ instance ToJSON ErrorCode where
toJSON = String . show
data Error = Error
{ errorCode :: ErrorCode
, errorMessage :: Text
{ errorCode :: !ErrorCode
, errorMessage :: !Text
}
deriving (Eq, Show)
instance ToJSON Error where

4
src/Lib/PkgRepository.hs
View File

@@ -161,8 +161,8 @@ newtype ManifestParseException = ManifestParseException FilePath
instance Exception ManifestParseException
data PkgRepo = PkgRepo
{ pkgRepoFileRoot :: FilePath
, pkgRepoAppMgrBin :: FilePath
{ pkgRepoFileRoot :: !FilePath
, pkgRepoAppMgrBin :: !FilePath
}
newtype EosRepo = EosRepo

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

@@ -69,18 +69,18 @@ instance PathPiece PkgId where
fromPathPiece = fmap PkgId . fromPathPiece
toPathPiece = unPkgId
data VersionInfo = VersionInfo
{ versionInfoVersion :: Version
, versionInfoReleaseNotes :: Text
, versionInfoDependencies :: HM.HashMap PkgId VersionRange
, versionInfoOsVersion :: Version
, versionInfoInstallAlert :: Maybe Text
{ versionInfoVersion :: !Version
, versionInfoReleaseNotes :: !Text
, versionInfoDependencies :: !(HM.HashMap PkgId VersionRange)
, versionInfoOsVersion :: !Version
, versionInfoInstallAlert :: !(Maybe Text)
}
deriving (Eq, Show)
data PackageDependency = PackageDependency
{ packageDependencyOptional :: Maybe Text
, packageDependencyVersion :: VersionRange
, packageDependencyDescription :: Maybe Text
{ packageDependencyOptional :: !(Maybe Text)
, packageDependencyVersion :: !VersionRange
, packageDependencyDescription :: !(Maybe Text)
}
deriving Show
instance FromJSON PackageDependency where

13
src/Lib/Types/Emver.hs
View File

@@ -15,6 +15,7 @@ scenario we were left with the conundrum of either unilaterally claiming a versi
or let the issue persist until the next update. Neither of these promote good user experiences, for different reasons.
This module extends the semver standard linked above with a 4th digit, which is given PATCH semantics.
-}
{-# LANGUAGE BangPatterns #-}
module Lib.Types.Emver
( major
@@ -53,6 +54,7 @@ import Startlude ( ($)
, IsString(..)
, Monad((>>=))
, Monoid(mappend, mempty)
, NFData(..)
, Num((+))
, Ord(compare)
, Ordering(..)
@@ -65,6 +67,7 @@ import Startlude ( ($)
, flip
, id
, on
, seq
, show
, (||)
)
@@ -137,12 +140,16 @@ type Operator = Either Ordering Ordering
-- Distributivity of conjunction over disjunction: Conj a (Disj b c) === Disj (Conj a b) (Conj a c)
-- Distributivity of disjunction over conjunction: Disj a (Conj b c) === Conj (Disj a b) (Disj a c)
data VersionRange
= Anchor Operator Version
= Anchor !Operator !Version
| Conj VersionRange VersionRange
| Disj VersionRange VersionRange
| Any
| None
deriving (Eq)
instance NFData VersionRange where
rnf (Conj a b) = rnf a `seq` rnf b
rnf (Disj a b) = rnf a `seq` rnf b
rnf other = other `seq` ()
-- | Smart constructor for conjunctions. Eagerly evaluates zeros and identities
conj :: VersionRange -> VersionRange -> VersionRange
@@ -150,7 +157,7 @@ conj Any b = b
conj a Any = a
conj None _ = None
conj _ None = None
conj a b = Conj a b
conj !a !b = Conj a b
-- | Smart constructor for disjunctions. Eagerly evaluates zeros and identities
disj :: VersionRange -> VersionRange -> VersionRange
@@ -158,7 +165,7 @@ disj Any _ = Any
disj _ Any = Any
disj None b = b
disj a None = a
disj a b = Disj a b
disj !a !b = Disj a b
exactly :: Version -> VersionRange
exactly = Anchor (Right EQ)

36
src/Settings.hs
View File

@@ -61,30 +61,30 @@ import Orphans.Emver ( )
-- theoretically even a database.
type AppPort = Word16
data AppSettings = AppSettings
{ appDatabaseConf :: PostgresConf
, appHost :: HostPreference
{ appDatabaseConf :: !PostgresConf
, appHost :: !HostPreference
-- ^ Host/interface the server should bind to.
, appPort :: AppPort
, appPort :: !AppPort
-- ^ Port to listen on
, appIpFromHeader :: Bool
, appIpFromHeader :: !Bool
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
, appDetailedRequestLogging :: Bool
, appDetailedRequestLogging :: !Bool
-- ^ Use detailed request logging system
, appShouldLogAll :: Bool
, appShouldLogAll :: !Bool
-- ^ Should all log messages be displayed?
, resourcesDir :: FilePath
, sslPath :: FilePath
, sslAuto :: Bool
, registryHostname :: Text
, registryVersion :: Version
, sslKeyLocation :: FilePath
, sslCsrLocation :: FilePath
, sslCertLocation :: FilePath
, torPort :: AppPort
, staticBinDir :: FilePath
, errorLogRoot :: FilePath
, marketplaceName :: Text
, resourcesDir :: !FilePath
, sslPath :: !FilePath
, sslAuto :: !Bool
, registryHostname :: !Text
, registryVersion :: !Version
, sslKeyLocation :: !FilePath
, sslCsrLocation :: !FilePath
, sslCertLocation :: !FilePath
, torPort :: !AppPort
, staticBinDir :: !FilePath
, errorLogRoot :: !FilePath
, marketplaceName :: !Text
}
instance Has PkgRepo AppSettings where
extract = liftA2 PkgRepo ((</> "apps") . resourcesDir) staticBinDir