Skip to content

Commit d517ebd

Browse files
KleidukosKleidukos
committed
Move uploader out of acid-state
1 parent 1217eb0 commit d517ebd

File tree

2 files changed

+91
-27
lines changed

2 files changed

+91
-27
lines changed

‎src/Distribution/Server/Features/PackageInfoJSON.hs‎

Lines changed: 60 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
{-# LANGUAGE RankNTypes #-}
2+
{-# LANGUAGE OverloadedRecordDot #-}
23
{-# LANGUAGE RecordWildCards #-}
34
{-# LANGUAGE ScopedTypeVariables #-}
5+
{-# LANGUAGE NamedFieldPuns #-}
46

57
module Distribution.Server.Features.PackageInfoJSON (
68
PackageInfoJSONFeature(..)
@@ -39,6 +41,7 @@ import Distribution.Server.Packages.Types (CabalFileText(.
3941
import Distribution.Server.Framework.BackupRestore (RestoreBackup(..))
4042

4143
import Distribution.Server.Features.PackageInfoJSON.State (PackageBasicDescription(..),
44+
PackageBasicDescriptionDTO(..),
4245
PackageVersions(..),
4346
PackageInfoState(..),
4447
GetPackageInfo(..),
@@ -54,8 +57,10 @@ import Data.Foldable (toList)
5457
import Data.Traversable (for)
5558
import qualified Data.List as List
5659
import Data.Time (UTCTime)
57-
import Distribution.Server.Users.Types (UserName, UserInfo(..))
60+
import Distribution.Server.Users.Types (UserName (..), UserInfo(..))
5861
import Distribution.Server.Features.Users (UserFeature(lookupUserInfo))
62+
import Data.Map (Map)
63+
import qualified Data.Map as Map
5964

6065

6166
data PackageInfoJSONFeature = PackageInfoJSONFeature {
@@ -92,17 +97,18 @@ initPackageInfoJSONFeature env = do
9297
\and the values are whether the version is preferred or not"
9398
vInfo = "Get basic package information at a specific metadata revision"
9499

100+
uploaderCache = undefined
95101
jsonResources = [
96102
(Framework.extendResource (corePackagePage coreR)) {
97103
Framework.resourceDesc = [(Framework.GET, info)]
98104
, Framework.resourceGet =
99-
[("json", servePackageBasicDescription coreR userFeature
105+
[("json", servePackageBasicDescription coreR uploaderCache userFeature
100106
preferred packageInfoState)]
101107
}
102108
, (Framework.extendResource (coreCabalFileRev coreR)) {
103109
Framework.resourceDesc = [(Framework.GET, vInfo)]
104110
, Framework.resourceGet =
105-
[("json", servePackageBasicDescription coreR userFeature
111+
[("json", servePackageBasicDescription coreR uploaderCache userFeature
106112
preferred packageInfoState)]
107113
}
108114
]
@@ -135,15 +141,14 @@ initPackageInfoJSONFeature env = do
135141

136142
-- | Pure function for extracting basic package info from a Cabal file
137143
getBasicDescription
138-
:: UserName
139-
-> UTCTime
144+
:: UTCTime
140145
-- ^ Time of upload
141146
-> CabalFileText
142147
-> Int
143148
-- ^ Metadata revision. This will be added to the resulting
144149
-- @PackageBasicDescription@
145150
-> Either String PackageBasicDescription
146-
getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev =
151+
getBasicDescription uploadedAt (CabalFileText cf) metadataRev =
147152
let parseResult = PkgDescr.parseGenericPackageDescription (BS.toStrict cf)
148153
in case PkgDescr.runParseResult parseResult of
149154
(_, Right pkg) -> let
@@ -157,28 +162,54 @@ getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev =
157162
pbd_homepage = T.pack . fromShortText $ PkgDescr.homepage pkgd
158163
pbd_metadata_revision = metadataRev
159164
pbd_uploaded_at = uploadedAt
160-
pbd_uploader = uploader
161165
in
162166
return $ PackageBasicDescription {..}
163167
(_, Left (_, perrs)) ->
164168
let errs = List.intersperse '\n' $ mconcat $ for (toList perrs) $ \err -> Parsec.showPError "" err
165169
in Left $ "Could not parse cabal file: "
166170
<> errs
167171

172+
basicDescriptionToDTO :: UserName -> PackageBasicDescription -> PackageBasicDescriptionDTO
173+
basicDescriptionToDTO uploader d =
174+
PackageBasicDescriptionDTO
175+
{ license = d.pbd_license
176+
, copyright = d.pbd_copyright
177+
, synopsis = d.pbd_synopsis
178+
, description = d.pbd_description
179+
, author = d.pbd_author
180+
, homepage = d.pbd_homepage
181+
, metadata_revision = d.pbd_metadata_revision
182+
, uploaded_at = d.pbd_uploaded_at
183+
, uploader
184+
}
185+
186+
dtoToBasicDescription :: PackageBasicDescriptionDTO -> PackageBasicDescription
187+
dtoToBasicDescription dto =
188+
PackageBasicDescription
189+
{ pbd_license = dto.license
190+
, pbd_copyright = dto.copyright
191+
, pbd_synopsis = dto.synopsis
192+
, pbd_description = dto.description
193+
, pbd_author = dto.author
194+
, pbd_homepage = dto.homepage
195+
, pbd_metadata_revision = dto.metadata_revision
196+
, pbd_uploaded_at = dto.uploaded_at
197+
}
168198

169199
-- | Get a JSON @PackageBasicDescription@ for a particular
170200
-- package/version/metadata-revision
171201
-- OR
172202
-- A listing of versions and their deprecation states
173203
servePackageBasicDescription
174204
:: CoreResource
205+
-> Map PackageIdentifier UserName
175206
-> UserFeature
176207
-> Preferred.VersionsFeature
177208
-> Framework.StateComponent Framework.AcidState PackageInfoState
178209
-> Framework.DynamicPath
179210
-- ^ URI specifying a package and version `e.g. lens or lens-4.11`
180211
-> Framework.ServerPartE Framework.Response
181-
servePackageBasicDescription resource userFeature preferred packageInfoState dpath = do
212+
servePackageBasicDescription resource uploaderCache userFeature preferred packageInfoState dpath = do
182213

183214
let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI
184215

@@ -196,15 +227,17 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa
196227
-> Maybe Int
197228
-> Framework.ServerPartE Framework.Response
198229
lookupOrInsertDescr pkgid metadataRev = do
199-
cachedDescr <- Framework.queryState packageInfoState $
200-
GetDescriptionFor (pkgid, metadataRev)
201-
descr :: PackageBasicDescription <- case cachedDescr of
202-
Just d -> return d
230+
cachedDescr <- Framework.queryState packageInfoState $ GetDescriptionFor (pkgid, metadataRev)
231+
descr :: PackageBasicDescriptionDTO <- case cachedDescr of
232+
Just d -> do
233+
uploader <- getPackageUploader pkgid uploaderCache
234+
return $ basicDescriptionToDTO uploader d
203235
Nothing -> do
204-
d <- getPackageDescr pkgid metadataRev
236+
dto <- getPackageDescr pkgid metadataRev
237+
let description = dtoToBasicDescription dto
205238
Framework.updateState packageInfoState $
206-
SetDescriptionFor (pkgid, metadataRev) (Just d)
207-
return d
239+
SetDescriptionFor (pkgid, metadataRev) (Just description)
240+
return dto
208241
return $ Framework.toResponse $ Aeson.toJSON descr
209242

210243
getPackageDescr pkgid metadataRev = do
@@ -227,10 +260,12 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa
227260
uploadedAt = fst $ uploadInfos Vector.! metadataInd
228261
uploaderId = snd $ uploadInfos Vector.! metadataInd
229262
uploader <- userName <$> lookupUserInfo userFeature uploaderId
230-
let pkgDescr = getBasicDescription uploader uploadedAt cabalFile metadataInd
263+
let pkgDescr = getBasicDescription uploadedAt cabalFile metadataInd
231264
case pkgDescr of
232265
Left e -> Framework.errInternalError [Framework.MText e]
233-
Right d -> return d
266+
Right d -> do
267+
let packageInfoDTO = basicDescriptionToDTO uploader d
268+
return packageInfoDTO
234269

235270
lookupOrInsertVersions
236271
:: PackageName
@@ -255,6 +290,14 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa
255290
. Preferred.classifyVersions prefInfo
256291
$ fmap packageVersion pkgs
257292

293+
getPackageUploader
294+
:: PackageIdentifier
295+
-> Map PackageIdentifier UserName
296+
-> Framework.ServerPartE UserName
297+
getPackageUploader pkgId cache =
298+
case Map.lookup pkgId cache of
299+
Just u -> pure u
300+
Nothing -> Framework.errNotFound "Could not find uploader" []
258301

259302
-- | Our backup doesn't produce any entries, and backup restore
260303
-- returns an empty state. Our responses are cheap enough to

‎src/Distribution/Server/Features/PackageInfoJSON/State.hs‎

Lines changed: 31 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -41,12 +41,38 @@ import qualified Distribution.Parsec as Parsec
4141

4242
import qualified Distribution.Server.Features.PreferredVersions as Preferred
4343
import Distribution.Server.Framework.MemSize (MemSize,
44-
memSize, memSize9)
44+
memSize, memSize8)
4545
import Distribution.Server.Users.Types (UserName)
4646

47+
-- | Data type used in the `/package/:packagename` JSON endpoint
48+
data PackageBasicDescriptionDTO = PackageBasicDescriptionDTO
49+
{ license :: !License
50+
, copyright :: !T.Text
51+
, synopsis :: !T.Text
52+
, description :: !T.Text
53+
, author :: !T.Text
54+
, homepage :: !T.Text
55+
, metadata_revision :: !Int
56+
, uploaded_at :: !UTCTime
57+
, uploader :: !UserName
58+
} deriving (Eq, Show, Generic)
59+
60+
instance Aeson.ToJSON PackageBasicDescriptionDTO where
61+
toJSON PackageBasicDescriptionDTO {..} =
62+
Aeson.object
63+
[ Key.fromString "license" .= Pretty.prettyShow license
64+
, Key.fromString "copyright" .= copyright
65+
, Key.fromString "synopsis" .= synopsis
66+
, Key.fromString "description" .= description
67+
, Key.fromString "author" .= author
68+
, Key.fromString "homepage" .= homepage
69+
, Key.fromString "metadata_revision" .= metadata_revision
70+
, Key.fromString "uploaded_at" .= uploaded_at
71+
, Key.fromString "uploader" .= uploader
72+
]
4773

48-
-- | Basic information about a package. These values are
49-
-- used in the `/package/:packagename` JSON endpoint
74+
-- | Basic information about a package.
75+
-- This data type is used for storage in acid-state.
5076
data PackageBasicDescription = PackageBasicDescription
5177
{ pbd_license :: !License
5278
, pbd_copyright :: !T.Text
@@ -56,7 +82,6 @@ data PackageBasicDescription = PackageBasicDescription
5682
, pbd_homepage :: !T.Text
5783
, pbd_metadata_revision :: !Int
5884
, pbd_uploaded_at :: !UTCTime
59-
, pbd_uploader :: !UserName
6085
} deriving (Eq, Show, Generic)
6186

6287
instance SafeCopy PackageBasicDescription where
@@ -69,7 +94,6 @@ instance SafeCopy PackageBasicDescription where
6994
put $ T.encodeUtf8 pbd_homepage
7095
put pbd_metadata_revision
7196
safePut pbd_uploaded_at
72-
safePut pbd_uploader
7397

7498
getCopy = contain $ do
7599
licenseStr <- get
@@ -83,7 +107,6 @@ instance SafeCopy PackageBasicDescription where
83107
pbd_homepage <- T.decodeUtf8 <$> get
84108
pbd_metadata_revision <- get
85109
pbd_uploaded_at <- safeGet
86-
pbd_uploader <- safeGet
87110
return PackageBasicDescription{..}
88111

89112

@@ -100,7 +123,6 @@ instance Aeson.ToJSON PackageBasicDescription where
100123
, Key.fromString "homepage" .= pbd_homepage
101124
, Key.fromString "metadata_revision" .= pbd_metadata_revision
102125
, Key.fromString "uploaded_at" .= pbd_uploaded_at
103-
, Key.fromString "uploader" .= pbd_uploader
104126
]
105127

106128
instance Aeson.FromJSON PackageBasicDescription where
@@ -118,7 +140,6 @@ instance Aeson.FromJSON PackageBasicDescription where
118140
pbd_homepage <- obj .: Key.fromString "homepage"
119141
pbd_metadata_revision <- obj .: Key.fromString "metadata_revision"
120142
pbd_uploaded_at <- obj .: Key.fromString "uploaded_at"
121-
pbd_uploader <- obj .: Key.fromString "uploader"
122143
return $ PackageBasicDescription {..}
123144

124145
-- | An index of versions for one Hackage package
@@ -233,8 +254,8 @@ deriveSafeCopy 0 'base ''PackageInfoState
233254

234255
instance MemSize PackageBasicDescription where
235256
memSize PackageBasicDescription{..} =
236-
memSize9 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis
237-
pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at pbd_uploader
257+
memSize8 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis
258+
pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at
238259

239260
instance MemSize PackageVersions where
240261
memSize (PackageVersions ps) = getSum $

0 commit comments

Comments
 (0)