Skip to content

Commit 8443cb9

Browse files
gracenotesgracenotes
committed
Implement Resource abstraction, integrate it into Feature, and integrate Feature into the main Server module
1 parent 5c79e3a commit 8443cb9

File tree

6 files changed

+222
-118
lines changed

6 files changed

+222
-118
lines changed

‎Distribution/Server.hs

Lines changed: 43 additions & 111 deletions
Original file line numberDiff line numberDiff line change
@@ -17,23 +17,22 @@ module Distribution.Server (
1717
initState,
1818
) where
1919

20-
import Distribution.Package
21-
( PackageIdentifier(..), packageName, PackageId )
22-
import Distribution.Text
23-
( display, simpleParse )
20+
import Distribution.Package (packageName)
2421
import Happstack.Server hiding (port, host)
2522
import qualified Happstack.Server
2623
import Happstack.State hiding (Version)
2724

28-
import Distribution.Server.ServerParts
29-
(guardAuth)
25+
import Distribution.Server.ServerParts (guardAuth)
3026
import qualified Distribution.Server.Import as Import ( importTar )
3127

3228
import Distribution.Server.Packages.ServerParts
3329
import Distribution.Server.Users.ServerParts
3430
import Distribution.Server.Distributions.ServerParts
3531
import Distribution.Server.Users.Permissions (GroupName(..))
3632

33+
import qualified Distribution.Server.Feature as Feature
34+
import qualified Distribution.Server.Features as Features
35+
3736
import Distribution.Server.State as State
3837
import Distribution.Server.Packages.State as State hiding (buildReports, bulkImport)
3938
import Distribution.Server.Users.State as State
@@ -43,30 +42,32 @@ import Distribution.Server.Packages.Types
4342
import qualified Distribution.Server.ResourceTypes as Resource
4443
import qualified Distribution.Server.Util.BlobStorage as BlobStorage
4544
import Distribution.Server.Util.BlobStorage (BlobStorage)
46-
import Distribution.Server.Util.Happstack (remainingPath)
4745
import qualified Distribution.Server.BulkImport as BulkImport
4846
import qualified Distribution.Server.BulkImport.UploadLog as UploadLog
4947

5048
import qualified Distribution.Server.Users.Users as Users
5149
import qualified Distribution.Server.Users.Types as Users
5250

5351
import Distribution.Server.Export.ServerParts (export)
54-
5552
import Distribution.Server.Auth.Types (PasswdPlain(..))
5653

54+
import Distribution.Server.Resource (addResponse, serverTreeEmpty, renderServerTree, spiffyResources)
55+
import Data.List (foldl')
56+
5757
import System.FilePath ((</>))
58-
import qualified System.FilePath.Posix as Posix (joinPath, splitExtension)
5958
import System.Directory
6059
( createDirectoryIfMissing, doesDirectoryExist )
6160
import Control.Concurrent.MVar (MVar)
6261
import Control.Monad.Trans
63-
import Control.Monad (when,msum,mzero)
62+
import Control.Monad (when, msum)
6463
import Data.ByteString.Lazy.Char8 (ByteString)
6564
import Network.URI
6665
( URIAuth(URIAuth) )
6766
import Network.BSD
6867
( getHostName )
68+
import qualified Data.Map as Map (empty)
6969

70+
import qualified Data.ByteString.Lazy.Char8 as BS
7071

7172
import Paths_hackage_server (getDataDir)
7273

@@ -75,7 +76,7 @@ data Config = Config {
7576
confPortNum :: Int,
7677
confStateDir :: FilePath,
7778
confStaticDir :: FilePath
78-
}
79+
} deriving (Show)
7980

8081
confHappsStateDir, confBlobStoreDir :: Config -> FilePath
8182
confHappsStateDir config = confStateDir config </> "db"
@@ -93,12 +94,10 @@ defaultConfig = do
9394
}
9495

9596
data Server = Server {
96-
serverStore :: BlobStorage,
97-
serverStaticDir :: FilePath,
98-
serverTxControl :: MVar TxControl,
99-
serverCache :: Cache.Cache,
100-
serverURI :: URIAuth,
101-
serverPort :: Int
97+
serverTxControl :: MVar TxControl,
98+
serverFeatureConfig :: Feature.Config,
99+
serverPort :: Int,
100+
serverCache :: Cache.Cache
102101
}
103102

104103
-- | If we made a server instance from this 'Config', would we find some
@@ -130,12 +129,14 @@ initialise config@(Config hostName portNum stateDir staticDir) = do
130129
cache <- Cache.new =<< stateToCache hostURI =<< query GetPackagesState
131130

132131
return Server {
133-
serverStore = store,
134-
serverStaticDir = staticDir,
135132
serverTxControl = txCtl,
136-
serverCache = cache,
137-
serverURI = hostURI,
138-
serverPort = portNum
133+
serverFeatureConfig = Feature.Config {
134+
Feature.serverStore = store,
135+
Feature.serverStaticDir = staticDir,
136+
Feature.serverURI = hostURI
137+
},
138+
serverPort = portNum,
139+
serverCache = cache
139140
}
140141

141142
where
@@ -151,9 +152,16 @@ hackageEntryPoint = Proxy
151152
-- | Actually run the server, i.e. start accepting client http connections.
152153
--
153154
run :: Server -> IO ()
154-
run server = simpleHTTP conf $ msum (impl server)
155+
run server = simpleHTTP conf $ mungeRequest $ impl server
155156
where
156157
conf = nullConf { Happstack.Server.port = serverPort server }
158+
mungeRequest = localRq mungeMethod
159+
mungeMethod req = case (rqMethod req, lookup "_method" (rqInputs req)) of
160+
(POST, Just input) -> case reads (BS.unpack (inputValue input)) of
161+
[(newMethod, "")] -> req { rqMethod = newMethod }
162+
_ -> req
163+
_ -> req
164+
-- todo: given a .json or .html suffix, munge it into an Accept header
157165

158166
-- | Perform a clean shutdown of the server.
159167
--
@@ -173,7 +181,7 @@ bulkImport :: Server
173181
-> Maybe String -- users
174182
-> Maybe String -- admin users
175183
-> IO [UploadLog.Entry]
176-
bulkImport (Server store _ _ cache host _)
184+
bulkImport (Server _ (Feature.Config store _ host) _ cache)
177185
indexFile logFile archiveFile htPasswdFile adminsFile = do
178186
pkgIndex <- either fail return (BulkImport.importPkgIndex indexFile)
179187
uploadLog <- either fail return (BulkImport.importUploadLog logFile)
@@ -213,7 +221,7 @@ bulkImport (Server store _ _ cache host _)
213221
Just uid -> Right uid
214222

215223
importTar :: Server -> ByteString -> IO (Maybe String)
216-
importTar (Server store _ _ cache host _) tar = do
224+
importTar (Server _ (Feature.Config store _ host) _ cache) tar = do
217225
res <- Import.importTar store tar
218226
case res of
219227
Nothing -> updateCache cache host
@@ -223,7 +231,7 @@ importTar (Server store _ _ cache host _) tar = do
223231
-- An alternative to an import.
224232
-- Starts the server off to a sane initial state.
225233
initState :: MonadIO m => Server -> m ()
226-
initState (Server _ _ _ cache host _) = do
234+
initState (Server _ (Feature.Config _ _ host) _ cache) = do
227235
-- clear off existing state
228236
update $ BulkImport [] Users.empty
229237
update $ BulkImportPermissions []
@@ -239,89 +247,13 @@ initState (Server _ _ _ cache host _) = do
239247

240248
updateCache cache host
241249

242-
-- Support the same URL scheme as the first version of hackage.
243-
legacySupport :: ServerPart Response
244-
legacySupport
245-
= msum [ legPackagesPath, legCgiScripts]
246250

247-
where
251+
impl :: Server -> ServerPart Response
252+
impl server = flip renderServerTree Map.empty $ spiffyResources $ foldl' (flip $ uncurry addResponse) serverTreeEmpty $ ([], core server):concatMap (Feature.serverParts) Features.hackageFeatures
248253

249-
-- the old "packages/archive" directory
250-
legPackagesPath
251-
= dir "packages" $
252-
dir "archive" $
253-
msum
254-
[ path $ \name ->
255-
path $ \version ->
256-
let pkgid = PackageIdentifier {pkgName = name, pkgVersion = version}
257-
in msum
258-
[ let dirName = display pkgid ++ ".tar.gz"
259-
in dir dirName $ methodSP GET $
260-
movedPermanently (packageTarball pkgid) (toResponse "")
261-
262-
, let fileName = display name ++ ".cabal"
263-
in dir fileName $ methodSP GET $
264-
movedPermanently (cabalPath pkgid) (toResponse "")
265-
266-
, dir "doc" $ dir "html" $ remainingPath $ \paths ->
267-
let doc = Posix.joinPath paths
268-
in methodSP GET $
269-
movedPermanently (docPath pkgid doc) (toResponse "")
270-
]
271-
272-
, dir "package" $ path $ \fileName -> methodSP GET $
273-
do packageStr <- splitExtensions fileName [".gz", ".tar"]
274-
case simpleParse packageStr of
275-
Just pkgid -> movedPermanently (packageTarball pkgid) $ toResponse ""
276-
_ -> mzero
277-
278-
, dir "00-index.tar.gz" $
279-
methodSP GET $
280-
movedPermanently "/00-index.tar.gz" (toResponse "")
281-
]
282-
283-
-- the old "cgi-bin/hackage-scripts" directory
284-
legCgiScripts =
285-
dir "cgi-bin" $
286-
dir "hackage-scripts" $
287-
msum
288-
[ dir "check-pkg" $
289-
methodSP POST $
290-
movedPermanently "/check" $
291-
toResponse ""
292-
, dir "upload-pkg" $
293-
methodSP POST $
294-
movedPermanently "/upload" $
295-
toResponse ""
296-
, dir "package" $ path $
297-
\packageId ->
298-
methodSP GET $
299-
movedPermanently ("/package/" ++ display (packageId :: PackageId)) $
300-
toResponse ""
301-
]
302-
303-
304-
packageTarball :: PackageId -> String
305-
packageTarball pkgid
306-
= "/package/" ++ display pkgid ++ ".tar.gz"
307-
308-
docPath pkgid file = "/package/" ++ display pkgid ++ "/"
309-
++ "documentation/" ++ file
310-
311-
cabalPath pkgid = "/package/" ++ display pkgid ++ "/"
312-
++ display (packageName pkgid) ++ ".cabal"
313-
314-
splitExtensions fp [] = return fp
315-
splitExtensions fp (x:xs) =
316-
case Posix.splitExtension fp of
317-
(fp', ext) | ext == x -> splitExtensions fp' xs
318-
_ -> mzero
319-
320-
321-
impl :: Server -> [ServerPartT IO Response]
322-
impl (Server store static _ cache host _) =
323-
[ legacySupport
324-
, dir "packages" $
254+
core :: Server -> ServerPart Response
255+
core (Server _ (Feature.Config store static host) _ cache) = msum
256+
[ dir "packages" $
325257
methodSP GET $
326258
ok . Cache.packagesPage =<< Cache.get cache
327259
, dir "package" $ msum
@@ -341,24 +273,24 @@ impl (Server store static _ cache host _) =
341273
cacheState <- Cache.get cache
342274
ok $ toResponse $ Resource.IndexTarball (Cache.indexTarball cacheState)
343275
]
344-
, dir "admin" $ admin store
276+
, dir "admin" $ admin static store
345277
, dir "check" checkPackage
346278
, dir "htpasswd" $ msum
347279
[ changePassword ]
348280
, dir "distro" distros
349281
, fileServe ["hackage.html"] static
350282
]
351283

352-
353284
-- Top level server part for administrative actions under the "admin"
354285
-- directory
355-
admin :: BlobStorage -> ServerPart Response
356-
admin storage = do
286+
admin :: FilePath -> BlobStorage -> ServerPart Response
287+
admin static storage = do
357288

358289
guardAuth [Administrator]
359290

360291
msum
361292
[ dir "users" userAdmin
362293
, dir "export.tar.gz" (export storage)
363294
, adminDist
295+
, fileServe ["admin.html"] static
364296
]

‎Distribution/Server/Feature.hs

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
module Distribution.Server.Feature where
22

33
import Distribution.Server.Util.BlobStorage (BlobStorage)
4+
import Distribution.Server.Resource
45
import Happstack.Server
56
import qualified Network.URI as URI
67

@@ -12,12 +13,19 @@ import qualified Network.URI as URI
1213

1314
data HackageFeature = HackageFeature {
1415
featureName :: String,
15-
16-
serverPart :: Config -> ServerPart Response,
17-
16+
resources :: [Resource],
17+
serverParts :: [(BranchPath, ServerPart Response)],
1818
dumpBackup :: IO [BackupEntry],
1919
restoreBackup :: [BackupEntry] -> IO ()
2020
}
21+
addFeatureResource :: Resource -> HackageFeature -> HackageFeature
22+
addFeatureResource resource feature = feature { resources = resource:(resources feature) }
23+
24+
addStaticURIPart :: [String] -> ServerPart Response -> HackageFeature -> HackageFeature
25+
addStaticURIPart = addDynamicURIPart . map StaticBranch
26+
27+
addDynamicURIPart :: BranchPath -> ServerPart Response -> HackageFeature -> HackageFeature
28+
addDynamicURIPart bpath response feature = feature { serverParts = (bpath, response):(serverParts feature) }
2129

2230
-- TODO: move this to a backup dump/restore module
2331
-- filesystem name + human readable content
@@ -28,3 +36,4 @@ data Config = Config {
2836
serverStaticDir :: FilePath,
2937
serverURI :: URI.URIAuth
3038
}
39+
--instance Eq SomeResource where (==) (SomeResource r1) (SomeResource r2) = typeRep r1 == typeRep r2

‎Distribution/Server/Features/LegacyRedirects.hs

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -22,11 +22,9 @@ import Control.Monad (msum, mzero)
2222
--
2323
legacyRedirectsFeature :: HackageFeature
2424
legacyRedirectsFeature = HackageFeature {
25-
2625
featureName = "legacy redirects",
27-
28-
serverPart = \_config -> serveLegacyRedirects,
29-
26+
resources = [],
27+
serverParts = [([], serveLegacyRedirects)],
3028
-- There is no persistent state for this feature,
3129
-- so nothing needs to be backed up.
3230
dumpBackup = return [],

‎Distribution/Server/Packages/ServerParts.hs

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -63,6 +63,32 @@ import System.FilePath.Posix ((</>))
6363
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
6464
import qualified Codec.Compression.GZip as GZip
6565

66+
{-
67+
TODO: change this module to support Resources that do:
68+
dir "package" $ msum
69+
[ path $ msum . handlePackageById store
70+
, path $ servePackage store
71+
]
72+
, dir "check" checkPackage
73+
, dir "upload" $ msum
74+
[ uploadPackage store cache host ]
75+
76+
With these BranchPaths:
77+
/packages/
78+
[StaticBranch "packages"]
79+
/packages/index.tar.gz
80+
[StaticBranch "index.tar.gz", StaticBranch "packages"]
81+
/package/<package>
82+
[DynamicBranch "package", StaticBranch "packages"]
83+
/package/<package>/<package>.cabal
84+
[DynamicBranch "cabal", DynamicBranch "package", StaticBranch "packages"]
85+
/package/<package>/<package>.tar.gz
86+
[DynamicBranch "tarball", DynamicBranch "package", StaticBranch "packages"]
87+
/package/<package>/doc/<doctree>
88+
[DynamicBranch "doctree", StaticBranch "doc", DynamicBranch "package", StaticBranch "packages"]
89+
/package/<package>/maintainers
90+
Automatic user group creation
91+
-}
6692

6793
--TODO: switch to new cache mechanism:
6894
updateCache :: MonadIO m => Cache.Cache -> URIAuth -> m ()

0 commit comments

Comments
 (0)