diff --git a/persistable-types-HDBC-pg.cabal b/persistable-types-HDBC-pg.cabal --- a/persistable-types-HDBC-pg.cabal +++ b/persistable-types-HDBC-pg.cabal @@ -1,5 +1,5 @@ name: persistable-types-HDBC-pg -version: 0.0.1.5 +version: 0.0.2.0 synopsis: HDBC and Relational-Record instances of PostgreSQL extended types description: This package contains HDBC Convertible instances and Relational-Record persistable instances of PostgreSQL extended types @@ -9,11 +9,12 @@ license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com -copyright: Copyright (c) 2015-2017 Kei Hibino +copyright: Copyright (c) 2015-2018 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 8.2.1 +tested-with: GHC == 8.4.1, GHC == 8.4.2 + , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 @@ -33,10 +34,27 @@ other-extensions: MultiParamTypeClasses build-depends: base <5 , bytestring + , dlist , text-postgresql , convertible , HDBC , persistable-record >= 0.4 + , relational-query , relational-query-HDBC hs-source-dirs: src default-language: Haskell2010 + +test-suite test + build-depends: base <5 + , relational-query + , relational-query-HDBC + , text-postgresql + , persistable-types-HDBC-pg + + type: exitcode-stdio-1.0 + main-is: runTest.hs + + hs-source-dirs: test + ghc-options: -Wall + + default-language: Haskell2010 diff --git a/src/Database/HDBC/PostgreSQL/Instances.hs b/src/Database/HDBC/PostgreSQL/Instances.hs --- a/src/Database/HDBC/PostgreSQL/Instances.hs +++ b/src/Database/HDBC/PostgreSQL/Instances.hs @@ -1,14 +1,30 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Database.HDBC.PostgreSQL.Instances +-- Copyright : 2015-2018 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines HDBC instances and SQL-literal instances for +-- PostgreSQL types module Database.HDBC.PostgreSQL.Instances () where import Control.Applicative ((<$>), pure, (<*)) +import Data.String (IsString, fromString) +import Data.Monoid ((<>)) +import Data.DList () import Data.ByteString.Char8 (unpack) import Data.Convertible (Convertible (..), ConvertResult, ConvertError (..)) -import Data.PostgreSQL.NetworkAddress (NetAddress (..), Inet (..), Cidr (..)) +import Data.PostgreSQL.NetworkAddress (NetAddress, Inet (..), Cidr (..)) import Database.HDBC (SqlValue (..)) import Database.HDBC.Record.Persistable () +import Database.Relational.Query (ShowConstantTermsSQL (..)) import Database.PostgreSQL.Parser (evalParser) import qualified Database.PostgreSQL.Parser as Parser import Database.PostgreSQL.Printer (execPrinter) @@ -54,3 +70,12 @@ instance Convertible Cidr SqlValue where safeConvert (Cidr n) = fromNetAddress n + +qstringNetAddr :: IsString s => NetAddress -> s +qstringNetAddr = fromString . ("'" ++) . (++ "'") . execPrinter Printer.netAddress + +instance ShowConstantTermsSQL Inet where + showConstantTermsSQL' (Inet na) = pure $ "INET" <> qstringNetAddr na + +instance ShowConstantTermsSQL Cidr where + showConstantTermsSQL' (Cidr na) = pure $ "CIDR" <> qstringNetAddr na diff --git a/src/Database/HDBC/PostgreSQL/Persistable.hs b/src/Database/HDBC/PostgreSQL/Persistable.hs --- a/src/Database/HDBC/PostgreSQL/Persistable.hs +++ b/src/Database/HDBC/PostgreSQL/Persistable.hs @@ -1,24 +1,33 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Database.HDBC.PostgreSQL.Persistable +-- Copyright : 2015-2018 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines Persistable instances for PostgreSQL types module Database.HDBC.PostgreSQL.Persistable () where import Data.Convertible (convert) import Data.PostgreSQL.NetworkAddress (Inet, Cidr) import Database.HDBC (SqlValue) import Database.HDBC.Record.Persistable () -import Database.Record.Persistable (PersistableWidth (..), unsafeValueWidth) import Database.Record.FromSql (FromSql (..), valueRecordFromSql) import Database.Record.ToSql (ToSql (..), valueRecordToSql) +import Database.Record.TH (deriveNotNullType) import Database.HDBC.PostgreSQL.Instances () -instance PersistableWidth Inet where - persistableWidth = unsafeValueWidth +$(deriveNotNullType [t| Inet |]) -instance PersistableWidth Cidr where - persistableWidth = unsafeValueWidth +$(deriveNotNullType [t| Cidr |]) instance FromSql SqlValue Inet where recordFromSql = valueRecordFromSql convert diff --git a/test/runTest.hs b/test/runTest.hs new file mode 100644 --- /dev/null +++ b/test/runTest.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +import GHC.Generics (Generic) +import Control.Applicative ((<$>), (*>)) +import Control.Monad (unless) +import Database.HDBC.Query.TH (makeRelationalRecord) +import Data.PostgreSQL.NetworkAddress + (Inet (..), Cidr (..), NetAddress (..), + V4HostAddress (..), V6HostAddress (..)) +import Database.Relational.Query (Relation, relation, value) + +import Database.HDBC.PostgreSQL.Persistable () + + +data Foo = + Foo + { s0 :: String + , i1 :: Maybe Inet + , c2 :: Maybe Cidr + } deriving Generic + +-- compile time check +$(makeRelationalRecord ''Foo) + +-- 192.168.0.1/24 +inet4 :: Relation () Inet +inet4 = + relation . return . value . Inet $ + NetAddress4 (V4HostAddress 192 168 0 1) 24 + +-- 224.0.0.0/4 +cidr4 :: Relation () Cidr +cidr4 = + relation . return . value . Cidr $ + NetAddress4 (V4HostAddress 224 0 0 0) 4 + +-- fd00::1/8 +inet6 :: Relation () Inet +inet6 = + relation . return . value . Inet $ + NetAddress6 (V6HostAddress 0xfd00 0 0 0 0 0 0 1) 8 + +-- ff00::/8 +cidr6 :: Relation () Cidr +cidr6 = + relation . return . value . Cidr $ + NetAddress6 (V6HostAddress 0xff00 0 0 0 0 0 0 0) 8 + +testSet :: [(String, String, [String])] +testSet = + [("inet - v4", show inet4, ["SELECT","ALL","INET","'192.168.0.1/24'","AS","f0"]), + ("cidr - v4", show cidr4, ["SELECT","ALL","CIDR","'224.0.0.0/4'","AS","f0"]), + ("inet - v6", show inet6, ["SELECT","ALL","INET","'fd00:0:0:0:0:0:0:1/8'","AS","f0"]), + ("cidr - v6", show cidr6, ["SELECT","ALL","CIDR","'ff00:0:0:0:0:0:0:0/8'","AS","f0"])] + +doTest :: (String, String, [String]) -> IO Bool +doTest (tag, q, a) + | words q == a = putStrLn ("success: " ++ tag) *> return True + | otherwise = putStrLn ("failed: " ++ tag) *> return False + +main :: IO () +main = do + ok <- and <$> mapM doTest testSet + unless ok $ fail "some tests are failed!"