This repository was archived by the owner on Feb 7, 2024. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 13
Expand file tree
/
Copy pathVersion.hs
More file actions
164 lines (131 loc) · 5.57 KB
/
Version.hs
File metadata and controls
164 lines (131 loc) · 5.57 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
{-# LANGUAGE TemplateHaskell #-}
module NStack.Module.Version where
import Control.Lens ((^?))
import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey, FromJSONKey)
import Data.Bifunctor (first)
import Data.Data (Data(..))
import Data.Functor.Identity (Identity)
import Data.Int (Int64)
import Data.Monoid ((<>))
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Serialize (Serialize(..))
import Data.Text (Text)
import Data.Thyme (getCurrentTime)
import Data.Void (Void)
import GHC.Generics (Generic)
import Numeric (showHex)
import Numeric.Lens (hex)
import Text.Megaparsec (parse, some, ParsecT)
import Text.Megaparsec.Char (hexDigitChar)
import Text.PrettyPrint.Mainland (Pretty, ppr, text)
import NStack.Prelude.Monad (orError, eitherToExcept)
import NStack.Prelude.Time (timeToUnix)
import NStack.SafeCopyOrphans ()
import NStack.UUIDOrphans ()
-- | Semantic Version with a release tag of type `r`
data SemVer r = SemVer {
major :: Integer,
minor :: Integer,
patch :: Integer,
release :: r
} deriving (Eq, Ord, Generic, Data, Functor, Foldable, Traversable)
-- Exact versions, e.g.
-- import Foo:1.0.2 --> A specific release reference
-- import Foo:1.0.2-SNAPSHOT-3457230459837 --> A specific resolved snapshot reference
type FuzzyVersion = SemVer FuzzyRelease
-- Fuzzy versions, e.g.
-- import Foo:LATEST --> resolve to latest version (release or snapshot?)
-- import Foo:0.0.1-SNAPSHOT --> resolve to latest actual snapshot for 0.0.1
-- import Foo:1.0.2 --> Exact references are a subset of fuzzy
-- import Foo:1.0.2-SNAPSHOT-3457230459837 --> Exact references are a subset of fuzzy
type ExactVersion = SemVer ExactRelease
data FuzzyRelease = FSnap SnapshotHash
| Snapshot
| FRelease
deriving (Eq, Ord, Generic, Data)
data ExactRelease = Snap SnapshotHash
| Release
deriving (Eq, Ord, Generic, Data)
-- Version Queries, e.g.
-- start Foo:LATEST --> resolve to latest version (release or snapshot?)
-- start Foo:0.0.1-SNAPSHOT --> resolve to latest actual snapshot for 0.0.1
-- start Foo:1.0.2 --> Exact references are a subset of queries
-- start Foo:1.0.2-SNAPSHOT-3457230459837 --> Exact references are a subset of queries
data VersionQuery = Latest -- Foo:LATEST
| Matching FuzzyVersion
-- All snapshots are stored as immutable against a specific version hash
data SnapshotHash = SnapshotHash Int64
deriving (Eq, Ord, Generic, Data)
mkSnapshotHash :: MonadIO m => m SnapshotHash
mkSnapshotHash = liftIO $ do
time <- read . timeToUnix <$> getCurrentTime
return $ SnapshotHash time
instance Serialize SnapshotHash
instance Show SnapshotHash where
show (SnapshotHash time) = showHex time ""
instance Show ExactRelease where
show (Snap hash) = "-SNAPSHOT-" <> show hash
show Release = ""
instance Show FuzzyRelease where
show (FSnap hash) = "-SNAPSHOT-" <> show hash
show Snapshot = "-SNAPSHOT"
show FRelease = ""
instance Pretty ExactRelease where
ppr = text . show
-- When pretty-printing a fuzzy release, hide the snapshot hash
instance Pretty FuzzyRelease where
ppr = text . show
-- Typeclass for diplaying a short (abbreviated but human readable) version
class ShowShort a where
showShort :: a -> String
instance ShowShort FuzzyRelease where
showShort (FSnap _) = "-SNAPSHOT"
showShort Snapshot = "-SNAPSHOT"
showShort FRelease = ""
instance ShowShort ExactRelease where
showShort (Snap _) = "-SNAPSHOT"
showShort Release = ""
instance ShowShort r => ShowShort (SemVer r) where
showShort (SemVer ma mi p r) = show ma <> "." <> show mi <> "." <> show p <> showShort r
instance Show r => Show (SemVer r) where
show (SemVer ma mi p r) = show ma <> "." <> show mi <> "." <> show p <> show r
instance Show r => Pretty (SemVer r) where
ppr = text . show
parseSnapshotHash :: MonadError String m => Text -> m SnapshotHash
parseSnapshotHash str = do
ts :: String <- eitherToExcept $ parse' pTimestamp str
timestamp <- (ts ^? hex) `orError` "Timestamp is not a valid hex string" -- This should never happen as we have safely parsed
return $ SnapshotHash timestamp
where pTimestamp = some hexDigitChar
parse' :: ParsecT Void Text Identity a -> Text -> Either String a
parse' p = first show . parse p "<no file>"
-- Instantiate snapshots with unique hashes; preserve exact versions
instantiateFuzzy' :: MonadIO m => FuzzyVersion -> m ExactVersion
instantiateFuzzy' = traverse instantiate
where instantiate (FSnap hash) = return $ Snap hash
instantiate FRelease = return Release
instantiate Snapshot = Snap <$> mkSnapshotHash
exactToFuzzy :: ExactRelease -> FuzzyRelease
exactToFuzzy (Snap h) = (FSnap h)
exactToFuzzy Release = FRelease
instance Serialize r => Serialize (SemVer r)
instance Serialize ExactRelease
instance Serialize FuzzyRelease
$(deriveSafeCopy 0 'base ''SemVer)
$(deriveSafeCopy 0 'base ''ExactRelease)
$(deriveSafeCopy 0 'base ''FuzzyRelease)
$(deriveSafeCopy 0 'base ''SnapshotHash)
instance ToJSON r => ToJSON (SemVer r)
instance FromJSON r => FromJSON (SemVer r)
instance ToJSON r => ToJSONKey (SemVer r)
instance FromJSON r => FromJSONKey (SemVer r)
instance ToJSON SnapshotHash
instance FromJSON SnapshotHash
instance ToJSON ExactRelease
instance FromJSON ExactRelease
instance ToJSONKey ExactRelease
instance FromJSONKey ExactRelease
instance ToJSON FuzzyRelease
instance FromJSON FuzzyRelease