diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +__v0.9.5__ + +add JSON roundtrip tests + __v0.9.4__ derive generic diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -1,5 +1,5 @@ name: pinboard -version: 0.9.4 +version: 0.9.5 synopsis: Access to the Pinboard API license: MIT license-file: LICENSE @@ -53,10 +53,31 @@ Pinboard.Error Pinboard.Types Pinboard.Util - ghc-options: -Wall -rtsopts + ghc-options: -Wall -fwarn-incomplete-patterns -funbox-strict-fields -fexpose-all-unfoldings +test-suite tests + ghc-options: -Wall -fno-warn-orphans + type: exitcode-stdio-1.0 + main-is: tests.hs + hs-source-dirs: tests + build-depends: base >=4.6 && < 5.0, + pinboard, + bytestring, + containers, + hspec >= 1.8 , + text, + time, + aeson, + semigroups, + QuickCheck, + mtl >= 2.2.1, + unordered-containers, + transformers >= 0.4.0.0 + ghc-options: -Wall + -fno-warn-orphans + default-language: Haskell2010 source-repository head type: git diff --git a/src/Pinboard/ApiTypes.hs b/src/Pinboard/ApiTypes.hs --- a/src/Pinboard/ApiTypes.hs +++ b/src/Pinboard/ApiTypes.hs @@ -206,7 +206,7 @@ , "hash" .= toJSON noteHash , "title" .= toJSON noteTitle , "text" .= toJSON noteText - , "length" .= toJSON (show noteLength) + , "length" .= toJSON noteLength , "created_at" .= toJSON (showNoteTime noteCreatedAt) , "updated_at" .= toJSON (showNoteTime noteUpdatedAt) ] diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -43,9 +43,7 @@ ,createParserErr ,httpStatusPinboardError -- * Client Dependencies - , module Pinboard.Error - , module Pinboard.Types - , module Pinboard.Util + , module X ) where @@ -67,9 +65,9 @@ import Network.HTTP.Client.TLS -import Pinboard.Types -import Pinboard.Error -import Pinboard.Util +import Pinboard.Types as X +import Pinboard.Error as X +import Pinboard.Util as X import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T @@ -127,7 +125,7 @@ responseBody r <$ checkStatusCodeResponse r runPinboardSingleJson - :: (Functor m, MonadIO m, FromJSON a) + :: (MonadIO m, FromJSON a) => PinboardConfig -> PinboardRequest -> m (Either PinboardError a) @@ -146,8 +144,7 @@ , "?" , T.decodeUtf8 $ paramsToByteString $ ("auth_token", urlEncode False apiToken) : encodeParams requestParams ] req <- buildReq $ T.unpack url - res <- liftIO $ httpLbs req mgr - return res + liftIO $ httpLbs req mgr -------------------------------------------------------------------------------- @@ -155,7 +152,7 @@ buildReq url = do req <- liftIO $ parseUrl $ "https://api.pinboard.in/v1/" <> url return $ req - { requestHeaders = [("User-Agent","pinboard.hs/0.9.4")] + { requestHeaders = [("User-Agent","pinboard.hs/0.9.5")] , checkStatus = \_ _ _ -> Nothing } @@ -177,7 +174,7 @@ -> m a decodeJSONResponse s = let r = eitherDecodeStrict' (LBS.toStrict s) - in either (throwError . createParserErr . toText) (return . id) r + in either (throwError . createParserErr . toText) return r -------------------------------------------------------------------------------- diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.Char (isSpace) +import Data.Monoid +import Data.Text (Text, pack) +import Data.List +import Data.Ord +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import Data.Typeable +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.HashMap.Strict as HM +import qualified Data.Set as Set + +import ApproxEq + +import Pinboard + +propJSON :: forall a b. (Arbitrary a, ToJSON a, FromJSON a, Show a, Typeable a, Testable b) + => (Either String a -> Either String a -> b) + -> Proxy a + -> Spec +propJSON eq _ = prop (show (typeOf (undefined :: a)) <> " FromJSON/ToJSON roundtrip") $ \(x :: a) -> + let actual = parseEither parseJSON (toJSON x) + expected = Right x + failMsg = "ACTUAL: " <> show actual <> "\nJSON: " <> BL8.unpack (encode x) + in counterexample failMsg (actual `eq` expected) + +propJSONEq :: forall a. (Arbitrary a, ToJSON a, FromJSON a, Show a, Typeable a, Eq a) => Proxy a -> Spec +propJSONEq = propJSON (==) + +propJSONApproxEq :: forall a. (Arbitrary a, ToJSON a, FromJSON a, Show a, Typeable a, ApproxEq a) => Proxy a -> Spec +propJSONApproxEq = propJSON (==~) + +instance Arbitrary Text where + arbitrary = pack <$> arbitrary + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay . (2000 +) <$> arbitrary + shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose (0, 86401)) + +instance Arbitrary Note where + arbitrary = Note <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary NoteList where + arbitrary = NoteList <$> arbitrary <*> resize 15 arbitrary + +instance Arbitrary NoteListItem where + arbitrary = NoteListItem <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Posts where + arbitrary = Posts <$> arbitrary <*> arbitrary <*> (resize 15 arbitrary) + +instance Arbitrary Post where + arbitrary = Post <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryTags + +instance Arbitrary JsonTagMap where + arbitrary = ToJsonTagMap <$> (HM.fromList <$> (listOf $ (,) <$> arbitraryTag <*> arbitrary)) + +arbitraryTags :: Gen [Tag] +arbitraryTags = listOf arbitraryTag + +arbitraryTag :: Gen Tag +arbitraryTag = pack <$> listOf1 (arbitrary `suchThat` (\c -> (not . isSpace) c && (',' /= c))) + +-- | Checks if a given list has no duplicates in _O(n log n)_. +hasNoDups :: (Ord a) => [a] -> Bool +hasNoDups = go Set.empty + where + go _ [] = True + go s (x:xs) + | s' <- Set.insert x s, + Set.size s' > Set.size s + = go s' xs + | otherwise = False + +instance Arbitrary PostDates where + arbitrary = PostDates <$> arbitrary <*> arbitrary <*> (arbitrary `suchThat` isValidDateCount) + where + isValidDateCount xs = hasNoDups (fst <$> xs) && all (> 0) (snd <$> xs) + +instance ApproxEq PostDates where + (=~) a b = + postDatesUser a == postDatesUser b + && postDatesTag a == postDatesTag b + && sorted (postDatesCount a) == sorted (postDatesCount b) + where sorted = sortBy (comparing fst <> comparing snd) + +instance Arbitrary Suggested where + arbitrary = arbitrary >>= \a -> elements [Popular a, Recommended a] + +main :: IO () +main = hspec $ do + prop "UTCTime" $ \(x :: UTCTime) -> (readNoteTime . showNoteTime) x == x + describe "JSON instances" $ do + propJSONEq (Proxy :: Proxy UTCTime) + propJSONEq (Proxy :: Proxy Post) + propJSONEq (Proxy :: Proxy Posts) + propJSONEq (Proxy :: Proxy Note) + propJSONEq (Proxy :: Proxy NoteList) + propJSONEq (Proxy :: Proxy NoteListItem) + propJSONEq (Proxy :: Proxy JsonTagMap) + propJSONEq (Proxy :: Proxy Suggested) + propJSONApproxEq (Proxy :: Proxy PostDates)