Automatic testing for schema

This commit is contained in:
Mats Rauhala 2018-10-26 23:47:14 +03:00
parent 5961a99d77
commit fb29a6e694
3 changed files with 77 additions and 7 deletions

View File

@ -86,3 +86,20 @@ executable backend
, NoImplicitPrelude , NoImplicitPrelude
, OverloadedStrings , OverloadedStrings
, RecordWildCards , RecordWildCards
test-suite spec
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: src
build-depends: base >=4.10
, classy-prelude
, http-api-data
, selda
, selda-postgresql
, aeson
, text
, validity
, genvalidity-hspec
, genvalidity-property
, genvalidity-text
, hspec

View File

@ -14,13 +14,13 @@ import Data.Aeson
import Web.HttpApiData import Web.HttpApiData
-- | User type -- | User type
newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq) newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic)
newtype HashedPassword = HashedPassword {unHashed :: ByteString} newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword data NoPassword = NoPassword
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData) newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData) newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic)
instance SqlType HashedPassword where instance SqlType HashedPassword where
mkLit = LCustom . LBlob . unHashed mkLit = LCustom . LBlob . unHashed
@ -42,9 +42,9 @@ instance SqlType Username where
newtype UserID = UserID {unUserID :: Int} deriving (Show) newtype UserID = UserID {unUserID :: Int} deriving (Show)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData) newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic)
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON) newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic)
newtype TagID = TagID {unTagID :: Int} deriving (Show) newtype TagID = TagID {unTagID :: Int} deriving (Show)
@ -77,7 +77,7 @@ data User pass = User { identifier :: UserID
, password :: pass } , password :: pass }
deriving (Show, Generic) deriving (Show, Generic)
data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic) data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic, Eq)
instance ToJSON Role instance ToJSON Role
instance FromJSON Role instance FromJSON Role
@ -125,7 +125,7 @@ data Tag = Tag { identifier :: TagID
deriving (Show, Generic) deriving (Show, Generic)
data Visibility = Public | Private | Followers data Visibility = Public | Private | Followers
deriving (Show, Read, Generic) deriving (Show, Read, Generic, Eq)
instance ToJSON Visibility instance ToJSON Visibility
instance FromJSON Visibility instance FromJSON Visibility

53
backend/src/Spec.hs Normal file
View File

@ -0,0 +1,53 @@
{-# Language TypeApplications #-}
module Main where
import qualified Data.Aeson as A
import Data.Char (isPrint)
import Data.GenValidity.Text ()
import qualified Data.Text as T
import Database.Schema
import Test.Hspec
import Test.Validity
instance GenUnchecked PlainPassword
instance GenValid PlainPassword
instance GenInvalid PlainPassword
instance Validity PlainPassword
instance GenUnchecked Email
instance GenValid Email
instance GenInvalid Email
instance Validity Email
instance GenUnchecked Username
instance GenValid Username
instance GenInvalid Username
instance Validity Username
instance GenUnchecked BookID
instance GenValid BookID
instance GenInvalid BookID
instance Validity BookID
instance GenUnchecked ChannelID
instance GenValid ChannelID
instance GenInvalid ChannelID
instance Validity ChannelID
instance GenUnchecked Role
instance GenValid Role
instance GenInvalid Role
instance Validity Role
instance GenUnchecked Visibility
instance GenValid Visibility
instance GenInvalid Visibility
instance Validity Visibility
spec :: Spec
spec = do
describe "JSON encoding" $ do
it "Works for PlainPassword" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @PlainPassword) A.decode
it "Works for Email" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Email) A.decode
it "Username" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Username) A.decode
it "Works for BookID" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @BookID) A.decode
it "Works for ChannelID" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @ChannelID) A.decode
it "Works for Role" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Role) A.decode
it "Works for Visibility" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Visibility) A.decode
main :: IO ()
main = hspec spec