diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index 09dacaa..f988fcc 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 6808351..a01ed67 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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: diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 2af9d2c..ba27c6d 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 (.*) = (.) . (.) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 1e752d6..187da10 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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 diff --git a/src/Handler/ErrorLogs.hs b/src/Handler/ErrorLogs.hs index 73b7e7b..6964a9a 100644 --- a/src/Handler/ErrorLogs.hs +++ b/src/Handler/ErrorLogs.hs @@ -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) diff --git a/src/Handler/Types/Marketplace.hs b/src/Handler/Types/Marketplace.hs index 535d822..729be94 100644 --- a/src/Handler/Types/Marketplace.hs +++ b/src/Handler/Types/Marketplace.hs @@ -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) diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 5d24304..a8514c0 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -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) diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index d761329..0167be5 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -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 diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index e5c2b48..c861d99 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -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 diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 6385024..4ab7953 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -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 diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 1cc5d87..9353557 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -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) diff --git a/src/Settings.hs b/src/Settings.hs index 68241ec..bca3e71 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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