Skip to content
This repository was archived by the owner on Feb 27, 2024. It is now read-only.

Commit e92a1bd

Browse files
petipeti
committed
Generalize the "unparsed" API.
See #9 (comment) for details on the motivation behind new-callback-api.hs and new-class-api.hs. Dropped support for older compilers. Building with GHC versions prior to 7.10.x is too much effort. Added parseIso8601 function to Distribution.Hackage.DB.Utility.
1 parent d9f4a29 commit e92a1bd

File tree

5 files changed

+267
-8
lines changed

5 files changed

+267
-8
lines changed

‎.travis.yml

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -42,12 +42,6 @@ matrix:
4242
- compiler: "ghc-7.10.3"
4343
# env: TEST=--disable-tests BENCH=--disable-benchmarks
4444
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}}
45-
- compiler: "ghc-7.8.4"
46-
# env: TEST=--disable-tests BENCH=--disable-benchmarks
47-
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4], sources: [hvr-ghc]}}
48-
- compiler: "ghc-7.6.3"
49-
# env: TEST=--disable-tests BENCH=--disable-benchmarks
50-
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3], sources: [hvr-ghc]}}
5145

5246
before_install:
5347
- HC=${CC}

‎hackage-db.cabal

Lines changed: 38 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,7 @@ license: BSD3
99
license-file: LICENSE
1010
author: Peter Simons, Alexander Altman, Ben James
1111
maintainer: Peter Simons <[email protected]>
12-
tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2,
13-
GHC == 8.4.4, GHC == 8.6.3
12+
tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3
1413
category: Distribution
1514
homepage: https://github.com/peti/hackage-db#readme
1615
bug-reports: https://github.com/peti/hackage-db/issues
@@ -79,3 +78,40 @@ executable show-package-versions
7978
build-depends: base >= 3 && < 5, Cabal, containers, hackage-db
8079
else
8180
buildable: False
81+
82+
executable new-callback-api
83+
main-is: new-callback-api.hs
84+
build-depends: base
85+
, Cabal
86+
, bytestring
87+
, containers
88+
, deepseq
89+
, filepath
90+
, hackage-db
91+
, mtl
92+
, tar
93+
default-language: Haskell2010
94+
ghc-options: -Wall -rtsopts
95+
96+
if impl(ghc > 8)
97+
ghc-options: -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates
98+
-Wredundant-constraints
99+
100+
executable new-class-api
101+
main-is: new-class-api.hs
102+
build-depends: base
103+
, Cabal
104+
, bytestring
105+
, containers
106+
, deepseq
107+
, exceptions
108+
, filepath
109+
, hackage-db
110+
, mtl
111+
, tar
112+
default-language: Haskell2010
113+
ghc-options: -Wall -rtsopts
114+
115+
if impl(ghc > 8)
116+
ghc-options: -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates
117+
-Wredundant-constraints

‎new-callback-api.hs

Lines changed: 104 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,104 @@
1+
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
2+
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
3+
4+
{- |
5+
Maintainer: [email protected]
6+
Stability: provisional
7+
Portability: portable
8+
-}
9+
10+
module Main ( main ) where
11+
12+
import Distribution.Hackage.DB.Errors
13+
import Distribution.Hackage.DB.Path
14+
import Distribution.Hackage.DB.Utility
15+
16+
import Codec.Archive.Tar as Tar
17+
import Codec.Archive.Tar.Entry as Tar
18+
import Control.DeepSeq
19+
import Control.Exception
20+
import Control.Monad
21+
import Control.Monad.State.Strict
22+
import qualified Data.ByteString as BSS
23+
import qualified Data.ByteString.Lazy as BSL
24+
import Data.Map.Strict ( Map )
25+
import qualified Data.Map.Strict as Map
26+
import GHC.Generics ( Generic )
27+
-- import Data.Time
28+
-- import Distribution.Types.GenericPackageDescription
29+
import Distribution.Types.PackageName
30+
import Distribution.Types.Version
31+
import System.FilePath
32+
33+
readHackageTarball :: IO (Entries FormatError)
34+
readHackageTarball = hackageTarball >>= readTarball
35+
36+
readTarball :: FilePath -> IO (Entries FormatError)
37+
readTarball = fmap Tar.read . BSL.readFile
38+
39+
data Builder m = Builder
40+
{ consumePreferredVersions :: PackageName -> EpochTime -> BSL.ByteString -> m ()
41+
, consumeCabalFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
42+
, consumeMetaFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
43+
, consumeError :: SomeException -> m ()
44+
}
45+
46+
parseTarball :: Applicative m => Builder m -> Maybe EpochTime -> Entries FormatError -> m ()
47+
parseTarball b (Just et) (Next e es) = unless (entryTime e > et) (consumeEntry b e *> parseTarball b (Just et) es)
48+
parseTarball b Nothing (Next e es) = consumeEntry b e *> parseTarball b Nothing es
49+
parseTarball b _ (Fail err) = consumeError b (toException err)
50+
parseTarball _ _ Done = pure ()
51+
52+
consumeEntry :: Builder m -> Entry -> m ()
53+
consumeEntry b e =
54+
case (splitDirectories (entryPath e), entryContent e) of
55+
([pn,"preferred-versions"], NormalFile buf _) -> consumePreferredVersions b (mkPackageName pn) (entryTime e) buf
56+
([pn,v,file], NormalFile buf _)
57+
| takeExtension file == ".cabal" -> consumeCabalFile b (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
58+
| takeExtension file == ".json" -> consumeMetaFile b (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
59+
_ -> consumeError b (toException (UnsupportedTarEntry e))
60+
61+
----- Test Code
62+
63+
main :: IO ()
64+
main = do
65+
es <- readHackageTarball
66+
db1 <- execStateT (parseTarball hackageDbBuilder Nothing es) mempty
67+
let db2 = execState (parseTarball hackageDbBuilder Nothing es) mempty
68+
unless (db1 == db2) $
69+
fail "This is not supposed to happen."
70+
71+
type HackageDB = Map PackageName PackageData
72+
73+
data PackageData = PackageData
74+
{ versions :: !(Map Version PackageVersionData)
75+
, preferredVersions :: !BSS.ByteString
76+
}
77+
deriving (Show, Eq, Generic, NFData)
78+
79+
data PackageVersionData = PackageVersionData
80+
{ cabalFile :: !BSS.ByteString
81+
, metaFile :: !BSS.ByteString
82+
}
83+
deriving (Show, Eq, Generic, NFData)
84+
85+
hackageDbBuilder :: MonadState HackageDB m => Builder m
86+
hackageDbBuilder = Builder
87+
{ consumePreferredVersions = \pn _ buf -> let new = PackageData mempty (BSL.toStrict buf)
88+
f old _ = old { preferredVersions = preferredVersions new }
89+
in modify (Map.insertWith f pn new)
90+
91+
, consumeCabalFile = \pn v _ buf -> let f Nothing = PackageData (Map.singleton v new) mempty
92+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
93+
new = PackageVersionData (BSL.toStrict buf) mempty
94+
g old _ = old { cabalFile = cabalFile new }
95+
in modify (Map.alter (Just . f) pn)
96+
97+
, consumeMetaFile = \pn v _ buf -> let f Nothing = PackageData (Map.singleton v new) mempty
98+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
99+
100+
new = PackageVersionData mempty (BSL.toStrict buf)
101+
g old _ = old { metaFile = metaFile new }
102+
in modify (Map.alter (Just . f) pn)
103+
, consumeError = fail . show
104+
}

‎new-class-api.hs

Lines changed: 112 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,112 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
3+
4+
{- |
5+
Maintainer: [email protected]
6+
Stability: provisional
7+
Portability: portable
8+
-}
9+
10+
module Main ( main ) where
11+
12+
import Distribution.Hackage.DB.Errors
13+
import Distribution.Hackage.DB.Path
14+
import Distribution.Hackage.DB.Utility
15+
16+
import Codec.Archive.Tar as Tar
17+
import Codec.Archive.Tar.Entry as Tar
18+
import Control.DeepSeq
19+
import Control.Exception
20+
import Control.Monad
21+
import Control.Monad.Catch
22+
import Control.Monad.State.Strict
23+
import qualified Data.ByteString as BSS
24+
import qualified Data.ByteString.Lazy as BSL
25+
import Data.Map.Strict ( Map )
26+
import qualified Data.Map.Strict as Map
27+
import GHC.Generics ( Generic )
28+
-- import Data.Time
29+
-- import Distribution.Types.GenericPackageDescription
30+
import Distribution.Types.PackageName
31+
import Distribution.Types.Version
32+
import System.FilePath
33+
34+
readHackageTarball :: IO (Entries FormatError)
35+
readHackageTarball = hackageTarball >>= readTarball
36+
37+
readTarball :: FilePath -> IO (Entries FormatError)
38+
readTarball = fmap Tar.read . BSL.readFile
39+
40+
class MonadThrow m => Builder m where
41+
consumePreferredVersions :: PackageName -> EpochTime -> BSL.ByteString -> m ()
42+
consumeCabalFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
43+
consumeMetaFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
44+
45+
parseTarball :: Builder m => Maybe EpochTime -> Entries FormatError -> m ()
46+
parseTarball (Just et) (Next e es) = unless (entryTime e > et) (consumeEntry e >> parseTarball (Just et) es)
47+
parseTarball Nothing (Next e es) = consumeEntry e >> parseTarball Nothing es
48+
parseTarball _ (Fail err) = throwM err
49+
parseTarball _ Done = return ()
50+
51+
consumeEntry :: Builder m => Entry -> m ()
52+
consumeEntry e =
53+
case (splitDirectories (entryPath e), entryContent e) of
54+
([pn,"preferred-versions"], NormalFile buf _) -> consumePreferredVersions (mkPackageName pn) (entryTime e) buf
55+
([pn,v,file], NormalFile buf _)
56+
| takeExtension file == ".cabal" -> consumeCabalFile (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
57+
| takeExtension file == ".json" -> consumeMetaFile (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
58+
_ -> throwM (UnsupportedTarEntry e)
59+
60+
----- Test Code
61+
62+
main :: IO ()
63+
main = do
64+
-- snapshot <- parseIso8601 "2018-12-20T02:09:00Z"
65+
-- let et <- toEpochTime snapshot
66+
es <- readHackageTarball
67+
68+
db1 <- execStateT (parseTarball Nothing es) (mempty :: HackageDB)
69+
70+
let db2 = case execStateT (parseTarball Nothing es) mempty of
71+
Left e -> error (show (e :: SomeException))
72+
Right db -> db
73+
74+
unless (db1 == db2) $
75+
fail "This is not supposed to happen."
76+
77+
78+
type HackageDB = Map PackageName PackageData
79+
80+
data PackageData = PackageData
81+
{ versions :: !(Map Version PackageVersionData)
82+
, preferredVersions :: !BSS.ByteString
83+
}
84+
deriving (Show, Eq, Generic, NFData)
85+
86+
data PackageVersionData = PackageVersionData
87+
{ cabalFile :: !BSS.ByteString
88+
, metaFile :: !BSS.ByteString
89+
}
90+
deriving (Show, Eq, Generic, NFData)
91+
92+
instance MonadThrow m => Builder (StateT HackageDB m) where
93+
consumePreferredVersions pn _ buf = modify (Map.insertWith f pn new)
94+
where
95+
new = PackageData mempty (BSL.toStrict buf)
96+
f old _ = old { preferredVersions = preferredVersions new }
97+
98+
consumeCabalFile pn v _ buf = modify (Map.alter (Just . f) pn)
99+
where
100+
f Nothing = PackageData (Map.singleton v new) mempty
101+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
102+
103+
new = PackageVersionData (BSL.toStrict buf) mempty
104+
g old _ = old { cabalFile = cabalFile new }
105+
106+
consumeMetaFile pn v _ buf = modify (Map.alter (Just . f) pn)
107+
where
108+
f Nothing = PackageData (Map.singleton v new) mempty
109+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
110+
111+
new = PackageVersionData mempty (BSL.toStrict buf)
112+
g old _ = old { metaFile = metaFile new }

‎src/Distribution/Hackage/DB/Utility.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import Codec.Archive.Tar.Entry as Tar
1313
import Data.Maybe
1414
import Data.Time.Clock
1515
import Data.Time.Clock.POSIX
16+
import Data.Time.Format
1617
import Distribution.Text
1718

1819
parseText :: Text a => String -> String -> a
@@ -29,3 +30,15 @@ fromEpochTime et = posixSecondsToUTCTime (realToFrac et)
2930

3031
toEpochTime :: UTCTime -> EpochTime
3132
toEpochTime = floor . utcTimeToPOSIXSeconds
33+
34+
-- | Parse an UTC timestamp in extended ISO8601 format a standard 'UTCTime'
35+
-- type. This function is useful to parse the "snapshot" identifier printed by
36+
-- @cabal-install@ after a database update into a useable type. Combine with
37+
-- 'toEpochTime' to obtain an 'EpochTime' that can be passed to the Hackage DB
38+
-- reading code from this library.
39+
--
40+
-- >>> parseIso8601 "2018-12-21T13:17:40Z"
41+
-- 2018-12-21 13:17:40 UTC
42+
43+
parseIso8601 :: Monad m => String -> m UTCTime
44+
parseIso8601 = parseTimeM False defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%SZ"))

0 commit comments

Comments
 (0)