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

6
src/Foundation.hs
View File

@@ -10,6 +10,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
module Foundation where module Foundation where
@@ -166,14 +167,17 @@ instance Has EosRepo RegistryCtx where
extract = transitiveExtract @AppSettings extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings update = transitiveUpdate @AppSettings
{-# INLINE transitiveExtract #-}
transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a
transitiveExtract = extract @a . extract @b transitiveExtract = extract @a . extract @b
{-# INLINE transitiveUpdate #-}
transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c) transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate f = update (update @a @b f) transitiveUpdate f = update (update @a @b f)
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () 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 -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- 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 onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb
{-# INLINE (.*) #-}
infixr 8 .*
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c (.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.*) = (.) . (.) (.*) = (.) . (.)

2
src/Handler/Apps.hs
View File

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

14
src/Handler/ErrorLogs.hs
View File

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

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

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

14
src/Lib/Error.hs
View File

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

4
src/Lib/PkgRepository.hs
View File

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

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

@@ -69,18 +69,18 @@ instance PathPiece PkgId where
fromPathPiece = fmap PkgId . fromPathPiece fromPathPiece = fmap PkgId . fromPathPiece
toPathPiece = unPkgId toPathPiece = unPkgId
data VersionInfo = VersionInfo data VersionInfo = VersionInfo
{ versionInfoVersion :: Version { versionInfoVersion :: !Version
, versionInfoReleaseNotes :: Text , versionInfoReleaseNotes :: !Text
, versionInfoDependencies :: HM.HashMap PkgId VersionRange , versionInfoDependencies :: !(HM.HashMap PkgId VersionRange)
, versionInfoOsVersion :: Version , versionInfoOsVersion :: !Version
, versionInfoInstallAlert :: Maybe Text , versionInfoInstallAlert :: !(Maybe Text)
} }
deriving (Eq, Show) deriving (Eq, Show)
data PackageDependency = PackageDependency data PackageDependency = PackageDependency
{ packageDependencyOptional :: Maybe Text { packageDependencyOptional :: !(Maybe Text)
, packageDependencyVersion :: VersionRange , packageDependencyVersion :: !VersionRange
, packageDependencyDescription :: Maybe Text , packageDependencyDescription :: !(Maybe Text)
} }
deriving Show deriving Show
instance FromJSON PackageDependency where 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. 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. This module extends the semver standard linked above with a 4th digit, which is given PATCH semantics.
-} -}
{-# LANGUAGE BangPatterns #-}
module Lib.Types.Emver module Lib.Types.Emver
( major ( major
@@ -53,6 +54,7 @@ import Startlude ( ($)
, IsString(..) , IsString(..)
, Monad((>>=)) , Monad((>>=))
, Monoid(mappend, mempty) , Monoid(mappend, mempty)
, NFData(..)
, Num((+)) , Num((+))
, Ord(compare) , Ord(compare)
, Ordering(..) , Ordering(..)
@@ -65,6 +67,7 @@ import Startlude ( ($)
, flip , flip
, id , id
, on , on
, seq
, show , 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 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) -- Distributivity of disjunction over conjunction: Disj a (Conj b c) === Conj (Disj a b) (Disj a c)
data VersionRange data VersionRange
= Anchor Operator Version = Anchor !Operator !Version
| Conj VersionRange VersionRange | Conj VersionRange VersionRange
| Disj VersionRange VersionRange | Disj VersionRange VersionRange
| Any | Any
| None | None
deriving (Eq) 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 -- | Smart constructor for conjunctions. Eagerly evaluates zeros and identities
conj :: VersionRange -> VersionRange -> VersionRange conj :: VersionRange -> VersionRange -> VersionRange
@@ -150,7 +157,7 @@ conj Any b = b
conj a Any = a conj a Any = a
conj None _ = None conj None _ = None
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 -- | Smart constructor for disjunctions. Eagerly evaluates zeros and identities
disj :: VersionRange -> VersionRange -> VersionRange disj :: VersionRange -> VersionRange -> VersionRange
@@ -158,7 +165,7 @@ disj Any _ = Any
disj _ Any = Any disj _ Any = Any
disj None b = b disj None b = b
disj a None = a disj a None = a
disj a b = Disj a b disj !a !b = Disj a b
exactly :: Version -> VersionRange exactly :: Version -> VersionRange
exactly = Anchor (Right EQ) exactly = Anchor (Right EQ)

36
src/Settings.hs
View File

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