postgresql-orm 0.2.2 → 0.2.3

raw patch · 4 files changed

+39/−23 lines, 4 filesdep +unordered-containers

Dependencies added: unordered-containers

Files

• Database/PostgreSQL/ORM.hs +1/−1
• Database/PostgreSQL/ORM/Model.hs +15/−5
• Database/PostgreSQL/ORM/Validations.hs +21/−16
• postgresql-orm.cabal +2/−1

@@ -19,7 +19,7 @@   -- ** Chaining associations   , nestAssoc, chainAssoc   -- ** Validations-  , InvalidError(..), ValidationError(..), validate, validateNotEmpty+  , ValidationError(..), validate, validateNotEmpty   ) where  import Database.PostgreSQL.ORM.Model

@@ -113,6 +113,7 @@ import Data.Char import Data.Data import Data.Int+import qualified Data.HashMap.Strict as H import Data.Maybe import Data.Monoid import Data.List hiding (find)@@ -160,6 +161,11 @@   toJSON NullKey = A.Null   toJSON (DBKey k) = A.toJSON k +instance A.FromJSON DBKey where+  parseJSON (A.Number a) = return $ DBKey (floor a)+  parseJSON A.Null = return NullKey+  parseJSON _ = error "Expected Number or Null"+ instance Eq DBKey where   (DBKey a) == (DBKey b) = a == b   _         == _         = error "compare NullKey"@@ -196,6 +202,10 @@ instance A.ToJSON (GDBRef t a) where   toJSON (DBRef k) = A.toJSON k +instance A.FromJSON (GDBRef t a) where+  parseJSON (A.Number n) = return $ DBRef (floor n)+  parseJSON _ = error "Expected Number"+ instance (Model t) => Show (GDBRef rt t) where   showsPrec n (DBRef k) = showsPrec n k instance (Model t) => Read (GDBRef rt t) where@@ -786,8 +796,8 @@    -- | Perform a validation of the model, returning any errors if   -- it is invalid.-  modelValid :: a -> [InvalidError]-  modelValid = const []+  modelValid :: a -> ValidationError+  modelValid = const mempty  -- | Degenerate instances of 'Model' for types in the 'ToRow' class -- are to enable extra 'ToRow' types to be included with ':.' in the@@ -1044,7 +1054,7 @@   eResp <- trySave c r   case eResp of     Right resp -> return resp-    Left  errs -> throwIO $ ValidationError errs+    Left  errs -> throwIO errs  -- | Write a 'Model' to the database.  If the primary key is -- 'NullKey', the item is written with an @INSERT@ query, read back@@ -1055,8 +1065,8 @@ -- If the 'Model' is invalid (i.e. the return value of 'modelValid' is -- non-empty), a list of 'InvalidError' is returned instead. trySave :: forall r. Model r-        => Connection -> r -> IO (Either [InvalidError] r)-trySave c r | not . null $ errors = return $ Left errors+        => Connection -> r -> IO (Either ValidationError r)+trySave c r | not . H.null $ validationErrors errors = return $ Left errors             | NullKey <- primaryKey r = do                   rs <- query c (modelInsertQuery qs) (InsertRow r)                   case rs of [r'] -> return $ Right $ lookupRow r'

@@ -3,36 +3,41 @@  import Control.Exception import Data.Aeson+import qualified Data.HashMap.Strict as H+import Data.Monoid import qualified Data.Text as T import Data.Typeable-import qualified Data.ByteString.Char8 as S8 -data InvalidError = InvalidError-  { invalidColumn :: !S8.ByteString-  , invalidError  :: !S8.ByteString } deriving (Show)+newtype ValidationError = ValidationError+  { validationErrors :: H.HashMap T.Text [T.Text] } deriving (Show, Typeable) -instance ToJSON InvalidError where-  toJSON ie = object ["column" .= invalidColumn ie, "error" .= invalidError ie]+instance Exception ValidationError -newtype ValidationError = ValidationError [InvalidError]-  deriving (Show, Typeable)+instance Monoid ValidationError where+  mempty = ValidationError mempty+  mappend ein zwei = ValidationError $!+    H.unionWith mappend (validationErrors ein) (validationErrors zwei) -instance Exception ValidationError+instance ToJSON ValidationError where+  toJSON = toJSON . validationErrors -type ValidationFunc a = a -> [InvalidError]+instance FromJSON ValidationError where+  parseJSON val = ValidationError `fmap` parseJSON val +type ValidationFunc a = a -> ValidationError+ validate :: (a -> Bool)-         -> S8.ByteString -- ^ Column name-         -> S8.ByteString -- ^ Error description+         -> T.Text -- ^ Column name+         -> T.Text -- ^ Error description          -> ValidationFunc a validate validator columnName desc = \a ->   if validator a then-    []-    else [InvalidError columnName desc]+    ValidationError H.empty+    else ValidationError $ H.singleton columnName [desc]  validateNotEmpty :: (a -> T.Text)-                 -> S8.ByteString-                 -> S8.ByteString+                 -> T.Text+                 -> T.Text                  -> ValidationFunc a validateNotEmpty accessor = validate (not . T.null . accessor) 

@@ -1,5 +1,5 @@ name: postgresql-orm-version: 0.2.2+version: 0.2.3 cabal-version: >= 1.14 build-type: Simple license: GPL@@ -46,6 +46,7 @@                , time                , transformers                , unix+               , unordered-containers                , vector   ghc-options: -Wall -fno-warn-unused-do-bind   exposed-modules: Data.GetField