text-postgresql (empty) → 0.0.1.0
raw patch · 10 files changed
+576/−0 lines, 10 filesdep +QuickCheckdep +basedep +dlistsetup-changed
Dependencies added: QuickCheck, base, dlist, quickcheck-simple, text-postgresql, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Control/Monad/Either/Plus.hs +48/−0
- src/Data/PostgreSQL/NetworkAddress.hs +82/−0
- src/Database/PostgreSQL/Parser.hs +131/−0
- src/Database/PostgreSQL/Printer.hs +78/−0
- src/Text/Parser/List.hs +79/−0
- src/Text/Printer/List.hs +22/−0
- test/ppIso.hs +60/−0
- text-postgresql.cabal +44/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kei Hibino nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/Either/Plus.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Control.Monad.Either.Plus+ ( EitherP (..)+ , eitherP, emap+ , leftP, rightP+ ) where++import Control.Applicative ((<$>), Applicative (..), Alternative (..))+import Control.Monad (MonadPlus (..))+import Data.Monoid (Monoid (..), (<>))+++newtype EitherP e a = EitherP { unEitherP :: Either e a }++eitherP :: (a -> c) -> (b -> c) -> EitherP a b -> c+eitherP f g = either f g . unEitherP++emap :: (e0 -> e1) -> EitherP e0 a -> EitherP e1 a+emap f = EitherP . eitherP (Left . f) Right++leftP :: e -> EitherP e a+leftP = EitherP . Left++rightP :: a -> EitherP e a+rightP = EitherP . Right++instance Functor (EitherP e) where+ fmap f (EitherP e) = EitherP $ f <$> e++instance Applicative (EitherP e) where+ pure = EitherP . pure+ EitherP a <*> EitherP b = EitherP $ a <*> b++instance Monad (EitherP e) where+ (EitherP e) >>= f = EitherP (e >>= unEitherP . f)+ return = EitherP . return++instance Monoid e => Alternative (EitherP e) where+ empty = EitherP $ Left mempty+ EitherP a <|> EitherP b = EitherP $ a `plus` b where+ x@(Right _) `plus` _ = x+ Left _ `plus` y@(Right _) = y+ Left e1 `plus` Left e2 = Left $ e1 <> e2++instance Monoid e => MonadPlus (EitherP e) where+ mzero = empty+ mplus = (<|>)
+ src/Data/PostgreSQL/NetworkAddress.hs view
@@ -0,0 +1,82 @@+-- |+-- Module : Data.PostgreSQL.NetworkAddress+-- Copyright : 2015 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This module defines network-address types of PostgreSQL.+-- http://www.postgresql.org/docs/current/static/datatype-net-types.html+module Data.PostgreSQL.NetworkAddress+ ( NetAddress (..)+ , HostAddress, hostAddress, hostAddressOctets+ , V6HostAddress (..), v6HostAddressLong, v6HostAddressWords+ , v6HostAddress, v6HostAddressL, v6HostAddressR++ , Inet (..), Cidr (..)+ ) where++import Control.Applicative (pure)+import Control.Monad (guard)+import Data.Word (Word8, Word16, Word32)+import Data.Bits ((.&.), (.|.), shiftL, shiftR)+++-- | Same as HostAddress of network package. Definition to reduce dependency.+type HostAddress = Word32++hostAddress :: Word8 -> Word8 -> Word8 -> Word8 -> HostAddress+hostAddress a b c d =+ fromIntegral a .|.+ fromIntegral b `shiftL` 8 .|.+ fromIntegral c `shiftL` 16 .|.+ fromIntegral d `shiftL` 24++hostAddressOctets :: HostAddress -> (Word8, Word8, Word8, Word8)+hostAddressOctets ha =+ ( getWord8 0,+ getWord8 8,+ getWord8 16,+ getWord8 24 )+ where+ getWord8 n = fromIntegral $ (ha `shiftR` n) .&. 0xFF+++-- | Not same as HostAddress6 of network package, because HostAddress6 has host-byteorder.+data V6HostAddress =+ V6HostAddress !Word16 !Word16 !Word16 !Word16 !Word16 !Word16 !Word16 !Word16+ deriving (Eq, Ord, Show)++v6HostAddressLong :: Word16 -> Word16 -> Word16 -> Word16+ -> Word16 -> Word16 -> Word16 -> Word16+ -> V6HostAddress+v6HostAddressLong = V6HostAddress++v6HostAddress :: [Word16] -> [Word16] -> Maybe V6HostAddress+v6HostAddress ls rs = do+ let v6length = 8+ guard . null . drop v6length $ ls ++ rs+ [a, b, c, d, e, f, g, h] <- pure $ ls ++ replicate (v6length - length ls - length rs) 0 ++ rs+ pure $ v6HostAddressLong a b c d e f g h++v6HostAddressR :: [Word16] -> Maybe V6HostAddress+v6HostAddressR = v6HostAddress []++v6HostAddressL :: [Word16] -> Maybe V6HostAddress+v6HostAddressL ls = v6HostAddress ls []++v6HostAddressWords :: V6HostAddress -> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)+v6HostAddressWords (V6HostAddress a b c d e f g h) =+ (a, b, c, d, e, f, g, h)+++data NetAddress+ = NetAddress4 !HostAddress !Word8+ | NetAddress6 !V6HostAddress !Word8+ deriving (Eq, Ord, Show)++newtype Inet = Inet NetAddress deriving (Eq, Ord, Show)++newtype Cidr = Cidr NetAddress deriving (Eq, Ord, Show)
+ src/Database/PostgreSQL/Parser.hs view
@@ -0,0 +1,131 @@++module Database.PostgreSQL.Parser+ ( Parser, runParser, evalParser+ , eof++ , netAddress+ , hostAddress, decMask4+ , v6HostAddress, decMask6+ ) where++import Control.Applicative ((<$>), pure, (<*>), (<*), (*>), (<|>), many, some, optional)+import Control.Monad (guard, replicateM)+import Data.Maybe (listToMaybe, fromMaybe)+import Data.Char (isDigit, isHexDigit)+import Data.Word (Word8, Word16)+import Numeric (readDec, readHex)++import Text.Parser.List (runParser, evalParser, eof, noteP, satisfy', satisfy)+import qualified Text.Parser.List as P+import Data.PostgreSQL.NetworkAddress (NetAddress (..), HostAddress, V6HostAddress)+import qualified Data.PostgreSQL.NetworkAddress as D+++type Parser = P.Parser Char++digit :: Parser Char+digit = satisfy' "digit" (const "must be digit.") isDigit++hexDigit :: Parser Char+hexDigit = satisfy' "hexDigit" (const "must be hex-digit.") isHexDigit++readNat :: String -> Maybe Integer+readNat s = listToMaybe [ i | (i, "") <- readDec s ] -- readDec accept only positive++readHexNat :: String -> Maybe Integer+readHexNat s = listToMaybe [ i | (i, "") <- readHex s ]++nat :: Parser Integer+nat = do+ xs <- some digit+ noteP "nat: invalid input" $ readNat xs++hexNat :: Parser Integer+hexNat = do+ xs <- some hexDigit+ noteP "hexNat: invalid input" $ readHexNat xs++rangedNat :: (Integral a, Show a) => a -> a -> Integer -> Parser a+rangedNat n x i = do+ noteP (concat ["rangedNat: out of range: ", show i, ": [", show n, ", ", show x, "]"])+ . guard $ (fromIntegral n <= i && i <= fromIntegral x)+ pure $ fromIntegral i++decW8 :: Parser Word8+decW8 = rangedNat minBound maxBound =<< nat++hexW16 :: Parser Word16+hexW16 = rangedNat minBound maxBound =<< hexNat++char :: Char -> Parser Char+char c = satisfy (== c)++dot :: Parser Char+dot = char '.'++colon :: Parser Char+colon = char ':'++slash :: Parser Char+slash = char '/'++hostAddress :: Parser HostAddress+hostAddress = D.hostAddress <$> decW8 <* dot <*> decW8 <* dot <*> decW8 <* dot <*> decW8++_exampleHostAddress :: [Either String HostAddress]+_exampleHostAddress =+ [ evalParser (hostAddress <* eof) s+ | s <- [ "0.0.0.0", "192.168.0.1" ]+ ]++mask4bits :: Word8+mask4bits = 32++decMask4 :: Parser Word8+decMask4 = rangedNat 0 mask4bits =<< nat++v6words :: Parser [Word16]+v6words =+ (:) <$> hexW16 <*> many (colon *> hexW16) <|>+ pure []++doubleColon6 :: Parser V6HostAddress+doubleColon6 = do+ m6 <- D.v6HostAddress <$> v6words <* replicateM 2 colon <*> v6words+ noteP "v6HostAddress: Too many numbers of 16-bit words." m6++v6HostAddress :: Parser V6HostAddress+v6HostAddress =+ doubleColon6 <|>+ D.v6HostAddressLong+ <$> hexW16 <* colon <*> hexW16 <* colon+ <*> hexW16 <* colon <*> hexW16 <* colon+ <*> hexW16 <* colon <*> hexW16 <* colon+ <*> hexW16 <* colon <*> hexW16++_exampleHostAddress6 :: [Either String V6HostAddress]+_exampleHostAddress6 =+ [ evalParser (v6HostAddress <* eof) s+ | s <- [ "::", "0:0:0:0:0:0:0:0", "2001:1::1:a2", "1:1:1:1:1:1:1:a1" ]+ ]++mask6bits :: Word8+mask6bits = 128++decMask6 :: Parser Word8+decMask6 = rangedNat 0 mask6bits =<< nat++optional' :: a -> Parser a -> Parser a+optional' x p =+ fromMaybe x <$> optional p++netAddress :: Parser NetAddress+netAddress =+ NetAddress4 <$> hostAddress <*> optional' mask4bits (slash *> decMask4) <|>+ NetAddress6 <$> v6HostAddress <*> optional' mask6bits (slash *> decMask6)++_exampleNetAddress :: [Either String NetAddress]+_exampleNetAddress =+ [ evalParser (netAddress <* eof) s+ | s <- [ "2001:1::a0:a2/64", "172.16.0.0" ]+ ]
+ src/Database/PostgreSQL/Printer.hs view
@@ -0,0 +1,78 @@++module Database.PostgreSQL.Printer+ ( Printer, execPrinter+ , hostAddress+ , v6HostAddress+ , netAddress+ ) where++import Numeric (showInt, showHex)++import Text.Printer.List (token, list, execPrinter)+import qualified Text.Printer.List as P+import Data.PostgreSQL.NetworkAddress+ (HostAddress, hostAddressOctets, V6HostAddress, v6HostAddressWords, NetAddress (..))+++type Printer a = P.Printer Char a+type PrintM = P.PrintM Char+++mapShowS :: (a -> ShowS) -> Printer a+mapShowS s = list . ($ []) . s++dec :: (Integral a, Show a) => Printer a+dec = mapShowS showInt++hex :: (Integral a, Show a) => Printer a+hex = mapShowS showHex++dot :: PrintM ()+dot = token '.'++colon :: PrintM ()+colon = token ':'++slash :: PrintM ()+slash = token '/'++hostAddress :: Printer HostAddress+hostAddress ha = do+ let (a, b, c, d) = hostAddressOctets ha+ dec a+ dot+ dec b+ dot+ dec c+ dot+ dec d++v6HostAddress :: Printer V6HostAddress+v6HostAddress ha = do+ let (a, b, c, d, e, f, g, h) = v6HostAddressWords ha+ hex a+ colon+ hex b+ colon+ hex c+ colon+ hex d+ colon+ hex e+ colon+ hex f+ colon+ hex g+ colon+ hex h++netAddress :: Printer NetAddress+netAddress = d where+ d (NetAddress4 ha m) = do+ hostAddress ha+ slash+ dec m+ d (NetAddress6 v6 m) = do+ v6HostAddress v6+ slash+ dec m
+ src/Text/Parser/List.hs view
@@ -0,0 +1,79 @@+module Text.Parser.List+ ( Parser, runParser, evalParser+ , Error, errorE, errorP, noteP++ , token, eof, sink, satisfy', satisfy, list+ ) where++import Control.Applicative (pure)+import Control.Monad (guard)+import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get, put)+import Data.Monoid (Last (..))+import Data.Maybe (fromMaybe)++import Control.Monad.Either.Plus (EitherP (..), emap, leftP)+++type Error = Last String++unError :: String -> Error -> String+unError s = fromMaybe s . getLast++type Parser t = StateT [t] (EitherP Error)++runParser :: Parser t a -> [t] -> Either String (a, [t])+runParser p = unEitherP . emap (unError "runParser: parse error.") . runStateT p++evalParser :: Parser t a -> [t] -> Either String a+evalParser p = unEitherP . emap (unError "evalParser: parse error.") . evalStateT p++errorE :: String -> EitherP Error a+errorE = leftP . Last . Just++errorP :: String -> Parser t a+errorP = StateT . const . errorE++noteP :: String -> Maybe a -> Parser t a+noteP s = maybe (errorP s) pure++token :: Parser t t+token = do+ cs0 <- get+ case cs0 of+ c:cs -> do+ put cs+ pure c+ [] ->+ errorP "token: end of input"++eof :: Parser t ()+eof = do+ cs <- get+ case cs of+ [] -> pure ()+ _:_ -> errorP "eof: not empty input"++sink :: Parser t [t]+sink = do+ cs <- get+ put []+ pure cs++satisfy' :: String -- ^ Parser name to print when error+ -> (t -> String) -- ^ Function to build error string+ -> (t -> Bool) -- ^ Predicate to satisfy+ -> Parser t t -- ^ Result parser+satisfy' n ef p = do+ c <- token+ noteP (n ++ ": " ++ ef c) . guard $ p c+ return c++-- | make satisfy parser with monoid-empty error.+satisfy :: (t -> Bool) -> Parser t t+satisfy p = do+ c <- token+ guard $ p c -- expect empty error+ return c++list :: Eq t => [t] -> Parser t [t]+list = mapM (satisfy . (==))
+ src/Text/Printer/List.hs view
@@ -0,0 +1,22 @@+module Text.Printer.List+ ( PrintM, Printer, execPrinter+ , token, list+ ) where++import Control.Monad.Trans.Writer (Writer, execWriter, tell)+import Data.DList (DList)+import qualified Data.DList as DList+++type PrintM t = Writer (DList t)++type Printer t a = a -> PrintM t ()++token :: Printer t t+token = tell . return++list :: Printer t [t]+list = mapM_ token++execPrinter :: Printer t a -> a -> [t]+execPrinter p = DList.toList . execWriter . p
+ test/ppIso.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS -fno-warn-orphans #-}+{--# LANGUAGE FlexibleInstances #--}++import Test.QuickCheck+ (Gen, Arbitrary (..), choose, oneof)+import Test.QuickCheck.Simple (defaultMain, Test, qcTest)++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8)++import Data.PostgreSQL.NetworkAddress+import Database.PostgreSQL.Parser (Parser, evalParser)+import qualified Database.PostgreSQL.Parser as Parser+import Database.PostgreSQL.Printer (Printer, execPrinter)+import qualified Database.PostgreSQL.Printer as Printer+++instance Arbitrary V6HostAddress where+ arbitrary =+ V6HostAddress+ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++mask4 :: Gen Word8+mask4 = choose (0, 32)++mask6 :: Gen Word8+mask6 = choose (0, 128)++instance Arbitrary NetAddress where+ arbitrary =+ oneof+ [ NetAddress4 <$> arbitrary <*> mask4+ , NetAddress6 <$> arbitrary <*> mask6 ]++isoProp :: Eq a => Printer a -> Parser a -> a -> Bool+isoProp pr ps a =+ Right a == (evalParser ps $ execPrinter pr a)++prop_hostAddressIso :: HostAddress -> Bool+prop_hostAddressIso =+ isoProp Printer.hostAddress Parser.hostAddress++prop_v6HostAddressIso :: V6HostAddress -> Bool+prop_v6HostAddressIso =+ isoProp Printer.v6HostAddress Parser.v6HostAddress++prop_netAddressIso :: NetAddress -> Bool+prop_netAddressIso =+ isoProp Printer.netAddress Parser.netAddress++tests :: [Test]+tests =+ [ qcTest "v4 address iso - print parse" prop_hostAddressIso+ , qcTest "v6 address iso - print parse" prop_v6HostAddressIso+ , qcTest "network address iso - print parse" prop_netAddressIso+ ]++main :: IO ()+main = defaultMain tests
+ text-postgresql.cabal view
@@ -0,0 +1,44 @@+name: text-postgresql+version: 0.0.1.0+synopsis: Parser and Printer of PostgreSQL extended types+description: This package involves parser and printer for+ text expressions of PostgreSQL extended types.+ - inet type, cidr type+homepage: http://khibino.github.io/haskell-relational-record/+license: BSD3+license-file: LICENSE+author: Kei Hibino+maintainer: ex8k.hibino@gmail.com+copyright: Copyright (c) 2015 Kei Hibino+category: Database+build-type: Simple++cabal-version: >=1.10++library+ exposed-modules:+ Data.PostgreSQL.NetworkAddress+ Database.PostgreSQL.Parser+ Database.PostgreSQL.Printer+ other-modules:+ Control.Monad.Either.Plus+ Text.Parser.List+ Text.Printer.List++ build-depends: base <5+ , transformers+ , dlist+ hs-source-dirs: src+ default-language: Haskell2010++test-suite pp+ build-depends: base <5+ , QuickCheck+ , quickcheck-simple+ , text-postgresql+ type: exitcode-stdio-1.0+ main-is: ppIso.hs+ hs-source-dirs: test++ ghc-options: -Wall+ default-language: Haskell2010