Skip to content

Commit 06cc2fb

Browse files
KleidukosKleidukos
committed
Move uploader out of acid-state
1 parent d7ffd50 commit 06cc2fb

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
@@ -40,12 +40,38 @@ import qualified Distribution.Parsec as Parsec
4040

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

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

47-
-- | Basic information about a package. These values are
48-
-- used in the `/package/:packagename` JSON endpoint
73+
-- | Basic information about a package.
74+
-- This data type is used for storage in acid-state.
4975
data PackageBasicDescription = PackageBasicDescription
5076
{ pbd_license :: !License
5177
, pbd_copyright :: !T.Text
@@ -55,7 +81,6 @@ data PackageBasicDescription = PackageBasicDescription
5581
, pbd_homepage :: !T.Text
5682
, pbd_metadata_revision :: !Int
5783
, pbd_uploaded_at :: !UTCTime
58-
, pbd_uploader :: !UserName
5984
} deriving (Eq, Show, Generic)
6085

6186
instance SafeCopy PackageBasicDescription where
@@ -68,7 +93,6 @@ instance SafeCopy PackageBasicDescription where
6893
put $ T.encodeUtf8 pbd_homepage
6994
put pbd_metadata_revision
7095
safePut pbd_uploaded_at
71-
safePut pbd_uploader
7296

7397
getCopy = contain $ do
7498
licenseStr <- get
@@ -82,7 +106,6 @@ instance SafeCopy PackageBasicDescription where
82106
pbd_homepage <- T.decodeUtf8 <$> get
83107
pbd_metadata_revision <- get
84108
pbd_uploaded_at <- safeGet
85-
pbd_uploader <- safeGet
86109
return PackageBasicDescription{..}
87110

88111

@@ -99,7 +122,6 @@ instance Aeson.ToJSON PackageBasicDescription where
99122
, Key.fromString "homepage" .= pbd_homepage
100123
, Key.fromString "metadata_revision" .= pbd_metadata_revision
101124
, Key.fromString "uploaded_at" .= pbd_uploaded_at
102-
, Key.fromString "uploader" .= pbd_uploader
103125
]
104126

105127
instance Aeson.FromJSON PackageBasicDescription where
@@ -117,7 +139,6 @@ instance Aeson.FromJSON PackageBasicDescription where
117139
pbd_homepage <- obj .: Key.fromString "homepage"
118140
pbd_metadata_revision <- obj .: Key.fromString "metadata_revision"
119141
pbd_uploaded_at <- obj .: Key.fromString "uploaded_at"
120-
pbd_uploader <- obj .: Key.fromString "uploader"
121142
return $ PackageBasicDescription {..}
122143

123144
-- | An index of versions for one Hackage package
@@ -232,8 +253,8 @@ deriveSafeCopy 0 'base ''PackageInfoState
232253

233254
instance MemSize PackageBasicDescription where
234255
memSize PackageBasicDescription{..} =
235-
memSize9 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis
236-
pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at pbd_uploader
256+
memSize8 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis
257+
pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at
237258

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

0 commit comments

Comments
 (0)