August 2017 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-logging-effect for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-logging-effect for openSUSE:Factory checked in at 2017-08-31 20:57:12 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-logging-effect (Old) and /work/SRC/openSUSE:Factory/.ghc-logging-effect.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-logging-effect" Thu Aug 31 20:57:12 2017 rev:2 rq:513425 version:1.2.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-logging-effect/ghc-logging-effect.changes 2017-04-12 18:07:37.966779948 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-logging-effect.new/ghc-logging-effect.changes 2017-08-31 20:57:14.420867517 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:59 UTC 2017 - psimons(a)suse.com + +- Update to version 1.2.0. + +------------------------------------------------------------------- Old: ---- logging-effect-1.1.3.tar.gz New: ---- logging-effect-1.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-logging-effect.spec ++++++ --- /var/tmp/diff_new_pack.9KTj9r/_old 2017-08-31 20:57:15.764678708 +0200 +++ /var/tmp/diff_new_pack.9KTj9r/_new 2017-08-31 20:57:15.768678146 +0200 @@ -18,7 +18,7 @@ %global pkg_name logging-effect Name: ghc-%{pkg_name} -Version: 1.1.3 +Version: 1.2.0 Release: 0 Summary: A mtl-style monad transformer for general purpose & compositional logging License: BSD-3-Clause ++++++ logging-effect-1.1.3.tar.gz -> logging-effect-1.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/logging-effect-1.1.3/Changelog.md new/logging-effect-1.2.0/Changelog.md --- old/logging-effect-1.1.3/Changelog.md 2017-02-18 10:48:06.000000000 +0100 +++ new/logging-effect-1.2.0/Changelog.md 2017-02-27 13:53:53.000000000 +0100 @@ -1,3 +1,15 @@ +# 1.2.0 + +## Major Changes + +- `withFDHandler` now explicitly flushes the file handle whenever log entries + are rendered out. Thanks to @filterfish for identifying this omission that + could lead to log messages being dropped. + + Upgrade steps: no changes other than updating `logging-effect`. + +--- + # 1.1.3 ## Other Changes @@ -49,7 +61,7 @@ severity. The combinators are: `logDebug`, `logInfo`, `logNotice`, `logWarning`, `logError`, `logCritical`, `logAlert` and `logEmergency`. -- `mapLogMessage` got a companion function `mapLogMessageM` that works with +- `mapLogMessage` got a companion function `mapLogMessageM` that works with monadic tranformations. *Other* diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/logging-effect-1.1.3/logging-effect.cabal new/logging-effect-1.2.0/logging-effect.cabal --- old/logging-effect-1.1.3/logging-effect.cabal 2017-02-18 10:48:06.000000000 +0100 +++ new/logging-effect-1.2.0/logging-effect.cabal 2017-02-27 13:53:53.000000000 +0100 @@ -1,5 +1,5 @@ name: logging-effect -version: 1.1.3 +version: 1.2.0 synopsis: A mtl-style monad transformer for general purpose & compositional logging homepage: https://github.com/ocharles/logging-effect license: BSD3 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/logging-effect-1.1.3/src/Control/Monad/Log.hs new/logging-effect-1.2.0/src/Control/Monad/Log.hs --- old/logging-effect-1.1.3/src/Control/Monad/Log.hs 2017-02-18 10:48:06.000000000 +0100 +++ new/logging-effect-1.2.0/src/Control/Monad/Log.hs 2017-02-27 13:53:53.000000000 +0100 @@ -100,7 +100,7 @@ #else import GHC.Stack (SrcLoc, CallStack, getCallStack, prettySrcLoc) #endif -import System.IO (Handle) +import System.IO (Handle, hFlush) import qualified Data.Text.Lazy as LT import qualified Text.PrettyPrint.Leijen.Text as PP import qualified Data.List.NonEmpty as NEL @@ -527,9 +527,16 @@ -> Int -- ^ The amount of characters per line. Lines longer than this will be pretty-printed across multiple lines if possible. -> (Handler io PP.Doc -> io a) -> io a -withFDHandler options fd ribbonFrac width = - withBatchedHandler options - (PP.displayIO fd . PP.renderPretty ribbonFrac width . (<> PP.linebreak) . PP.vsep . NEL.toList) +withFDHandler options fd ribbonFrac width = withBatchedHandler options flush + where + flush messages = do + PP.displayIO + fd + (PP.renderPretty + ribbonFrac + width + (PP.vsep (NEL.toList messages) <> PP.linebreak)) + hFlush fd -------------------------------------------------------------------------------- -- | A 'MonadLog' handler optimised for pure usage. Log messages are accumulated

1 0

commit ghc-line for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-line for openSUSE:Factory checked in at 2017-08-31 20:57:10 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-line (Old) and /work/SRC/openSUSE:Factory/.ghc-line.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-line" Thu Aug 31 20:57:10 2017 rev:2 rq:513421 version:3.1.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-line/ghc-line.changes 2017-05-16 14:42:32.145212575 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-line.new/ghc-line.changes 2017-08-31 20:57:10.965353028 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:47 UTC 2017 - psimons(a)suse.com + +- Update to version 3.1.0. + +------------------------------------------------------------------- Old: ---- line-2.2.0.tar.gz New: ---- line-3.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-line.spec ++++++ --- /var/tmp/diff_new_pack.sHyZ6F/_old 2017-08-31 20:57:11.873225469 +0200 +++ /var/tmp/diff_new_pack.sHyZ6F/_new 2017-08-31 20:57:11.881224346 +0200 @@ -19,7 +19,7 @@ %global pkg_name line %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.2.0 +Version: 3.1.0 Release: 0 Summary: Haskell SDK for the LINE API License: BSD-3-Clause ++++++ line-2.2.0.tar.gz -> line-3.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/line-2.2.0/CHANGELOG.md new/line-3.1.0/CHANGELOG.md --- old/line-2.2.0/CHANGELOG.md 2017-01-15 08:48:15.000000000 +0100 +++ new/line-3.1.0/CHANGELOG.md 2017-05-25 18:17:47.000000000 +0200 @@ -1,3 +1,15 @@ +## 3.1.0 (26 May 2017) + +* Add support for file message + +## 3.0.1 (26 Apr 2017) + +* Use Text instead of String for Beacon dm + +## 3.0.0 (26 Apr 2017) + +* Add type and dm support for Beacon event + ## 2.2.0 (15 Jan 2017) * Add multicast API support diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/line-2.2.0/line.cabal new/line-3.1.0/line.cabal --- old/line-2.2.0/line.cabal 2017-01-15 08:47:41.000000000 +0100 +++ new/line-3.1.0/line.cabal 2017-05-25 18:16:57.000000000 +0200 @@ -1,5 +1,5 @@ name: line -version: 2.2.0 +version: 3.1.0 synopsis: Haskell SDK for the LINE API homepage: https://github.com/noraesae/line license: BSD3 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/line-2.2.0/src/Line/Messaging/Webhook/Types.hs new/line-3.1.0/src/Line/Messaging/Webhook/Types.hs --- old/line-2.2.0/src/Line/Messaging/Webhook/Types.hs 2016-12-01 15:21:38.000000000 +0100 +++ new/line-3.1.0/src/Line/Messaging/Webhook/Types.hs 2017-05-25 18:13:40.000000000 +0200 @@ -40,6 +40,8 @@ EventMessage (..), -- *** Beacon event BeaconData (..), + getHWID, + getDeviceMessage, ) where import Data.Aeson @@ -222,6 +224,7 @@ | ImageEM ID -- ^ Image event message. | VideoEM ID -- ^ Video event message. | AudioEM ID -- ^ Audio event message. + | FileEM ID T.Text Integer -- ^ File event message. | LocationEM ID Location -- ^ Location event message. | StickerEM ID Sticker -- ^ Sticker event message. deriving (Eq, Show) @@ -233,20 +236,38 @@ "image" -> ImageEM <$> v .: "id" "video" -> VideoEM <$> v .: "id" "audio" -> AudioEM <$> v .: "id" + "file" -> FileEM <$> v .: "id" <*> v .: "fileName" <*> (read <$> v .: "fileSize") "location" -> LocationEM <$> v .: "id" <*> parseJSON (Object v) "sticker" -> StickerEM <$> v .: "id" <*> parseJSON (Object v) _ -> fail "EventMessage" parseJSON _ = fail "IncommingMessage" -- | Represent beacon data. -data BeaconData = BeaconEnter { getHWID :: ID - -- ^ Get hardware ID of the beacon. - } +data BeaconData = BeaconEnter ID (Maybe T.Text) + | BeaconLeave ID (Maybe T.Text) + | BeaconBanner ID (Maybe T.Text) deriving (Eq, Show) + +-- | Get hardware ID of the beacon. +getHWID :: BeaconData -> ID +getHWID (BeaconEnter hwid _) = hwid +getHWID (BeaconLeave hwid _) = hwid +getHWID (BeaconBanner hwid _) = hwid + +-- | Get device message from the beacon, if exists. +getDeviceMessage :: BeaconData -> Maybe T.Text +getDeviceMessage (BeaconEnter _ dm) = dm +getDeviceMessage (BeaconLeave _ dm) = dm +getDeviceMessage (BeaconBanner _ dm) = dm + instance FromJSON BeaconData where parseJSON (Object v) = v .: "type" >>= \ t -> case t :: T.Text of - "enter" -> BeaconEnter <$> v .: "hwid" + "enter" -> parseBeacon BeaconEnter + "leave" -> parseBeacon BeaconLeave + "banner" -> parseBeacon BeaconBanner _ -> fail "BeaconData" + where + parseBeacon f = f <$> v .: "hwid" <*> v .:? "dm" parseJSON _ = fail "BeaconData" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/line-2.2.0/test/Line/Messaging/Webhook/TypesSpec.hs new/line-3.1.0/test/Line/Messaging/Webhook/TypesSpec.hs --- old/line-2.2.0/test/Line/Messaging/Webhook/TypesSpec.hs 2016-12-03 11:16:23.000000000 +0100 +++ new/line-3.1.0/test/Line/Messaging/Webhook/TypesSpec.hs 2017-05-25 18:11:31.000000000 +0200 @@ -73,6 +73,11 @@ , ( badAudioMessage, Nothing ) ] + describe "file message event" $ fromJSONSpec + [ ( goodFileMessage, replyE MessageEvent (FileEM "325708" "hello.txt" 1234) ) + , ( badFileMessage, Nothing ) + ] + describe "location message event" $ fromJSONSpec [ ( goodLocationMessage, replyE MessageEvent (LocationEM "325708" $ Location @@ -129,6 +134,9 @@ ] describe "beacon event" $ fromJSONSpec - [ ( goodBeacon, replyE BeaconEvent (BeaconEnter "d41d8cd98f") ) + [ ( goodBeacon, replyE BeaconEvent (BeaconEnter "d41d8cd98f" Nothing) ) + , ( goodBeaconLeave, replyE BeaconEvent (BeaconLeave "d41d8cd98f" Nothing) ) + , ( goodBeaconBanner, replyE BeaconEvent (BeaconBanner "d41d8cd98f" Nothing) ) + , ( goodBeaconWithDm, replyE BeaconEvent (BeaconEnter "d41d8cd98f" (Just "i am a direct message.")) ) , ( badBeacon, Nothing ) ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/line-2.2.0/test/Line/Messaging/Webhook/TypesSpecHelper.hs new/line-3.1.0/test/Line/Messaging/Webhook/TypesSpecHelper.hs --- old/line-2.2.0/test/Line/Messaging/Webhook/TypesSpecHelper.hs 2016-12-03 11:09:38.000000000 +0100 +++ new/line-3.1.0/test/Line/Messaging/Webhook/TypesSpecHelper.hs 2017-05-25 18:09:31.000000000 +0200 @@ -190,6 +190,48 @@ ] } |] +goodFileMessage :: BL.ByteString +goodFileMessage = [r| +{ "events": [ +{ + "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", + "type": "message", + "timestamp": 1462629479859, + "source": { + "type": "user", + "userId": "U206d25c2ea6bd87c17655609a1c37cb8" + }, + "message": { + "id": "325708", + "type": "file", + "fileName": "hello.txt", + "fileSize": "1234" + } +} +] } +|] + +badFileMessage :: BL.ByteString +badFileMessage = [r| +{ "events": [ +{ + "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", + "type": "message", + "timestamp": 1462629479859, + "source": { + "type": "user", + "userId": "U206d25c2ea6bd87c17655609a1c37cb8" + }, + "message": { + "id": "325708", + "type": "file'", + "fileName": "hello.txt", + "fileSize": "1234" + } +} +] } +|] + goodLocationMessage :: BL.ByteString goodLocationMessage = [r| { "events": [ @@ -447,6 +489,64 @@ } } ] } +|] + +goodBeaconLeave :: BL.ByteString +goodBeaconLeave = [r| +{ "events": [ +{ + "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", + "type": "beacon", + "timestamp": 1462629479859, + "source": { + "type": "user", + "userId": "U206d25c2ea6bd87c17655609a1c37cb8" + }, + "beacon": { + "hwid": "d41d8cd98f", + "type": "leave" + } +} +] } +|] + +goodBeaconBanner :: BL.ByteString +goodBeaconBanner = [r| +{ "events": [ +{ + "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", + "type": "beacon", + "timestamp": 1462629479859, + "source": { + "type": "user", + "userId": "U206d25c2ea6bd87c17655609a1c37cb8" + }, + "beacon": { + "hwid": "d41d8cd98f", + "type": "banner" + } +} +] } +|] + +goodBeaconWithDm :: BL.ByteString +goodBeaconWithDm = [r| +{ "events": [ +{ + "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", + "type": "beacon", + "timestamp": 1462629479859, + "source": { + "type": "user", + "userId": "U206d25c2ea6bd87c17655609a1c37cb8" + }, + "beacon": { + "hwid": "d41d8cd98f", + "type": "enter", + "dm": "i am a direct message." + } +} +] } |] badBeacon :: BL.ByteString

1 0

commit ghc-licensor for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-licensor for openSUSE:Factory checked in at 2017-08-31 20:57:07 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-licensor (Old) and /work/SRC/openSUSE:Factory/.ghc-licensor.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-licensor" Thu Aug 31 20:57:07 2017 rev:2 rq:513420 version:0.2.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-licensor/ghc-licensor.changes 2017-04-06 11:00:29.565638892 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-licensor.new/ghc-licensor.changes 2017-08-31 20:57:10.033483959 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:34 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.1. + +------------------------------------------------------------------- Old: ---- licensor-0.2.0.tar.gz New: ---- licensor-0.2.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-licensor.spec ++++++ --- /var/tmp/diff_new_pack.E58ryc/_old 2017-08-31 20:57:10.653396859 +0200 +++ /var/tmp/diff_new_pack.E58ryc/_new 2017-08-31 20:57:10.661395735 +0200 @@ -18,7 +18,7 @@ %global pkg_name licensor Name: ghc-%{pkg_name} -Version: 0.2.0 +Version: 0.2.1 Release: 0 Summary: A license compatibility helper License: MIT ++++++ licensor-0.2.0.tar.gz -> licensor-0.2.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/licensor-0.2.0/CHANGELOG.md new/licensor-0.2.1/CHANGELOG.md --- old/licensor-0.2.0/CHANGELOG.md 2016-09-19 00:17:42.000000000 +0200 +++ new/licensor-0.2.1/CHANGELOG.md 2017-07-24 16:26:29.000000000 +0200 @@ -1,3 +1,7 @@ +# 0.2.1 (2017-07-24) + +- Allow base 4.10 and Cabal 2.0 (7bbb360) + # 0.2.0 (2016-09-18) ## Enhancements diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/licensor-0.2.0/Main.hs new/licensor-0.2.1/Main.hs --- old/licensor-0.2.0/Main.hs 2016-09-16 15:27:50.000000000 +0200 +++ new/licensor-0.2.1/Main.hs 2017-07-05 15:01:13.000000000 +0200 @@ -64,6 +64,7 @@ } &= program s &= summary (unwords ["licensor", Version.showVersion version]) + &= verbosity -- | @@ -74,6 +75,8 @@ main = do LiArgs <- cmdArgsRun . liArgs =<< getProgName + quiet <- fmap not isNormal + maybePackage <- getPackage pid <- @@ -105,7 +108,7 @@ Just dependencies -> do (dependenciesByLicense', failed) <- - orderPackagesByLicense pid dependencies + orderPackagesByLicense quiet pid dependencies let dependenciesByLicense = fmap (Set.map display) dependenciesByLicense' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/licensor-0.2.0/README.md new/licensor-0.2.1/README.md --- old/licensor-0.2.0/README.md 2016-09-18 23:46:36.000000000 +0200 +++ new/licensor-0.2.1/README.md 2017-07-05 15:01:13.000000000 +0200 @@ -5,8 +5,8 @@ [0]: https://circleci.com/gh/jpvillaisaza/licensor [1]: https://circleci.com/gh/jpvillaisaza/licensor.svg?style=svg -![][2] -![][3] +[![][2]](https://www.stackage.org/lts/package/licensor) +[![][3]](https://www.stackage.org/nightly/package/licensor) [2]: https://www.stackage.org/package/licensor/badge/lts [3]: https://www.stackage.org/package/licensor/badge/nightly @@ -167,7 +167,8 @@ ## Additional resources -- [Choose a License](http://choosealicense.com/) +- [Choose a License](https://choosealicense.com/) +- [The Legal Side of Open Source](https://opensource.guide/legal/) - [License compatibility][ar-01] - [Understanding open source and free software licensing][ar-02] (Andrew M. St. Laurent) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/licensor-0.2.0/licensor.cabal new/licensor-0.2.1/licensor.cabal --- old/licensor-0.2.0/licensor.cabal 2016-09-19 00:18:09.000000000 +0200 +++ new/licensor-0.2.1/licensor.cabal 2017-07-24 16:26:14.000000000 +0200 @@ -1,5 +1,5 @@ name: licensor -version: 0.2.0 +version: 0.2.1 build-type: Simple cabal-version: >= 1.21 @@ -21,7 +21,7 @@ category: Distribution -tested-with: GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1 extra-source-files: CHANGELOG.md, README.md @@ -34,9 +34,9 @@ other-modules: Paths_licensor build-depends: - base >= 4.8 && < 4.10 + base >= 4.8 && < 4.11 , bytestring - , Cabal >= 1.22 && < 1.25 + , Cabal >= 1.22 && < 2.1 , containers , directory , http-conduit >= 2.1 && < 2.3 @@ -51,8 +51,8 @@ main-is: Main.hs build-depends: - base >= 4.8 && < 5.0 - , Cabal >= 1.22 && < 1.25 + base + , Cabal , cmdargs >= 0.10 && < 0.11 , containers , directory diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/licensor-0.2.0/src/Licensor.hs new/licensor-0.2.1/src/Licensor.hs --- old/licensor-0.2.0/src/Licensor.hs 2016-09-11 22:25:54.000000000 +0200 +++ new/licensor-0.2.1/src/Licensor.hs 2017-07-05 15:01:13.000000000 +0200 @@ -24,6 +24,7 @@ -- base import qualified Control.Exception as Exception +import Control.Monad (unless) import Data.Monoid ((<>)) import Data.Version (Version) import System.IO @@ -130,9 +131,9 @@ -- -- -getPackageLicense :: PackageIdentifier -> IO (Maybe LiLicense) -getPackageLicense p@PackageIdentifier{..} = do - putStr $ display p ++ "..." +getPackageLicense :: Bool -> PackageIdentifier -> IO (Maybe LiLicense) +getPackageLicense quiet p@PackageIdentifier{..} = do + unless quiet (putStr $ display p ++ "...") let url = "GET https://hackage.haskell.org/package/" @@ -157,7 +158,7 @@ hClose handle removeFile file - putStrLn $ display license + unless quiet (putStrLn $ display license) return $ Just (LiLicense license) @@ -167,16 +168,17 @@ -- orderPackagesByLicense - :: Maybe PackageIdentifier + :: Bool + -> Maybe PackageIdentifier -> Set PackageIdentifier -> IO (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier) -orderPackagesByLicense maybeP = +orderPackagesByLicense quiet maybeP = let cond = maybe (const False) (==) maybeP insertPackage package orderedPackages' = do - maybeLicense <- getPackageLicense package + maybeLicense <- getPackageLicense quiet package (orderedPackages, failed) <- orderedPackages' return $

1 0

commit ghc-language-puppet for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-language-puppet for openSUSE:Factory checked in at 2017-08-31 20:57:04 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-language-puppet (Old) and /work/SRC/openSUSE:Factory/.ghc-language-puppet.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-language-puppet" Thu Aug 31 20:57:04 2017 rev:3 rq:513417 version:1.3.8.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-language-puppet/ghc-language-puppet.changes 2017-05-18 20:50:45.806571635 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-language-puppet.new/ghc-language-puppet.changes 2017-08-31 20:57:06.050043645 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:07 UTC 2017 - psimons(a)suse.com + +- Update to version 1.3.8.1. + +------------------------------------------------------------------- Old: ---- language-puppet-1.3.7.tar.gz New: ---- language-puppet-1.3.8.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-language-puppet.spec ++++++ --- /var/tmp/diff_new_pack.Op7lNK/_old 2017-08-31 20:57:06.817935753 +0200 +++ /var/tmp/diff_new_pack.Op7lNK/_new 2017-08-31 20:57:06.821935192 +0200 @@ -19,7 +19,7 @@ %global pkg_name language-puppet %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.3.7 +Version: 1.3.8.1 Release: 0 Summary: Tools to parse and evaluate the Puppet DSL License: BSD-3-Clause ++++++ language-puppet-1.3.7.tar.gz -> language-puppet-1.3.8.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/CHANGELOG.markdown new/language-puppet-1.3.8.1/CHANGELOG.markdown --- old/language-puppet-1.3.7/CHANGELOG.markdown 2017-03-14 18:12:30.000000000 +0100 +++ new/language-puppet-1.3.8.1/CHANGELOG.markdown 2017-07-21 12:04:15.000000000 +0200 @@ -1,3 +1,13 @@ +# v1.3.8.1 (2017/07/21) + +* Fix haddocks error (#208) + +# v1.3.8 (2017/07/20) + +* Add support for calling Functions in Strings (#199) +* Add $facts hash for Puppet 4 (#198) +* Initial support for datatype syntax (#206) + # v1.3.7 (2017/03/14) * Add puppet `sprintf` function diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Daemon.hs new/language-puppet-1.3.8.1/Puppet/Daemon.hs --- old/language-puppet-1.3.7/Puppet/Daemon.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Daemon.hs 2017-06-22 13:15:37.000000000 +0200 @@ -28,6 +28,7 @@ import System.Log.Handler (setFormatter) import qualified System.Log.Handler.Simple as LOG (streamHandler) import qualified System.Log.Logger as LOG +import qualified Text.Megaparsec as P import Erb.Compute import Hiera.Server @@ -184,7 +185,7 @@ cnt <- T.readFile fname o <- case runPParser fname cnt of Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) - Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr)) + Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (P.parseErrorPretty rr)) traceEventIO ("STOP parsing " ++ fname) return o diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Interpreter/PrettyPrinter.hs new/language-puppet-1.3.8.1/Puppet/Interpreter/PrettyPrinter.hs --- old/language-puppet-1.3.7/Puppet/Interpreter/PrettyPrinter.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Interpreter/PrettyPrinter.hs 2017-06-22 13:04:21.000000000 +0200 @@ -50,6 +50,7 @@ pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n)) pretty (PArray v) = list (map pretty (V.toList v)) pretty (PHash g) = containerComma g + pretty (PType dt) = pretty dt instance Pretty TopLevelType where pretty TopNode = dullyellow (text "node") diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Interpreter/Resolve.hs new/language-puppet-1.3.8.1/Puppet/Interpreter/Resolve.hs --- old/language-puppet-1.3.7/Puppet/Interpreter/Resolve.hs 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Interpreter/Resolve.hs 2017-06-22 13:11:40.000000000 +0200 @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} -- | This module is all about converting and resolving foreign data into -- the fully exploitable corresponding data type. The main use case is the -- conversion of 'Expression' to 'PValue'. @@ -26,7 +27,8 @@ hfSetvars, hfRestorevars, toNumbers, - fixResourceName + fixResourceName, + datatypeMatch ) where import Control.Lens @@ -45,7 +47,8 @@ import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS -import Data.Maybe (fromMaybe, mapMaybe) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (fromMaybe, mapMaybe, catMaybes) import qualified Data.Maybe.Strict as S import Data.Scientific import qualified Data.Text as T @@ -285,6 +288,9 @@ Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr) Right Nothing -> checkCond xs Right (Just _) -> resolveExpression ce + checkCond ((SelectorType dt :!: ce) : xs) = if datatypeMatch dt rese + then resolveExpression ce + else checkCond xs checkCond ((SelectorValue uv :!: ce) : xs) = do rv <- resolveValue uv if puppetEquality rese rv @@ -712,3 +718,40 @@ PHash hh -> return $ PHash $ HM.fromList $ map Prelude.fst $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x) + +-- | Checks that a value matches a puppet datatype +datatypeMatch :: DataType -> PValue -> Bool +datatypeMatch dt v + = case dt of + DTType -> has _PType v + DTUndef -> v == PUndef + NotUndef -> v /= PUndef + DTString mmin mmax -> boundedBy _PString T.length mmin mmax + DTInteger mmin mmax -> boundedBy (_PNumber . to toBoundedInteger . _Just) id mmin mmax + DTFloat mmin mmax -> boundedBy _PNumber toRealFloat mmin mmax + DTBoolean -> has _PBoolean v + DTArray sdt mi mmx -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx + DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k,a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx + DTScalar -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v + DTData -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v + DTOptional sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v + DTVariant sdts -> any (`datatypeMatch` v) sdts + DTEnum lst -> maybe False (`elem` lst) (v ^? _PString) + DTAny -> True + DTCollection -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v + DTPattern patterns -> maybe False (\str -> any (checkPattern (T.encodeUtf8 str)) patterns) (v ^? _PString) + where + checkPattern str (CompRegex _ ptrn) + = case execute' ptrn str of + Right (Just _) -> True + _ -> False + container :: Fold PValue [a] -> (a -> Bool) -> Int -> Maybe Int -> Bool + container f c mi mmx = + let lst = v ^. f + ln = length lst + in ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst + boundedBy :: Ord b => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool + boundedBy prm f mmin mmax + = fromMaybe False $ do + vr <- f <$> v ^? prm + return $ and $ catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Interpreter/Types.hs new/language-puppet-1.3.8.1/Puppet/Interpreter/Types.hs --- old/language-puppet-1.3.7/Puppet/Interpreter/Types.hs 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Interpreter/Types.hs 2017-06-22 10:15:07.000000000 +0200 @@ -41,7 +41,17 @@ , HasInterpreterState(..) , InterpreterState(InterpreterState) -- * Sum types + -- ** PValue , PValue(..) + , _PType + , _PBoolean + , _PString + , _PResourceReference + , _PArray + , _PHash + , _PNumber + , _PUndef + -- ** Misc , CurContainerDesc(..) , ResourceCollectorType(..) , RSearchExpression(..) @@ -148,6 +158,7 @@ | PArray !(V.Vector PValue) | PHash !(Container PValue) | PNumber !Scientific + | PType DataType deriving (Eq, Show) instance IsString PValue where @@ -270,7 +281,7 @@ , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) , _readerGetTemplate :: Either Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text) , _readerPdbApi :: PuppetDBAPI m - , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) + , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ external func such as stdlib or puppetlabs , _readerNodename :: Text , _readerHieraQuery :: HieraQueryFunc m , _readerIoMethods :: IoMethods m @@ -485,7 +496,7 @@ makeClassy ''NodeInfo makeClassy ''WireCatalog makeClassy ''FactInfo - +makePrisms ''PValue class Monad m => MonadThrowPos m where throwPosError :: Doc -> m a @@ -531,6 +542,7 @@ parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o) instance ToJSON PValue where + toJSON (PType t) = toJSON t toJSON (PBoolean b) = Bool b toJSON PUndef = Null toJSON (PString s) = String s diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Interpreter/Utils.hs new/language-puppet-1.3.8.1/Puppet/Interpreter/Utils.hs --- old/language-puppet-1.3.7/Puppet/Interpreter/Utils.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Interpreter/Utils.hs 2017-06-14 10:52:51.000000000 +0200 @@ -31,7 +31,10 @@ initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] [] where callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)] - factvars = fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts + factvars = + -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#access… + let facts' = HM.insert "facts" (PHash facts) facts + in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts' settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Interpreter.hs new/language-puppet-1.3.8.1/Puppet/Interpreter.hs --- old/language-puppet-1.3.7/Puppet/Interpreter.hs 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Interpreter.hs 2017-06-22 16:21:07.000000000 +0200 @@ -210,7 +210,7 @@ evaluateNode (NodeDecl _ sx inheritnode p) = do curPos .= p pushScope ContRoot - unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled yet, and will probably never be" + unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled. It is deprecated since puppet v4" mapM evaluateStatement sx >>= finalize . concat noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres)) @@ -557,11 +557,11 @@ -- -- It is able to fill unset parameters with values from Hiera (for classes -- only) or default values. -loadParameters :: Foldable f => Container PValue -> f (Pair Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () +loadParameters :: Foldable f => Container PValue -> f (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () loadParameters params classParams defaultPos wHiera = do p <- use curPos curPos .= defaultPos - let classParamSet = HS.fromList (classParams ^.. folded . _1) + let classParamSet = HS.fromList (classParams ^.. folded . _1 . _1) spuriousParams = ikeys params `HS.difference` classParamSet mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera @@ -588,10 +588,12 @@ -- try to set a value to all parameters -- The order of evaluation is defined / hiera / default - unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: defValue) -> do + unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: mtype :!: defValue) -> do ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue) case ev of - Right v -> loadVariable k v >> return [] + Right v -> do + forM_ mtype $ \dt -> unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> pretty k <+> "but its value was:" <+> pretty v)) + loadVariable k v >> return [] Left (Max True) -> loadVariable k PUndef >> return [] Left (Max False) -> return [k] curPos .= p diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Lens.hs new/language-puppet-1.3.8.1/Puppet/Lens.hs --- old/language-puppet-1.3.7/Puppet/Lens.hs 2015-12-10 19:50:05.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Lens.hs 2017-06-22 10:16:04.000000000 +0200 @@ -3,7 +3,7 @@ ( -- * Pure resolution prisms _PResolveExpression , _PResolveValue - -- * Prisms for PValues + -- * Prisms for PValues (reexport from "Puppet.Interpreter.Types") , _PHash , _PBoolean , _PString @@ -67,8 +67,6 @@ import Data.Tuple.Strict hiding (uncurry) import Control.Exception (SomeException, toException, fromException) --- Prisms -makePrisms ''PValue --makePrisms ''Statement makePrisms ''Expression @@ -152,6 +150,7 @@ toU (PResourceReference t n) = UResourceReference t (Terminal (UString n)) toU (PArray r) = UArray (fmap (Terminal . toU) r) toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h) + toU (PType _) = error "TODO, _PResolveValue PType undefined" -- | Extracts the statements from 'ClassDeclaration', 'DefineDeclaration', -- 'Node' and the spurious statements of 'TopContainer'. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Parser/PrettyPrinter.hs new/language-puppet-1.3.8.1/Puppet/Parser/PrettyPrinter.hs --- old/language-puppet-1.3.7/Puppet/Parser/PrettyPrinter.hs 2015-12-10 19:50:05.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Parser/PrettyPrinter.hs 2017-06-22 13:23:58.000000000 +0200 @@ -34,6 +34,32 @@ escapeChar x = T.singleton x {-# INLINE stringEscape #-} +instance Pretty DataType where + pretty t = case t of + DTType -> "Type" + DTString ma mb -> bounded "String" ma mb + DTInteger ma mb -> bounded "Integer" ma mb + DTFloat ma mb -> bounded "Float" ma mb + DTBoolean -> "Boolean" + DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx) + DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx) + DTUndef -> "Undef" + DTScalar -> "Scalar" + DTData -> "Data" + DTOptional o -> "Optional" <> brackets (pretty o) + NotUndef -> "NotUndef" + DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs) + DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs) + DTEnum tx -> "Enum" <> list (foldMap (pure . text . T.unpack) tx) + DTAny -> "Any" + DTCollection -> "Collection" + where + bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc + bounded s ma mb = s <> case (ma, mb) of + (Just a, Nothing) -> list [pretty a] + (Just a, Just b) -> list [pretty a, pretty b] + _ -> mempty + instance Pretty Expression where pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b) pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b) @@ -66,6 +92,7 @@ pretty LambReduce = bold $ red $ text "reduce" pretty LambFilter = bold $ red $ text "filter" pretty LambSlice = bold $ red $ text "slice" + pretty LambLookup = bold $ red $ text "lookup" instance Pretty LambdaParameters where pretty b = magenta (char '|') <+> vars <+> magenta (char '|') @@ -96,11 +123,14 @@ pretty (UResourceReference t n) = capitalize t <> brackets (pretty n) pretty (UArray v) = list (map pretty (V.toList v)) pretty (UHash g) = hashComma g - pretty (URegexp (CompRegex r _)) = char '/' <> text (T.unpack r) <> char '/' + pretty (URegexp r) = pretty r pretty (UVariableReference v) = dullblue (char '$' <> text (T.unpack v)) pretty (UFunctionCall f args) = showFunc f args pretty (UHOLambdaCall c) = pretty c +instance Pretty CompRegex where + pretty (CompRegex r _) = char '/' <> text (T.unpack r) <> char '/' + instance Pretty HOLambdaCall where pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}' where @@ -112,6 +142,7 @@ S.Nothing -> mempty instance Pretty SelectorCase where pretty SelectorDefault = dullmagenta (text "default") + pretty (SelectorType t) = pretty t pretty (SelectorValue v) = pretty v instance Pretty LinkType where @@ -138,15 +169,15 @@ maxlen = maximum (fmap (\(AttributeDecl k _ _) -> T.length k) vx) prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v -showArgs :: V.Vector (Pair T.Text (S.Maybe Expression)) -> Doc +showArgs :: V.Vector (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression)) -> Doc showArgs vec = tupled (map ra lst) where lst = V.toList vec - maxlen = maximum (map (T.length . S.fst) lst) - ra (argname :!: rval) = dullblue (char '$' <> fill maxlen (text (T.unpack argname))) - <> case rval of - S.Nothing -> empty - S.Just v -> empty <+> char '=' <+> pretty v + maxlen = maximum (map (T.length . S.fst . S.fst) lst) + ra (argname :!: mtype :!: rval) + = dullblue (char '$' <> foldMap (\t -> pretty t <+> empty) mtype + <> fill maxlen (text (T.unpack argname))) + <> foldMap (\v -> empty <+> char '=' <+> pretty v) rval showFunc :: T.Text -> V.Vector Expression -> Doc showFunc funcname args = bold (red (text (T.unpack funcname))) <> parensList args diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Parser/Types.hs new/language-puppet-1.3.8.1/Puppet/Parser/Types.hs --- old/language-puppet-1.3.7/Puppet/Parser/Types.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Parser/Types.hs 2017-07-21 11:58:54.000000000 +0200 @@ -30,6 +30,8 @@ Virtuality(..), NodeDesc(..), LinkType(..), + -- ** Datatypes + DataType(..), -- ** Search Expressions SearchExpression(..), -- ** Statements @@ -52,6 +54,7 @@ import Control.Lens import Data.Aeson +import Data.Aeson.TH (deriveToJSON) import Data.Char (toUpper) import Data.Hashable import qualified Data.Maybe.Strict as S @@ -61,6 +64,7 @@ import qualified Data.Text as T import Data.Tuple.Strict import qualified Data.Vector as V +import Data.List.NonEmpty (NonEmpty) import GHC.Exts import GHC.Generics @@ -110,6 +114,7 @@ | LambReduce | LambFilter | LambSlice + | LambLookup deriving (Eq, Show) -- | Lambda block parameters: @@ -147,6 +152,10 @@ show (CompRegex t _) = show t instance Eq CompRegex where (CompRegex a _) == (CompRegex b _) = a == b +instance FromJSON CompRegex where + parseJSON = fail "Can't deserialize a regular expression" +instance ToJSON CompRegex where + toJSON (CompRegex t _) = toJSON t -- | An unresolved value, typically the parser's output. data UnresolvedValue @@ -176,6 +185,7 @@ data SelectorCase = SelectorValue !UnresolvedValue + | SelectorType !DataType | SelectorDefault deriving (Eq, Show) @@ -207,6 +217,29 @@ | Terminal !UnresolvedValue -- ^ Terminal object contains no expression deriving (Eq, Show) +data DataType + = DTType + | DTString (Maybe Int) (Maybe Int) + | DTInteger (Maybe Int) (Maybe Int) + | DTFloat (Maybe Double) (Maybe Double) + | DTBoolean + | DTArray DataType Int (Maybe Int) + | DTHash DataType DataType Int (Maybe Int) + | DTUndef + | DTScalar + | DTData + | DTOptional DataType + | NotUndef + | DTVariant (NonEmpty DataType) + | DTPattern (NonEmpty CompRegex) + | DTEnum (NonEmpty Text) + | DTAny + | DTCollection + -- Tuple (NonEmpty DataType) Integer Integer + -- DTDefault + -- Struct TODO + deriving (Eq, Show) + instance IsList Expression where type Item Expression = Expression fromList = Terminal . fromList @@ -299,8 +332,8 @@ -- (interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ...") data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) -data ClassDecl = ClassDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) -data DefineDecl = DefineDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) +data ClassDecl = ClassDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) +data DefineDecl = DefineDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) -- | A node is a collection of statements + maybe an inherit node data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show) @@ -338,3 +371,5 @@ deriving (Eq, Show) makeClassy ''HOLambdaCall +$(deriveToJSON defaultOptions ''DataType) + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Parser.hs new/language-puppet-1.3.8.1/Puppet/Parser.hs --- old/language-puppet-1.3.7/Puppet/Parser.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Parser.hs 2017-06-22 13:21:05.000000000 +0200 @@ -6,6 +6,7 @@ -- * Parsers , puppetParser , expression + , datatype ) where import Control.Applicative @@ -13,7 +14,10 @@ import Control.Monad import Data.Char import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Maybe.Strict as S +import Data.Maybe (fromMaybe) import Data.Scientific import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -86,16 +90,19 @@ symbolic '?' return $ maybe trm ($ trm) lookups let cas = do - c <- (SelectorDefault <$ symbol "default") -- default case - <|> fmap SelectorValue (fmap UVariableReference variableReference - <|> fmap UBoolean puppetBool - <|> (UUndef <$ symbol "undef") - <|> literalValue - <|> fmap UInterpolable interpolableString - <|> (URegexp <$> termRegexp)) - void $ symbol "=>" - e <- expression - return (c :!: e) + c <- (SelectorDefault <$ symbol "default") -- default case + <|> fmap SelectorType (try datatype) + <|> fmap SelectorValue + ( fmap UVariableReference variableReference + <|> fmap UBoolean puppetBool + <|> (UUndef <$ symbol "undef") + <|> literalValue + <|> fmap UInterpolable interpolableString + <|> (URegexp <$> termRegexp) + ) + void $ symbol "=>" + e <- expression + return (c :!: e) cases <- braces (sepComma1 cas) return (ConditionalValue selectedExpression (V.fromList cases)) @@ -198,17 +205,12 @@ return v rvariable = Terminal . UVariableReference <$> rvariableName simpleIndexing = Lookup <$> rvariable <*> between (symbolic '[') (symbolic ']') expression - interpolableVariableReference = try $ do + interpolableVariableReference = do void (char '$') - lookAhead anyChar >>= \c -> case c of - '{' -> between (symbolic '{') (char '}') ( try simpleIndexing - <|> rvariable - ) - -- This is not as robust as the "qualif" - -- implementation, but considerably shorter. - -- - -- This needs refactoring. - _ -> rvariable + let fenced = try (simpleIndexing <* char '}') + <|> try (rvariable <* char '}') + <|> (expression <* char '}') + (symbolic '{' *> fenced) <|> try rvariable <|> pure (Terminal (UString (T.singleton '$'))) regexp :: Parser T.Text regexp = do @@ -377,15 +379,17 @@ pe <- getPosition return (DefineDecl name params st (p :!: pe)) -puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression))) +puppetClassParameters :: Parser (V.Vector (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression))) puppetClassParameters = V.fromList <$> parens (sepComma var) where toStrictMaybe (Just x) = S.Just x toStrictMaybe Nothing = S.Nothing - var :: Parser (Pair T.Text (S.Maybe Expression)) - var = (:!:) - <$> variableReference - <*> (toStrictMaybe <$> optional (symbolic '=' *> expression)) + var :: Parser (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression)) + var = do + tp <- toStrictMaybe <$> optional datatype + n <- variableReference + df <- toStrictMaybe <$> optional (symbolic '=' *> expression) + return (n :!: tp :!: df) puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList @@ -631,6 +635,67 @@ <|> (pure . MainFunctionDeclaration <$> mainFuncDecl) <?> "Statement" +datatype :: Parser DataType +datatype = dtString + <|> dtInteger + <|> dtFloat + <|> dtNumeric + <|> (DTBoolean <$ reserved "Boolean") + <|> (DTScalar <$ reserved "Scalar") + <|> (DTData <$ reserved "Data") + <|> (DTAny <$ reserved "Any") + <|> (DTCollection <$ reserved "Collection") + <|> dtArray + <|> dtHash + <|> (DTUndef <$ reserved "Undef") + <|> (reserved "Optional" *> (DTOptional <$> brackets datatype)) + <|> (NotUndef <$ reserved "NotUndef") + <|> (reserved "Variant" *> (DTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ','))) + <|> (reserved "Pattern" *> (DTPattern . NE.fromList <$> brackets (termRegexp `sepBy1` symbolic ','))) + <|> (reserved "Enum" *> (DTEnum . NE.fromList <$> brackets ((stringLiteral' <|> bareword) `sepBy1` symbolic ','))) + <?> "DataType" + where + integer = integerOrDouble >>= either (return . fromIntegral) (const (fail "Integer value expected")) + float = either fromIntegral id <$> integerOrDouble + dtArgs str def parseArgs = do + void $ reserved str + fromMaybe def <$> optional (brackets parseArgs) + dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do + lst <- parser `sepBy` symbolic ',' + case lst of + [minlen] -> return $ constructor (Just minlen) Nothing + [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen) + _ -> fail ("Too many arguments to datatype " ++ s) + dtString = dtbounded "String" DTString integer + dtInteger = dtbounded "Integer" DTInteger integer + dtFloat = dtbounded "Float" DTFloat float + dtNumeric = dtbounded "Numeric" (\ma mb -> DTVariant (DTFloat ma mb :| [DTInteger (truncate <$> ma) (truncate <$> mb)])) float + dtArray = do + reserved "Array" + ml <- optional $ brackets $ do + tp <- datatype + rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',') + return (tp, rst) + case ml of + Nothing -> return (DTArray DTData 0 Nothing) + Just (t, Nothing) -> return (DTArray t 0 Nothing) + Just (t, Just [mi]) -> return (DTArray t mi Nothing) + Just (t, Just [mi, mx]) -> return (DTArray t mi (Just mx)) + Just (_, Just _) -> fail "Too many arguments to datatype Array" + dtHash = do + reserved "Hash" + ml <- optional $ brackets $ do + tk <- datatype + symbolic ',' + tv <- datatype + rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',') + return (tk, tv, rst) + case ml of + Nothing -> return (DTHash DTScalar DTData 0 Nothing) + Just (tk, tv, Nothing) -> return (DTHash tk tv 0 Nothing) + Just (tk, tv, Just [mi]) -> return (DTHash tk tv mi Nothing) + Just (tk, tv, Just [mi, mx]) -> return (DTHash tk tv mi (Just mx)) + Just (_, _, Just _) -> fail "Too many arguments to datatype Hash" statementList :: Parser (V.Vector Statement) statementList = (V.fromList . concat) <$> many statement @@ -640,17 +705,18 @@ let toStrict (Just x) = S.Just x toStrict Nothing = S.Nothing HOLambdaCall <$> lambFunc - <*> fmap (toStrict . join) (optional (parens (optional expression))) - <*> lambParams - <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) - <*> fmap toStrict (optional expression) <* symbolic '}' + <*> fmap (toStrict . join) (optional (parens (optional expression))) + <*> lambParams + <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) + <*> fmap toStrict (optional expression) <* symbolic '}' where lambFunc :: Parser LambdaFunc lambFunc = (reserved "each" *> pure LambEach) - <|> (reserved "map" *> pure LambMap ) - <|> (reserved "reduce" *> pure LambReduce) - <|> (reserved "filter" *> pure LambFilter) - <|> (reserved "slice" *> pure LambSlice) + <|> (reserved "map" *> pure LambMap ) + <|> (reserved "reduce" *> pure LambReduce) + <|> (reserved "filter" *> pure LambFilter) + <|> (reserved "slice" *> pure LambSlice) + <|> (reserved "lookup" *> pure LambLookup) lambParams :: Parser LambdaParameters lambParams = between (symbolic '|') (symbolic '|') hp where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/Puppet/Stdlib.hs new/language-puppet-1.3.8.1/Puppet/Stdlib.hs --- old/language-puppet-1.3.7/Puppet/Stdlib.hs 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/Puppet/Stdlib.hs 2017-06-22 10:17:30.000000000 +0200 @@ -23,7 +23,6 @@ import Puppet.Interpreter.Resolve import Puppet.Interpreter.Types import Puppet.Interpreter.Utils -import Puppet.Lens import Puppet.PP -- | Contains the implementation of the StdLib functions. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/PuppetDB/TestDB.hs new/language-puppet-1.3.8.1/PuppetDB/TestDB.hs --- old/language-puppet-1.3.7/PuppetDB/TestDB.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/PuppetDB/TestDB.hs 2017-06-22 10:17:44.000000000 +0200 @@ -28,7 +28,6 @@ import Text.Megaparsec.Pos import Puppet.Interpreter.Types -import Puppet.Lens import Puppet.Parser.Types import Puppet.PP diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/README.adoc new/language-puppet-1.3.8.1/README.adoc --- old/language-puppet-1.3.7/README.adoc 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/README.adoc 2017-06-19 12:43:44.000000000 +0200 @@ -17,11 +17,10 @@ git clone https://github.com/bartavelle/language-puppet.git cd language-puppet # Add ~/.local/bin to $PATH +ln -s stack-8.0.yaml stack.yaml stack install ``` -https://hub.docker.com/r/pierrer/language-puppet/[A docker image] is available. - == Puppetresources The `puppetresources` command is a command line utility that let you interactively compute catalogs on your local computer. @@ -173,8 +172,12 @@ == Unsupported Puppet idioms or features +OS:: + * `OS X` is currently not supported (https://github.com/bartavelle/language-puppet/issues/197[issue #197]) + puppet functions:: * the `require` function is not supported (see https://github.com/bartavelle/language-puppet/issues/17[issue #17]) - * the deprecated `import` function is not supported (see https://github.com/bartavelle/language-puppet/issues/82[issue #82]) + * the deprecated `import` function is not supported + * the deprecated node inheritance feature is not supported custom ruby functions:: diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/language-puppet.cabal new/language-puppet-1.3.8.1/language-puppet.cabal --- old/language-puppet-1.3.7/language-puppet.cabal 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/language-puppet.cabal 2017-07-21 12:03:54.000000000 +0200 @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.3.7 +version: 1.3.8.1 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -15,7 +15,7 @@ build-type: Simple cabal-version: >=1.8 -Tested-With: GHC == 7.10.3, GHC == 8.0.1 +Tested-With: GHC == 7.10.3, GHC == 8.0.2 extra-source-files: CHANGELOG.markdown @@ -175,7 +175,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings - build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl + build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl,hspec-megaparsec other-modules: Function.ShellquoteSpec Function.SprintfSpec Function.SizeSpec @@ -187,6 +187,7 @@ InterpreterSpec Interpreter.CollectorSpec Interpreter.IfSpec + DT.Parser Helpers main-is: Spec.hs diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/progs/PuppetResources.hs new/language-puppet-1.3.8.1/progs/PuppetResources.hs --- old/language-puppet-1.3.7/progs/PuppetResources.hs 2017-01-12 07:15:51.000000000 +0100 +++ new/language-puppet-1.3.8.1/progs/PuppetResources.hs 2017-06-22 12:56:45.000000000 +0200 @@ -371,7 +371,7 @@ -- | Parse mode run Options {_optParse = Just fp, ..} = parseFile fp >>= \case - Left rr -> error ("parse error:" ++ show rr) + Left rr -> error (P.parseErrorPretty rr) Right s -> if _optLoglevel == LOG.DEBUG then mapM_ print s else putDoc $ ppStatements s diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/tests/DT/Parser.hs new/language-puppet-1.3.8.1/tests/DT/Parser.hs --- old/language-puppet-1.3.7/tests/DT/Parser.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/language-puppet-1.3.8.1/tests/DT/Parser.hs 2017-07-21 11:50:10.000000000 +0200 @@ -0,0 +1,19 @@ +module DT.Parser (spec) where + +import qualified Data.Text as T +import Puppet.Parser +import Puppet.Parser.Types +import Test.Hspec +import Test.Hspec.Megaparsec +import Text.Megaparsec (parse) + +spec :: Spec +spec = do + let prs s r = it s $ parse datatype "?" (T.pack s) `shouldParse` r + fl s = it s $ shouldFailOn (parse datatype "?") (T.pack s) + describe "String" $ do + "String" `prs` DTString Nothing Nothing + fl "String[]" + fl "String[4,5,6]" + "String[5]" `prs` DTString (Just 5) Nothing + "String[5,8]" `prs` DTString (Just 5) (Just 8) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/tests/Spec.hs new/language-puppet-1.3.8.1/tests/Spec.hs --- old/language-puppet-1.3.7/tests/Spec.hs 2017-03-14 18:12:16.000000000 +0100 +++ new/language-puppet-1.3.8.1/tests/Spec.hs 2017-06-19 13:28:05.000000000 +0200 @@ -11,12 +11,15 @@ import qualified Function.DeleteAtSpec import qualified Interpreter.IfSpec import qualified Function.SprintfSpec +import qualified DT.Parser main :: IO () main = hspec spec spec :: Spec spec = do + describe "Data types" $ do + describe "Parser" DT.Parser.spec describe "Interpreter" $ do describe "Collector" InterpreterSpec.collectorSpec describe "Class include" InterpreterSpec.classIncludeSpec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/tests/evals.hs new/language-puppet-1.3.8.1/tests/evals.hs --- old/language-puppet-1.3.7/tests/evals.hs 2015-10-29 20:18:03.000000000 +0100 +++ new/language-puppet-1.3.8.1/tests/evals.hs 2017-06-14 10:52:51.000000000 +0200 @@ -21,6 +21,8 @@ , "[1,2,3] << 10 == [1,2,3,10]" , "[1,2,3] << [4,5] == [1,2,3,[4,5]]" , "4 / 2.0 == 2" + , "$architecture == 'amd64'" + , "$facts['architecture'] == 'amd64'" , "$settings::confdir == '/etc/puppet'" , "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'" , "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-puppet-1.3.7/tests/expr.hs new/language-puppet-1.3.8.1/tests/expr.hs --- old/language-puppet-1.3.7/tests/expr.hs 2016-03-14 08:12:49.000000000 +0100 +++ new/language-puppet-1.3.8.1/tests/expr.hs 2017-06-14 10:52:51.000000000 +0200 @@ -23,9 +23,12 @@ (V.fromList [SelectorValue UUndef :!: Terminal (UString "undef") ,SelectorDefault :!: Terminal (UString "default")])) , ("$x", Terminal (UVariableReference "x")) + , ("x($y)", Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y"))))) , ("\"${x}\"", Terminal (UInterpolable (V.fromList [Terminal (UVariableReference "x")]))) , ("\"${x[3]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) 3]))) , ("\"${x[$y]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ]))) + , ("\"${x($y)}\"", Terminal (UInterpolable (V.fromList [ Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))) ]))) + , ("\"${x($y)}$'\"", Terminal (UInterpolable (V.fromList [ Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))),Terminal (UString "$"),Terminal (UString "'")]))) ] main :: IO ()

1 0

commit ghc-language-glsl for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-language-glsl for openSUSE:Factory checked in at 2017-08-31 20:56:59 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-language-glsl (Old) and /work/SRC/openSUSE:Factory/.ghc-language-glsl.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-language-glsl" Thu Aug 31 20:56:59 2017 rev:2 rq:513416 version:0.2.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-language-glsl/ghc-language-glsl.changes 2017-03-16 09:35:33.153579392 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-language-glsl.new/ghc-language-glsl.changes 2017-08-31 20:57:03.330425760 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:18 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.1. + +------------------------------------------------------------------- Old: ---- language-glsl-0.2.0.tar.gz New: ---- language-glsl-0.2.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-language-glsl.spec ++++++ --- /var/tmp/diff_new_pack.zMUMqf/_old 2017-08-31 20:57:04.058323488 +0200 +++ /var/tmp/diff_new_pack.zMUMqf/_new 2017-08-31 20:57:04.062322926 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-language-glsl # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name language-glsl %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.0 +Version: 0.2.1 Release: 0 Summary: GLSL abstract syntax tree, parser, and pretty-printer License: BSD-3-Clause @@ -61,7 +61,7 @@ %install %ghc_lib_install -%ghc_fix_dynamic_rpath glsl-pprint +%ghc_fix_rpath %{pkg_name}-%{version} %check %cabal_test ++++++ language-glsl-0.2.0.tar.gz -> language-glsl-0.2.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-glsl-0.2.0/Language/GLSL/Pretty.hs new/language-glsl-0.2.1/Language/GLSL/Pretty.hs --- old/language-glsl-0.2.0/Language/GLSL/Pretty.hs 2015-05-19 20:05:24.000000000 +0200 +++ new/language-glsl-0.2.1/Language/GLSL/Pretty.hs 2017-07-16 16:29:51.000000000 +0200 @@ -10,10 +10,20 @@ -- helpers (TODO clean) ---------------------------------------------------------------------- +type Assoc = (Rational -> Rational, Rational -> Rational) + +assocLeft, assocRight, assocNone :: Assoc +assocLeft = (id,bump) +assocRight = (bump,id) +assocNone = (bump,bump) + +bump :: Rational -> Rational +bump = (+ 0.5) + prettyBinary :: Pretty a => - PrettyLevel -> Rational -> Rational -> String -> a -> a -> Doc -prettyBinary l p op o e1 e2 = prettyParen (p > op) $ - pPrintPrec l op e1 <+> text o <+> pPrintPrec l op e2 + PrettyLevel -> Rational -> Rational -> Assoc -> String -> a -> a -> Doc +prettyBinary l p op (lf,rf) o e1 e2 = prettyParen (p > op) $ + pPrintPrec l (lf op) e1 <+> text o <+> pPrintPrec l (rf op) e2 option :: Pretty a => Maybe a -> Doc option Nothing = empty @@ -237,40 +247,40 @@ UnaryOneComplement e1 -> prettyParen (p > 15) $ text "~" <> pPrintPrec l 15 e1 -- binary expression - Mul e1 e2 -> prettyBinary l p 14 "*" e1 e2 - Div e1 e2 -> prettyBinary l p 14 "/" e1 e2 - Mod e1 e2 -> prettyBinary l p 14 "%" e1 e2 - Add e1 e2 -> prettyBinary l p 13 "+" e1 e2 - Sub e1 e2 -> prettyBinary l p 13 "-" e1 e2 - LeftShift e1 e2 -> prettyBinary l p 12 "<<" e1 e2 - RightShift e1 e2 -> prettyBinary l p 12 ">>" e1 e2 - Lt e1 e2 -> prettyBinary l p 11 "<" e1 e2 - Gt e1 e2 -> prettyBinary l p 11 ">" e1 e2 - Lte e1 e2 -> prettyBinary l p 11 "<=" e1 e2 - Gte e1 e2 -> prettyBinary l p 11 ">=" e1 e2 - Equ e1 e2 -> prettyBinary l p 10 "==" e1 e2 - Neq e1 e2 -> prettyBinary l p 10 "!=" e1 e2 - BitAnd e1 e2 -> prettyBinary l p 9 "&" e1 e2 - BitXor e1 e2 -> prettyBinary l p 8 "^" e1 e2 - BitOr e1 e2 -> prettyBinary l p 7 "|" e1 e2 - And e1 e2 -> prettyBinary l p 6 "&&" e1 e2 + Mul e1 e2 -> prettyBinary l p 14 assocLeft "*" e1 e2 + Div e1 e2 -> prettyBinary l p 14 assocLeft "/" e1 e2 + Mod e1 e2 -> prettyBinary l p 14 assocLeft "%" e1 e2 + Add e1 e2 -> prettyBinary l p 13 assocLeft "+" e1 e2 + Sub e1 e2 -> prettyBinary l p 13 assocLeft "-" e1 e2 + LeftShift e1 e2 -> prettyBinary l p 12 assocLeft "<<" e1 e2 + RightShift e1 e2 -> prettyBinary l p 12 assocLeft ">>" e1 e2 + Lt e1 e2 -> prettyBinary l p 11 assocLeft "<" e1 e2 + Gt e1 e2 -> prettyBinary l p 11 assocLeft ">" e1 e2 + Lte e1 e2 -> prettyBinary l p 11 assocLeft "<=" e1 e2 + Gte e1 e2 -> prettyBinary l p 11 assocLeft ">=" e1 e2 + Equ e1 e2 -> prettyBinary l p 10 assocLeft "==" e1 e2 + Neq e1 e2 -> prettyBinary l p 10 assocLeft "!=" e1 e2 + BitAnd e1 e2 -> prettyBinary l p 9 assocLeft "&" e1 e2 + BitXor e1 e2 -> prettyBinary l p 8 assocLeft "^" e1 e2 + BitOr e1 e2 -> prettyBinary l p 7 assocLeft "|" e1 e2 + And e1 e2 -> prettyBinary l p 6 assocLeft "&&" e1 e2 -- TODO Xor 5 "^^" - Or e1 e2 -> prettyBinary l p 4 "||" e1 e2 + Or e1 e2 -> prettyBinary l p 4 assocLeft "||" e1 e2 Selection e1 e2 e3 -> prettyParen (p > 3) $ pPrintPrec l 3 e1 <+> char '?' <+> pPrintPrec l 3 e2 <+> char ':' <+> pPrintPrec l 3 e3 -- assignment, the left Expr should be unary expression - Equal e1 e2 -> prettyBinary l p 2 "=" e1 e2 - MulAssign e1 e2 -> prettyBinary l p 2 "*=" e1 e2 - DivAssign e1 e2 -> prettyBinary l p 2 "/=" e1 e2 - ModAssign e1 e2 -> prettyBinary l p 2 "%=" e1 e2 - AddAssign e1 e2 -> prettyBinary l p 2 "+=" e1 e2 - SubAssign e1 e2 -> prettyBinary l p 2 "-=" e1 e2 - LeftAssign e1 e2 -> prettyBinary l p 2 "<<=" e1 e2 - RightAssign e1 e2 -> prettyBinary l p 2 ">>=" e1 e2 - AndAssign e1 e2 -> prettyBinary l p 2 "&=" e1 e2 - XorAssign e1 e2 -> prettyBinary l p 2 "^=" e1 e2 - OrAssign e1 e2 -> prettyBinary l p 2 "|=" e1 e2 + Equal e1 e2 -> prettyBinary l p 2 assocRight "=" e1 e2 + MulAssign e1 e2 -> prettyBinary l p 2 assocRight "*=" e1 e2 + DivAssign e1 e2 -> prettyBinary l p 2 assocRight "/=" e1 e2 + ModAssign e1 e2 -> prettyBinary l p 2 assocRight "%=" e1 e2 + AddAssign e1 e2 -> prettyBinary l p 2 assocRight "+=" e1 e2 + SubAssign e1 e2 -> prettyBinary l p 2 assocRight "-=" e1 e2 + LeftAssign e1 e2 -> prettyBinary l p 2 assocRight "<<=" e1 e2 + RightAssign e1 e2 -> prettyBinary l p 2 assocRight ">>=" e1 e2 + AndAssign e1 e2 -> prettyBinary l p 2 assocRight "&=" e1 e2 + XorAssign e1 e2 -> prettyBinary l p 2 assocRight "^=" e1 e2 + OrAssign e1 e2 -> prettyBinary l p 2 assocRight "|=" e1 e2 -- sequence Sequence e1 e2 -> prettyParen (p > 1) $ pPrintPrec l 1 e1 <> char ',' <+> pPrintPrec l 1 e2 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-glsl-0.2.0/glsl/sample-01.glsl new/language-glsl-0.2.1/glsl/sample-01.glsl --- old/language-glsl-0.2.0/glsl/sample-01.glsl 2015-05-19 20:05:24.000000000 +0200 +++ new/language-glsl-0.2.1/glsl/sample-01.glsl 2017-07-16 16:29:51.000000000 +0200 @@ -124,3 +124,7 @@ { float pattern[100]; float arr[]; }; + +float x = a / b / c; +float x = (a / b) / c; +float x = a / (b / c); diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/language-glsl-0.2.0/language-glsl.cabal new/language-glsl-0.2.1/language-glsl.cabal --- old/language-glsl-0.2.0/language-glsl.cabal 2015-05-19 20:05:24.000000000 +0200 +++ new/language-glsl-0.2.1/language-glsl.cabal 2017-07-16 16:29:51.000000000 +0200 @@ -1,5 +1,5 @@ name: language-glsl -version: 0.2.0 +version: 0.2.1 Cabal-Version: >= 1.8 synopsis: GLSL abstract syntax tree, parser, and pretty-printer description:

1 0

commit ghc-kawhi for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-kawhi for openSUSE:Factory checked in at 2017-08-31 20:56:57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-kawhi (Old) and /work/SRC/openSUSE:Factory/.ghc-kawhi.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-kawhi" Thu Aug 31 20:56:57 2017 rev:3 rq:513413 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-kawhi/ghc-kawhi.changes 2017-06-04 01:54:33.276909504 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-kawhi.new/ghc-kawhi.changes 2017-08-31 20:56:59.546957350 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:44 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- kawhi-0.2.3.tar.gz New: ---- kawhi-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-kawhi.spec ++++++ --- /var/tmp/diff_new_pack.ILLYid/_old 2017-08-31 20:57:00.266856202 +0200 +++ /var/tmp/diff_new_pack.ILLYid/_new 2017-08-31 20:57:00.270855639 +0200 @@ -19,7 +19,7 @@ %global pkg_name kawhi %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.3 +Version: 0.3.0 Release: 0 Summary: Stats.NBA.com library License: MIT ++++++ kawhi-0.2.3.tar.gz -> kawhi-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/kawhi-0.2.3/changelog.md new/kawhi-0.3.0/changelog.md --- old/kawhi-0.2.3/changelog.md 2017-04-24 01:04:24.000000000 +0200 +++ new/kawhi-0.3.0/changelog.md 2017-04-23 00:55:23.000000000 +0200 @@ -1,10 +1,18 @@ # Changelog -## 0.2.3 +## 0.3.0 -Add HTTP `Referer` header to all requests. +### Summary -*This may not be added versions greater than `0.2.*`, because `0.3.0` allows users to independently retrieve data from NBA Stats.* +Added parse-only APIs. + +### API Changes + +- `splitRows` +- `splitRow` +- `splitRowsGeneric` +- `splitRowGeneric` +- `StatsBytes` ## 0.2.2 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/kawhi-0.2.3/kawhi.cabal new/kawhi-0.3.0/kawhi.cabal --- old/kawhi-0.2.3/kawhi.cabal 2017-04-24 01:04:22.000000000 +0200 +++ new/kawhi-0.3.0/kawhi.cabal 2017-04-23 00:54:07.000000000 +0200 @@ -1,5 +1,5 @@ name: kawhi -version: 0.2.3 +version: 0.3.0 synopsis: stats.NBA.com library description: Functions and types for interacting with stats.NBA.com homepage: https://github.com/thunky-monk/kawhi diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/kawhi-0.2.3/library/Data/NBA/Stats.hs new/kawhi-0.3.0/library/Data/NBA/Stats.hs --- old/kawhi-0.2.3/library/Data/NBA/Stats.hs 2017-04-24 01:04:24.000000000 +0200 +++ new/kawhi-0.3.0/library/Data/NBA/Stats.hs 2017-04-23 00:55:48.000000000 +0200 @@ -19,10 +19,14 @@ -- * Simple API getSplitRows, getSplitRow, + splitRows, + splitRow, -- * Generic API getSplitRowsGeneric, getSplitRowGeneric, + splitRowsGeneric, + splitRowGeneric, -- * Types Stats(..), @@ -32,6 +36,7 @@ SplitRow, StatsPath, StatsParameters, + StatsBytes, StatsError(..), ) where @@ -55,6 +60,8 @@ {- | Gets all the rows in a NBA Stats split. + To retrieve the raw data from NBA Stats independently from parsing, use 'splitRows'. + When using this function in a custom monad transformer, it may be desirable to use the generic version of this function, 'getSplitRowsGeneric', instead. -} getSplitRows :: @@ -66,8 +73,24 @@ getSplitRows path splitName params = Except.runExceptT $ getSplitRowsGeneric path splitName params {- | + Parses all the rows of an NBA Stats split from abitrary data. + + Alternatively, 'getSplitRows' retrieves the data from NBA Stats before parsing. + + To use something other than 'Either' for errors, use the generic version of this function, 'splitRowsGeneric', instead. +-} +splitRows :: + Aeson.FromJSON a + => SplitName -- ^ The split name. + -> StatsBytes -- ^ The bytes to decode into split rows. + -> Either StatsError [a] -- ^ The return value: an action resulting in an error or split rows. +splitRows = splitRowsGeneric + +{- | Gets a row in a NBA Stats split. + To retrieve the raw data from NBA Stats independently from parsing, use 'splitRows'. + When using this function in a custom monad transformer, it may be desirable to use the generic version of this function, 'getSplitRowGeneric', instead. -} getSplitRow :: @@ -81,8 +104,26 @@ getSplitRow path splitName key value params = Except.runExceptT $ getSplitRowGeneric path splitName key value params {- | + Parses a row of an NBA Stats split from abitrary data. + + Alternatively, 'getSplitRow' retrieves the data from NBA Stats before parsing. + + To use something other than 'Either' for errors, use the generic version of this function, 'splitRowGeneric', instead. +-} +splitRow :: + (Eq v, Show v, Aeson.FromJSON v, Aeson.FromJSON a) + => SplitName -- ^ The split name. + -> SplitColumn -- ^ The column name key for a the desired row. + -> v -- ^ The expected row value associated with the column name key for a the desired row. + -> StatsBytes -- ^ The bytes to decode into a split row. + -> Either StatsError a -- ^ The return value: an action resulting in an error or a split row. +splitRow = splitRowGeneric + +{- | Gets all the rows in a NBA Stats split. + To retrieve the raw data from NBA Stats independently from parsing, use 'splitRowsGeneric'. + The simpler version of this function, 'getSplitRows', has a concrete 'm'. -} getSplitRowsGeneric :: @@ -91,14 +132,27 @@ -> SplitName -- ^ The split name. -> StatsParameters -- ^ The parameters for customizing the stats. -> m [a] -- ^ The return value: an action resulting in an error or split rows. -getSplitRowsGeneric path splitName params = do - response <- get path params - split <- findSplit response splitName +getSplitRowsGeneric path splitName params = get path params >>= splitRowsGeneric splitName + +{- | + Parses all the rows of an NBA Stats split from abitrary data. + + Alternatively, 'getSplitRowsGeneric' retrieves the data from NBA Stats before parsing. +-} +splitRowsGeneric :: + (Except.MonadError StatsError m, Aeson.FromJSON a) + => SplitName -- ^ The split name. + -> StatsBytes -- ^ The bytes to decode into split rows. + -> m [a] -- ^ The return value: an action resulting in an error or split rows. +splitRowsGeneric splitName bytes = do + split <- findSplit splitName bytes traverse (parseSplitRow $ columns split) $ rows split {- | Gets a row in an NBA Stats split. + To retrieve the raw data from NBA Stats independently from parsing, use 'splitRowGeneric'. + The simpler version of this function, 'getSplitRows', has a concrete 'm'. -} getSplitRowGeneric :: @@ -109,9 +163,22 @@ -> v -- ^ The expected row value associated with the column name key for a the desired row. -> StatsParameters -- ^ The parameters for customizing the stats. -> m a -- ^ The return value: an action resulting in an error or a split row. -getSplitRowGeneric path splitName key value params = do - response <- get path params - split <- findSplit response splitName +getSplitRowGeneric path splitName key value params = get path params >>= splitRowGeneric splitName key value + +{- | + Parses a row of an NBA Stats split from abitrary data. + + Alternatively, 'getSplitRowGeneric' retrieves the data from NBA Stats before parsing. +-} +splitRowGeneric :: + (Except.MonadError StatsError m, Eq v, Show v, Aeson.FromJSON v, Aeson.FromJSON a) + => SplitName -- ^ The split name. + -> SplitColumn -- ^ The column name key for a the desired row. + -> v -- ^ The expected row value associated with the column name key for a the desired row. + -> StatsBytes -- ^ The bytes to decode into a split row. + -> m a -- ^ The return value: an action resulting in an error or a split row. +splitRowGeneric splitName key value bytes = do + split <- findSplit splitName bytes keyIndex <- maybe (Except.throwError $ SplitColumnNameNotFound $ Text.unpack key) return @@ -196,6 +263,9 @@ -- | A collection of parameters that customize NBA Stats resources. type StatsParameters = [(SBS.ByteString, Maybe SBS.ByteString)] +-- | Bytes representing an NBA Stats resource. +type StatsBytes = LBS.ByteString + {- | An error which may be generated by this library. -} @@ -235,12 +305,12 @@ Aeson.Success split -> return split else Except.throwError $ SplitRowCardinalityInconsistent $ show row -findSplit :: (Except.MonadError StatsError m) => HTTP.Response LBS.ByteString -> SplitName -> m Split -findSplit response splitName = do +findSplit :: (Except.MonadError StatsError m) => SplitName -> StatsBytes -> m Split +findSplit splitName bytes = do stats <- either (Except.throwError . StatsResponseDecodeFailure) return - (Aeson.eitherDecode . HTTP.responseBody $ response) + (Aeson.eitherDecode bytes) maybe (Except.throwError $ SplitNameNotFound $ Text.unpack splitName) return @@ -248,13 +318,15 @@ -get :: (MonadHttp.MonadHttp m, Catch.MonadThrow m) => StatsPath -> StatsParameters -> m (HTTP.Response LBS.ByteString) -get path params = - modifyRequest <$> HTTP.parseRequest (Char8.unpack $ "http://stats.nba.com/stats/" <> path) - >>= MonadHttp.performRequest +get :: (MonadHttp.MonadHttp m, Catch.MonadThrow m) => StatsPath -> StatsParameters -> m StatsBytes +get path params = HTTP.responseBody <$> getRequest where + getRequest = + modifyRequest + <$> HTTP.parseRequest (Char8.unpack $ "http://stats.nba.com/stats/" <> path) + >>= MonadHttp.performRequest modifyRequest = - HTTP.setRequestHeaders [("Accept-Language","en-us"), ("Accept", "application/json"), ("Referer", "stats.nba.com")] + HTTP.setRequestHeaders [("Accept-Language","en-us"), ("Accept", "application/json")] . HTTP.setQueryString params {- $use

1 0

commit ghc-katip-elasticsearch for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-katip-elasticsearch for openSUSE:Factory checked in at 2017-08-31 20:56:55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-katip-elasticsearch (Old) and /work/SRC/openSUSE:Factory/.ghc-katip-elasticsearch.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-katip-elasticsearch" Thu Aug 31 20:56:55 2017 rev:3 rq:513412 version:0.4.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-katip-elasticsearch/ghc-katip-elasticsearch.changes 2017-07-11 08:26:41.248321059 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-katip-elasticsearch.new/ghc-katip-elasticsearch.changes 2017-08-31 20:56:55.615509731 +0200 @@ -1,0 +2,5 @@ +Fri Jul 28 10:09:18 UTC 2017 - psimons(a)suse.com + +- Update to version 0.4.0.0. + +------------------------------------------------------------------- Old: ---- katip-elasticsearch-0.3.1.0.tar.gz New: ---- katip-elasticsearch-0.4.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-katip-elasticsearch.spec ++++++ --- /var/tmp/diff_new_pack.nRhBdQ/_old 2017-08-31 20:56:56.203427126 +0200 +++ /var/tmp/diff_new_pack.nRhBdQ/_new 2017-08-31 20:56:56.203427126 +0200 @@ -19,7 +19,7 @@ %global pkg_name katip-elasticsearch %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3.1.0 +Version: 0.4.0.0 Release: 0 Summary: ElasticSearch scribe for the Katip logging framework License: BSD-3-Clause @@ -30,6 +30,7 @@ BuildRequires: ghc-aeson-devel BuildRequires: ghc-async-devel BuildRequires: ghc-bloodhound-devel +BuildRequires: ghc-bytestring-devel BuildRequires: ghc-enclosed-exceptions-devel BuildRequires: ghc-exceptions-devel BuildRequires: ghc-http-client-devel @@ -51,6 +52,7 @@ BuildRequires: ghc-lens-aeson-devel BuildRequires: ghc-lens-devel BuildRequires: ghc-quickcheck-instances-devel +BuildRequires: ghc-tagged-devel BuildRequires: ghc-tasty-devel BuildRequires: ghc-tasty-hunit-devel BuildRequires: ghc-tasty-quickcheck-devel @@ -96,6 +98,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) -%doc README.md changelog.md +%doc README.md changelog.md examples %changelog ++++++ katip-elasticsearch-0.3.1.0.tar.gz -> katip-elasticsearch-0.4.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/bench/Main.hs new/katip-elasticsearch-0.4.0.0/bench/Main.hs --- old/katip-elasticsearch-0.3.1.0/bench/Main.hs 2017-06-27 00:42:06.000000000 +0200 +++ new/katip-elasticsearch-0.4.0.0/bench/Main.hs 2017-07-24 22:50:35.000000000 +0200 @@ -11,14 +11,15 @@ import Control.Monad import Criterion.Main import Data.Aeson -import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict as HM +import Data.Proxy (Proxy (..)) import Data.RNG -import qualified Data.Text as T -import Database.Bloodhound.Types +import qualified Data.Text as T +import Database.V1.Bloodhound.Types import Numeric ------------------------------------------------------------------------------- import Katip.Scribes.ElasticSearch -import Katip.Scribes.ElasticSearch.Annotations +import Katip.Scribes.ElasticSearch.Internal (ESV1) ------------------------------------------------------------------------------- main :: IO () @@ -34,7 +35,7 @@ mkDocIdBenchmark :: RNG -> Benchmark mkDocIdBenchmark rng = bgroup "mkDocId" [ - bench "mkDocId (randomIO)" $ nfIO mkDocId + bench "mkDocId (randomIO)" $ nfIO (mkDocId (Proxy :: Proxy ESV1)) , bench "mkDocId' (shared )" $ nfIO $ mkDocId' rng ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/changelog.md new/katip-elasticsearch-0.4.0.0/changelog.md --- old/katip-elasticsearch-0.3.1.0/changelog.md 2017-06-27 00:42:06.000000000 +0200 +++ new/katip-elasticsearch-0.4.0.0/changelog.md 2017-07-24 22:50:35.000000000 +0200 @@ -1,3 +1,8 @@ +0.4.0.0 +======= +* Update to bloodhound >= 0.13.0.0. This version adds support for both ElasticSearch versions 1 and 5. Previously, we implicitly supported one and maybe would work on 5. The types in `EsScribeCfg` had to change to be able to specify which version was being targeted. +* Improved documentation. + 0.3.1.0 ======= * Widen dependency on katip diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/examples/example.hs new/katip-elasticsearch-0.4.0.0/examples/example.hs --- old/katip-elasticsearch-0.3.1.0/examples/example.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/katip-elasticsearch-0.4.0.0/examples/example.hs 2017-07-24 22:50:35.000000000 +0200 @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Control.Exception +import Database.V5.Bloodhound +import Network.HTTP.Client +------------------------------------------------------------------------------- +import Katip +import Katip.Scribes.ElasticSearch +------------------------------------------------------------------------------- + + +main :: IO () +main = do + mgr <- newManager defaultManagerSettings + let bhe = mkBHEnv (Server "localhost") mgr + esScribe <- mkEsScribe + -- Reasonable for production + defaultEsScribeCfgV5 + -- Reasonable for single-node in development + -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound 1) (ReplicaCount 0)} + bhe + (IndexName "all-indices-prefixed-with") + (MappingName "application-logs") + DebugS + V3 + let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<< initLogEnv "MyApp" "production" + bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do + logMsg "ns" InfoS "This goes to elasticsearch" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/katip-elasticsearch.cabal new/katip-elasticsearch-0.4.0.0/katip-elasticsearch.cabal --- old/katip-elasticsearch-0.3.1.0/katip-elasticsearch.cabal 2017-06-27 00:42:06.000000000 +0200 +++ new/katip-elasticsearch-0.4.0.0/katip-elasticsearch.cabal 2017-07-24 22:50:35.000000000 +0200 @@ -1,7 +1,7 @@ name: katip-elasticsearch synopsis: ElasticSearch scribe for the Katip logging framework. description: See README.md for more details. -version: 0.3.1.0 +version: 0.4.0.0 license: BSD3 license-file: LICENSE author: Ozgun Ataman, Michael Xavier @@ -14,6 +14,7 @@ README.md changelog.md bench/Main.hs + examples/example.hs test/Main.hs tested-with: GHC == 7.8.4, GHC== 7.10.3 @@ -25,10 +26,11 @@ exposed-modules: Katip.Scribes.ElasticSearch Katip.Scribes.ElasticSearch.Annotations + Katip.Scribes.ElasticSearch.Internal build-depends: base >=4.6 && <5 - , katip >= 0.2.0.0 && < 0.5 - , bloodhound >= 0.11.0.0 && < 0.13 + , katip >= 0.2.0.0 && < 0.6 + , bloodhound >= 0.13.0.0 && < 0.15 , uuid >= 1.3.12 && < 1.4 , aeson >=0.6 && <1.2 , stm >= 2.4.3 && < 2.5 @@ -44,6 +46,7 @@ , transformers >= 0.2 && < 0.6 , http-types >= 0.8 && < 0.10 , time >= 1 && < 1.7 + , bytestring hs-source-dirs: src default-language: Haskell2010 hs-source-dirs: src @@ -96,6 +99,8 @@ , scientific , time , stm + , bytestring + , tagged if flag(lib-Werror) ghc-options: -Wall -Werror diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch/Internal.hs new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch/Internal.hs --- old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch/Internal.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch/Internal.hs 2017-07-24 22:50:35.000000000 +0200 @@ -0,0 +1,520 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | This is an internal module. No guarantees are made in this module +-- about API stability. +module Katip.Scribes.ElasticSearch.Internal where + + +------------------------------------------------------------------------------- +import Control.Applicative as A +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM.TBMQueue +import Control.Exception.Base +import Control.Exception.Enclosed +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.STM +import Control.Retry (RetryPolicy, + exponentialBackoff, + limitRetries, + recovering) +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Typeable as Typeable +import Data.UUID +import qualified Data.UUID.V4 as UUID4 +import qualified Database.V1.Bloodhound as V1 +import qualified Database.V5.Bloodhound as V5 +import Network.HTTP.Client +import Network.HTTP.Types.Status +import Text.Printf (printf) +------------------------------------------------------------------------------- +import Katip.Core +import Katip.Scribes.ElasticSearch.Annotations +------------------------------------------------------------------------------- + + +-- | EsScribeCfg now carries a type variable for the version of +-- ElasticSearch it targets, either 'ESV1' or 'ESV5'. You can use +-- 'defaultEsScribeCfgV1' and 'defaultESScribeCfgV5' for a good +-- starting point depending on the ES version you have. +data EsScribeCfg v = EsScribeCfg { + essRetryPolicy :: RetryPolicy + -- ^ Retry policy when there are errors sending logs to the server + , essQueueSize :: EsQueueSize + -- ^ Maximum size of the bounded log queue + , essPoolSize :: EsPoolSize + -- ^ Worker pool size limit for sending data to the + , essAnnotateTypes :: Bool + -- ^ Different payload items coexist in the "data" attribute in + -- ES. It is possible for different payloads to have different + -- types for the same key, e.g. an "id" key that is sometimes a + -- number and sometimes a string. If you're having ES do dynamic + -- mapping, the first log item will set the type and any that + -- don't conform will be *discarded*. If you set this to True, + -- keys will recursively be appended with their ES core + -- type. e.g. "id" would become "id::l" and "id::s" + -- automatically, so they won't conflict. When this library + -- exposes a querying API, we will try to make deserialization and + -- querying transparently remove the type annotations if this is + -- enabled. + , essIndexSettings :: IndexSettings v + -- ^ This will be the IndexSettings type from the appropriate + -- bloodhound module, either @Database.V1.Bloodhound@ or + -- @Database.V5.Bloodhound@ + , essIndexSharding :: IndexShardingPolicy + } deriving (Typeable) + + +-- | Reasonable defaults for a config: +-- +-- * defaultManagerSettings +-- +-- * exponential backoff with 25ms base delay up to 5 retries +-- +-- * Queue size of 1000 +-- +-- * Pool size of 2 +-- +-- * Annotate types set to False +-- +-- * DailyIndexSharding +defaultEsScribeCfg' :: ESVersion v => proxy v -> EsScribeCfg v +defaultEsScribeCfg' prx = EsScribeCfg { + essRetryPolicy = exponentialBackoff 25 <> limitRetries 5 + , essQueueSize = EsQueueSize 1000 + , essPoolSize = EsPoolSize 2 + , essAnnotateTypes = False + , essIndexSettings = defaultIndexSettings prx + , essIndexSharding = DailyIndexSharding + } + + +------------------------------------------------------------------------------- +-- | Alias of 'defaultEsScribeCfgV1' to minimize API +-- breakage. Previous versions of katip-elasticsearch only supported +-- ES version 1. +defaultEsScribeCfg :: EsScribeCfg ESV1 +defaultEsScribeCfg = defaultEsScribeCfgV1 + + +------------------------------------------------------------------------------- +-- | EsScribeCfg that will use ElasticSearch V1 +defaultEsScribeCfgV1 :: EsScribeCfg ESV1 +defaultEsScribeCfgV1 = defaultEsScribeCfg' (Typeable.Proxy :: Typeable.Proxy ESV1) + + +------------------------------------------------------------------------------- +-- | EsScribeCfg that will use ElasticSearch V5 +defaultEsScribeCfgV5 :: EsScribeCfg ESV5 +defaultEsScribeCfgV5 = defaultEsScribeCfg' (Typeable.Proxy :: Typeable.Proxy ESV5) + + +------------------------------------------------------------------------------- +-- | How should katip store your log data? +-- +-- * NoIndexSharding will store all logs in one index name. This is +-- the simplest option but is not advised in production. In practice, +-- the index will grow very large and will get slower to +-- search. Deleting records based on some sort of retention period is +-- also extremely slow. +-- +-- * MonthlyIndexSharding, DailyIndexSharding, HourlyIndexSharding, +-- EveryMinuteIndexSharding will generate indexes based on the time of +-- the log. Index name is treated as a prefix. So if your index name +-- is @foo@ and DailySharding is used, logs will be stored in +-- @foo-2016-2-25@, @foo-2016-2-26@ and so on. Index templating will +-- be used to set up mappings automatically. Deletes based on date are +-- very fast and queries can be restricted to date ranges for better +-- performance. Queries against all dates should use @foo-*@ as an +-- index name. Note that index aliasing's glob feature is not suitable +-- for these date ranges as it matches index names as they are +-- declared, so new dates will be excluded. DailyIndexSharding is a +-- reasonable choice. Changing index sharding strategies is not +-- advisable. +-- +-- * CustomSharding: supply your own function that decomposes an item +-- into its index name hierarchy which will be appended to the index +-- name. So for instance if your function return ["arbitrary", +-- "prefix"], the index will be @foo-arbitrary-prefix@ and the index +-- template will be set to match @foo-*@. In general, you want to use +-- segments of increasing granularity (like year, month, day for +-- dates). This makes it easier to address groups of indexes +-- (e.g. @foo-2016-*@). +data IndexShardingPolicy = NoIndexSharding + | MonthlyIndexSharding + | WeeklyIndexSharding + -- ^ A special case of daily which shards to sunday + | DailyIndexSharding + | HourlyIndexSharding + | EveryMinuteIndexSharding + | CustomIndexSharding (forall a. Item a -> [IndexNameSegment]) + + +instance Show IndexShardingPolicy where + show NoIndexSharding = "NoIndexSharding" + show MonthlyIndexSharding = "MonthlyIndexSharding" + show WeeklyIndexSharding = "WeeklyIndexSharding" + show DailyIndexSharding = "DailyIndexSharding" + show HourlyIndexSharding = "HourlyIndexSharding" + show EveryMinuteIndexSharding = "EveryMinuteIndexSharding" + show (CustomIndexSharding _) = "CustomIndexSharding λ" + + +------------------------------------------------------------------------------- +newtype IndexNameSegment = IndexNameSegment { + indexNameSegment :: Text + } deriving (Show, Eq, Ord) + + +------------------------------------------------------------------------------- +shardPolicySegs :: IndexShardingPolicy -> Item a -> [IndexNameSegment] +shardPolicySegs NoIndexSharding _ = [] +shardPolicySegs MonthlyIndexSharding Item {..} = [sis y, sis m] + where + (y, m, _) = toGregorian (utctDay _itemTime) +shardPolicySegs WeeklyIndexSharding Item {..} = [sis y, sis m, sis d] + where + (y, m, d) = toGregorian (roundToSunday (utctDay _itemTime)) +shardPolicySegs DailyIndexSharding Item {..} = [sis y, sis m, sis d] + where + (y, m, d) = toGregorian (utctDay _itemTime) +shardPolicySegs HourlyIndexSharding Item {..} = [sis y, sis m, sis d, sis h] + where + (y, m, d) = toGregorian (utctDay _itemTime) + (h, _) = splitTime (utctDayTime _itemTime) +shardPolicySegs EveryMinuteIndexSharding Item {..} = [sis y, sis m, sis d, sis h, sis mn] + where + (y, m, d) = toGregorian (utctDay _itemTime) + (h, mn) = splitTime (utctDayTime _itemTime) +shardPolicySegs (CustomIndexSharding f) i = f i + + +------------------------------------------------------------------------------- +-- | If the given day is sunday, returns the input, otherwise returns +-- the previous sunday +roundToSunday :: Day -> Day +roundToSunday d + | dow == 7 = d + | w > 1 = fromWeekDate y (w - 1) 7 + | otherwise = fromWeekDate (y - 1) 53 7 + where + (y, w, dow) = toWeekDate d + + +------------------------------------------------------------------------------- +chooseIxn :: ESVersion v => proxy v -> IndexName v -> IndexShardingPolicy -> Item a -> IndexName v +chooseIxn prx ixn p i = + toIndexName prx (T.intercalate "-" ((fromIndexName prx ixn):segs)) + where + segs = indexNameSegment A.<$> shardPolicySegs p i + + +------------------------------------------------------------------------------- +sis :: Integral a => a -> IndexNameSegment +sis = IndexNameSegment . T.pack . fmt + where + fmt = printf "%02d" . toInteger + + +------------------------------------------------------------------------------- +splitTime :: DiffTime -> (Int, Int) +splitTime t = asMins `divMod` 60 + where + asMins = floor t `div` 60 + + +------------------------------------------------------------------------------- +data EsScribeSetupError = CouldNotCreateIndex !(Response ByteString) + | CouldNotCreateMapping !(Response ByteString) deriving (Typeable, Show) + + +instance Exception EsScribeSetupError + + +------------------------------------------------------------------------------- +-- | The Any field tagged with a @v@ corresponds to the type of the +-- same name in the corresponding @bloodhound@ module. For instance, +-- if you are configuring for ElasticSearch version 1, import +-- @Database.V1.Bloodhound@ and @BHEnv v@ will refer to @BHEnv@ from +-- that module, @IndexName v@ will repsond to @IndexName@ from that +-- module, etc. +mkEsScribe + :: forall v. ( ESVersion v + , MonadIO (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => EsScribeCfg v + -> BHEnv v + -> IndexName v + -- ^ Treated as a prefix if index sharding is enabled + -> MappingName v + -> Severity + -> Verbosity + -> IO Scribe +mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do + q <- newTBMQueueIO $ unEsQueueSize essQueueSize + endSig <- newEmptyMVar + + runBH prx env $ do + chk <- indexExists prx ix + -- note that this doesn't update settings. That's not available + -- through the Bloodhound API yet + unless chk $ void $ do + r1 <- createIndex prx essIndexSettings ix + unless (statusIsSuccessful (responseStatus r1)) $ + liftIO $ throwIO (CouldNotCreateIndex r1) + r2 <- if shardingEnabled + then putTemplate prx tpl tplName + else putMapping prx ix mapping base + unless (statusIsSuccessful (responseStatus r2)) $ + liftIO $ throwIO (CouldNotCreateMapping r2) + + workers <- replicateM (unEsPoolSize essPoolSize) $ async $ + startWorker cfg env mapping q + + _ <- async $ do + takeMVar endSig + atomically $ closeTBMQueue q + mapM_ waitCatch workers + putMVar endSig () + + let finalizer = putMVar endSig () >> takeMVar endSig + return (Scribe (logger q) finalizer) + where + logger :: forall a. LogItem a => TBMQueue (IndexName v, Value) -> Item a -> IO () + logger q i = when (_itemSeverity i >= sev) $ + void $ atomically $ tryWriteTBMQueue q (chooseIxn prx ix essIndexSharding i, itemJson' i) + prx :: Typeable.Proxy v + prx = Typeable.Proxy + tplName = toTemplateName prx ixn + shardingEnabled = case essIndexSharding of + NoIndexSharding -> False + _ -> True + tpl = toIndexTemplate prx (toTemplatePattern prx (ixn <> "-*")) (Just essIndexSettings) [toJSON base] + base = baseMapping prx mapping + ixn = fromIndexName prx ix + itemJson' :: LogItem a => Item a -> Value + itemJson' i + | essAnnotateTypes = itemJson verb (TypeAnnotated <$> i) + | otherwise = itemJson verb i + + +------------------------------------------------------------------------------- +baseMapping :: ESVersion v => proxy v -> MappingName v -> Value +baseMapping prx mn = + object [ fromMappingName prx mn .= object ["properties" .= object prs] ] + where prs = [ str "thread" + , str "sev" + , str "pid" + , str "ns" + , str "msg" + , "loc" .= locType + , str "host" + , str "env" + , "at" .= dateType + , str "app" + ] + str k = k .= object ["type" .= String "string"] + locType = object ["properties" .= object locPairs] + locPairs = [ str "loc_pkg" + , str "loc_mod" + , str "loc_ln" + , str "loc_fn" + , str "loc_col" + ] + dateType = object [ "format" .= esDateFormat + , "type" .= String "date" + ] + + +------------------------------------------------------------------------------- +-- | Handle both old-style aeson and picosecond-level precision +esDateFormat :: Text +esDateFormat = "yyyy-MM-dd'T'HH:mm:ssZ||yyyy-MM-dd'T'HH:mm:ss.SSSZ||yyyy-MM-dd'T'HH:mm:ss.SSSSSSSSSSSSZ" + + +------------------------------------------------------------------------------- +mkDocId :: ESVersion v => proxy v -> IO (DocId v) +mkDocId prx = (toDocId prx . T.decodeUtf8 . toASCIIBytes) `fmap` UUID4.nextRandom + + +------------------------------------------------------------------------------- +newtype EsQueueSize = EsQueueSize { + unEsQueueSize :: Int + } deriving (Show, Eq, Ord) + + +instance Bounded EsQueueSize where + minBound = EsQueueSize 1 + maxBound = EsQueueSize maxBound + + +mkEsQueueSize :: Int -> Maybe EsQueueSize +mkEsQueueSize = mkNonZero EsQueueSize + + +------------------------------------------------------------------------------- +newtype EsPoolSize = EsPoolSize { + unEsPoolSize :: Int + } deriving (Show, Eq, Ord) + + +instance Bounded EsPoolSize where + minBound = EsPoolSize 1 + maxBound = EsPoolSize maxBound + + +mkEsPoolSize :: Int -> Maybe EsPoolSize +mkEsPoolSize = mkNonZero EsPoolSize + + +------------------------------------------------------------------------------- +mkNonZero :: (Int -> a) -> Int -> Maybe a +mkNonZero ctor n + | n > 0 = Just $ ctor n + | otherwise = Nothing + + +------------------------------------------------------------------------------- +startWorker + :: forall v. (ESVersion v) + => EsScribeCfg v + -> BHEnv v + -> MappingName v + -> TBMQueue (IndexName v, Value) + -> IO () +startWorker EsScribeCfg {..} env mapping q = go + where + go = do + popped <- atomically $ readTBMQueue q + case popped of + Just (ixn, v) -> do + sendLog ixn v `catchAny` eat + go + Nothing -> return () + prx :: Typeable.Proxy v + prx = Typeable.Proxy + sendLog :: IndexName v -> Value -> IO () + sendLog ixn v = void $ recovering essRetryPolicy [handler] $ const $ do + did <- mkDocId prx + res <- runBH prx env $ indexDocument prx ixn mapping (defaultIndexDocumentSettings prx) v did + return res + eat _ = return () + handler _ = Handler $ \e -> + case fromException e of + Just (_ :: AsyncException) -> return False + _ -> return True + + +------------------------------------------------------------------------------- +-- We are spanning multiple versions of ES which use completely +-- separate types and APIs, but the subset we use is the same for both +-- versions. This will be kept up to date with bloodhound's supported +-- versions and should be minimally visible to the end user. +class ESVersion v where + -- Types + type BHEnv v + type IndexSettings v + defaultIndexSettings :: proxy v -> IndexSettings v + type IndexName v + toIndexName :: proxy v -> Text -> IndexName v + fromIndexName :: proxy v -> IndexName v -> Text + type MappingName v + fromMappingName :: proxy v -> MappingName v -> Text + type DocId v + toDocId :: proxy v -> Text -> DocId v + type BH v :: (* -> *) -> * -> * + runBH :: proxy v -> BHEnv v -> BH v m a -> m a + type TemplateName v + toTemplateName :: proxy v -> Text -> TemplateName v + type TemplatePattern v + toTemplatePattern :: proxy v -> Text -> TemplatePattern v + type IndexTemplate v + toIndexTemplate :: proxy v -> TemplatePattern v -> Maybe (IndexSettings v) -> [Value] -> IndexTemplate v + type IndexDocumentSettings v + defaultIndexDocumentSettings :: proxy v -> IndexDocumentSettings v + + -- Operations + -- We're deciding on IO here, but it isn't necessary + indexExists :: proxy v -> IndexName v -> BH v IO Bool + indexDocument :: ToJSON doc => proxy v -> IndexName v -> MappingName v -> IndexDocumentSettings v -> doc -> DocId v -> BH v IO (Response ByteString) + createIndex :: proxy v -> IndexSettings v -> IndexName v -> BH v IO (Response ByteString) + putTemplate :: proxy v -> IndexTemplate v -> TemplateName v -> BH v IO (Response ByteString) + putMapping :: (ToJSON a) => proxy v -> IndexName v -> MappingName v -> a -> BH v IO (Response ByteString) + + +data ESV1 = ESV1 + +instance ESVersion ESV1 where + type BHEnv ESV1 = V1.BHEnv + type IndexSettings ESV1 = V1.IndexSettings + defaultIndexSettings _ = V1.defaultIndexSettings + type IndexName ESV1 = V1.IndexName + toIndexName _ = V1.IndexName + fromIndexName _ (V1.IndexName x) = x + type MappingName ESV1 = V1.MappingName + fromMappingName _ (V1.MappingName x) = x + type DocId ESV1 = V1.DocId + toDocId _ = V1.DocId + type BH ESV1 = V1.BH + runBH _ = V1.runBH + type TemplateName ESV1 = V1.TemplateName + toTemplateName _ = V1.TemplateName + type TemplatePattern ESV1 = V1.TemplatePattern + toTemplatePattern _ = V1.TemplatePattern + type IndexTemplate ESV1 = V1.IndexTemplate + toIndexTemplate _ = V1.IndexTemplate + type IndexDocumentSettings ESV1 = V1.IndexDocumentSettings + defaultIndexDocumentSettings _ = V1.defaultIndexDocumentSettings + indexExists _ = V1.indexExists + indexDocument _ = V1.indexDocument + createIndex _ = V1.createIndex + putTemplate _ = V1.putTemplate + putMapping _ = V1.putMapping + + +data ESV5 = ESV5 + +instance ESVersion ESV5 where + type BHEnv ESV5 = V5.BHEnv + type IndexSettings ESV5 = V5.IndexSettings + defaultIndexSettings _ = V5.defaultIndexSettings + type IndexName ESV5 = V5.IndexName + toIndexName _ = V5.IndexName + fromIndexName _ (V5.IndexName x) = x + type MappingName ESV5 = V5.MappingName + fromMappingName _ (V5.MappingName x) = x + type DocId ESV5 = V5.DocId + toDocId _ = V5.DocId + type BH ESV5 = V5.BH + runBH _ = V5.runBH + type TemplateName ESV5 = V5.TemplateName + toTemplateName _ = V5.TemplateName + type TemplatePattern ESV5 = V5.TemplatePattern + toTemplatePattern _ = V5.TemplatePattern + type IndexTemplate ESV5 = V5.IndexTemplate + toIndexTemplate _ = V5.IndexTemplate + type IndexDocumentSettings ESV5 = V5.IndexDocumentSettings + defaultIndexDocumentSettings _ = V5.defaultIndexDocumentSettings + indexExists _ = V5.indexExists + indexDocument _ = V5.indexDocument + createIndex _ = V5.createIndex + putTemplate _ = V5.putTemplate + putMapping _ = V5.putMapping diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch.hs new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch.hs --- old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch.hs 2017-06-27 00:42:06.000000000 +0200 +++ new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch.hs 2017-07-24 22:50:35.000000000 +0200 @@ -1,14 +1,41 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Includes a scribe that can be used to log structured, JSON log -- messages to ElasticSearch. These logs can be explored easily using -- <https://www.elastic.co/products/kibana kibana> or your tool of --- choice. +-- choice. Supports ElasticSearch servers with version 1.x or 5.x by +-- way of different configs. -- --- == __Important Note on Index Settings__ +-- Example of configuring for ES5: +-- +-- @ +-- +-- import Control.Exception +-- import Database.V5.Bloodhound +-- import Network.HTTP.Client +-- import Katip +-- import Katip.Scribes.ElasticSearch +-- +-- +-- main :: IO () +-- main = do +-- mgr <- newManager defaultManagerSettings +-- let bhe = mkBHEnv (Server "localhost") mgr +-- esScribe <- mkEsScribe +-- -- Reasonable for production +-- defaultEsScribeCfgV5 +-- -- Reasonable for single-node in development +-- -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound 1) (ReplicaCount 0)} +-- bhe +-- (IndexName "all-indices-prefixed-with") +-- (MappingName "application-logs") +-- DebugS +-- V3 +-- let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<< initLogEnv "MyApp" "production" +-- bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do +-- logMsg "ns" InfoS "This goes to elasticsearch" +-- +-- @ +-- +-- __Important Note on Index Settings__ -- -- 'defaultEsScribeCfg' inherits a set of default index settings from -- the @bloodhound@ package. These settings at this time of writing @@ -30,6 +57,9 @@ , mkEsQueueSize , EsPoolSize , mkEsPoolSize + , IndexShardingPolicy(..) + , IndexNameSegment(..) + -- ** EsScribeCfg and fields , EsScribeCfg , essRetryPolicy , essQueueSize @@ -37,375 +67,29 @@ , essAnnotateTypes , essIndexSettings , essIndexSharding - , IndexShardingPolicy(..) - , IndexNameSegment(..) , defaultEsScribeCfg + , defaultEsScribeCfgV1 + , defaultEsScribeCfgV5 + -- ** Version-Proxied APIS + -- $versionproxies + , defaultEsScribeCfg' + , ESV1 + , ESV5 -- * Utilities , mkDocId , module Katip.Scribes.ElasticSearch.Annotations - , roundToSunday ) where ------------------------------------------------------------------------------- -import Control.Applicative as A -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM.TBMQueue -import Control.Exception.Base -import Control.Exception.Enclosed -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.STM -import Control.Retry (RetryPolicy, - exponentialBackoff, - limitRetries, - recovering) -import Data.Aeson -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Typeable -import Data.UUID -import qualified Data.UUID.V4 as UUID4 -import Database.Bloodhound -import Network.HTTP.Client -import Network.HTTP.Types.Status -import Text.Printf (printf) -------------------------------------------------------------------------------- -import Katip.Core import Katip.Scribes.ElasticSearch.Annotations +import Katip.Scribes.ElasticSearch.Internal ------------------------------------------------------------------------------- -data EsScribeCfg = EsScribeCfg { - essRetryPolicy :: RetryPolicy - -- ^ Retry policy when there are errors sending logs to the server - , essQueueSize :: EsQueueSize - -- ^ Maximum size of the bounded log queue - , essPoolSize :: EsPoolSize - -- ^ Worker pool size limit for sending data to the - , essAnnotateTypes :: Bool - -- ^ Different payload items coexist in the "data" attribute in - -- ES. It is possible for different payloads to have different - -- types for the same key, e.g. an "id" key that is sometimes a - -- number and sometimes a string. If you're having ES do dynamic - -- mapping, the first log item will set the type and any that - -- don't conform will be *discarded*. If you set this to True, - -- keys will recursively be appended with their ES core - -- type. e.g. "id" would become "id::l" and "id::s" - -- automatically, so they won't conflict. When this library - -- exposes a querying API, we will try to make deserialization and - -- querying transparently remove the type annotations if this is - -- enabled. - , essIndexSettings :: IndexSettings - , essIndexSharding :: IndexShardingPolicy - } deriving (Typeable) - - --- | Reasonable defaults for a config: --- --- * defaultManagerSettings --- --- * exponential backoff with 25ms base delay up to 5 retries --- --- * Queue size of 1000 --- --- * Pool size of 2 --- --- * Annotate types set to False --- --- * DailyIndexSharding -defaultEsScribeCfg :: EsScribeCfg -defaultEsScribeCfg = EsScribeCfg { - essRetryPolicy = exponentialBackoff 25 <> limitRetries 5 - , essQueueSize = EsQueueSize 1000 - , essPoolSize = EsPoolSize 2 - , essAnnotateTypes = False - , essIndexSettings = defaultIndexSettings - , essIndexSharding = DailyIndexSharding - } - - -------------------------------------------------------------------------------- --- | How should katip store your log data? --- --- * NoIndexSharding will store all logs in one index name. This is --- the simplest option but is not advised in production. In practice, --- the index will grow very large and will get slower to --- search. Deleting records based on some sort of retention period is --- also extremely slow. --- --- * MonthlyIndexSharding, DailyIndexSharding, HourlyIndexSharding, --- EveryMinuteIndexSharding will generate indexes based on the time of --- the log. Index name is treated as a prefix. So if your index name --- is @foo@ and DailySharding is used, logs will be stored in --- @foo-2016-2-25@, @foo-2016-2-26@ and so on. Index templating will --- be used to set up mappings automatically. Deletes based on date are --- very fast and queries can be restricted to date ranges for better --- performance. Queries against all dates should use @foo-*@ as an --- index name. Note that index aliasing's glob feature is not suitable --- for these date ranges as it matches index names as they are --- declared, so new dates will be excluded. DailyIndexSharding is a --- reasonable choice. Changing index sharding strategies is not --- advisable. --- --- * CustomSharding: supply your own function that decomposes an item --- into its index name hierarchy which will be appended to the index --- name. So for instance if your function return ["arbitrary", --- "prefix"], the index will be @foo-arbitrary-prefix@ and the index --- template will be set to match @foo-*@. In general, you want to use --- segments of increasing granularity (like year, month, day for --- dates). This makes it easier to address groups of indexes --- (e.g. @foo-2016-*@). -data IndexShardingPolicy = NoIndexSharding - | MonthlyIndexSharding - | WeeklyIndexSharding - -- ^ A special case of daily which shards to sunday - | DailyIndexSharding - | HourlyIndexSharding - | EveryMinuteIndexSharding - | CustomIndexSharding (forall a. Item a -> [IndexNameSegment]) - - -instance Show IndexShardingPolicy where - show NoIndexSharding = "NoIndexSharding" - show MonthlyIndexSharding = "MonthlyIndexSharding" - show WeeklyIndexSharding = "WeeklyIndexSharding" - show DailyIndexSharding = "DailyIndexSharding" - show HourlyIndexSharding = "HourlyIndexSharding" - show EveryMinuteIndexSharding = "EveryMinuteIndexSharding" - show (CustomIndexSharding _) = "CustomIndexSharding λ" - - -------------------------------------------------------------------------------- -newtype IndexNameSegment = IndexNameSegment { - indexNameSegment :: Text - } deriving (Show, Eq, Ord) - - -------------------------------------------------------------------------------- -shardPolicySegs :: IndexShardingPolicy -> Item a -> [IndexNameSegment] -shardPolicySegs NoIndexSharding _ = [] -shardPolicySegs MonthlyIndexSharding Item {..} = [sis y, sis m] - where - (y, m, _) = toGregorian (utctDay _itemTime) -shardPolicySegs WeeklyIndexSharding Item {..} = [sis y, sis m, sis d] - where - (y, m, d) = toGregorian (roundToSunday (utctDay _itemTime)) -shardPolicySegs DailyIndexSharding Item {..} = [sis y, sis m, sis d] - where - (y, m, d) = toGregorian (utctDay _itemTime) -shardPolicySegs HourlyIndexSharding Item {..} = [sis y, sis m, sis d, sis h] - where - (y, m, d) = toGregorian (utctDay _itemTime) - (h, _) = splitTime (utctDayTime _itemTime) -shardPolicySegs EveryMinuteIndexSharding Item {..} = [sis y, sis m, sis d, sis h, sis mn] - where - (y, m, d) = toGregorian (utctDay _itemTime) - (h, mn) = splitTime (utctDayTime _itemTime) -shardPolicySegs (CustomIndexSharding f) i = f i - - -------------------------------------------------------------------------------- --- | If the given day is sunday, returns the input, otherwise returns --- the previous sunday -roundToSunday :: Day -> Day -roundToSunday d - | dow == 7 = d - | w > 1 = fromWeekDate y (w - 1) 7 - | otherwise = fromWeekDate (y - 1) 53 7 - where - (y, w, dow) = toWeekDate d - - -------------------------------------------------------------------------------- -chooseIxn :: IndexName -> IndexShardingPolicy -> Item a -> IndexName -chooseIxn (IndexName ixn) p i = - IndexName (T.intercalate "-" (ixn:segs)) - where - segs = indexNameSegment A.<$> shardPolicySegs p i - - -------------------------------------------------------------------------------- -sis :: Integral a => a -> IndexNameSegment -sis = IndexNameSegment . T.pack . fmt - where - fmt = printf "%02d" . toInteger - - -------------------------------------------------------------------------------- -splitTime :: DiffTime -> (Int, Int) -splitTime t = asMins `divMod` 60 - where - asMins = floor t `div` 60 - - -------------------------------------------------------------------------------- -data EsScribeSetupError = CouldNotCreateIndex !Reply - | CouldNotCreateMapping !Reply deriving (Typeable, Show) - - -instance Exception EsScribeSetupError - -------------------------------------------------------------------------------- -mkEsScribe - :: EsScribeCfg - -> BHEnv - -> IndexName - -- ^ Treated as a prefix if index sharding is enabled - -> MappingName - -> Severity - -> Verbosity - -> IO (Scribe, IO ()) - -- ^ Returns a finalizer that will gracefully flush all remaining logs before shutting down workers -mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do - q <- newTBMQueueIO $ unEsQueueSize essQueueSize - endSig <- newEmptyMVar - - runBH env $ do - chk <- indexExists ix - -- note that this doesn't update settings. That's not available - -- through the Bloodhound API yet - unless chk $ void $ do - r1 <- createIndex essIndexSettings ix - unless (statusIsSuccessful (responseStatus r1)) $ - liftIO $ throwIO (CouldNotCreateIndex r1) - r2 <- if shardingEnabled - then putTemplate tpl tplName - else putMapping ix mapping (baseMapping mapping) - unless (statusIsSuccessful (responseStatus r2)) $ - liftIO $ throwIO (CouldNotCreateMapping r2) - - workers <- replicateM (unEsPoolSize essPoolSize) $ async $ - startWorker cfg env mapping q +{- $versionproxies - _ <- async $ do - takeMVar endSig - atomically $ closeTBMQueue q - mapM_ waitCatch workers - putMVar endSig () - - let scribe = Scribe $ \ i -> - when (_itemSeverity i >= sev) $ - void $ atomically $ tryWriteTBMQueue q (chooseIxn ix essIndexSharding i, itemJson' i) - let finalizer = putMVar endSig () >> takeMVar endSig - return (scribe, finalizer) - where - tplName = TemplateName ixn - shardingEnabled = case essIndexSharding of - NoIndexSharding -> False - _ -> True - tpl = IndexTemplate (TemplatePattern (ixn <> "-*")) (Just essIndexSettings) [toJSON (baseMapping mapping)] - IndexName ixn = ix - itemJson' i - | essAnnotateTypes = itemJson verb (TypeAnnotated <$> i) - | otherwise = itemJson verb i - - -------------------------------------------------------------------------------- -baseMapping :: MappingName -> Value -baseMapping (MappingName mn) = - object [ mn .= object ["properties" .= object prs] ] - where prs = [ str "thread" - , str "sev" - , str "pid" - , str "ns" - , str "msg" - , "loc" .= locType - , str "host" - , str "env" - , "at" .= dateType - , str "app" - ] - str k = k .= object ["type" .= String "string"] - locType = object ["properties" .= object locPairs] - locPairs = [ str "loc_pkg" - , str "loc_mod" - , str "loc_ln" - , str "loc_fn" - , str "loc_col" - ] - dateType = object [ "format" .= esDateFormat - , "type" .= String "date" - ] - - -------------------------------------------------------------------------------- --- | Handle both old-style aeson and picosecond-level precision -esDateFormat :: Text -esDateFormat = "yyyy-MM-dd'T'HH:mm:ssZ||yyyy-MM-dd'T'HH:mm:ss.SSSZ||yyyy-MM-dd'T'HH:mm:ss.SSSSSSSSSSSSZ" - - -------------------------------------------------------------------------------- -mkDocId :: IO DocId -mkDocId = (DocId . T.decodeUtf8 . toASCIIBytes) `fmap` UUID4.nextRandom - - -------------------------------------------------------------------------------- -newtype EsQueueSize = EsQueueSize { - unEsQueueSize :: Int - } deriving (Show, Eq, Ord) - - -instance Bounded EsQueueSize where - minBound = EsQueueSize 1 - maxBound = EsQueueSize maxBound - - -mkEsQueueSize :: Int -> Maybe EsQueueSize -mkEsQueueSize = mkNonZero EsQueueSize - - -------------------------------------------------------------------------------- -newtype EsPoolSize = EsPoolSize { - unEsPoolSize :: Int - } deriving (Show, Eq, Ord) - - -instance Bounded EsPoolSize where - minBound = EsPoolSize 1 - maxBound = EsPoolSize maxBound - - -mkEsPoolSize :: Int -> Maybe EsPoolSize -mkEsPoolSize = mkNonZero EsPoolSize - - -------------------------------------------------------------------------------- -mkNonZero :: (Int -> a) -> Int -> Maybe a -mkNonZero ctor n - | n > 0 = Just $ ctor n - | otherwise = Nothing - - -------------------------------------------------------------------------------- -startWorker - :: EsScribeCfg - -> BHEnv - -> MappingName - -> TBMQueue (IndexName, Value) - -> IO () -startWorker EsScribeCfg {..} env mapping q = go - where - go = do - popped <- atomically $ readTBMQueue q - case popped of - Just (ixn, v) -> do - sendLog ixn v `catchAny` eat - go - Nothing -> return () - sendLog :: IndexName -> Value -> IO () - sendLog ixn v = void $ recovering essRetryPolicy [handler] $ const $ do - did <- mkDocId - res <- runBH env $ indexDocument ixn mapping defaultIndexDocumentSettings v did - return res - eat _ = return () - handler _ = Handler $ \e -> - case fromException e of - Just (_ :: AsyncException) -> return False - _ -> return True + You may need these these functions and types if type inference + fails. For instance, you may need to hint to the compiler that a + config is @:: EsScribeCfg ESV5@, for instance. +-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/test/Main.hs new/katip-elasticsearch-0.4.0.0/test/Main.hs --- old/katip-elasticsearch-0.3.1.0/test/Main.hs 2017-06-27 00:42:06.000000000 +0200 +++ new/katip-elasticsearch-0.4.0.0/test/Main.hs 2017-07-24 22:50:35.000000000 +0200 @@ -1,7 +1,13 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main ( main @@ -9,117 +15,258 @@ ------------------------------------------------------------------------------- -import Control.Applicative as A +import Control.Applicative as A import Control.Concurrent.STM -import Control.Lens hiding (mapping, (.=)) +import Control.Lens hiding (mapping, (.=)) import Control.Monad import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.Lens import Data.Aeson.Types -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as M +import Data.ByteString.Lazy (ByteString) +import qualified Data.HashMap.Strict as HM import Data.Monoid import Data.Scientific +import Data.Tagged +import Data.Text (Text) import Data.Time import Data.Time.Calendar.WeekDate -import qualified Data.Vector as V -import Database.Bloodhound hiding (key) +import Data.Typeable as Typeable +import qualified Data.Vector as V +import qualified Database.V1.Bloodhound as V1 +import qualified Database.V5.Bloodhound as V5 import Network.HTTP.Client import Network.HTTP.Types.Status -import Test.QuickCheck.Instances () +import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.Options import Test.Tasty.QuickCheck ------------------------------------------------------------------------------- import Katip -import Katip.Scribes.ElasticSearch +import Katip.Scribes.ElasticSearch.Annotations +import Katip.Scribes.ElasticSearch.Internal ------------------------------------------------------------------------------- main :: IO () -main = defaultMain $ testGroup "katip-elasticsearch" +main = defaultMainWithIngredients ings $ askOption $ \vers -> testGroup "katip-elasticsearch" [ - esTests + case vers of + TestV1 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV1) + TestV5 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV5) , typeAnnotatedTests , roundToSundayTests ] + where + ings = (includingOptions [Option (Typeable.Proxy :: Typeable.Proxy TestWithESVersion)]):defaultIngredients ------------------------------------------------------------------------------- -setupSearch :: (EsScribeCfg -> EsScribeCfg) -> IO (Scribe, IO ()) -setupSearch modScribeCfg = do - bh dropESSchema +data TestWithESVersion = TestV1 + | TestV5 + deriving (Typeable) + + +instance IsOption TestWithESVersion where + defaultValue = TestV1 + parseValue "1" = Just TestV1 + parseValue "5" = Just TestV5 + parseValue _ = Nothing + optionName = Tagged "es-version" + optionHelp = Tagged "Version of ES to test against, either 1 or 5, defaulting to 1." + + +class ESVersion v => TestESVersion v where + type Server v + toServer :: proxy v -> Text -> Server v + toMappingName :: proxy v -> Text -> MappingName v + type Search v + type Query v + type Filter v + mkSearch :: proxy v -> Maybe (Query v) -> Maybe (Filter v) -> Search v + mkBHEnv :: proxy v -> Server v -> Manager -> BHEnv v + type ShardCount v + toShardCount :: proxy v -> Int -> ShardCount v + type ReplicaCount v + toReplicaCount :: proxy v -> Int -> ReplicaCount v + indexShards :: proxy v -> Lens' (IndexSettings v) (ShardCount v) + indexReplicas :: proxy v -> Lens' (IndexSettings v) (ReplicaCount v) + + deleteIndex :: proxy v -> IndexName v -> BH v IO (Response ByteString) + deleteTemplate :: proxy v -> TemplateName v -> BH v IO (Response ByteString) + refreshIndex :: proxy v -> IndexName v -> BH v IO (Response ByteString) + withBH :: proxy v -> ManagerSettings -> Server v -> BH v IO a -> IO a + searchByIndex :: proxy v -> IndexName v -> Search v -> BH v IO (Response ByteString) + + +instance TestESVersion ESV1 where + type Server ESV1 = V1.Server + toServer _ = V1.Server + toMappingName _ = V1.MappingName + type Search ESV1 = V1.Search + type Query ESV1 = V1.Query + type Filter ESV1 = V1.Filter + type ShardCount ESV1 = V1.ShardCount + toShardCount _ = V1.ShardCount + type ReplicaCount ESV1 = V1.ReplicaCount + toReplicaCount _ = V1.ReplicaCount + mkSearch _ = V1.mkSearch + mkBHEnv _ = V1.mkBHEnv + indexShards _ = lens V1.indexShards (\s v -> s { V1.indexShards = v}) + indexReplicas _ = lens V1.indexReplicas (\r v -> r { V1.indexReplicas = v}) + + deleteIndex _ = V1.deleteIndex + deleteTemplate _ = V1.deleteTemplate + refreshIndex _ = V1.refreshIndex + withBH _ = V1.withBH + searchByIndex _ = V1.searchByIndex + + +instance TestESVersion ESV5 where + type Server ESV5 = V5.Server + toServer _ = V5.Server + toMappingName _ = V5.MappingName + type Search ESV5 = V5.Search + type Query ESV5 = V5.Query + type Filter ESV5 = V5.Filter + type ShardCount ESV5 = V5.ShardCount + toShardCount _ = V5.ShardCount + type ReplicaCount ESV5 = V5.ReplicaCount + toReplicaCount _ = V5.ReplicaCount + mkSearch _ = V5.mkSearch + mkBHEnv _ = V5.mkBHEnv + indexShards _ = lens V5.indexShards (\s v -> s { V5.indexShards = v}) + indexReplicas _ = lens V5.indexReplicas (\r v -> r { V5.indexReplicas = v}) + + deleteIndex _ = V5.deleteIndex + deleteTemplate _ = V5.deleteTemplate + refreshIndex _ = V5.refreshIndex + withBH _ = V5.withBH + searchByIndex _ = V5.searchByIndex + + +------------------------------------------------------------------------------- +setupSearch + :: forall proxy v. ( TestESVersion v + , MonadIO (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => proxy v + -> (EsScribeCfg v -> EsScribeCfg v) + -> IO Scribe +setupSearch prx modScribeCfg = do + bh prx (dropESSchema prx) mgr <- newManager defaultManagerSettings - mkEsScribe cfg (mkBHEnv svr mgr) ixn mn DebugS V3 + mkEsScribe cfg (mkBHEnv prx (svr prx) mgr) (ixn prx) (mn prx) DebugS V3 where - cfg = modScribeCfg (defaultEsScribeCfg { essAnnotateTypes = True - , essIndexSettings = ixs - }) + cfg :: EsScribeCfg v + cfg = modScribeCfg $ + (defaultEsScribeCfg' prx) + { essAnnotateTypes = True + , essIndexSettings = ixs prx + } ------------------------------------------------------------------------------- -teardownSearch :: (Scribe, IO ()) -> IO () -teardownSearch (_, finalizer) = do - finalizer - bh $ do - when False $ dropESSchema - when False $ dropESSTemplate --TODO: drop +teardownSearch + :: ( TestESVersion v + , Monad (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => proxy v + -> IO () +teardownSearch prx = do + bh prx $ do + dropESSchema prx + dropESSTemplate prx ------------------------------------------------------------------------------- -withSearch :: (IO (Scribe, IO ()) -> TestTree) -> TestTree +withSearch + :: ( TestESVersion v + , MonadIO (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => proxy v + -> (IO Scribe -> TestTree) + -> TestTree withSearch = withSearch' id ------------------------------------------------------------------------------- -withSearch' :: (EsScribeCfg -> EsScribeCfg) -> (IO (Scribe, IO ()) -> TestTree) -> TestTree -withSearch' modScribeCfg = withResource (setupSearch modScribeCfg) teardownSearch +withSearch' + :: ( TestESVersion v + , MonadIO (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => (EsScribeCfg v -> EsScribeCfg v) + -> proxy v + -> (IO Scribe -> TestTree) + -> TestTree +withSearch' modScribeCfg prx = withResource (setupSearch prx modScribeCfg) (const (teardownSearch prx)) ------------------------------------------------------------------------------- -esTests :: TestTree -esTests = testGroup "elasticsearch scribe" +esTests + :: ( TestESVersion v + , MonadIO (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + , Show (IndexName v) + ) + => proxy v + -> TestTree +esTests prx = testGroup "elasticsearch scribe" [ - withSearch' (\c -> c { essIndexSharding = NoIndexSharding}) $ \setup -> testCase "it flushes to elasticsearch" $ withTestLogging setup $ \done -> do + withSearch' (\c -> c { essIndexSharding = NoIndexSharding}) prx $ \setup -> testCase "it flushes to elasticsearch" $ withTestLogging prx setup $ \done -> do $(logT) (ExampleCtx True) mempty InfoS "A test message" liftIO $ do void done - logs <- getLogs + logs <- getLogs prx length logs @?= 1 let l = head logs l ^? key "_source" . key "msg" . _String @?= Just "A test message" l ^? key "_source" . key "data" . key "whatever::b" . _Bool @?= Just True - , withSearch $ \setup -> testCase "date-based index sharding" $ do + , withSearch prx $ \setup -> testCase "date-based index sharding" $ do let t1 = mkTime 2016 1 2 3 4 5 fakeClock <- newTVarIO t1 - withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) setup $ \done -> do + withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) prx setup $ \done -> do $(logT) (ExampleCtx True) mempty InfoS "today" let t2 = mkTime 2016 1 3 3 4 5 liftIO (atomically (writeTVar fakeClock t2)) $(logT) (ExampleCtx True) mempty InfoS "tomorrow" liftIO $ do void done - todayLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-01-02") - tomorrowLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-01-03") + todayLogs <- getLogsByIndex prx (toIndexName prx "katip-elasticsearch-tests-2016-01-02") + tomorrowLogs <- getLogsByIndex prx (toIndexName prx "katip-elasticsearch-tests-2016-01-03") assertBool ("todayLogs has " <> show (length todayLogs) <> " items") (length todayLogs == 1) assertBool ("tomorrowLogs has " <> show (length tomorrowLogs) <> " items") (length tomorrowLogs == 1) let logToday = head todayLogs let logTomorrow = head tomorrowLogs logToday ^? key "_source" . key "msg" . _String @?= Just "today" logTomorrow ^? key "_source" . key "msg" . _String @?= Just "tomorrow" - , withSearch' (\c -> c { essIndexSharding = WeeklyIndexSharding}) $ \setup -> testCase "weekly index sharding rounds to previous sunday" $ do + , withSearch' (\c -> c { essIndexSharding = WeeklyIndexSharding}) prx $ \setup -> testCase "weekly index sharding rounds to previous sunday" $ do let t1 = mkTime 2016 3 5 0 0 0 -- saturday, march 5th fakeClock <- newTVarIO t1 - withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) setup $ \done -> do + withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) prx setup $ \done -> do $(logT) (ExampleCtx True) mempty InfoS "today" let t2 = mkTime 2016 3 6 0 0 0 -- sunday march 6th liftIO (atomically (writeTVar fakeClock t2)) $(logT) (ExampleCtx True) mempty InfoS "tomorrow" liftIO $ do void done - todayLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-02-28") -- rounds back to previous sunday - tomorrowLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-03-06") -- is on sunday, so uses current date + todayLogs <- getLogsByIndex prx (toIndexName prx "katip-elasticsearch-tests-2016-02-28") -- rounds back to previous sunday + tomorrowLogs <- getLogsByIndex prx (toIndexName prx "katip-elasticsearch-tests-2016-03-06") -- is on sunday, so uses current date assertBool ("todayLogs has " <> show (length todayLogs) <> " items") (length todayLogs == 1) assertBool ("tomorrowLogs has " <> show (length tomorrowLogs) <> " items") (length tomorrowLogs == 1) let logToday = head todayLogs @@ -232,76 +379,127 @@ ------------------------------------------------------------------------------- -getLogs :: IO [Value] -getLogs = getLogsByIndex ixn +getLogs + :: ( TestESVersion v + , Monad (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + , Show (IndexName v) + ) + => proxy v + -> IO [Value] +getLogs prx = getLogsByIndex prx (ixn prx) ------------------------------------------------------------------------------- -getLogsByIndex :: IndexName -> IO [Value] -getLogsByIndex i = do - r <- bh $ do - void (refreshIndex i) - searchByIndex i (mkSearch Nothing Nothing) +getLogsByIndex + :: ( TestESVersion v + , Monad (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + , Show (IndexName v) + ) + => proxy v + -> IndexName v + -> IO [Value] +getLogsByIndex prx i = do + r <- bh prx $ do + void (refreshIndex prx i) + searchByIndex prx i (mkSearch prx Nothing Nothing) let actualCode = statusCode (responseStatus r) assertBool ("search by " <> show i <> " " <> show actualCode <> " /= 200") (actualCode == 200) return $ responseBody r ^.. key "hits" . key "hits" . values ------------------------------------------------------------------------------- -bh :: BH IO a -> IO a -bh = withBH defaultManagerSettings svr +bh :: TestESVersion v => proxy v -> BH v IO a -> IO a +bh prx = withBH prx defaultManagerSettings (svr prx) ------------------------------------------------------------------------------- withTestLogging - :: IO (Scribe, IO a) -> (IO Reply -> KatipT IO b) -> IO b + :: TestESVersion v + => proxy v + -> IO Scribe + -> (IO (Response ByteString) -> KatipT IO b) + -> IO b withTestLogging = withTestLogging' id ------------------------------------------------------------------------------- withTestLogging' - :: (LogEnv -> LogEnv) - -> IO (Scribe, IO a) - -> (IO Reply -> KatipT IO b) + :: (TestESVersion v) + => (LogEnv -> LogEnv) + -> proxy v + -> IO Scribe + -> (IO (Response ByteString) -> KatipT IO b) -> IO b -withTestLogging' modEnv setup f = do - (scr, done) <- setup +withTestLogging' modEnv prx setup f = do + scr <- setup le <- modEnv <$> initLogEnv ns env - let done' = done >> bh (refreshIndex ixn) - runKatipT le { _logEnvScribes = M.singleton "es" scr} (f done') + le' <- registerScribe "es" scr defaultScribeSettings le + let done' = do + _ <- closeScribes le' + bh prx (refreshIndex prx (ixn prx)) + runKatipT le' (f done') where ns = Namespace ["katip-test"] env = Environment "test" ------------------------------------------------------------------------------- -svr :: Server -svr = Server "http://localhost:9200" +svr :: TestESVersion v => proxy v -> Server v +svr prx = toServer prx "http://localhost:9200" + + +------------------------------------------------------------------------------- +ixn :: TestESVersion v => proxy v -> IndexName v +ixn prx = toIndexName prx "katip-elasticsearch-tests" ------------------------------------------------------------------------------- -ixn :: IndexName -ixn = IndexName "katip-elasticsearch-tests" +ixs :: TestESVersion v => proxy v -> IndexSettings v +ixs prx = defaultIndexSettings prx + & indexShards prx .~ toShardCount prx 1 + & indexReplicas prx .~ toReplicaCount prx 1 ------------------------------------------------------------------------------- -ixs :: IndexSettings -ixs = defaultIndexSettings { indexShards = ShardCount 1 - , indexReplicas = ReplicaCount 1} +tn :: TestESVersion v => proxy v -> TemplateName v +tn prx = toTemplateName prx "katip-elasticsearch-tests" + ------------------------------------------------------------------------------- -mn :: MappingName -mn = MappingName "logs" +mn :: TestESVersion v => proxy v -> MappingName v +mn prx = toMappingName prx "logs" ------------------------------------------------------------------------------- -dropESSchema :: BH IO () -dropESSchema = void $ deleteIndex (IndexName "katip-elasticsearch-tests*") +dropESSchema + :: ( TestESVersion v + , Monad (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => proxy v + -> BH v IO () +dropESSchema prx = void $ deleteIndex prx (toIndexName prx "katip-elasticsearch-tests*") ------------------------------------------------------------------------------- -dropESSTemplate :: BH IO () -dropESSTemplate = void $ deleteTemplate (TemplateName "katip-elasticsearch-tests") +dropESSTemplate + :: ( TestESVersion v + , Monad (BH v IO) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800 + , Functor (BH v IO) +#endif + ) + => proxy v + -> BH v IO () +dropESSTemplate prx = void $ deleteTemplate prx (tn prx) -------------------------------------------------------------------------------

1 0

commit ghc-katip for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-katip for openSUSE:Factory checked in at 2017-08-31 20:56:53 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-katip (Old) and /work/SRC/openSUSE:Factory/.ghc-katip.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-katip" Thu Aug 31 20:56:53 2017 rev:3 rq:513411 version:0.5.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-katip/ghc-katip.changes 2017-06-23 09:18:36.768332603 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-katip.new/ghc-katip.changes 2017-08-31 20:56:54.719635604 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:59 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.0.0. + +------------------------------------------------------------------- Old: ---- katip-0.3.1.5.tar.gz New: ---- katip-0.5.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-katip.spec ++++++ --- /var/tmp/diff_new_pack.rlHvB2/_old 2017-08-31 20:56:55.347547380 +0200 +++ /var/tmp/diff_new_pack.rlHvB2/_new 2017-08-31 20:56:55.351546818 +0200 @@ -19,7 +19,7 @@ %global pkg_name katip %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3.1.5 +Version: 0.5.0.0 Release: 0 Summary: A structured logging framework License: BSD-3-Clause @@ -33,7 +33,6 @@ BuildRequires: ghc-bytestring-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-either-devel -BuildRequires: ghc-exceptions-devel BuildRequires: ghc-hostname-devel BuildRequires: ghc-microlens-devel BuildRequires: ghc-microlens-th-devel @@ -42,7 +41,9 @@ BuildRequires: ghc-old-locale-devel BuildRequires: ghc-resourcet-devel BuildRequires: ghc-rpm-macros +BuildRequires: ghc-safe-exceptions-devel BuildRequires: ghc-semigroups-devel +BuildRequires: ghc-stm-devel BuildRequires: ghc-string-conv-devel BuildRequires: ghc-template-haskell-devel BuildRequires: ghc-text-devel @@ -50,7 +51,6 @@ BuildRequires: ghc-transformers-base-devel BuildRequires: ghc-transformers-compat-devel BuildRequires: ghc-transformers-devel -BuildRequires: ghc-unagi-chan-devel BuildRequires: ghc-unix-devel BuildRequires: ghc-unordered-containers-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ katip-0.3.1.5.tar.gz -> katip-0.5.0.0.tar.gz ++++++ ++++ 1635 lines of diff (skipped)

1 0

commit ghc-js-jquery for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-js-jquery for openSUSE:Factory checked in at 2017-08-31 20:56:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-js-jquery (Old) and /work/SRC/openSUSE:Factory/.ghc-js-jquery.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-js-jquery" Thu Aug 31 20:56:51 2017 rev:9 rq:513410 version:3.2.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-js-jquery/ghc-js-jquery.changes 2016-11-05 21:27:46.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-js-jquery.new/ghc-js-jquery.changes 2017-08-31 20:56:52.855897465 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:56 UTC 2017 - psimons(a)suse.com + +- Update to version 3.2.1. + +------------------------------------------------------------------- Old: ---- js-jquery-3.1.1.tar.gz New: ---- js-jquery-3.2.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-js-jquery.spec ++++++ --- /var/tmp/diff_new_pack.8u5Rt9/_old 2017-08-31 20:56:53.847758105 +0200 +++ /var/tmp/diff_new_pack.8u5Rt9/_new 2017-08-31 20:56:53.851757543 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-js-jquery # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name js-jquery %bcond_with tests Name: ghc-%{pkg_name} -Version: 3.1.1 +Version: 3.2.1 Release: 0 Summary: Obtain minified jQuery code License: MIT @@ -73,10 +73,10 @@ %defattr(-,root,root,-) %doc LICENSE %dir %{_datadir}/%{pkg_name}-%{version} -%{_datadir}/%{pkg_name}-%{version}/jquery-3.1.1.min.js +%{_datadir}/%{pkg_name}-%{version}/jquery-3.2.1.min.js %files devel -f %{name}-devel.files %defattr(-,root,root,-) -%doc README.md +%doc CHANGES.txt README.md %changelog ++++++ js-jquery-3.1.1.tar.gz -> js-jquery-3.2.1.tar.gz ++++++ ++++ 20556 lines of diff (skipped)

1 0

commit ghc-isotope for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-isotope for openSUSE:Factory checked in at 2017-08-31 20:56:48 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-isotope (Old) and /work/SRC/openSUSE:Factory/.ghc-isotope.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-isotope" Thu Aug 31 20:56:48 2017 rev:2 rq:513408 version:0.5.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-isotope/ghc-isotope.changes 2017-04-11 09:38:30.689459377 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-isotope.new/ghc-isotope.changes 2017-08-31 20:56:49.936307676 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:43 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.0.1. + +------------------------------------------------------------------- Old: ---- isotope-0.4.0.0.tar.gz New: ---- isotope-0.5.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-isotope.spec ++++++ --- /var/tmp/diff_new_pack.PLp2z4/_old 2017-08-31 20:56:50.588216081 +0200 +++ /var/tmp/diff_new_pack.PLp2z4/_new 2017-08-31 20:56:50.596214957 +0200 @@ -19,7 +19,7 @@ %global pkg_name isotope %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.0.0 +Version: 0.5.0.1 Release: 0 Summary: Isotopic masses and relative abundances License: GPL-3.0+ ++++++ isotope-0.4.0.0.tar.gz -> isotope-0.5.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/README.md new/isotope-0.5.0.1/README.md --- old/isotope-0.4.0.0/README.md 2017-03-11 09:42:03.000000000 +0100 +++ new/isotope-0.5.0.1/README.md 2017-04-30 01:08:04.000000000 +0200 @@ -1,5 +1,5 @@ [![Build Status](https://travis-ci.org/Michaelt293/isotope.svg?branch=master)](https… -[![Gitter](https://badges.gitter.im/Join Chat.svg)](https://gitter.im/Michaelt293/isotope) +[![Gitter](https://badges.gitter.im/Michaelt293/isotope.svg)](https://gitter.im/Michaelt293/isotope) ![alt tag](https://github.com/Michaelt293/isotope/blob/master/isotope_jpeg.jpg) @@ -13,6 +13,7 @@ * [ToElementalComposition type class](#elementalcomposition-type-class) * [Behaviour of ElementalComposition, MolecularFormula, CondensedFormula and EmpiricalFormula data types](#behaviour-of-elementalcomposition-molecularformula-condensedformula-and-empiricalformula-data-types) * [Additional functions accepting an ElementSymbol as input](#additional-functions-accepting-an-elementsymbol-as-input) + * [Representing ions in Isotope](#representing-ions-in-isotope) * [Comparison to other chemistry libraries](#comparison-to-other-chemistry-libraries) * [Radium](#radium) * [Ouch](#ouch) @@ -108,13 +109,13 @@ ### `ToElementalComposition` type class -`ToElementalComposition` is a superclass of `ToMolecularFormula`, `ToCondensedFormula` and `ToEmpiricalFormula`. In addition to the `toElementalComposition` method, the `ToElementalComposition` type class has three other methods; `monoisotopicMass`, `nominalMass` and `averageMass`. (`toElementalComposition` is the minimal complete definition.) `ElementSymbol`, `ElementalComposition`, `MolecularFormula`, `CondensedFormula` and `EmpiricalFormula` all have instances of `ToElementalComposition`. This provides a uniform approach to working with elements, elemental compositions, molecular formulae, condensed formulae and empirical formulae. +`ToElementalComposition` is a superclass of `ToMolecularFormula`, `ToCondensedFormula` and `ToEmpiricalFormula`. In addition to the `toElementalComposition` method, the `ToElementalComposition` type class has four other methods; `charge`, `monoisotopicMass`, `nominalMass` and `averageMass`. (`toElementalComposition` and `charge` is the minimal complete definition.) `ElementSymbol`, `ElementalComposition`, `MolecularFormula`, `CondensedFormula` and `EmpiricalFormula` all have instances of `ToElementalComposition`. This provides a uniform approach to working with elements, elemental compositions, molecular formulae, condensed formulae and empirical formulae. ```haskell ghci> nominalMass C NominalMass {getNominalMass = 12} ghci> averageMass [mol|CH4|] AverageMass {getAverageMass = 16.042498912958358} -ghci> monoisotopicMass [mol|N(CH3)3|] +ghci> monoisotopicMass [con|N(CH3)3|] MonoisotopicMass {getMonoisotopicMass = 59.073499294499996} ``` @@ -158,6 +159,36 @@ [IsotopicMass {getIsotopicMass = 45.95262772},IsotopicMass {getIsotopicMass = 46.95175879},IsotopicMass {getIsotopicMass = 47.94794198},IsotopicMass {getIsotopicMass = 48.94786568},IsotopicMass {getIsotopicMass = 49.94478689}] ``` +### Representing ions in Isotope + +Ions are represented in `Isotope` using the `Ion` type class. The `Ion` type class has two methods, `mz` and `polarity`; where `mz` is mass-to-charge ratio and `polarity` is either `Positive` or `Negative`. Any type with an `ToElementalComposition` instance can have an `Ion` instance if charge is not equal to zero. If charge is equal to zero, a runtime exception will occur! Ideally, the type system should be put better use to catch this error at compile-time. + +```haskell +data Ammonium = Ammonium deriving Show + +instance ToElementalComposition Ammonium where + toElementalComposition _ = mkElementalComposition [(N, 1), (H, 4)] + charge _ = Just 1 + +instance Ion Ammonium + +ghci> mz Ammonium +Mz {getMz = 18.03437413335} +``` + +`Protonated` and `Deprotonated` types, with `Ion` instances, are provided to represent protonated and deprotonated ions, respectively. + +```haskell +ghci> mz . Protonated $ mkMolecularFormula [(H, 2), (O, 1)] +Mz {getMz = 19.01838971626} +ghci> mz . Deprotonated $ mkMolecularFormula [(H, 2), (O, 1)] +Mz {getMz = 17.0027396518} +ghci> polarity . Protonated $ mkMolecularFormula [(H, 2), (O, 1)] +Positive +ghci> polarity . Deprotonated $ mkMolecularFormula [(H, 2), (O, 1)] +Negative +``` + ## Comparison to other chemistry libraries In addition to Isotope, there are two other open-source chemistry libraries written in Haskell; Radium [2] and Ouch [3]. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/isotope.cabal new/isotope-0.5.0.1/isotope.cabal --- old/isotope-0.4.0.0/isotope.cabal 2017-03-11 09:41:07.000000000 +0100 +++ new/isotope-0.5.0.1/isotope.cabal 2017-04-30 01:07:25.000000000 +0200 @@ -1,5 +1,5 @@ name: isotope -version: 0.4.0.0 +version: 0.5.0.1 synopsis: Isotopic masses and relative abundances. description: Please see README.md homepage: https://github.com/Michaelt293/Element-isotopes/blob/master/README.md @@ -18,6 +18,7 @@ exposed-modules: Isotope , Isotope.Base , Isotope.Parsers + , Isotope.Ion build-depends: base >= 4.7 && < 5 , containers >= 0.5 && < 0.6 , megaparsec >= 5 && < 6 @@ -37,5 +38,6 @@ , megaparsec other-modules: Isotope.BaseSpec , Isotope.ParsersSpec + , Isotope.IonSpec ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/src/Isotope/Base.hs new/isotope-0.5.0.1/src/Isotope/Base.hs --- old/isotope-0.4.0.0/src/Isotope/Base.hs 2017-03-11 09:41:07.000000000 +0100 +++ new/isotope-0.5.0.1/src/Isotope/Base.hs 2017-04-29 12:29:38.000000000 +0200 @@ -189,6 +189,8 @@ -- neutron number) for an isotope. type MassNumber = Int +type Charge = Int + -------------------------------------------------------------------------------- -- 'Isotope' and 'Element' data types @@ -638,13 +640,14 @@ -- 'monoisotopicMass', 'nominalMass' and 'averageMass'. class ToElementalComposition a where toElementalComposition :: a -> ElementalComposition + charge :: a -> Maybe Charge monoisotopicMass :: a -> MonoisotopicMass nominalMass :: a -> NominalMass averageMass :: a -> AverageMass monoisotopicMass = getFormulaSum elementMonoisotopicMass nominalMass = getFormulaSum elementNominalMass averageMass = getFormulaSum elementAverageMass - {-# MINIMAL (toElementalComposition) #-} + {-# MINIMAL (toElementalComposition, charge) #-} -- Helper function for the calculating monoistopic masses, average mass and -- nominal masses for molecular formulae. @@ -672,9 +675,11 @@ instance ToElementalComposition ElementSymbol where toElementalComposition sym = mkElementalComposition [(sym, 1)] + charge _ = Nothing instance ToElementalComposition ElementalComposition where toElementalComposition = id + charge _ = Nothing instance Formula ElementalComposition where renderFormula f = foldMap renderFoldfunc @@ -742,6 +747,7 @@ instance ToElementalComposition MolecularFormula where toElementalComposition (MolecularFormula m) = ElementalComposition m + charge _ = Nothing instance Formula MolecularFormula where renderFormula f = foldMap renderFoldfunc @@ -766,6 +772,7 @@ instance ToElementalComposition CondensedFormula where toElementalComposition = ElementalComposition . getMolecularFormula . toMolecularFormula + charge _ = Nothing instance ToMolecularFormula CondensedFormula where toMolecularFormula c = foldMap foldFunc (getCondensedFormula c) @@ -814,6 +821,7 @@ instance ToElementalComposition EmpiricalFormula where toElementalComposition (EmpiricalFormula a) = ElementalComposition a + charge _ = Nothing instance Formula EmpiricalFormula where renderFormula f = foldMap renderFoldfunc diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/src/Isotope/Ion.hs new/isotope-0.5.0.1/src/Isotope/Ion.hs --- old/isotope-0.4.0.0/src/Isotope/Ion.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/isotope-0.5.0.1/src/Isotope/Ion.hs 2017-04-29 12:29:38.000000000 +0200 @@ -0,0 +1,70 @@ +{-| +Module : Isotope.Ion +Description : Provides support for ions. +Copyright : Michael Thomas +License : GPL-3 +Maintainer : Michael Thomas <Michaelt293(a)gmail.com> +Stability : Experimental + +This module allows the mass-to-charge ratio and polarity of ions to be +calculated. +-} +module Isotope.Ion where + +import Isotope.Base +import Data.Maybe (fromMaybe) +import Data.Monoid + +-- | The polarity of a charge. A charge can be either `Positive` or `Negative`. +data Polarity = Positive | Negative + deriving (Show, Read, Eq, Ord) + +-- | The mass-to-charge ratio of an ion. +newtype Mz = Mz { getMz :: Double } + deriving (Show, Read, Eq, Ord) + +-- | The `Ion` type class. This type class has two methods: `mz` and `polarity`. +class ToElementalComposition a => Ion a where + mz :: a -> Mz + polarity :: a -> Polarity + mz a = Mz . abs $ monoisotopicMass' / charge' + where + monoisotopicMass' = getMonoisotopicMass $ monoisotopicMass a + charge' = let charge'' = fromMaybe 0 (charge a) + in if charge'' /= 0 + then fromIntegral charge'' + else error "An ion can't have a charge of 0!" + polarity a = polarity' $ fromMaybe 0 (charge a) + where + polarity' c + | c > 0 = Positive + | c < 0 = Negative + | c == 0 = error "An ion can't have a charge of 0!" + +-- | Protonated represents a protonated ion. +newtype Protonated a = Protonated a deriving (Show, Read, Eq, Ord) + +instance ToElementalComposition a => ToElementalComposition (Protonated a) where + toElementalComposition (Protonated a) = toElementalComposition a |+| + mkElementalComposition [(H, 1)] + charge (Protonated a) = getSum <$> Just (Sum 1) <> (Sum <$> charge a) + +instance ToElementalComposition a => Ion (Protonated a) + +-- | `doublyProtonated` takes a type and returns a doubly `Protonated` ion. +doublyProtonated :: a -> Protonated (Protonated a) +doublyProtonated = Protonated . Protonated + +-- | `Deprotonated` represents a deprotonated ion. +newtype Deprotonated a = Deprotonated a deriving (Show, Read, Eq, Ord) + +instance ToElementalComposition a => ToElementalComposition (Deprotonated a) where + toElementalComposition (Deprotonated a) = toElementalComposition a |-| + mkElementalComposition [(H, 1)] + charge (Deprotonated a) = getSum <$> Just (Sum (-1)) <> (Sum <$> charge a) + +instance ToElementalComposition a => Ion (Deprotonated a) + +-- | `doublyDeprotonated` takes a type and returns a doubly `Deprotonated` ion. +doublyDeprotonated :: a -> Deprotonated (Deprotonated a) +doublyDeprotonated = Deprotonated . Deprotonated diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/test/Isotope/BaseSpec.hs new/isotope-0.5.0.1/test/Isotope/BaseSpec.hs --- old/isotope-0.4.0.0/test/Isotope/BaseSpec.hs 2017-03-11 09:41:07.000000000 +0100 +++ new/isotope-0.5.0.1/test/Isotope/BaseSpec.hs 2017-04-29 12:29:38.000000000 +0200 @@ -115,6 +115,8 @@ describe "ToElementalComposition - ElementalComposition instance" $ do it "toElementalComposition" . property $ \ec -> toElementalComposition ec == (ec :: ElementalComposition) + it "charge of an elemental composition should Just 0" . property $ + \ec -> charge (ec :: ElementalComposition) == Nothing it "monoisotopic mass of ethanol" $ withinTolerance (getMonoisotopicMass (monoisotopicMass [ele|C2H6O|])) 46.04186 0.0001 `shouldBe` True @@ -130,9 +132,11 @@ it "should give the correct formula" $ mkElementalComposition [(C, 2), (H, 6), (O, 1)] `shouldBe` [ele|C2H6O|] - describe "ToElementalComposition - ElementSymbol instance" . + describe "ToElementalComposition - ElementSymbol instance" $ do it "monoisotopicMass" . property $ \sym -> monoisotopicMass sym == monoisotopicMass (mkElementalComposition [(sym, 1)]) + it "charge of a symbol should be Just 0" . property $ + \sym -> charge (sym :: ElementSymbol) == Nothing describe "Monoid instance for MolecularFormula" $ do it "associativity" . property $ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/test/Isotope/IonSpec.hs new/isotope-0.5.0.1/test/Isotope/IonSpec.hs --- old/isotope-0.4.0.0/test/Isotope/IonSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/isotope-0.5.0.1/test/Isotope/IonSpec.hs 2017-04-29 12:29:38.000000000 +0200 @@ -0,0 +1,22 @@ +module Isotope.IonSpec (spec) where + +import Isotope +import Isotope.Ion +import Test.Hspec + +spec :: Spec +spec = do + describe "mz" $ do + it "The mass-to-charge ratio of protonated water should be 19.01838971626" $ + mz (Protonated water) `shouldBe` Mz {getMz = 19.01838971626} + it "The mass-to-charge ratio of deprotonated water should be 17.0027396518" $ + mz (Deprotonated water) `shouldBe` Mz {getMz = 17.0027396518} + + describe "polarity" $ do + it "The polarity of protonated water should be Positive" $ + polarity (Protonated water) `shouldBe` Positive + it "The polarity of deprotonated water should be Negative" $ + polarity (Deprotonated water) `shouldBe` Negative + +water :: MolecularFormula +water = mkMolecularFormula [(H, 2), (O, 1)] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/isotope-0.4.0.0/test/Spec.hs new/isotope-0.5.0.1/test/Spec.hs --- old/isotope-0.4.0.0/test/Spec.hs 2016-11-12 04:43:36.000000000 +0100 +++ new/isotope-0.5.0.1/test/Spec.hs 2017-04-29 12:29:38.000000000 +0200 @@ -4,8 +4,10 @@ import Test.QuickCheck import Isotope.BaseSpec import Isotope.ParsersSpec +import Isotope.IonSpec main :: IO () main = hspec $ do describe "Base" Isotope.BaseSpec.spec describe "Parsers" Isotope.ParsersSpec.spec + describe "Ion" Isotope.IonSpec.spec

1 0