diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Peter Simons + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Peter Simons nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +distribution-opensuse +===================== + +[![hackage release](https://img.shields.io/hackage/v/distribution-opensuse.svg?label=hackage)](http://hackage.haskell.org/package/distribution-opensuse) +[![stackage LTS package](http://stackage.org/package/distribution-opensuse/badge/lts)](http://stackage.org/lts/package/distribution-opensuse) +[![stackage Nightly package](http://stackage.org/package/distribution-opensuse/badge/nightly)](http://stackage.org/nightly/package/distribution-opensuse) +[![travis build status](https://img.shields.io/travis/peti/distribution-opensuse/master.svg?label=travis+build)](https://travis-ci.org/peti/distribution-opensuse) + +Types, functions, and tools to manipulate the openSUSE distribution. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/distribution-opensuse.cabal b/distribution-opensuse.cabal new file mode 100644 --- /dev/null +++ b/distribution-opensuse.cabal @@ -0,0 +1,64 @@ +name: distribution-opensuse +version: 1.0.0 +synopsis: Types, functions, and tools to manipulate the openSUSE distribution +description: Types, functions, and tools to manipulate the openSUSE distribution. +license: BSD3 +license-file: LICENSE +author: Peter Simons +maintainer: simons@cryp.to +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 +category: Distribution +homepage: https://github.com/peti/distribution-opensuse/ +build-type: Simple +extra-source-files: README.md + tests/run-tests + tests/guess-changelog/*.test +cabal-version: >= 1.10 + +source-repository head + type: git + location: git://github.com/peti/distribution-opensuse.git + +library + exposed-modules: OpenSuse.GuessChangeLog + OpenSuse.Prelude + OpenSuse.Prelude.Parser + OpenSuse.Prelude.PrettyPrinting + OpenSuse.Prelude.PrettyPrinting.Orphans + OpenSuse.Types.ChangeLog + OpenSuse.Types.EMailAddress + OpenSuse.Types.Issue + OpenSuse.Types.PackageName + OpenSuse.Types.ProjectId + OpenSuse.Types.RequestId + OpenSuse.Types.UserName + hs-source-dirs: src + build-depends: base < 5 + , Diff + , aeson + , binary + , bytestring + , containers + , deepseq + , extra + , foldl + , hashable + , hsemail + , mtl + , parsec-class + , pretty + , text + , time + , turtle + default-language: Haskell2010 + default-extensions: MonadFailDesugaring + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints + +executable guess-changelog + main-is: guess-changelog.hs + build-depends: base, containers, distribution-opensuse, text, turtle + default-language: Haskell2010 + default-extensions: MonadFailDesugaring + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -threaded diff --git a/guess-changelog.hs b/guess-changelog.hs new file mode 100644 --- /dev/null +++ b/guess-changelog.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main ( main ) where + +import OpenSuse.GuessChangeLog + +import Data.Set ( Set ) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Prelude hiding ( FilePath ) +import Turtle hiding ( l ) + +parser :: Parser (FilePath, FilePath) +parser = do + old <- argPath "old" "directory containing the old package version" + new <- argPath "new" "directory containing the new package version" + pure (old,new) + +main :: IO () +main = do + (oldDir,newDir) <- options "Guess the change log entry between two version of a package." parser + result <- guessChangeLog oldDir newDir + case result of + Right txt -> Text.putStrLn txt + Left desc -> case desc of + NoChangeLogFiles -> eprintf "no change log files found\n" + UndocumentedUpdate p -> eprintf ("file "%fp%" has not changed between releases\n") p + NoCommonChangeLogFiles l r -> eprintf ("both directories have no files in common: "%fps%" vs. "%fps%"\n") l r + MoreThanOneChangeLogFile p -> eprintf ("too many changelog files: "%fps%"\n") p + UnmodifiedTopIsTooLarge p n -> eprintf (fp%" has more than 10 unmodified lines at top: "%d%"\n") p n + NotJustTopAdditions p -> eprintf (fp%" has more edits than just adding at the top\n") p + +-- * Utility Functions + +fps :: Format r (Set FilePath -> r) +fps = makeFormat (Text.intercalate ", " . map (format fp) . Set.toAscList) diff --git a/src/OpenSuse/GuessChangeLog.hs b/src/OpenSuse/GuessChangeLog.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/GuessChangeLog.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenSuse.GuessChangeLog ( guessChangeLog, GuessedChangeLog(..) ) where + +import qualified Control.Foldl as Fold +import Control.Monad.Except +import Data.Algorithm.Diff +import Data.Set ( Set ) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Prelude hiding ( FilePath ) +import Turtle hiding ( l, x ) + +guessChangeLog :: FilePath -> FilePath -> IO (Either GuessedChangeLog Text) +guessChangeLog oldDir newDir = runExceptT $ do + oldCLF <- Set.fromList <$> listShell (findChangeLogFiles oldDir) + newCLF <- Set.fromList <$> listShell (findChangeLogFiles newDir) + when (all null [oldCLF,newCLF]) (throwError NoChangeLogFiles) + let clf' = oldCLF `Set.intersection` newCLF + clf <- case Set.toAscList clf' of + [] -> throwError (NoCommonChangeLogFiles oldCLF newCLF) + [clf] -> return clf + _ -> throwError (MoreThanOneChangeLogFile clf') + (oec,old) <- shellStrict (format ("git stripspace < "%fp) (oldDir clf)) empty + (nec,new) <- shellStrict (format ("git stripspace < "%fp) (newDir clf)) empty + unless (all (== ExitSuccess) [oec,nec]) $ + -- TODO: Throw a proper exception here, or even don't even rely on git-stripspace. + die (format ("git stripspace failed with "%w%"\n") oec) + let changes = cleanupEmptyLines (getDiff (Text.lines old) (Text.lines new)) + (top,diff) = span inBoth changes + (add,foot) = span inSecond diff + topAddOnly = all inBoth foot + when (all inBoth changes) (throwError (UndocumentedUpdate clf)) + unless (length top < 10) (throwError (UnmodifiedTopIsTooLarge clf (fromIntegral (length top)))) + unless topAddOnly (throwError (NotJustTopAdditions clf)) + return (Text.strip (Text.unlines (map unDiff add))) + +data GuessedChangeLog = NoChangeLogFiles + | UndocumentedUpdate FilePath + | NoCommonChangeLogFiles (Set FilePath) (Set FilePath) + | MoreThanOneChangeLogFile (Set FilePath) + | UnmodifiedTopIsTooLarge FilePath Word + | NotJustTopAdditions FilePath + deriving (Show) + +cleanupEmptyLines :: [Diff Text] -> [Diff Text] +cleanupEmptyLines [] = [] +cleanupEmptyLines (Second t1 : Both "" "" : Second t2 : xs) = Second t1 : Second "" : Second t2 : cleanupEmptyLines xs +cleanupEmptyLines (First t1 : Both "" "" : First t2 : xs) = First t1 : First "" : First t2 : cleanupEmptyLines xs +cleanupEmptyLines (x:xs) = x : cleanupEmptyLines xs + +inBoth :: Diff a -> Bool +inBoth (Both _ _) = True +inBoth _ = False + +inSecond :: Diff a -> Bool +inSecond (Second _) = True +inSecond _ = False + +unDiff :: Diff a -> a +unDiff (First txt) = txt +unDiff (Both txt _) = txt +unDiff (Second txt) = txt + +findChangeLogFiles :: FilePath -> Shell FilePath +findChangeLogFiles dirPath = + onFiles (grepText changelogFilePattern) (filename <$> ls dirPath) + +changelogFilePattern :: Pattern Text +changelogFilePattern = star dot <> asciiCI "change" <> star dot + +-- * Utility Functions + +listShell :: MonadIO io => Shell a -> io [a] +listShell = flip fold Fold.list diff --git a/src/OpenSuse/Prelude.hs b/src/OpenSuse/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Prelude.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} + +module OpenSuse.Prelude + ( + -- * Standard Prelude + module Prelude + , module Control.Monad.Extra + , module Control.Monad.Fail + , module Control.Monad.IO.Class + , module Data.Monoid + , module Data.Semigroup + , module Data.Word + , module GHC.Generics + , module Numeric.Natural + + -- * Parsing & Pretty Printing + , Text, LazyText, ByteString, LazyByteString + , packText, unpackText + , module OpenSuse.Prelude.Parser + , module OpenSuse.Prelude.PrettyPrinting + , module Data.Aeson + , module Data.String + + -- * Date & Time + , module Data.Time.Clock + + -- * Container + , module Data.Set + + -- * Miscellaneous + , module Control.DeepSeq + , module Data.Binary + , module Data.Hashable + , module Data.Maybe + + ) + where + +import Prelude hiding ( fail +#if MIN_VERSION_base(4,11,0) + , (<>) -- https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid +#endif + ) + +import OpenSuse.Prelude.Parser ( CharParser, HasParser(..), ErrorContext, parseM, parse + , runParser, runParserT + ) +import OpenSuse.Prelude.PrettyPrinting ( Doc, Pretty(pPrint), prettyShow ) + +import Control.DeepSeq ( NFData ) +import Control.Monad.Extra hiding ( fail ) +import Control.Monad.Fail +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Aeson ( FromJSON, ToJSON ) +import Data.Binary ( Binary ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as LBS +import Data.Hashable ( Hashable ) +import Data.Maybe ( fromMaybe ) +import Data.Monoid ( Monoid(..) ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Set ( Set ) +import Data.String ( IsString(..) ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import Data.Time.Clock ( UTCTime(..), DiffTime ) +import Data.Word ( Word8 ) +import GHC.Generics ( Generic ) +import Numeric.Natural ( Natural ) + +type LazyText = LText.Text +type LazyByteString = LBS.ByteString + +packText :: String -> Text +packText = Text.pack + +unpackText :: Text -> String +unpackText = Text.unpack diff --git a/src/OpenSuse/Prelude/Parser.hs b/src/OpenSuse/Prelude/Parser.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Prelude/Parser.hs @@ -0,0 +1,3 @@ +module OpenSuse.Prelude.Parser ( module Text.Parsec.Class ) where + +import Text.Parsec.Class diff --git a/src/OpenSuse/Prelude/PrettyPrinting.hs b/src/OpenSuse/Prelude/PrettyPrinting.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Prelude/PrettyPrinting.hs @@ -0,0 +1,11 @@ +-- | This is simply a re-export of the standard library @pretty@ with some +-- orphan instances added for convenience. + +module OpenSuse.Prelude.PrettyPrinting + ( module Text.PrettyPrint.HughesPJClass + ) + where + +import OpenSuse.Prelude.PrettyPrinting.Orphans ( ) + +import Text.PrettyPrint.HughesPJClass diff --git a/src/OpenSuse/Prelude/PrettyPrinting/Orphans.hs b/src/OpenSuse/Prelude/PrettyPrinting/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Prelude/PrettyPrinting/Orphans.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module OpenSuse.Prelude.PrettyPrinting.Orphans ( ) where + +import Numeric.Natural +import Text.PrettyPrint.HughesPJClass + +instance Pretty Natural where + pPrint = text . show diff --git a/src/OpenSuse/Types/ChangeLog.hs b/src/OpenSuse/Types/ChangeLog.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/ChangeLog.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module OpenSuse.Types.ChangeLog + ( ChangeLog(..), Entry(..) + , parseEntry, parseDashedLine, parseDateAddressLine, parseDescription + ) + where + +import OpenSuse.Prelude +import OpenSuse.Prelude.Parser as Parse +import qualified OpenSuse.Prelude.PrettyPrinting as Pretty ( ) +import OpenSuse.Types.EMailAddress +import Data.Time.Format + +newtype ChangeLog = ChangeLog [Entry] + deriving (Show, Eq, Ord, Generic, NFData, Semigroup, Monoid) + +instance HasParser ChangeLog where + parser = ChangeLog <$> (parseDashedLine *> many parser) + +data Entry = Entry + { changedAt :: UTCTime + , changedBy :: EMailAddress + , changeDescription :: Text + } + deriving (Show, Eq, Ord, Generic) + +instance NFData Entry + +instance HasParser Entry where + parser = parseEntry + +-- * Useful parsers for ChangeLog elements + +{-# ANN parseEntry "HLint: ignore Use <$>" #-} +parseEntry :: CharParser st input m Entry +parseEntry = do + (ts,author) <- parseDateAddressLine + parseEmptyLine + txt <- parseDescription + return (Entry ts author (packText txt)) + +parseDashedLine :: CharParser st input m () +parseDashedLine = do + _ <- string "------------------------------------------------------------" + skipMany1 (char '-') + _ <- endOfLine + return () + +-- | Note that the input must be terminated by a newline. +-- +-- >>> parseTest parseDateAddressLine "Wed Jun 27 09:25:07 UTC 2018 - foo@example.org\n" +-- (2018-06-27 09:25:07 UTC,EMailAddress "foo@example.org") +parseDateAddressLine :: CharParser st input m (UTCTime, EMailAddress) +parseDateAddressLine = do + ts <- many1 (alphaNum <|> oneOf ": ") + _ <- char '-' + addr <- parser + _ <- endOfLine + utct <- parseTimeM True defaultTimeLocale changeLogDateFormat ts + return (utct,addr) + +-- | Consume an empty line, i.e. a line that contains only whitespace. +parseEmptyLine :: CharParser st input m () +parseEmptyLine = skipMany (oneOf " \t") <* endOfLine + +-- | Consume all text until the end of the file or a dashed line is found. In +-- the latter case, the dashed line is consumed as well. This is unfortunate, +-- but it's how the 'notFollowedBy' combinator works, unfortunately, +parseDescription :: CharParser st input m String +parseDescription = manyTill anyChar (try parseDashedLine <|> eof) + +-- | Appropriate format parameter for 'formatTime' and 'parseTimeM'. +changeLogDateFormat :: String +changeLogDateFormat = "%a %b %e %H:%M:%S %Z %Y" diff --git a/src/OpenSuse/Types/EMailAddress.hs b/src/OpenSuse/Types/EMailAddress.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/EMailAddress.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} + +module OpenSuse.Types.EMailAddress + ( EMailAddress, mkEMailAddress, unEMailAddress + ) + where + +import OpenSuse.Prelude +import OpenSuse.Prelude.PrettyPrinting as Pretty +import Text.Parsec.Rfc2822 ( addr_spec ) + +-- | +-- +-- >>> mkEMailAddress " accept . full (rfc822) . syntax @ example . org " +-- Just (EMailAddress "accept.full.syntax@example.org") +-- +-- >>> mkEMailAddress "@this@is@not@good@" +-- Nothing +-- +-- >>> prettyShow (fromString "joe @ example.net" :: EMailAddress) +-- "joe@example.net" +newtype EMailAddress = EMailAddress String + deriving (Show, Eq, Ord, Generic, Hashable, Binary, NFData) + +-- | Constructor function for e-mail addresses. Returns 'Nothing' if the input +-- is syntactically invalid. +mkEMailAddress :: String -> Maybe EMailAddress +mkEMailAddress = parseM "e-mail address" + +-- | Accessor function for the underlying path of strings. +unEMailAddress :: EMailAddress -> String +unEMailAddress (EMailAddress str) = str + +instance HasParser EMailAddress where + parser = EMailAddress <$> addr_spec + +instance IsString EMailAddress where + fromString = parse "e-mail address" + +instance Pretty EMailAddress where + pPrint = Pretty.text . unEMailAddress diff --git a/src/OpenSuse/Types/Issue.hs b/src/OpenSuse/Types/Issue.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/Issue.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} + +module OpenSuse.Types.Issue + ( Issue(..), parseIssue, parseCve, parseBsc, showIssue + , isCve, isBsc + ) + where + +import OpenSuse.Prelude + +import Data.Aeson +import Data.List +import Data.Text ( unpack ) +import GHC.Generics ( Generic ) +import Text.Read + +data Issue = Bsc Natural + | Cve Natural Natural + deriving (Show, Eq, Ord, Generic) + +instance Hashable Issue +instance Binary Issue +instance NFData Issue + +parseIssue :: String -> Issue +parseIssue ('C':'V':'E':'-':cve) = parseCve cve +parseIssue ('b':'s':'c':'#':bsc) = parseBsc bsc +parseIssue bsc = parseBsc bsc + +showIssue :: Issue -> String +showIssue (Cve y n) = "CVE-" ++ show y ++ "-" ++ show n +showIssue (Bsc n) = "bsc#" ++ show n + +parseCve :: String -> Issue +parseCve cve = Cve (safeRead "cve-year" y) (safeRead "cve-number" n) + where (y,'-':n) = break (=='-') cve + +parseBsc :: String -> Issue -- TODO: https://gitlab.suse.de/l3ms/smelt/issues/184 +parseBsc bsc = Bsc (safeRead "bsc number" (stripFixmeSuffix bsc)) + +instance FromJSON Issue where + parseJSON = withText "Issue ID" (return . parseIssue . unpack) + +instance FromJSONKey Issue where + fromJSONKey = FromJSONKeyText (parseIssue . unpack) + +safeRead :: Read a => String -> String -> a +safeRead ctx x = fromMaybe (error ("invalid " ++ ctx ++ ": " ++ show x)) (readMaybe x) + +stripFixmeSuffix :: String -> String +stripFixmeSuffix x + | "_FIXME" `isSuffixOf` x = reverse . drop 6 . reverse $ x + | otherwise = x + +isCve :: Issue -> Bool +isCve (Cve _ _) = True +isCve _ = False + +isBsc :: Issue -> Bool +isBsc (Bsc _) = True +isBsc _ = False diff --git a/src/OpenSuse/Types/PackageName.hs b/src/OpenSuse/Types/PackageName.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/PackageName.hs @@ -0,0 +1,3 @@ +module OpenSuse.Types.PackageName ( PackageName ) where + +type PackageName = String diff --git a/src/OpenSuse/Types/ProjectId.hs b/src/OpenSuse/Types/ProjectId.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/ProjectId.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module OpenSuse.Types.ProjectId + ( ProjectId, mkProjectId, unProjectId + ) + where + +import OpenSuse.Prelude +import OpenSuse.Prelude.Parser as Parse +import OpenSuse.Prelude.PrettyPrinting as Pretty + +import Data.Aeson as Json +import Data.Aeson.Types as Json ( toJSONKeyText ) + +-- | Projects are identified on OBS by a string path. +-- +-- >>> parse "project id" "SUSE:SLE-12-SP2:Update" :: ProjectId +-- ProjectId ["SUSE","SLE-12-SP2","Update"] +-- >>> parseM "project id" "SUSE::SLE-12-SP2" :: Maybe ProjectId +-- Nothing +-- >>> parseM "project id" ":SUSE" :: Maybe ProjectId +-- Nothing +-- >>> parseM "project id" "SUSE:" :: Maybe ProjectId +-- Nothing + +newtype ProjectId = ProjectId [String] + deriving (Show, Eq, Ord, Generic, Hashable, Binary, NFData, Semigroup, Monoid) + +-- | Constructor function for project identifiers. +-- +-- TODO: Figure out how to deal with the [] project. +mkProjectId :: [String] -> ProjectId +mkProjectId = ProjectId + +-- | Accessor function for the underlying path of strings. +unProjectId :: ProjectId -> [String] +unProjectId (ProjectId str) = str + +instance IsString ProjectId where + fromString = parse "code stream" + +instance Pretty ProjectId where + pPrint = hcat . punctuate colon . map text . unProjectId + +instance HasParser ProjectId where + parser = mkProjectId <$> sepBy1 (many1 (alphaNum <|> oneOf "_-")) (Parse.char ':') + +instance FromJSON ProjectId where + parseJSON = withText "ProjectId" (parseM "project id") + +instance FromJSONKey ProjectId where + fromJSONKey = FromJSONKeyTextParser (parseM "project id") + +instance ToJSON ProjectId where + toJSON = fromString . prettyShow + +instance ToJSONKey ProjectId where + toJSONKey = toJSONKeyText (fromString . prettyShow) diff --git a/src/OpenSuse/Types/RequestId.hs b/src/OpenSuse/Types/RequestId.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/RequestId.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} + +module OpenSuse.Types.RequestId + ( RequestId, mkRequestId, unRequestId + , ReleaseRequestId, MaintenanceRequestId + ) + where + +import OpenSuse.Prelude + +-- An OBS request identifier that is, essentially, a natural number. +newtype RequestId = RequestId Natural + deriving (Show, Eq, Ord, Enum, Generic, Hashable, Binary, NFData) + +-- | Constructor function for typed request identifiers. +mkRequestId :: Natural -> RequestId +mkRequestId = RequestId + +-- | Accessor function for the underlying natural number. +unRequestId :: RequestId -> Natural +unRequestId (RequestId n) = n + +-- | Type synonym for convenience. +type MaintenanceRequestId = RequestId + +-- | Type synonym for convenience. +type ReleaseRequestId = RequestId + +instance FromJSON RequestId +instance ToJSON RequestId + +instance IsString RequestId where + fromString = parse "request id" + +instance Pretty RequestId where + pPrint = pPrint . unRequestId + +instance HasParser RequestId where + parser = mkRequestId <$> parser diff --git a/src/OpenSuse/Types/UserName.hs b/src/OpenSuse/Types/UserName.hs new file mode 100644 --- /dev/null +++ b/src/OpenSuse/Types/UserName.hs @@ -0,0 +1,3 @@ +module OpenSuse.Types.UserName ( UserName ) where + +type UserName = String diff --git a/tests/guess-changelog/ignore-unrelated-whitespace-additions.test b/tests/guess-changelog/ignore-unrelated-whitespace-additions.test new file mode 100644 --- /dev/null +++ b/tests/guess-changelog/ignore-unrelated-whitespace-additions.test @@ -0,0 +1,43 @@ +# aeson has added whitespace in the middle of the file. +# Verify that our code isn't thrown off by that issue. + +$$$ rm -rf _tmp +$$$ cabal -v0 unpack -d _tmp aeson-1.2.4.0 +$$$ cabal -v0 unpack -d _tmp aeson-1.3.0.0 +$$$ diff _tmp/aeson-1.2.4.0/changelog.md _tmp/aeson-1.3.0.0/changelog.md +>>> +2a3,16 +> ### 1.3.0.0 +> +> Breaking changes: +> * `GKeyValue` has been renamed to `KeyValuePair`, thanks to Xia Li-yao +> * Removed unused `FromJSON` constraint in `withEmbeddedJson`, thanks to Tristan Seligmann +> +> Other improvements: +> * Optimizations of TH toEncoding, thanks to Xia Li-yao +> * Optimizations of hex decoding when using the default/pure unescape implementation, thanks to Xia Li-yao +> * Improved error message on `Day` parse failures, thanks to Gershom Bazerman +> * Add `encodeFile` as well as `decodeFile*` variants, thanks to Markus Hauck +> * Documentation fixes, thanks to Lennart Spitzner +> * CPP cleanup, thanks to Ryan Scott +> +5a20 +> +>>>= 1 + +$$$ cabal -v0 new-run guess-changelog -- _tmp/aeson-1.2.4.0 _tmp/aeson-1.3.0.0 +>>> +### 1.3.0.0 + +Breaking changes: +* `GKeyValue` has been renamed to `KeyValuePair`, thanks to Xia Li-yao +* Removed unused `FromJSON` constraint in `withEmbeddedJson`, thanks to Tristan Seligmann + +Other improvements: +* Optimizations of TH toEncoding, thanks to Xia Li-yao +* Optimizations of hex decoding when using the default/pure unescape implementation, thanks to Xia Li-yao +* Improved error message on `Day` parse failures, thanks to Gershom Bazerman +* Add `encodeFile` as well as `decodeFile*` variants, thanks to Markus Hauck +* Documentation fixes, thanks to Lennart Spitzner +* CPP cleanup, thanks to Ryan Scott +>>>= 0 diff --git a/tests/guess-changelog/undocumented-releases.test b/tests/guess-changelog/undocumented-releases.test new file mode 100644 --- /dev/null +++ b/tests/guess-changelog/undocumented-releases.test @@ -0,0 +1,11 @@ +# haskell-src-meta has not documented the 0.8.0.3 release + +$$$ rm -rf _tmp +$$$ cabal -v0 unpack -d _tmp haskell-src-meta-0.8.0.2 +$$$ cabal -v0 unpack -d _tmp haskell-src-meta-0.8.0.3 +$$$ diff _tmp/haskell-src-meta-0.8.0.2/ChangeLog _tmp/haskell-src-meta-0.8.0.3/ChangeLog + +$$$ cabal -v0 new-run guess-changelog -- _tmp/haskell-src-meta-0.8.0.2 _tmp/haskell-src-meta-0.8.0.3 +>>>2 +file ChangeLog has not changed between releases +>>>= 0 diff --git a/tests/run-tests b/tests/run-tests new file mode 100644 --- /dev/null +++ b/tests/run-tests @@ -0,0 +1,4 @@ +#! /bin/sh + +cd "$(dirname "$0")" || exit 1 +exec shelltest --execdir .