Skip to content

Commit 37abd76

Browse files
petipeti
committed
Generalize the "unparsed" API.
See NixOS/hackage-db#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 278cb46 commit 37abd76

File tree

5 files changed

+263
-8
lines changed

5 files changed

+263
-8
lines changed

‎hackage-db/.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/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

‎hackage-db/new-callback-api.hs‎

Lines changed: 102 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,102 @@
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 Distribution.Types.PackageName
28+
import Distribution.Types.Version
29+
import System.FilePath
30+
31+
readHackageTarball :: IO (Entries FormatError)
32+
readHackageTarball = hackageTarball >>= readTarball
33+
34+
readTarball :: FilePath -> IO (Entries FormatError)
35+
readTarball = fmap Tar.read . BSL.readFile
36+
37+
data Builder m = Builder
38+
{ consumePreferredVersions :: PackageName -> EpochTime -> BSL.ByteString -> m ()
39+
, consumeCabalFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
40+
, consumeMetaFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
41+
, consumeError :: SomeException -> m ()
42+
}
43+
44+
parseTarball :: Applicative m => Builder m -> Maybe EpochTime -> Entries FormatError -> m ()
45+
parseTarball b (Just et) (Next e es) = unless (entryTime e > et) (consumeEntry b e *> parseTarball b (Just et) es)
46+
parseTarball b Nothing (Next e es) = consumeEntry b e *> parseTarball b Nothing es
47+
parseTarball b _ (Fail err) = consumeError b (toException err)
48+
parseTarball _ _ Done = pure ()
49+
50+
consumeEntry :: Builder m -> Entry -> m ()
51+
consumeEntry b e =
52+
case (splitDirectories (entryPath e), entryContent e) of
53+
([pn,"preferred-versions"], NormalFile buf _) -> consumePreferredVersions b (mkPackageName pn) (entryTime e) buf
54+
([pn,v,file], NormalFile buf _)
55+
| takeExtension file == ".cabal" -> consumeCabalFile b (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
56+
| takeExtension file == ".json" -> consumeMetaFile b (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
57+
_ -> consumeError b (toException (UnsupportedTarEntry e))
58+
59+
----- Test Code
60+
61+
main :: IO ()
62+
main = do
63+
es <- readHackageTarball
64+
db1 <- execStateT (parseTarball hackageDbBuilder Nothing es) mempty
65+
let db2 = execState (parseTarball hackageDbBuilder Nothing es) mempty
66+
unless (db1 == db2) $
67+
fail "This is not supposed to happen."
68+
69+
type HackageDB = Map PackageName PackageData
70+
71+
data PackageData = PackageData
72+
{ versions :: !(Map Version PackageVersionData)
73+
, preferredVersions :: !BSS.ByteString
74+
}
75+
deriving (Show, Eq, Generic, NFData)
76+
77+
data PackageVersionData = PackageVersionData
78+
{ cabalFile :: !BSS.ByteString
79+
, metaFile :: !BSS.ByteString
80+
}
81+
deriving (Show, Eq, Generic, NFData)
82+
83+
hackageDbBuilder :: MonadState HackageDB m => Builder m
84+
hackageDbBuilder = Builder
85+
{ consumePreferredVersions = \pn _ buf -> let new = PackageData mempty (BSL.toStrict buf)
86+
f old _ = old { preferredVersions = preferredVersions new }
87+
in modify (Map.insertWith f pn new)
88+
89+
, consumeCabalFile = \pn v _ buf -> let f Nothing = PackageData (Map.singleton v new) mempty
90+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
91+
new = PackageVersionData (BSL.toStrict buf) mempty
92+
g old _ = old { cabalFile = cabalFile new }
93+
in modify (Map.alter (Just . f) pn)
94+
95+
, consumeMetaFile = \pn v _ buf -> let f Nothing = PackageData (Map.singleton v new) mempty
96+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
97+
98+
new = PackageVersionData mempty (BSL.toStrict buf)
99+
g old _ = old { metaFile = metaFile new }
100+
in modify (Map.alter (Just . f) pn)
101+
, consumeError = fail . show
102+
}

‎hackage-db/new-class-api.hs‎

Lines changed: 110 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,110 @@
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 Distribution.Types.PackageName
29+
import Distribution.Types.Version
30+
import System.FilePath
31+
32+
readHackageTarball :: IO (Entries FormatError)
33+
readHackageTarball = hackageTarball >>= readTarball
34+
35+
readTarball :: FilePath -> IO (Entries FormatError)
36+
readTarball = fmap Tar.read . BSL.readFile
37+
38+
class MonadThrow m => Builder m where
39+
consumePreferredVersions :: PackageName -> EpochTime -> BSL.ByteString -> m ()
40+
consumeCabalFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
41+
consumeMetaFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> m ()
42+
43+
parseTarball :: Builder m => Maybe EpochTime -> Entries FormatError -> m ()
44+
parseTarball (Just et) (Next e es) = unless (entryTime e > et) (consumeEntry e >> parseTarball (Just et) es)
45+
parseTarball Nothing (Next e es) = consumeEntry e >> parseTarball Nothing es
46+
parseTarball _ (Fail err) = throwM err
47+
parseTarball _ Done = return ()
48+
49+
consumeEntry :: Builder m => Entry -> m ()
50+
consumeEntry e =
51+
case (splitDirectories (entryPath e), entryContent e) of
52+
([pn,"preferred-versions"], NormalFile buf _) -> consumePreferredVersions (mkPackageName pn) (entryTime e) buf
53+
([pn,v,file], NormalFile buf _)
54+
| takeExtension file == ".cabal" -> consumeCabalFile (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
55+
| takeExtension file == ".json" -> consumeMetaFile (mkPackageName pn) (parseText "Version" v) (entryTime e) buf
56+
_ -> throwM (UnsupportedTarEntry e)
57+
58+
----- Test Code
59+
60+
main :: IO ()
61+
main = do
62+
-- snapshot <- parseIso8601 "2018-12-20T02:09:00Z"
63+
-- let et <- toEpochTime snapshot
64+
es <- readHackageTarball
65+
66+
db1 <- execStateT (parseTarball Nothing es) (mempty :: HackageDB)
67+
68+
let db2 = case execStateT (parseTarball Nothing es) mempty of
69+
Left e -> error (show (e :: SomeException))
70+
Right db -> db
71+
72+
unless (db1 == db2) $
73+
fail "This is not supposed to happen."
74+
75+
76+
type HackageDB = Map PackageName PackageData
77+
78+
data PackageData = PackageData
79+
{ versions :: !(Map Version PackageVersionData)
80+
, preferredVersions :: !BSS.ByteString
81+
}
82+
deriving (Show, Eq, Generic, NFData)
83+
84+
data PackageVersionData = PackageVersionData
85+
{ cabalFile :: !BSS.ByteString
86+
, metaFile :: !BSS.ByteString
87+
}
88+
deriving (Show, Eq, Generic, NFData)
89+
90+
instance MonadThrow m => Builder (StateT HackageDB m) where
91+
consumePreferredVersions pn _ buf = modify (Map.insertWith f pn new)
92+
where
93+
new = PackageData mempty (BSL.toStrict buf)
94+
f old _ = old { preferredVersions = preferredVersions new }
95+
96+
consumeCabalFile pn v _ buf = modify (Map.alter (Just . f) pn)
97+
where
98+
f Nothing = PackageData (Map.singleton v new) mempty
99+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
100+
101+
new = PackageVersionData (BSL.toStrict buf) mempty
102+
g old _ = old { cabalFile = cabalFile new }
103+
104+
consumeMetaFile pn v _ buf = modify (Map.alter (Just . f) pn)
105+
where
106+
f Nothing = PackageData (Map.singleton v new) mempty
107+
f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) }
108+
109+
new = PackageVersionData mempty (BSL.toStrict buf)
110+
g old _ = old { metaFile = metaFile new }

‎hackage-db/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)